From 29e0bd0cf248709cdd7ead9629d6077bfe52dc55 Mon Sep 17 00:00:00 2001 From: Craig Williams Date: Thu, 11 Apr 2019 12:47:53 +0100 Subject: [PATCH] Syntax conformation --- Parses.R | 243 ++++++++++++++++++----------------- app.R | 379 ++++++++++++++++++++++++++++--------------------------- 2 files changed, 325 insertions(+), 297 deletions(-) diff --git a/Parses.R b/Parses.R index 1c1dc42..d12c844 100644 --- a/Parses.R +++ b/Parses.R @@ -1,27 +1,27 @@ -modules::import(openxlsx) modules::import(bnlearn) +modules::import(openxlsx) modules::import(stringr) -modules::import(graph) -modules::import(ggplot2) modules::import(stats) -modules::import(plotly) -modules::import(utils) #Improvements needed: make the selection of first row/column of nodes programmatic FIRST_NODE_COL <- 3 -mappings <- c('TestScenario', 'Map_P_BA', 'Map_BA_OP', 'Map_OP_ES') -nodeTypes <- c('Input.Nodes', 'Internal.Nodes', 'Published.Nodes') -states <- c('impact', 'confidence', 'growth', 'recovery', 'layer') -refs <-c(1:length(mappings)) +mappings <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES") +nodeTypes <- c("Input.Nodes", "Internal.Nodes", "Published.Nodes") +states <- c("impact", "confidence", "growth", "recovery", "layer") +refs <- c(1:length(mappings)) setEmpties <- function(val) { - if (is.na(val)) return(0) else return(val) + if (is.na(val)) { + return(0) + } else { + return(val) + } } -readXL <- function(fName, sheetN, startRow=1) { +readXL <- function(fName, sheetN, startRow = 1) { xl <- read.xlsx(fName, sheet = sheetN, startRow) #, rowNames = import) return(data.frame(xl, stringsAsFactors = FALSE, row.names = NULL)) } @@ -32,73 +32,87 @@ delNA <- function(vec) { buildExpr <- function(pressStatus) { #pressStatus is a two column DF of name of pressure and status Ii.e. on or off) - MEANPRESS = 0 + MEANPRESS <- 0 expr <- "(" for (p in 1:nrow(pressStatus)) { - if (pressStatus$status[p] == 'On') symbol='>=' else symbol='<=' + if (pressStatus$status[p] == "On") { + symbol <- ">=" + } else { + symbol <- "<=" + } + expr <- paste0(expr, "(\"", pressStatus$code[p], "\"", symbol, MEANPRESS, ") & ") } - expr<-substr(expr, 1, nchar(expr)-2) - expr<-paste0(expr, ')') + expr <- substr(expr, 1, nchar(expr) - 2) + expr <- paste0(expr, ")") return(expr) } -parseScenario <- function(press, prefix = 'p') { +parseScenario <- function(press, prefix = "p") { pressNames <- colnames(press)[2:length(colnames(press))] - coefs <- matrix(data=NA, nrow=length(pressNames), ncol=3, dimnames=list(NULL, c('growth', 'confidence', 'layer'))) + coefs <- matrix( + data = NA, + nrow = length(pressNames), + ncol = 3, + dimnames = list(NULL, c("growth", "confidence", "layer")) + ) for (col in 2:ncol(press)) { - coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c('growth', 'confidence', 'layer'), states)] + coefs[col-1,] <- as.numeric(split(press[1, col]))[match(c("growth", "confidence", "layer"), states)] } press[is.na(press)] <- 0 - if (sum(duplicated(pressNames))>0) { - cat('Duplicated pressure node names found') + if (sum(duplicated(pressNames)) > 0) { + cat("Duplicated pressure node names found") print(pressNodes[duplicated(pressNames)]) } return(list( - timeSeq=press, - nodes=data.frame(name = pressNames, - code=paste0(prefix, seq(1:length(pressNames))), - growth = coefs[,'growth'], - confidence=coefs[,'confidence'], - layer=coefs[,'layer'], - stringsAsFactors = FALSE), - edges=data.frame(input=NULL, output=NULL, impact=NULL) + timeSeq = press, + nodes = data.frame( + name = pressNames, + code = paste0(prefix, seq(1:length(pressNames))), + growth = coefs[,"growth"], + confidence = coefs[,"confidence"], + layer = coefs[,"layer"], + stringsAsFactors = FALSE + ), + edges = data.frame(input = NULL, output = NULL, impact = NULL) )) } getInitial <- function(string, letter) { - return(tolower(substr(string, start=1, stop=1))) + return(tolower(substr(string, start = 1, stop = 1))) } split <- function(cell) { - params <- unlist(strsplit(cell, ',')) + params <- unlist(strsplit(cell, ",")) values <- rep(0, length(states)) for (n in 1:length(params)) { - kvp <- unlist(strsplit(params[n], '=')) + kvp <- unlist(strsplit(params[n], "=")) ref <- match(getInitial(trimws(kvp[1])), getInitial(states)) - if ((ref>0) & (ref<=length(values))) { + + if ((ref > 0) & (ref <= length(values))) { values[ref] <- kvp[2] } else { - print(paste('Unrecognised parameter(s):',params[n])) + print(paste("Unrecognised parameter(s):",params[n])) } - } - return(values) + return(values) } cleanTitles <- function(titleV) { - return(str_replace_all(titleV, c(' ' = '.', '-' = ''))) + return(str_replace_all(titleV, c(" " = ".", "-" = ""))) } getOutNodes <- function(codes, codeList) { - v <- vector(mode='logical', length=length(codes)) + v <- vector(mode = "logical", length = length(codes)) + for (idx in 1:length(codes)) { - v[idx] <- (sum(startsWith(codes[idx], codeList))>0) + v[idx] <- (sum(startsWith(codes[idx], codeList)) > 0) } + return(v) } @@ -112,38 +126,38 @@ buildGraph <- function(model, desc) { #outputCodes - all subsequent layers to be included in the model inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))] - inputText <- paste0("[", inputNodes, "]", collapse ="") + inputText <- paste0("[", inputNodes, "]", collapse = "") #do the internal nodes edges <- "" outNodes <- model$nodes$code[getOutNodes(model$nodes$code, desc$outputCodes)] - outDist <- vector(mode="list", length=length(outNodes)) + outDist <- vector(mode = "list", length = length(outNodes)) for (idx in 1:length(outNodes)) { nodeRef <- match(outNodes[idx], model$nodes$code) rows <- which(model$edges$output == outNodes[idx]) - inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep=":", collapse="") - edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start=1, stop=(nchar(inputsStr)-1)), "]")) + inputsStr <- paste0(model$edges$input[which(model$edges$output == outNodes[idx])], sep = ":", collapse = "") + edges <- paste0(edges, paste0("[", outNodes[idx], "|", substr(inputsStr, start = 1, stop = (nchar(inputsStr)-1)), "]")) #Make the coefficient of the distribution - coefVal <- setNames(c(model$nodes$growth[nodeRef], model$edges$values[rows]), - c("(Intercept)", model$edges$input[rows]) - ) + coefVal <- setNames( + c(model$nodes$growth[nodeRef], model$edges$values[rows]), + c("(Intercept)", model$edges$input[rows]) + ) #str(coefVal) - outDist[[idx]] <- list(coef = coefVal, - sd = model$nodes$confidence[nodeRef]) + outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef]) } - print('about to build network') + print("about to build network") print(paste0(inputText, edges)) - net <- model2network(paste0(inputText, edges), debug=TRUE) + net <- model2network(paste0(inputText, edges), debug = TRUE) - print('network build successful') + print("network build successful") - inDist <- vector(mode="list", length=length(inputNodes)) + inDist <- vector(mode = "list", length = length(inputNodes)) for (idx in 1:length(inputNodes)) { inRef <- match(inputNodes[idx], model$nodes$code) @@ -151,17 +165,17 @@ buildGraph <- function(model, desc) { inDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[inRef]) } - allDists = as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) - cfit = custom.fit(net, allDists) + allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) + cfit <- custom.fit(net, allDists) - cat('about to calculate sample distributions') + cat("about to calculate sample distributions") print(outNodes) sampleDists <- cpdist(cfit, nodes = outNodes, evidence = TRUE, n = 10000, method = "lw") summDists <- summary(sampleDists) #stdDev <- sd(sampleDists) - print('sample distribution build successful') + print("sample distribution build successful") model$edges$input <- model$nodes$name[match(model$edges$input, model$nodes$code)] model$edges$output <- model$nodes$name[match(model$edges$output, model$nodes$code)] @@ -185,58 +199,62 @@ getValidNodes <- function(mapping, prevOutputs, prefix) { inputNodes <- mapping[2:nrow(mapping),1] #check that all input nodes are in the previous table - inputNodes <- delNA(mapping[mapping[,"Node.Type"] == 'input', "Nodes"]) - if (length(inputNodes)>0) { - if (sum(inputNodes %in% prevOutputs$name) 0) { + if (sum(inputNodes %in% prevOutputs$name) < length(inputNodes)) { + cat("Missing entries for input nodes in previous output columns") print(inputNodes[!inputNodes %in% prevOutputs$name]) } - } else print('Invalid sheet - table must have at least one input row containing names from previous table') + } else { + print("Invalid sheet - table must have at least one input row containing names from previous table") + } #Check the row headings concur with previous names validInputs <- delNA(inputNodes[which(unique(inputNodes) %in% prevOutputs$name)]) - if (length(validInputs)==0) print('Invalid sheet - table must have at least one input row containing names from previous table') + if (length(validInputs) == 0) { + print("Invalid sheet - table must have at least one input row containing names from previous table") + } - inputInts <- delNA(inputNodes[mapping$Node.Type!='link']) + inputInts <- delNA(inputNodes[mapping$Node.Type != "link"]) if (sum(duplicated(inputInts))>0) { - cat('Duplicated input node names found') + cat("Duplicated input node names found") print(inputNodes[duplicated(inputNodes)]) } outNodes <- delNA(colnames(mapping)[FIRST_NODE_COL:ncol(mapping)]) - if (sum(duplicated(outNodes))>0) { - cat('Duplicated output node names found') + if (sum(duplicated(outNodes)) > 0) { + cat("Duplicated output node names found") print(outNodes[duplicated(outNodes)]) } #check that all internal nodes are in the columns - intNodes <- delNA(mapping[mapping[,"Node.Type"] == 'internal', "Nodes"]) - if (length(intNodes)>0) { + intNodes <- delNA(mapping[mapping[,"Node.Type"] == "internal", "Nodes"]) + if (length(intNodes) > 0) { if (sum(intNodes %in% outNodes)0) { + if (length(names) > 0) { sheets <- sort(delNA(match(names, mappings))) - cat('starting sheet parse') + cat("starting sheet parse") print(sheets) - if (sum(sheets==refs)==length(refs)) { + if (sum(sheets == refs) == length(refs)) { #read all mapping tables - scenario <- parseScenario(readXL(fName,mappings[1], startRow=1), prefix='p') - p_ba <- parseMapping(readXL(fName,mappings[2], startRow=1), scenario, prefix='ba') - p_op <- parseMapping(readXL(fName,mappings[3], startRow=1), p_ba, prefix='op') - p_es <- parseMapping(readXL(fName,mappings[4], startRow=1), p_op, prefix='es') + scenario <- parseScenario(readXL(fName,mappings[1], startRow = 1), prefix = "p") + p_ba <- parseMapping(readXL(fName,mappings[2], startRow = 1), scenario, prefix = "ba") + p_op <- parseMapping(readXL(fName,mappings[3], startRow = 1), p_ba, prefix = "op") + p_es <- parseMapping(readXL(fName,mappings[4], startRow = 1), p_op, prefix = "es") - #print('building graphs') + #print("building graphs") - #p_baNet <- buildGraph(p_ba, desc=list(inputCode='p', outputCodes='ba')) - #p_opNet <- buildGraph(p_op, desc=list(inputCode='p', outputCodes=c('ba', 'op'))) - #p_esNet <- buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) + #p_baNet <- buildGraph(p_ba, desc = list(inputCode = "p", outputCodes = "ba")) + #p_opNet <- buildGraph(p_op, desc = list(inputCode = "p", outputCodes = c("ba", "op"))) + #p_esNet <- buildGraph(p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es"))) - print('sheet load completed') + print("sheet load completed") return( #list( #pressBioAss = p_baNet, @@ -339,8 +356,8 @@ parseSheet <- function(fName) { ) } else { - print(paste('Sheets found include', mappings[sheets])) - cat('Missing sheets are:') + print(paste("Sheets found include", mappings[sheets])) + cat("Missing sheets are:") print(refs[-sheets]) } } diff --git a/app.R b/app.R index a737005..f5f6042 100644 --- a/app.R +++ b/app.R @@ -1,47 +1,40 @@ -modules::import(DT) modules::import(shiny) -modules::import(shinyBS) -modules::import(shinyjs) modules::import(shinydashboard) modules::import(shinydashboardPlus) -modules::import(htmltools) -modules::import(DiagrammeR) -modules::import(magrittr) -modules::import(plotly) -modules::import(kableExtra) -modules::import(Rgraphviz) -modules::import(knitr) modules::import(shinycssloaders) -modules::import(googleway) +modules::import(shinyjs) + modules::import(bnlearn) modules::import(visNetwork) modules::import(RColorBrewer) -modules::import(zip) -modules::import(processx) +modules::import(plotly) modules::import(openxlsx) +modules::import(zip) +modules::import(DT) +parser <- modules::use("Parses.R") -parser <- modules::use('Parses.R') - -layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services") -transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services") -impacts <- c('Very High', '>=High', '>=Medium', '>=Low', 'All') -thresholds <- c(0.97, 0.9, 0.45, 0.17, 0) -impLabels <- c('Very High', 'High', 'Medium', 'Low', 'Very Low') - -legends <- c('Pressures', - 'Suspension feeders', - 'Mobile and burrow dwellers', - 'Predators', - 'Epifauna and algae', - 'Functional groups', - 'Output processes', - 'Output enablers', - 'Ecosystem services') addResourcePath("js", "./www/js") -ui<-dashboardPage( + +layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services") +transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services") +impacts <- c("Very High", ">= High", ">= Medium", ">= Low", "All") +thresholds <- c(0.97, 0.9, 0.45, 0.17, 0) +impLabels <- c("Very High", "High", "Medium", "Low", "Very Low") + +legends <- c("Pressures", + "Suspension feeders", + "Mobile and burrow dwellers", + "Predators", + "Epifauna and algae", + "Functional groups", + "Output processes", + "Output enablers", + "Ecosystem services") + +ui <- dashboardPage( dashboardHeader(title = "JNCC MESO online", tags$li( id = "dropdownHelp", @@ -95,52 +88,52 @@ ui<-dashboardPage( menuItem("Bayesian Network", tabName = "2", icon = icon("atom")), #menuItem("Habitats", tabName = "3", icon = icon("atlas")), #menuItem("Ingestion", tabName = "3", icon = icon("utensils")), - selectInput("modelSelect", "Select MESO model", choices=c(""), selected=NULL, multiple=FALSE), - downloadButton("download", "", icon=icon("download")), + selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE), + downloadButton("download", "", icon = icon("download")), uiOutput("pressureList") #selectInput("layerSelect", "Select Transition", - # choices=transitions, - # selected=NULL, multiple=FALSE) + # choices = transitions, + # selected = NULL, multiple = FALSE) ) ), dashboardBody( tabItems( - tabItem(tabName = "1", h2('Impact Distribution'), + tabItem(tabName = "1", h2("Impact Distribution"), fluidRow( column( - width=6, - h4('Effect on bio-assemblage') + width = 6, + h4("Effect on bio-assemblage") ), column( - width=1, - actionButton("layer1Slider", "1", icon=icon("sliders-h")) + width = 1, + actionButton("layer1Slider", "1", icon = icon("sliders-h")) ), column( - width=5, + width = 5, strong("Customise sensitivity weightings") ) ), - plotlyOutput("layer1", height="270px") %>% withSpinner(), - h4('Effect on Output Processes'), - plotlyOutput("layer2", height="270px") %>% withSpinner(), - h4('Effect on Ecosystem services'), - plotlyOutput("layer3", height="270px") %>% withSpinner() + plotlyOutput("layer1", height = "270px") %>% withSpinner(), + h4("Effect on Output Processes"), + plotlyOutput("layer2", height = "270px") %>% withSpinner(), + h4("Effect on Ecosystem services"), + plotlyOutput("layer3", height = "270px") %>% withSpinner() ), tabItem(tabName = "2",h2("Bayesian Network"), fluidPage( - p('Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!'), + p("Graphical output of the Bayesian Network. Note: The graph will only draw if pressures are applied!"), fluidRow( column( - width=4, - checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE) + width = 4, + checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE) ), column( - width=4, - checkboxInput("bbnDisplayEdges", "Display edge status", value=FALSE) + width = 4, + checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE) ), column( - width=4, - selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All') + width = 4, + selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All") ) ), fluidRow( @@ -148,14 +141,14 @@ ui<-dashboardPage( ), fluidRow( column( - width=6, - h4('Ecoservice nodes'), - DT::dataTableOutput('nodeTable') + width = 6, + h4("Ecoservice nodes"), + DT::dataTableOutput("nodeTable") ), column( - width=6, - h4('Ecoservice influences'), - DT::dataTableOutput('edgeTable') + width = 6, + h4("Ecoservice influences"), + DT::dataTableOutput("edgeTable") ) ) ) @@ -169,8 +162,8 @@ ui<-dashboardPage( fluidPage( p("Select a spreadsheet from your network for input into the JNCC Bayesian Network Analyser:"), fileInput("fileSelect", "Choose Excel Spreadsheet File (xlsx format)", multiple = FALSE, accept = "xlsx"), - fluidRow(renderUI('status')), - actionButton('loadAB', 'Load') # icon='upload') + fluidRow(renderUI("status")), + actionButton("loadAB", "Load") # icon = "upload") ) ) ) @@ -180,20 +173,20 @@ ui<-dashboardPage( server <- function(input, output, session) { #SERVER Constants - print('Loading data') + print("Loading data") #set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M") - dataStorage <- 'data/' + dataStorage <- "data/" - models<-NULL + models <- NULL pressures <- NULL .loadStatus <- reactiveValues( - valid = c(p=FALSE, ba=FALSE, op=FALSE, es=FALSE), + valid = c(p = FALSE, ba = FALSE, op = FALSE, es = FALSE), msgs = NULL ) - .likelihoods <-reactiveValues( + .likelihoods <- reactiveValues( p_ba = NULL, ba_os = NULL, os_es = NULL, @@ -206,7 +199,7 @@ server <- function(input, output, session) { .resistanceScores <- c( - ins= -0.01, + ins = -0.01, hr = -0.2, mr = -0.75, lr = -0.95, @@ -216,11 +209,11 @@ server <- function(input, output, session) { ) .selections <- reactiveValues( - model=1, - bbnImpact=1, - bbnNames=FALSE, - bbnEdges=FALSE, - pressStatus=NULL + model = 1, + bbnImpact = 1, + bbnNames = FALSE, + bbnEdges = FALSE, + pressStatus = NULL ) getImpact <- function(v) { @@ -234,13 +227,13 @@ server <- function(input, output, session) { } getAvailableModels <- function() { - fileList <- list.files(dataStorage, pattern='.xlsx') + fileList <- list.files(dataStorage, pattern = ".xlsx") modelList <- list() - cnt<-1 + cnt <- 1 for (idx in 1:length(fileList)) { - print(paste('attempting to load', paste0(dataStorage, fileList[idx]))) + print(paste("attempting to load", paste0(dataStorage, fileList[idx]))) tmp <- parser$parseSheet(paste0(dataStorage, fileList[idx])) print(tmp) @@ -249,12 +242,12 @@ server <- function(input, output, session) { if (!is.null(tmp)) { modelList[[cnt]] <- tmp models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5))) - print(paste('Model file successfully loaded', fileList[idx])) - #save(tmp, file='tmp.RData') - cnt=cnt+1 + print(paste("Model file successfully loaded", fileList[idx])) + #save(tmp, file = "tmp.RData") + cnt <- cnt+1 } } - updateSelectInput(session, "modelSelect", choices=models) + updateSelectInput(session, "modelSelect", choices = models) return(modelList) } @@ -266,41 +259,41 @@ server <- function(input, output, session) { isolate({ - #if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es' + #if (layer == 1) layerStr = "ba" else if (layer == 2) layerStr = "op" else if (layer == 3) layerStr = "es" #layerRange <- which(startsWith(thisModel$nodes$code, layerStr)) - #nodeCodes <-thisModel$nodes$code[layerRange] + #nodeCodes <- thisModel$nodes$code[layerRange] #nodeNames <- thisModel$nodes$name[layerRange] thisModel <- modelList[[.selections$model]] modelList[[.selections$model]]$edges$values <<- sapply(thisModel$edges$impact, getImpact) - modelList[[.selections$model]]$nodes$growth <<- .resistanceScores['ssgr'] - modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores['pressSD'] + modelList[[.selections$model]]$nodes$growth <<- .resistanceScores["ssgr"] + modelList[[.selections$model]]$nodes$confidence <<- .resistanceScores["pressSD"] thisModel <- modelList[[.selections$model]] - MEANPOS=1 - MEANNEG=0 + MEANPOS <- 1 + MEANNEG <- 0 expr <- "list(" for (p in 1:nrow(pressStatus)) { - if (pressStatus$status[p] == 'On') { - threshold = MEANPOS + if (pressStatus$status[p] == "On") { + threshold <- MEANPOS } else { - threshold = MEANNEG + threshold <- MEANNEG } - expr <- paste0(expr, "\"", pressStatus$code[p], "\"=", threshold, ", ") + expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ") } - expr <-substr(expr, 1, nchar(expr)-2) - expr<-paste0(expr, ')') + expr <- substr(expr, 1, nchar(expr)-2) + expr <- paste0(expr, ")") - thisNet <- parser$buildGraph(thisModel, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es'))) + thisNet <- parser$buildGraph(thisModel, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es"))) sampleDists <- cpdist( fitted = thisNet$cfit, @@ -308,7 +301,7 @@ server <- function(input, output, session) { evidence = eval(parse(text = expr)), method = "lw", n = 10000, - debug=TRUE + debug = TRUE ) }) @@ -319,23 +312,23 @@ server <- function(input, output, session) { means <- apply(sampleDists, 2, mean) stdDev <- apply(sampleDists, 2, sd) - print(paste('Building likelihoods from model, sample dists', length(thisModel$nodes$name), length(sampleDists))) + print(paste("Building likelihoods from model, sample dists", length(thisModel$nodes$name), length(sampleDists))) return(data.frame( - name = thisModel$nodes$name, - code = thisModel$nodes$code, - layer = thisModel$nodes$layer, - range = c( - apply(sampleDists, 2, min), - means - 2*stdDev, - means - stdDev, - means, - means + stdDev, - means + 2*stdDev, - apply(sampleDists, 2, max) - ), - stringsAsFactors=FALSE - )) + name = thisModel$nodes$name, + code = thisModel$nodes$code, + layer = thisModel$nodes$layer, + range = c( + apply(sampleDists, 2, min), + means - 2*stdDev, + means - stdDev, + means, + means + stdDev, + means + 2*stdDev, + apply(sampleDists, 2, max) + ), + stringsAsFactors = FALSE + )) } @@ -347,19 +340,21 @@ server <- function(input, output, session) { isolate(myList <- reactiveValuesToList(input)) matches <- match(pressures$code, names(myList)) - if (length(matches)>0) { - status <-NULL - for (n in 1:length(matches)) status[n] = myList[[matches[n]]] + if (length(matches) > 0) { + status <- NULL + for (n in 1:length(matches)) { + status[n] <- myList[[matches[n]]] + } - newStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE) + newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE) if (!identical(newStatus, .selections$pressStatus)) { - print('Running calc') + print("Running calc") #.likelihoods$p_ba <<- calcLikelihood(1, newStatus) #.likelihoods$ba_os <<- calcLikelihood(2, newStatus) #.likelihoods$os_es <<- calcLikelihood(3, newStatus) .likelihoods$p_es <<- calcLikelihood(0, newStatus) - #write.xlsx(.likelihoods$p_es, 'tmp.xlsx') + #write.xlsx(.likelihoods$p_es, "tmp.xlsx") .selections$pressStatus <<- newStatus } @@ -367,15 +362,18 @@ server <- function(input, output, session) { }) makeRadioButtons <- function(row) { - radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE) + radioButtons(row["code"], row["name"], choices = c("Off", "On"), selected = "Off", inline = TRUE) } output$pressureList <- renderUI({ #isolate({ if (!is.null(modelList[[.selections$model]]$nodes)) { - pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, 'p')) - pressures <- data.frame(code = modelList[[.selections$model]]$nodes$code[pressCodes], - name = modelList[[.selections$model]]$nodes$name[pressCodes], stringsAsFactors=FALSE) + pressCodes <- which(startsWith(modelList[[.selections$model]]$nodes$code, "p")) + pressures <- data.frame( + code = modelList[[.selections$model]]$nodes$code[pressCodes], + name = modelList[[.selections$model]]$nodes$name[pressCodes], + stringsAsFactors = FALSE + ) setPressures(pressures) btnList <- apply(pressures, 1, makeRadioButtons) } @@ -402,36 +400,36 @@ server <- function(input, output, session) { showModal( modalDialog({ tagList( - sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step=0.01), - sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step=0.01), - sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step=0.01), - sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step=0.01), - sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step=0.01), - sliderInput("ssgr", "Steady state growth rate", -0.1, 0.1,.resistanceScores[6], step=0.01), - sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step=0.01) + sliderInput("l1VL", "Insensitive", 0.01, 0.2, abs(.resistanceScores[1]), step = 0.01), + sliderInput("l1L", "Low Sensitivity/High resistance", 0.15, 0.5, abs(.resistanceScores[2]), step = 0.01), + sliderInput("l1M", "Medium Sensitivity/Med resistance", 0.5, 0.75, abs(.resistanceScores[3]), step = 0.01), + sliderInput("l1H", "High Sensitivity/Low resistance", 0.75, 1.0, abs(.resistanceScores[4]), step = 0.01), + sliderInput("l1VH", "Very High Sensitivity/No resistance", 0.9, 1.0, abs(.resistanceScores[5]), step = 0.01), + sliderInput("ssgr", "Steady state growth rate", -0.1, 0.1,.resistanceScores[6], step = 0.01), + sliderInput("l1PressSD", "Pressure Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01) ) }, - title='Layer 1 controls', - footer=tagList( + title = "Layer 1 controls", + footer = tagList( modalButton("Cancel"), actionButton("modalOK", "OK") ), - size='s') + size = "s") ) }) observeEvent(input$modalOK, { - print('Modal ok pressed') + print("Modal ok pressed") - .resistanceScores['nr'] <<- -input$l1VH - .resistanceScores['lr'] <<- -input$l1H - .resistanceScores['mr'] <<- -input$l1M - .resistanceScores['hr'] <<- -input$l1L - .resistanceScores['ins'] <<- -input$l1VL - .resistanceScores['ssgr'] <<- input$ssgr - .resistanceScores['pressSD'] <<- input$l1PressSD + .resistanceScores["nr"] <<- -input$l1VH + .resistanceScores["lr"] <<- -input$l1H + .resistanceScores["mr"] <<- -input$l1M + .resistanceScores["hr"] <<- -input$l1L + .resistanceScores["ins"] <<- -input$l1VL + .resistanceScores["ssgr"] <<- input$ssgr + .resistanceScores["pressSD"] <<- input$l1PressSD - print('Running calc') + print("Running calc") #.likelihoods$p_ba <<- calcLikelihood(1, .selections$pressStatus) #.likelihoods$ba_os <<- calcLikelihood(2, .selections$pressStatus) #.likelihoods$os_es <<- calcLikelihood(3, .selections$pressStatus) @@ -442,38 +440,52 @@ server <- function(input, output, session) { output$nodeTable <- DT::renderDataTable( - modelList[[.selections$model]]$nodes, - selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE - ) + selection = "single", + server = TRUE, + escape = FALSE, + rownames = TRUE, + options = list(searching = TRUE, pageLength = 10, editable = TRUE) + ) output$edgeTable <- DT::renderDataTable( - modelList[[.selections$model]]$edges, - selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE + selection = "single", + server = TRUE, + escape = FALSE, + rownames = TRUE, + options = list(searching = TRUE, pageLength = 10, editable = TRUE) ) getLabel <- function(value) { - sign <- ifelse(value<0, "-", "+") - idx <- min(which((abs(value)>=thresholds)==TRUE)) + sign <- ifelse(value < 0, "-", "+") + idx <- min(which((abs(value) >= thresholds) == TRUE)) return(paste0(sign, impLabels[idx])) } makeBbnGraph <- function(model) { nodes <- model$nodes - if (.selections$bbnEdges) {labels <- sapply(model$edges$values, getLabel)} else {labels <- rep("", nrow(model$edges))} + if (.selections$bbnEdges) { + labels <- sapply(model$edges$values, getLabel) + } else { + labels <- rep("", nrow(model$edges)) + } edges <- data.frame( id = rownames(model$edges), - from=match(model$edges$input, nodes$code), - to=match(model$edges$output, nodes$code), - values=model$edges$values, - label=labels, - arrows="to", - stringsAsFactors=FALSE + from = match(model$edges$input, nodes$code), + to = match(model$edges$output, nodes$code), + values = model$edges$values, + label = labels, + arrows = "to", + stringsAsFactors = FALSE ) - if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code} + if (.selections$bbnNames) { + labels <- nodes$name + } else { + labels <- nodes$code + } nodeSpacing <- ifelse(.selections$bbnNames, 600, 150) @@ -486,19 +498,19 @@ server <- function(input, output, session) { group = nodes$layer, color = palette[as.integer(nodes$layer)], code = nodes$code, - stringsAsFactors=FALSE + stringsAsFactors = FALSE ) - edges <- edges[(abs(edges$values)>=.selections$bbnImpact),] + edges <- edges[(abs(edges$values) >= .selections$bbnImpact),] - nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c('On')]),] + nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c("On")]),] - #save(nodes, edges, nodeNet, file = 'tmp.RData') + #save(nodes, edges, nodeNet, file = "tmp.RData") - if (nrow(nodeNet)>0) { + if (nrow(nodeNet) > 0) { #do pressures edgeNet <- edges[edges$from %in% nodeNet$id, ] - idx = 1 + idx <- 1 repeat { nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ] nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),] @@ -507,12 +519,14 @@ server <- function(input, output, session) { edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),] idx <- idx + 1 - if ((idx>20) || ((nrow(nodesToAdd)==0) && (nrow(edgesToAdd)==0))) break + if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break nodeNet <- rbind(nodeNet, nodesToAdd) edgeNet <- rbind(edgeNet, edgesToAdd) } #until finished - } else edgeNet <- edges + } else { + edgeNet <- edges + } legendDF <- data.frame( id = 1:length(legends), @@ -521,10 +535,10 @@ server <- function(input, output, session) { stringsAsFactors = FALSE ) - visNetwork(nodeNet, edgeNet, width = "100%", main='Bayesian Belief Network', submain=input$modelSelect) %>% + visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>% visExport() %>% - visLegend(useGroups=FALSE, addNodes=legendDF) %>% - visHierarchicalLayout(nodeSpacing=nodeSpacing, direction='LR') %>% + visLegend(useGroups = FALSE, addNodes = legendDF) %>% + visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>% visOptions(highlightNearest = TRUE) #%>% #visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE) } @@ -535,39 +549,39 @@ server <- function(input, output, session) { #observe({ # visNetworkProxy("bbnGraphPlot") %>% - # visStabilize(iterations=10) + # visStabilize(iterations = 10) #}) getModelName <- function() { - paste0('data/', input$modelSelect, '.xlsx') + paste0("data/", input$modelSelect, ".xlsx") } genPlot <- function(boxPlot, title) { - if (nrow(boxPlot)>0) { + if (nrow(boxPlot) > 0) { palette <- brewer.pal(length(legends), "RdYlGn") #print(palette) colours <- palette[as.integer(boxPlot$Group)] - #print(paste('Box plot, colours', nrow(boxPlot), length(colours))) + #print(paste("Box plot, colours", nrow(boxPlot), length(colours))) #cat(colours) xform <- list(categoryorder = "array", categoryarray = boxPlot[,1], - zerolinewidth=10) + zerolinewidth = 10) # plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = colours, colors = palette, type = "box") %>% - layout(xaxis = xform, showlegend=FALSE, title=title) + layout(xaxis = xform, showlegend = FALSE, title = title) } } - prepPlot <- function(code="ba", name="Bio-Assemblage") { + prepPlot <- function(code = "ba", name = "Bio-Assemblage") { if (!is.null(.likelihoods$p_es)) { inScope <- startsWith(.likelihoods$p_es$code, code) thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)] colnames(thisPlot) <- c(name, "Group", "Range") - title <- paste(input$modelSelect, name, 'Box Plot') + title <- paste(input$modelSelect, name, "Box Plot") genPlot(thisPlot, title) } } @@ -588,33 +602,30 @@ server <- function(input, output, session) { export <- function(model) { #Get the network graph - l1 <- orca(prepPlot("ba", "Bio-Assemblage"), 'tmp/layer1.png') - l2 <- orca(prepPlot("op", "Output Processes"),'tmp/layer2.png') - l3 <- orca(prepPlot("es", "Ecosystem Services"), 'tmp/layer3.png') + l1 <- orca(prepPlot("ba", "Bio-Assemblage"), "tmp/layer1.png") + l2 <- orca(prepPlot("op", "Output Processes"),"tmp/layer2.png") + l3 <- orca(prepPlot("es", "Ecosystem Services"), "tmp/layer3.png") #Save pressure list, confidence levels, node and edge tables in xlsx l <- list( pressures = .selections$pressStatus, nodes = model$nodes, edges = model$edges, - settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors=FALSE) + settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE) ) - xl <- write.xlsx(l, 'tmp/dataset.xlsx') + xl <- write.xlsx(l, "tmp/dataset.xlsx") - print('saving xlsx file export tmp/dataset.xlsx') + print("saving xlsx file export tmp/dataset.xlsx") - zipFile <- zipr(paste0('tmp/MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), c('tmp/layer1.png', 'tmp/layer2.png', 'tmp/layer3.png', 'tmp/dataset.xlsx')) + zipFile <- zipr(paste0("tmp/MESO-", format(Sys.time(), "%m%d_%H%M"), ".zip"), c("tmp/layer1.png", "tmp/layer2.png", "tmp/layer3.png", "tmp/dataset.xlsx")) - print(paste('zip file complete', zipFile)) + print(paste("zip file complete", zipFile)) return(zipFile) } - - - output$linkBackgroundData <- downloadHandler( filename = getModelName(), content = function(file) { @@ -623,8 +634,8 @@ server <- function(input, output, session) { contentType = "application/xlsx" ) - output$download <-downloadHandler( - filename = paste0('MESO-', format(Sys.time(), "%m%d_%H%M"), '.zip'), + output$download <- downloadHandler( + filename = paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".zip"), content = function(file) { fName <- export(modelList[[.selections$model]]) file.copy(fName, file)