Strip comments, save files and whitespace blocks
This commit is contained in:
25
Parses.R
25
Parses.R
@@ -117,7 +117,6 @@ getOutNodes <- function(codes, codeList) {
|
||||
}
|
||||
|
||||
buildGraph <- function(model, desc) {
|
||||
|
||||
# model contains the following
|
||||
# node table, edge table
|
||||
|
||||
@@ -125,7 +124,6 @@ buildGraph <- function(model, desc) {
|
||||
# inputCode - the top layer of the model
|
||||
# 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 = "")
|
||||
|
||||
@@ -153,13 +151,7 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
print("Saving model prior to network modelling")
|
||||
modelDefn <- paste0(inputText, edges)
|
||||
save(modelDefn, file = "buildGraph.RData")
|
||||
|
||||
|
||||
# print("about to build network")
|
||||
# print(paste0(inputText, edges))
|
||||
|
||||
|
||||
# save(modelDefn, file = "buildGraph.RData")
|
||||
|
||||
net <- model2network(paste0(inputText, edges), debug = FALSE)
|
||||
|
||||
@@ -175,15 +167,12 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes)))
|
||||
|
||||
# print(allDists)
|
||||
cfit <- custom.fit(net, allDists)
|
||||
|
||||
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")
|
||||
|
||||
@@ -204,7 +193,6 @@ buildGraph <- function(model, desc) {
|
||||
|
||||
|
||||
getValidNodes <- function(mapping, prevOutputs, prefix) {
|
||||
|
||||
# Find row id for input nodes, internal and published
|
||||
inputNodes <- mapping[2:nrow(mapping), 1]
|
||||
|
||||
@@ -271,10 +259,6 @@ getCode <- function(name, nodeDF) {
|
||||
}
|
||||
|
||||
getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
|
||||
# utils::str(nodeDF)
|
||||
|
||||
# save(mapping, nodeDF, prevEdge, prefix, file="validEdges.RData")
|
||||
|
||||
edgeCols <- c("inputNode", "outputNode", "impact")
|
||||
edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols))
|
||||
|
||||
@@ -297,6 +281,7 @@ getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) {
|
||||
# if (count == 0) print(paste("No edges found for output", colnames(mapping)[col]))
|
||||
}
|
||||
}
|
||||
|
||||
if (is.null(prevEdge)) {
|
||||
return(data.frame(
|
||||
input = edgeM[, "inputNode"],
|
||||
@@ -321,8 +306,6 @@ parseMapping <- function(mapping, prevOutputs, prefix) {
|
||||
nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix)
|
||||
edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix)
|
||||
|
||||
# save(nodeDF, edgeDF, file="mapping.RData")
|
||||
|
||||
return(list(
|
||||
# New structure
|
||||
nodes = nodeDF,
|
||||
@@ -331,8 +314,6 @@ parseMapping <- function(mapping, prevOutputs, prefix) {
|
||||
}
|
||||
|
||||
parseSheet <- function(fName) {
|
||||
# get sheet names
|
||||
|
||||
print(paste("starting sheet load", fName))
|
||||
|
||||
if (file.exists(fName)) {
|
||||
@@ -342,7 +323,7 @@ parseSheet <- function(fName) {
|
||||
sheets <- sort(delNA(match(names, mappings)))
|
||||
|
||||
cat("starting sheet parse")
|
||||
# print(sheets)
|
||||
print(sheets)
|
||||
|
||||
if (sum(sheets == refs) == length(refs)) {
|
||||
# read all mapping tables
|
||||
|
||||
66
app.R
66
app.R
@@ -8,7 +8,6 @@ modules::import(shinyBS)
|
||||
modules::import(bnlearn)
|
||||
modules::import(visNetwork)
|
||||
modules::import(RColorBrewer)
|
||||
modules::import(plotly)
|
||||
modules::import(openxlsx)
|
||||
modules::import(zip)
|
||||
modules::import(DT)
|
||||
@@ -16,7 +15,6 @@ modules::import(plyr)
|
||||
modules::import(magrittr)
|
||||
|
||||
parser <- modules::use("Parses.R")
|
||||
|
||||
rw <- modules::use("reWeight.R")
|
||||
|
||||
|
||||
@@ -173,11 +171,11 @@ ui <- dashboardPage(
|
||||
p("Download results as Excel workbook")
|
||||
)
|
||||
),
|
||||
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
|
||||
plotly::plotlyOutput("layer1", height = "270px") %>% withSpinner(),
|
||||
h4("Effect on Ecosystem Processes"),
|
||||
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
|
||||
plotly::plotlyOutput("layer2", height = "270px") %>% withSpinner(),
|
||||
h4("Effect on Ecosystem Services"),
|
||||
plotlyOutput("layer3", height = "270px") %>% withSpinner()
|
||||
plotly::plotlyOutput("layer3", height = "270px") %>% withSpinner()
|
||||
),
|
||||
tabItem(
|
||||
tabName = "3", h2("Bayesian Network"),
|
||||
@@ -229,7 +227,6 @@ server <- function(input, output, session) {
|
||||
|
||||
palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue")
|
||||
|
||||
|
||||
models <- NULL
|
||||
pressures <- NULL
|
||||
|
||||
@@ -302,9 +299,6 @@ server <- function(input, output, session) {
|
||||
}
|
||||
|
||||
setNewNames <- function(wb, habName) {
|
||||
|
||||
# habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
|
||||
|
||||
print(habName)
|
||||
possNames <- newNameMap %>%
|
||||
dplyr::filter(hab == habName) %>%
|
||||
@@ -334,7 +328,6 @@ server <- function(input, output, session) {
|
||||
print(paste("attempting to load", paste0(dataStorage, fileList[idx])))
|
||||
|
||||
wb <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
|
||||
# print(tmp)
|
||||
|
||||
wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact)
|
||||
|
||||
@@ -349,11 +342,9 @@ server <- function(input, output, session) {
|
||||
models <<- c(models, habName)
|
||||
print(paste("Model file successfully loaded", fileList[idx]))
|
||||
|
||||
# save(tmp, file = "tmp.RData")
|
||||
cnt <- cnt + 1
|
||||
}
|
||||
}
|
||||
# save(modelList, file="models.RData")
|
||||
updateSelectInput(session, "modelSelect", choices = models)
|
||||
return(modelList)
|
||||
}
|
||||
@@ -361,11 +352,6 @@ 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")
|
||||
|
||||
# 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)
|
||||
@@ -393,22 +379,12 @@ server <- function(input, output, session) {
|
||||
print(names(thisModel))
|
||||
|
||||
# Now do it in stages with one assessment per stage
|
||||
|
||||
|
||||
|
||||
thisModel$p_es$nodes$confidence <- 0.1 * thisModel$p_es$nodes$confidence
|
||||
|
||||
|
||||
# save(pressStatus, thisModel, file="beforeWeight.RData")
|
||||
|
||||
|
||||
|
||||
if (sum(pressStatus$status == "On") > 0) {
|
||||
thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus)
|
||||
} # else nothing to do
|
||||
|
||||
# save(pressStatus, thisModel, file="afterWeight.RData")
|
||||
|
||||
thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
|
||||
|
||||
sampleDists <- cpdist(
|
||||
@@ -467,7 +443,6 @@ server <- function(input, output, session) {
|
||||
|
||||
observeEvent(input$modelSelect, {
|
||||
.selections$model <<- match(input$modelSelect, models)
|
||||
# .selections$runOnce <<- TRUE
|
||||
})
|
||||
|
||||
observeEvent(reactiveValuesToList(input), {
|
||||
@@ -510,7 +485,6 @@ server <- function(input, output, session) {
|
||||
)
|
||||
|
||||
# This assumes all pressures are the same...
|
||||
|
||||
setPressures(pressures)
|
||||
btnList <- apply(pressures, 1, makeRadioButtons)
|
||||
}
|
||||
@@ -634,8 +608,6 @@ server <- function(input, output, session) {
|
||||
|
||||
nodeNet <- nodes[(nodes$code %in% .selections$pressStatus$code[.selections$pressStatus$status %in% c("On")]), ]
|
||||
|
||||
# save(nodes, edges, nodeNet, file = "tmp.RData")
|
||||
|
||||
if (nrow(nodeNet) > 0) {
|
||||
# do pressures
|
||||
edgeNet <- edges[edges$from %in% nodeNet$id, ]
|
||||
@@ -677,36 +649,22 @@ server <- function(input, output, session) {
|
||||
makeBbnGraph(modelList[[.selections$model]])
|
||||
})
|
||||
|
||||
# observe({
|
||||
# visNetworkProxy("bbnGraphPlot") %>%
|
||||
# visStabilize(iterations = 10)
|
||||
# })
|
||||
|
||||
getModelName <- function() {
|
||||
paste0("data/", input$modelSelect, ".xlsx")
|
||||
}
|
||||
|
||||
genPlot <- function(boxPlot, title, paletteLength) {
|
||||
if (nrow(boxPlot) > 0) {
|
||||
|
||||
# print(paste('Palette length', paletteLength))
|
||||
|
||||
# palette <- brewer.pal(paletteLength, "Set3")
|
||||
|
||||
# palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure")
|
||||
|
||||
names(palette) <- 1:length(palette)
|
||||
|
||||
# print(paste("Box plot, colours", nrow(boxPlot), length(colours)))
|
||||
# cat(colours)
|
||||
xform <- list(
|
||||
categoryorder = "array",
|
||||
categoryarray = boxPlot[, 1],
|
||||
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)
|
||||
|
||||
plotly::plot_ly(boxPlot, x = boxPlot[, 1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>%
|
||||
plotly::layout(xaxis = xform, yaxis = list(dtick = 0.25, range = c(-1.25, 1.25)), showlegend = FALSE, title = title)
|
||||
}
|
||||
}
|
||||
|
||||
@@ -722,15 +680,15 @@ server <- function(input, output, session) {
|
||||
}
|
||||
}
|
||||
|
||||
output$layer1 <- renderPlotly({
|
||||
output$layer1 <- plotly::renderPlotly({
|
||||
prepPlot("ba", "Functional Groups")
|
||||
})
|
||||
|
||||
output$layer2 <- renderPlotly({
|
||||
output$layer2 <- plotly::renderPlotly({
|
||||
prepPlot("op", "Ecosystem Processes")
|
||||
})
|
||||
|
||||
output$layer3 <- renderPlotly({
|
||||
output$layer3 <- plotly::renderPlotly({
|
||||
prepPlot("es", "Ecosystem Services")
|
||||
})
|
||||
|
||||
@@ -831,8 +789,6 @@ server <- function(input, output, session) {
|
||||
dir.create(tmp)
|
||||
setwd(tmp)
|
||||
|
||||
|
||||
|
||||
l <- list(
|
||||
pressures = .selections$pressStatus,
|
||||
nodes = modelList[[.selections$model]]$p_es$nodes,
|
||||
@@ -842,12 +798,8 @@ server <- function(input, output, session) {
|
||||
)
|
||||
xl <- write.xlsx(l, "dataset.xlsx")
|
||||
|
||||
# zipFile <- zipr(file, c("dataset.xlsx"))
|
||||
|
||||
file.copy("dataset.xlsx", file)
|
||||
|
||||
# print(paste("zip file complete", zipFile))
|
||||
|
||||
setwd(oldDir)
|
||||
unlink(tmp)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user