diff --git a/Parses.R b/Parses.R index af95a5b..d7a98c9 100644 --- a/Parses.R +++ b/Parses.R @@ -85,6 +85,7 @@ getInitial <- function(string, letter) { } split <- function(cell) { + params <- unlist(strsplit(cell, ",")) values <- rep(0, length(states)) @@ -151,7 +152,7 @@ buildGraph <- function(model, desc) { } print("about to build network") - #print(paste0(inputText, edges)) + print(paste0(inputText, edges)) net <- model2network(paste0(inputText, edges), debug = FALSE) @@ -246,8 +247,6 @@ getValidNodes <- function(mapping, prevOutputs, prefix) { coefs[idx,] <- as.numeric(split(mapping[1, col]))[match(c("growth", "confidence", "layer"), states)] } - #print(coefs) - return(data.frame( code = c(prevOutputs$code, paste0(prefix, seq(1:length(outNodes)))), name = c(prevOutputs$name, outNodes), diff --git a/app.R b/app.R index cebc03f..1afd3f8 100644 --- a/app.R +++ b/app.R @@ -11,6 +11,7 @@ modules::import(plotly) modules::import(openxlsx) modules::import(zip) modules::import(DT) +modules::import(plyr) parser <- modules::use("Parses.R") @@ -271,6 +272,7 @@ server <- function(input, output, session) { wb <- parser$parseSheet(paste0(dataStorage, fileList[idx])) #print(tmp) + wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact) if (!is.null(wb)) { @@ -332,24 +334,28 @@ server <- function(input, output, session) { #displayCols <- match(nodeCodes, colnames(sampleDists)) sampleDists <- sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))] + means <- apply(sampleDists, 2, mean) stdDev <- apply(sampleDists, 2, sd) + quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99))) print(paste("Building likelihoods from model, sample dists", length(thisModel$p_es$nodes$name), length(sampleDists))) - + #str(quantiles) + if (forPlotly) { return(data.frame( name = thisModel$p_es$nodes$name, code = thisModel$p_es$nodes$code, layer = thisModel$p_es$nodes$layer, range = c( - apply(sampleDists, 2, min), - means - 2*stdDev, - means - stdDev, - means, - means + stdDev, - means + 2*stdDev, - apply(sampleDists, 2, max) + #apply(sampleDists, 2, min), + quantiles[,1], + quantiles[,2], + quantiles[,2], + quantiles[,3], + quantiles[,4], + quantiles[,4], + quantiles[,5] ), stringsAsFactors = FALSE )) @@ -391,6 +397,7 @@ server <- function(input, output, session) { #.selections$runOnce = FALSE print("Running calc") .likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE) + .selections$pressStatus <<- newStatus } @@ -413,7 +420,7 @@ server <- function(input, output, session) { #status = status, stringsAsFactors = FALSE ) - print(pressures) + #This assumes all pressures are the same... setPressures(pressures) @@ -459,7 +466,7 @@ server <- function(input, output, session) { }) observeEvent(input$modalOK, { - print("Modal ok pressed") + .resistanceScores["nr"] <<- -input$l1VH .resistanceScores["lr"] <<- -input$l1H @@ -469,7 +476,7 @@ server <- function(input, output, session) { .resistanceScores["ssgr"] <<- input$ssgr .resistanceScores["pressSD"] <<- input$l1PressSD - print("Running calc") + .likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE) removeModal() @@ -573,7 +580,7 @@ server <- function(input, output, session) { stringsAsFactors = FALSE ) - print(legendDF) + visNetwork(nodeNet, edgeNet, width = "100%", main = "Bayesian Belief Network", submain = input$modelSelect) %>% visExport() %>% @@ -626,7 +633,7 @@ server <- function(input, output, session) { colnames(thisPlot) <- c(name, "Group", "Range") title <- paste(input$modelSelect, name, "Box Plot") paletteLength <- nrow(modelList[[.selections$model]]$legend) - print(paste('prep plot palette', paletteLength)) + #print(paste('prep plot palette', paletteLength)) genPlot(thisPlot, title, paletteLength) } } @@ -663,14 +670,62 @@ server <- function(input, output, session) { }, contentType = "application/xlsx" ) + + makeLikelihoods <- function() { + + + likeliTab <- as.data.frame( + cbind( + .likelihoods$p_es, codeVal = sapply( + .likelihoods$p_es$code, function(str) { + if (startsWith(str, 'p')) as.numeric(substring(str, 2, nchar(str))) + else as.numeric(substring(str, 3, nchar(str))) + } + )), + stringsAsFactors=FALSE + ) + + likeliTab <- arrange(likeliTab, layer, codeVal) + + outputRows <- trunc(nrow(likeliTab)/7) + outputTab <- NULL + + for (idx in 1:outputRows) { + elementRow <- (idx - 1) * 7 + 1 + + tabRow <-c( + name = likeliTab$name[elementRow], + code = likeliTab$code[elementRow], + layer = likeliTab$layer[elementRow], + min=likeliTab$range[elementRow], + q1 =likeliTab$range[elementRow+2], + median =likeliTab$range[elementRow+3], + q3 =likeliTab$range[elementRow+4], + max =likeliTab$range[elementRow+6] + ) + outputTab <- rbind(outputTab, tabRow) + + } + + likelihoods <- data.frame( + name = outputTab[,1], + code = outputTab[,2], + layer = as.numeric(outputTab[,3]), + max =as.numeric(outputTab[,8]), + q3 =as.numeric(outputTab[,7]), + median =as.numeric(outputTab[,6]), + q1 =as.numeric(outputTab[,5]), + min=as.numeric(outputTab[,4]), + stringsAsFactors = FALSE, + row.names = NULL + ) + } output$download <- downloadHandler( - filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") }, content = function(file) { - print("STARTING download") - + showModal( modalDialog( fluidRow( @@ -681,24 +736,19 @@ server <- function(input, output, session) { ) oldDir <- getwd() - + tmp <- tempfile("") dir.create(tmp) setwd(tmp) - - #Get the network graph - #l1 <- exportOrca(prepPlot("ba", "Bio-Assemblage"), "layer1.png") - #l2 <- exportOrca(prepPlot("op", "Output Processes"),"layer2.png") - #l3 <- exportOrca(prepPlot("es", "Ecosystem Services"),"layer3.png") - - #Save pressure list, confidence levels, node and edge tables in xlsx + + l <- list( pressures = .selections$pressStatus, nodes = modelList[[.selections$model]]$p_es$nodes, edges = modelList[[.selections$model]]$p_es$edges, settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE), - likelihoods = calcLikelihood(0, .selections$pressStatus, FALSE) + likelihoods = makeLikelihoods() ) xl <- write.xlsx(l, "dataset.xlsx") diff --git a/data/Sub_littoral_mixed_release_#2.xlsx b/data/Sub_littoral_mixed_release_#2.xlsx new file mode 100644 index 0000000..03ffe63 Binary files /dev/null and b/data/Sub_littoral_mixed_release_#2.xlsx differ diff --git a/data/Sub_littoral_mud_release_#2.xlsx b/data/Sub_littoral_mud_release_#2.xlsx new file mode 100644 index 0000000..6d87649 Binary files /dev/null and b/data/Sub_littoral_mud_release_#2.xlsx differ diff --git a/data/Sub_littoral_rock_release_#2.xlsx b/data/Sub_littoral_rock_release_#2.xlsx new file mode 100644 index 0000000..3e99dcf Binary files /dev/null and b/data/Sub_littoral_rock_release_#2.xlsx differ diff --git a/data/Sub_littoral_sand_release_#2.xlsx b/data/Sub_littoral_sand_release_#2.xlsx new file mode 100644 index 0000000..46d2ff1 Binary files /dev/null and b/data/Sub_littoral_sand_release_#2.xlsx differ diff --git a/www/Manual.pdf b/www/Manual.pdf index b01c3fa..705383f 100644 Binary files a/www/Manual.pdf and b/www/Manual.pdf differ diff --git a/www/Report.pdf b/www/Report.pdf index b3fd0b3..2cd4118 100644 Binary files a/www/Report.pdf and b/www/Report.pdf differ