StyleR run

Parses.R

@@ -85,7 +85,6 @@ getInitial <- function(string, letter) {
 }
 
 split <- function(cell) {
-
   params <- unlist(strsplit(cell, ","))
   values <- rep(0, length(states))
 
@@ -284,10 +283,11 @@ getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
     count <- 0
 
     for (row in 2:nrow(mapping)) {
-
       if (!is.na(mapping[row, col])) {
-        edgeM <- rbind(edgeM,
+        edgeM <- rbind(
-          c(getCode(mapping[row, 1], nodeDF),
+          edgeM,
+          c(
+            getCode(mapping[row, 1], nodeDF),
             getCode(colnames(mapping)[col], nodeDF),
             split(mapping[row, col])[match("impact", states)]
           )
@@ -339,7 +339,6 @@ parseSheet <- function(fName) {
     names <- openxlsx::getSheetNames(fName)
 
     if (length(names) > 0) {
-
       sheets <- sort(delNA(match(names, mappings)))
 
       cat("starting sheet parse")
@@ -360,7 +359,6 @@ parseSheet <- function(fName) {
             legend = legend
           )
         )
-
       } else {
         print(paste("Sheets found include", mappings[sheets]))
         cat("Missing sheets are:")

app.R

@@ -31,8 +31,8 @@ impLabels <- c("Very High", "High", "Medium", "Low", "Very Low")
 
 
 ui <- dashboardPage(
-
+  dashboardHeader(
-      dashboardHeader(title = "JNCC MESO online",
+    title = "JNCC MESO online",
     tags$li(
       id = "dropdownHelp",
       class = "dropdown",
@@ -80,7 +80,8 @@ ui <- dashboardPage(
     )
   ),
   dashboardSidebar(
-        sidebarMenu(id = "tabs",
+    sidebarMenu(
+      id = "tabs",
       menuItem("Introduction", tabName = "1", icon = icon("arrow-down")),
       menuItem("Pressure Test", tabName = "2", icon = icon("arrow-down")),
       menuItem("Bayesian Network", tabName = "3", icon = icon("atom")),
@@ -127,8 +128,10 @@ ui <- dashboardPage(
         tags$p(
           style = "font-size: 12pt",
           "Impact of pressures are as defined in ",
-              tags$a(href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
+          tags$a(
-                     "the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK")
+            href = "https://www.marlin.ac.uk/sensitivity/sensitivity_rationale",
+            "the Marine Evidence based Sensitivity Assessment (MarESA).", target = "_BLANK"
+          )
         ),
         tags$p(
           style = "margin-top: 150px; font-size: 12pt",
@@ -145,7 +148,8 @@ ui <- dashboardPage(
           "Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
         )
       ),
-          tabItem(tabName = "2", h2("Impact Distribution"),
+      tabItem(
+        tabName = "2", h2("Impact Distribution"),
         fluidRow(
           column(
             width = 6,
@@ -175,7 +179,8 @@ ui <- dashboardPage(
         h4("Effect on Ecosystem Services"),
         plotlyOutput("layer3", height = "270px") %>% withSpinner()
       ),
-          tabItem(tabName = "3",h2("Bayesian Network"),
+      tabItem(
+        tabName = "3", h2("Bayesian Network"),
         fluidPage(
           p("Graphical output of the Bayesian Network.  Note: The graph will only draw if pressures are applied!"),
           fluidRow(
@@ -262,11 +267,21 @@ server <- function(input, output, session) {
   )
 
   getImpact <- function(v) {
-    if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
+    if ((v == "INS") || (v == "IV")) {
-    if ((v == "HR") || (v == "III")) return(.resistanceScores[2])
+      return(.resistanceScores[1])
-    if ((v == "MR") || (v == "II")) return(.resistanceScores[3])
+    }
-    if ((v == "LR") || (v == "I")) return(.resistanceScores[4])
+    if ((v == "HR") || (v == "III")) {
-    if (v == "NR") return(.resistanceScores[5])
+      return(.resistanceScores[2])
+    }
+    if ((v == "MR") || (v == "II")) {
+      return(.resistanceScores[3])
+    }
+    if ((v == "LR") || (v == "I")) {
+      return(.resistanceScores[4])
+    }
+    if (v == "NR") {
+      return(.resistanceScores[5])
+    }
     as.numeric(v)
   }
 
@@ -277,7 +292,8 @@ server <- function(input, output, session) {
   # save(newNameMap, file="nameMap.RData")
 
   stripStr <- function(nodeStr) {
-    nodeStr %>% stringr::str_replace_all("\\.", "") %>%
+    nodeStr %>%
+      stringr::str_replace_all("\\.", "") %>%
       stringr::str_replace_all(" ", "") %>%
       stringr::str_replace_all("\\(", "") %>%
       stringr::str_replace_all("\\)", "") %>%
@@ -323,7 +339,6 @@ server <- function(input, output, session) {
       wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact)
 
       if (!is.null(wb)) {
-
         habName <- substr(fileList[idx], 1, (nchar(fileList[idx]) - 5)) %>%
           stringr::str_replace_all("_", " ")
         print(habName)
@@ -346,15 +361,13 @@ server <- function(input, output, session) {
   # parse on load sheets in the input sheet folder - replace with R Data
   modelList <- getAvailableModels()
 
-  save(modelList, file="model.RData")
+  # save(modelList, file = "model.RData")
 
   # print(load("modelList.RData"))
 
 
   calcLikelihood <- function(layer, pressStatus, forPlotly) {
-
     isolate({
-
       modelList[[.selections$model]]$p_es$edges$values <<- sapply(modelList[[.selections$model]]$p_es$edges$impact, getImpact)
       modelList[[.selections$model]]$p_es$nodes$growth <<- .resistanceScores["ssgr"]
       modelList[[.selections$model]]$p_es$nodes$confidence <<- .resistanceScores["pressSD"]
@@ -438,7 +451,6 @@ server <- function(input, output, session) {
         stringsAsFactors = FALSE
       ))
     } else {
-
       return(data.frame(
         name = thisModel$p_es$nodes$name,
         code = thisModel$p_es$nodes$code,
@@ -449,7 +461,6 @@ server <- function(input, output, session) {
         maxes = apply(sampleDists, 2, max),
         stringsAsFactors = FALSE
       ))
-
     }
   }
 
@@ -478,7 +489,6 @@ server <- function(input, output, session) {
 
         .selections$pressStatus <<- newStatus
       }
-
     }
   })
 
@@ -517,13 +527,13 @@ server <- function(input, output, session) {
 
   observeEvent(input$bbnDisplayEdges, {
     .selections$bbnEdges <- input$bbnDisplayEdges
-
   })
 
 
   observeEvent(input$layer1Slider, {
     showModal(
-      modalDialog({
+      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),
@@ -539,13 +549,12 @@ server <- function(input, output, session) {
           modalButton("Cancel"),
           actionButton("modalOK", "OK")
         ),
-      size = "s")
+        size = "s"
+      )
     )
   })
 
   observeEvent(input$modalOK, {
-
-
     .resistanceScores["nr"] <<- -input$l1VH
     .resistanceScores["lr"] <<- -input$l1H
     .resistanceScores["mr"] <<- -input$l1M
@@ -557,7 +566,6 @@ server <- function(input, output, session) {
 
     .likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE)
     removeModal()
-
   })
 
 
@@ -643,7 +651,6 @@ server <- function(input, output, session) {
         if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
         nodeNet <- rbind(nodeNet, nodesToAdd)
         edgeNet <- rbind(edgeNet, edgesToAdd)
-
       } # until finished
     } else {
       edgeNet <- edges
@@ -692,13 +699,14 @@ server <- function(input, output, session) {
 
       # print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
       # cat(colours)
-      xform <- list(categoryorder = "array",
+      xform <- list(
+        categoryorder = "array",
         categoryarray = boxPlot[, 1],
-                    zerolinewidth = 10)
+        zerolinewidth = 10
+      )
       #
       plot_ly(boxPlot, x = boxPlot[, 1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
         layout(xaxis = xform, yaxis = list(dtick = 0.25, range = c(-1.25, 1.25)), showlegend = FALSE, title = title)
-
     }
   }
 
@@ -727,16 +735,20 @@ server <- function(input, output, session) {
   })
 
 
-  isAbsolutePath = function( path ){
+  isAbsolutePath <- function(path) {
-      if( path == "~" )
+    if (path == "~") {
-          return(TRUE);
+      return(TRUE)
-      if( grepl("^~/", path) )
+    }
-          return(TRUE);
+    if (grepl("^~/", path)) {
-      if( grepl("^.:(/|\\\\)", path) )
+      return(TRUE)
-          return(TRUE);
+    }
-      if( grepl("^(/|\\\\)", path) )
+    if (grepl("^.:(/|\\\\)", path)) {
-          return(TRUE);
+      return(TRUE)
-      return(FALSE);
+    }
+    if (grepl("^(/|\\\\)", path)) {
+      return(TRUE)
+    }
+    return(FALSE)
   }
 
   output$linkBackgroundData <- downloadHandler(
@@ -748,16 +760,19 @@ server <- function(input, output, session) {
   )
 
   makeLikelihoods <- function() {
-
-
     likeliTab <- as.data.frame(
       cbind(
-        .likelihoods$p_es, codeVal = sapply(
+        .likelihoods$p_es,
+        codeVal = sapply(
           .likelihoods$p_es$code, function(str) {
-            if (startsWith(str, 'p')) as.numeric(substring(str, 2, nchar(str)))
+            if (startsWith(str, "p")) {
-            else as.numeric(substring(str, 3, nchar(str)))
+              as.numeric(substring(str, 2, nchar(str)))
+            } else {
+              as.numeric(substring(str, 3, nchar(str)))
             }
-        )),
+          }
+        )
+      ),
       stringsAsFactors = FALSE
     )
 
@@ -780,7 +795,6 @@ server <- function(input, output, session) {
         max = likeliTab$range[elementRow + 6]
       )
       outputTab <- rbind(outputTab, tabRow)
-
     }
 
     likelihoods <- data.frame(
@@ -798,10 +812,10 @@ server <- function(input, output, session) {
   }
 
   output$download <- downloadHandler(
-
+    filename = function() {
-    filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") },
+      paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx")
+    },
     content = function(file) {
-
       showModal(
         modalDialog(
           fluidRow(
@@ -841,8 +855,6 @@ server <- function(input, output, session) {
     },
     contentType = "application/xlsx"
   )
-
-
 }
 
 shinyApp(ui, server)

extract.R

@@ -5,12 +5,16 @@ fList <- list.files("data", pattern="*.xlsx")
 # Objective to create data tables with
 linkCheck <- function(nodeType, nodeString, nodeStringCheck) {
   nodeString <- stringr::str_replace_all(nodeString, "\\.", " ")
-  res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>% is.na() %>% which()
+  res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>%
+    is.na() %>%
+    which()
   if (length(res) > 0) print(paste("Clean up error found in", nodeType, "mapping at", names(res)))
 }
 
 getNodeVals <- function(nodeStr) {
-  params <- stringr::str_split(nodeStr, ",") %>% unlist() %>% trimws()
+  params <- stringr::str_split(nodeStr, ",") %>%
+    unlist() %>%
+    trimws()
   paramVals <- stringr::str_split(params, "=")
   vals <- c()
   lapply(paramVals, function(l) {
@@ -32,7 +36,9 @@ getNodeVals <- function(nodeStr) {
 sheetNames <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend")
 
 cleanNames <- function(namVec) {
-  stringr::str_replace_all(namVec, "\\.", " ") %>% trimws() %>% tolower()
+  stringr::str_replace_all(namVec, "\\.", " ") %>%
+    trimws() %>%
+    tolower()
 }
 
 nodeTable <- tibble::tibble()
@@ -98,7 +104,6 @@ for (wbIdx in 1:length(fList)) {
       res
     )
   )
-
 }
 
 mapNewNames <- function() {
@@ -106,6 +111,3 @@ mapNewNames <- function() {
     dplyr::select(hab, nodeType, Suggestion, node, newname)
   save(newNameMap, file = "nameMap.RData")
 }
-
-
-

reWeight.R

@@ -1,7 +1,6 @@
 modules::import(magrittr)
 
 reWeightLayer <- function(nestedLayerTib, fudge = 1) {
-
   for (idx in 1:nrow(nestedLayerTib)) {
     # print(nestedLayerTib$data[idx])
     thisData <- nestedLayerTib$data[idx][[1]]
@@ -12,16 +11,22 @@ reWeightLayer <- function(nestedLayerTib, fudge=1) {
     survived <- 1
     grown <- 1
     for (depIdx in 1:nrow(thisData)) {
-      if (thisData$values[depIdx]<0) survived <- survived * (1 + thisData$values[depIdx]) else
+      if (thisData$values[depIdx] < 0) {
+        survived <- survived * (1 + thisData$values[depIdx])
+      } else {
         grown <- (1 - thisData$values[depIdx]) * grown
       }
+    }
     # Update the edge weightings to reflect the combined depletion on the BA from each of the edges
 
     effDepRate <- survived - 1
     effGrowthRate <- 1 - grown
     # print(effDepRate)
-    if (sum(thisData$values)==0) newValues <- rep(0, length(thisData$values)) else
+    if (sum(thisData$values) == 0) {
+      newValues <- rep(0, length(thisData$values))
+    } else {
       newValues <- round(thisData$values / sum(thisData$values) * (effDepRate + effGrowthRate), digits = 3)
+    }
     # print(paste(idx, paste(newValues, collapse=",")))
     nestedLayerTib$data[idx][[1]]$values <- newValues / fudge
   }
@@ -29,14 +34,15 @@ reWeightLayer <- function(nestedLayerTib, fudge=1) {
   return(nestedLayerTib %>% tidyr::unnest(cols = c(data)))
 }
 
-assignWeights <- function(
+assignWeights <- function(edgesTib,
-  edgesTib,
                           incode,
                           outcode,
                           value) {
   for (idx in 1:length(incode)) {
-    ref <- intersect(which(edgesTib$input == incode[idx]),
+    ref <- intersect(
-                     which(edgesTib$output == outcode[idx]))
+      which(edgesTib$input == incode[idx]),
+      which(edgesTib$output == outcode[idx])
+    )
 
     utils::str(ref)
 
@@ -44,13 +50,11 @@ assignWeights <- function(
     print(paste(ref, edgesTib$values[ref], value[idx]))
     edgesTib$values[ref] <- value[idx]
     # Set the appropriate values
-
   }
   return(edgesTib)
 }
 
 reWeightModel <- function(thisNet, pressStatus) {
-
   print("About to recalc p - ba")
 
   # what is the depletion factor for each of the pressures applied to the BA?
@@ -128,5 +132,4 @@ reWeightModel <- function(thisNet, pressStatus) {
   print("exitting reweighting process")
 
   return(thisNet)
-
 }