Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
EoreCampfire/app.R
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
713 lines (577 sloc)
25.3 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| # CAMPFIRE VERSION! | |
| # Shiny demo of Eore Radial Network and Sunburst | |
| # UPDATE: 06 Sep 2024 (Fixed some reactive stuff) | |
| # For the future: https://jokergoo.github.io/circlize_book/book/ | |
| library(shiny) | |
| library(tidyverse) | |
| library(networkD3) | |
| library(data.tree) | |
| library(data.table) # 27 Aug | |
| library(readxl) | |
| library(mwshiny) | |
| library(DT) | |
| library(plotly) # 27 Aug | |
| library(tools) # 27 Aug | |
| # Data preparation: See eorePrep.R | |
| # Read in our pre-cooked dataframe | |
| eore.df <- readRDS("eore.df.Rds") | |
| reactant_types <- readRDS("reactant_types.Rds") | |
| # Functiom definition | |
| #### Define the magic function... | |
| # See: https://stackoverflow.com/questions/57395424/how-to-format-data-for-plotly-sunburst-treemap-diagram | |
| # As modified: 27 Aug 2024 (JSE) | |
| as.sunburstDF <- function(DF, value_column = NULL, | |
| add_root = FALSE, root_name = "Root", | |
| drop_na_nodes = TRUE){ | |
| colNamesDF <- names(DF) | |
| if(is.data.table(DF)){ | |
| DT <- copy(DF) | |
| } else { | |
| DT <- data.table(DF, stringsAsFactors = FALSE) | |
| } | |
| if(add_root){ | |
| DT[, root := root_name] | |
| } | |
| colNamesDT <- names(DT) | |
| hierarchy_columns <- setdiff(colNamesDT, value_column) | |
| numeric_hierarchy_columns <- names(which(unlist(lapply(DT, is.numeric)))) | |
| if(is.null(value_column) && add_root){ | |
| setcolorder(DT, c("root", colNamesDF)) | |
| } else if(!is.null(value_column) && !add_root) { | |
| setnames(DT, value_column, "values", skip_absent=TRUE) | |
| setcolorder(DT, c(setdiff(colNamesDF, value_column), "values")) | |
| } else if(!is.null(value_column) && add_root) { | |
| setnames(DT, value_column, "values", skip_absent=TRUE) | |
| setcolorder(DT, c("root", setdiff(colNamesDF, value_column), "values")) | |
| } | |
| for(current_column in setdiff(numeric_hierarchy_columns, c("root", value_column))){ | |
| DT[, (current_column) := apply(.SD, 1, function(x){fifelse(is.na(x), yes = NA_character_, no = toTitleCase(gsub("_"," ", paste(names(x), x, sep = ": ", collapse = " | "))))}), .SDcols = current_column] | |
| } | |
| hierarchyList <- list() | |
| for(i in seq_along(hierarchy_columns)){ | |
| current_columns <- colNamesDT[1:i] | |
| if(is.null(value_column)){ | |
| currentDT <- unique(DT[, ..current_columns][, values := .N, by = current_columns], by = current_columns) | |
| } else { | |
| currentDT <- DT[, lapply(.SD, sum, na.rm = TRUE), by=current_columns, .SDcols = "values"] | |
| } | |
| setnames(currentDT, length(current_columns), "labels") | |
| currentDT[, depth := length(current_columns)-1] | |
| hierarchyList[[i]] <- currentDT | |
| } | |
| hierarchyDT <- rbindlist(hierarchyList, use.names = TRUE, fill = TRUE) | |
| if(drop_na_nodes){ | |
| hierarchyDT <- na.omit(hierarchyDT, cols = "labels") | |
| parent_columns <- setdiff(names(hierarchyDT), c("labels", "values", "depth", value_column)) | |
| hierarchyDT[, parents := apply(.SD, 1, function(x){fifelse(all(is.na(x)), yes = NA_character_, no = paste(x[!is.na(x)], sep = ":", collapse = " - "))}), .SDcols = parent_columns] | |
| } else { | |
| parent_columns <- setdiff(names(hierarchyDT), c("labels", "values", value_column)) | |
| hierarchyDT[, parents := apply(.SD, 1, function(x){fifelse(x["depth"] == "0", yes = NA_character_, no = paste(x[seq(2, as.integer(x["depth"])+1)], sep = ":", collapse = " - "))}), .SDcols = parent_columns] | |
| } | |
| hierarchyDT[, ids := apply(.SD, 1, function(x){paste(c(if(is.na(x["parents"])){NULL}else{x["parents"]}, x["labels"]), collapse = " - ")}), .SDcols = c("parents", "labels")] | |
| hierarchyDT[, union(parent_columns, "depth") := NULL] | |
| return(hierarchyDT) | |
| } | |
| ####### | |
| # MWS Stuff! | |
| ui_win <- list() | |
| ui_win[["Controller"]] <- fluidPage( | |
| titlePanel("Welcome to the EORE Data Explorer!"), | |
| # Define controllers | |
| fluidPage( | |
| selectInput("level1_select", | |
| label="solute_name_initial_1 ('All' to reset)", | |
| multiple = FALSE, | |
| choices=c("All","ImpA","ImpG","ImpC","ImpU"), | |
| selected=c("All"), | |
| width = '500px' | |
| ), | |
| selectInput("level2_select", | |
| label="total_system_pressure_initial('All' to reset)", | |
| multiple = FALSE, | |
| choices=c("All","1","1000"), | |
| selected=c("All"), | |
| width = '500px' | |
| ), | |
| selectInput("level3_select", | |
| label="temperature_initial ('All' to reset)", | |
| multiple = FALSE, | |
| choices=c("All","23","30","40","50","60","70","85","25","80","83","22"), | |
| selected=c("All"), | |
| width = '500px' | |
| ), | |
| selectInput("level4_select", | |
| label = "solute_name_initial_2 or solid_name_initial_1 ('All' to reset)", | |
| multiple = FALSE, | |
| selected="All", | |
| choices =c("All","pyrophyllite", "kaolinite", "Montmorillonite, (Volclay, SPV-200)", | |
| "pyrite", "pyrrhotite", "galena", | |
| "natrolite", "stilbite", "faujasite", | |
| "chabazite", "ZSM-5", "corundum", | |
| "hematite", "magnetite", "anorthite", | |
| "albite", "orthoclase", "quartz", | |
| "olivine", "apatite", "diopside", | |
| "chlorite", "brucite", "NaCl", | |
| "halite", "CaCl2", "MgCl2", | |
| "CoCl2", "MnCl2", "PbCl2", | |
| "SrCl2", "DyCl3", "ErCl3", | |
| "CuCl2", "FeCl2", "Montmorillonite, (untreated)", | |
| "Montmorillonite, (treated)", "MES") , | |
| width = '500px' | |
| ), | |
| selectInput("type_select", | |
| label = "Reactant type select ('All' to reset)", | |
| multiple = FALSE, | |
| selected="All", | |
| choices =c("All","Mineral","Metal Chloride","Liquid") , | |
| width = '500px' | |
| ), | |
| sliderInput("level6_select","Polymer length range", | |
| min = min(eore.df$Level6), | |
| max = max(eore.df$Level6), | |
| value = c(min(eore.df$Level6),max(eore.df$Level6)), | |
| width = '500px' | |
| ) | |
| ) | |
| ) | |
| ui_win[["Floor"]] <- fillPage( | |
| radialNetworkOutput("eorePlot", | |
| height = 1352, | |
| width = 1352) | |
| ) | |
| ui_win[["Sunburst"]] <- fillPage( | |
| plotlyOutput("eoreSunburst", | |
| height = 1352, | |
| width = 1352) | |
| ) | |
| ui_win[["Citations"]] <- fluidPage( | |
| tags$h3("Relevant Citations for Selected Results"), | |
| DTOutput("citations") | |
| ) | |
| ui_win[["TabularResults"]] <- fluidPage( | |
| tags$h3("Selected Results"), | |
| DTOutput("results") | |
| ) | |
| # Set up calculations ############################## | |
| serv_calc <- list() | |
| serv_calc[[1]] <- function(calc, session){ | |
| eore.trim <- reactiveVal(eore.df) | |
| # Initialize with all of the papers | |
| eore.cites <- reactiveVal(eore.df %>% | |
| select("paper_title", | |
| "paper_author", | |
| "paper_year") %>% | |
| distinct()) | |
| } | |
| serv_calc[[2]] <- function(calc, session){ | |
| # React to Level 1 selection | |
| observeEvent(calc$level1_select, { | |
| eore.trim.tmp <- isolate(calc$eore.trim) | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| serv_calc[[3]] <- function(calc, session){ | |
| # React to Level 2 selection | |
| observeEvent(calc$level2_select, { | |
| eore.trim.tmp <- isolate(calc$eore.trim) | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| serv_calc[[4]] <- function(calc, session){ | |
| # React to Level 3 selection | |
| observeEvent(calc$level3_select, { | |
| eore.trim.tmp <- isolate(calc$eore.trim) | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| serv_calc[[5]] <- function(calc, session){ | |
| # React to Level 4 selection | |
| observeEvent(calc$level4_select, { | |
| eore.trim.tmp <- isolate(calc$eore.trim) | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| serv_calc[[6]] <- function(calc, session){ | |
| # React to Level 6 range selection | |
| observeEvent(calc$level6_select, { | |
| eore.trim.tmp <- calc$eore.trim | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| serv_calc[[7]] <- function(calc, session){ | |
| # React to reactant type selection | |
| observeEvent(calc$type_select, { | |
| eore.trim.tmp <- isolate(calc$eore.trim) | |
| # Filter: Level 1 | |
| if (isolate(calc$level1_select) == "All") { | |
| # If 'All' then reset | |
| eore.trim.tmp <- eore.df | |
| } else { | |
| # Reset, then filter based on select | |
| eore.trim.tmp <- eore.df %>% filter(Level1 == isolate(calc$level1_select)) | |
| } | |
| # Filter: Level 2 | |
| if (isolate(calc$level2_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level2 == isolate(calc$level2_select)) | |
| } | |
| # Filter: Level 3 | |
| if (isolate(calc$level3_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level3 == isolate(calc$level3_select)) | |
| } | |
| # Filter: Level 4 | |
| if (isolate(calc$level4_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(Level4 == isolate(calc$level4_select)) | |
| } | |
| # Filter: Reactant type | |
| if (isolate(calc$type_select) == "All") { | |
| eore.trim.tmp <- eore.trim.tmp | |
| } else { | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(type == isolate(calc$type_select)) | |
| } | |
| # Now filter by range | |
| eore.trim.tmp <- eore.trim.tmp %>% filter(dplyr::between(Level6, | |
| isolate(calc$level6_select[1]), | |
| isolate(calc$level6_select[2]))) | |
| Level1_choices.tmp <- c("All",unique(eore.trim.tmp$Level1)) | |
| Level2_choices.tmp <- c("All",unique(eore.trim.tmp$Level2)) | |
| Level3_choices.tmp <- c("All",unique(eore.trim.tmp$Level3)) | |
| Level4_choices.tmp <- c("All",unique(eore.trim.tmp$Level4)) | |
| calc$eore.trim <- eore.trim.tmp | |
| # TODO: Update selectors | |
| # Level 1: Whatever it is | |
| # Levels 2-4: "All" | |
| updateSelectInput(session, "level1_select",choices = Level1_choices.tmp, selected = isolate(calc$level1_select)) | |
| updateSelectInput(session, "level2_select",choices = Level2_choices.tmp, selected = isolate(calc$level2_select)) | |
| updateSelectInput(session, "level3_select",choices = Level3_choices.tmp, selected = isolate(calc$level3_select)) | |
| updateSelectInput(session, "level4_select",choices = Level4_choices.tmp, selected = isolate(calc$level4_select)) | |
| }) | |
| } | |
| ##### | |
| # Set up outputs | |
| serv_out <- list() | |
| serv_out[["eorePlot"]] <- function(calc, session){ | |
| # Reactively regenerate the radial plot | |
| renderRadialNetwork({ | |
| # Create a local version | |
| eore.trim.tmp <- calc$eore.trim | |
| eoreTree <- as.Node(eore.trim.tmp, pathDelimiter = "|") | |
| eoreTree.df <- ToDataFrameNetwork(eoreTree, "name") | |
| minerals <- unique(reactant_types$reactant[reactant_types$type == "Mineral"]) | |
| metal_chlorides <- unique(reactant_types$reactant[reactant_types$type == "Metal Chloride"]) | |
| liquids <- unique(reactant_types$reactant[reactant_types$type == "Liquid"]) | |
| colorVector <- rep("black", nrow(eoreTree.df)) | |
| colorVector[str_detect(eoreTree.df$name,paste(minerals, collapse = "|"))] <- "blue" | |
| colorVector[str_detect(eoreTree.df$from,paste(minerals, collapse = "|"))] <- "blue" | |
| colorVector[str_detect(eoreTree.df$name,paste(metal_chlorides, collapse = "|"))] <- "green" | |
| colorVector[str_detect(eoreTree.df$from,paste(metal_chlorides, collapse = "|"))] <- "green" | |
| colorVector[str_detect(eoreTree.df$name,paste(liquids, collapse = "|"))] <- "red" | |
| colorVector[str_detect(eoreTree.df$from,paste(liquids, collapse = "|"))] <- "red" | |
| # Create JS function that changes node colors in the diagram | |
| jsarray <- paste0('["', paste(colorVector, collapse = '", "'), '"]') | |
| nodeStrokeJS <- JS(paste0('function(d, i) { return ', jsarray, '[i-1]; }')) | |
| #convert to Node | |
| eoreTree <- as.Node(eore.trim.tmp, pathDelimiter = "|") | |
| #plot with networkD3 | |
| eoreTreeList <- ToListExplicit(eoreTree, unname = TRUE) | |
| # Plot it! | |
| radialNetwork(eoreTreeList, | |
| height = 1352, | |
| width = 1352, | |
| nodeColour = nodeStrokeJS, | |
| nodeStroke = nodeStrokeJS, | |
| linkColour = "darkgray", | |
| textColour = "black", | |
| opacity = 1 | |
| ) | |
| }) | |
| } | |
| serv_out[["eoreSunburst"]] <- function(calc, session){ | |
| # Reactively regenerate the radial plot | |
| renderPlotly({ | |
| # Create a local version | |
| eore.df.levels.tmp <- calc$eore.trim %>% select(Level1, | |
| Level2, | |
| Level3, | |
| Level4, | |
| Level5, | |
| Level6) | |
| eore.df.levels.tmp$Length <- eore.df.levels.tmp$Level6 | |
| eore.df.levels.tmp <- eore.df.levels.tmp %>% | |
| relocate(Length,.before = Level6) | |
| # Apply the magic function | |
| sunburstDF.eore <- as.sunburstDF(eore.df.levels.tmp, | |
| value_column = "Level6", | |
| add_root = TRUE, | |
| root_name = "RNA\nExperiments") | |
| plot_ly(data = sunburstDF.eore, | |
| ids = ~ids, labels= ~labels, parents = ~parents, | |
| type='sunburst') | |
| }) | |
| } | |
| # List the papers | |
| serv_out[["citations"]] <- function(calc, session) { | |
| # Render... | |
| renderDT(calc$eore.trim %>% | |
| select(paper_title, | |
| paper_author, | |
| paper_year) %>% | |
| distinct(), | |
| options=list(pageLength=25)) | |
| } | |
| # List the selected results | |
| serv_out[["results"]] <- function(calc, session) { | |
| # Render... | |
| renderDT(calc$eore.trim %>% | |
| select(Level1,Level2,Level3,Level4,Level5,Level6) %>% | |
| rename( "solute_name_initial_1"=Level1, | |
| "total_system_pressure_initial"=Level2, | |
| "temperature_initial"=Level3, | |
| "solute_name_initial_2 or solid_name_initial_1"=Level4, | |
| "solute_concentration_initial_2 or solid_mass_initial_1"=Level5, | |
| "max_polymer_length_final_3"=Level6 | |
| ), | |
| options=list(pageLength=25)) | |
| } | |
| # Run the application | |
| mwsApp(ui_win, serv_calc, serv_out) |