Updates to manual, sheets and final report

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),

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),
+           #apply(sampleDists, 2, min),
-          means - 2*stdDev,
+           quantiles[,1],
-          means - stdDev,
+           quantiles[,2],
-          means,
+           quantiles[,2],
-          means + stdDev,
+           quantiles[,3],
-          means + 2*stdDev,
+           quantiles[,4],
-          apply(sampleDists, 2, max)
+           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")