JNCC/MESO
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

StyleR run

Browse Source
This commit is contained in:
Craig Williams
2022-04-07 09:24:38 +01:00
parent be5319a423
commit 882f4cfb69
4 changed files with 507 additions and 492 deletions
Download Patch File Download Diff File Expand all files Collapse all files

646
app.R
View File

@@ -31,198 +31,203 @@ impLabels <- c("Very High", "High", "Medium", "Low", "Very Low")
ui <- dashboardPage(
dashboardHeader(title = "JNCC MESO online",
tags$li(
id = "dropdownHelp",
class = "dropdown",
tags$head(
tags$script(
paste0(
"$(document).ready(function(){",
" $('#dropdownHelp')",
" .find('ul')",
" .click(function(e) { e.stopPropagation(); });",
"});"
)
)
),
tags$a(
href = "javascript:void(0);",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon("question")
),
tags$ul(
class = "dropdown-menu",
style = "left: auto; right: 0; min-width: 200px",
tags$li(
tags$div(
style = "margin-left: auto; margin-right: auto; width: 90%;",
tags$a(
href = "Manual.pdf",
target = "_BLANK",
"Open user guide in tab"
)
)
),
tags$li(
tags$div(
style = "margin-left: auto; margin-right: auto; width: 90%;",
tags$a(
href = "Report.pdf",
target = "_BLANK",
"Open Final Report in tab"
)
)
)
dashboardHeader(
title = "JNCC MESO online",
tags$li(
id = "dropdownHelp",
class = "dropdown",
tags$head(
tags$script(
paste0(
"$(document).ready(function(){",
" $('#dropdownHelp')",
" .find('ul')",
" .click(function(e) { e.stopPropagation(); });",
"});"
)
)
),
dashboardSidebar(
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")),
#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")),
uiOutput("pressureList")
)
tags$a(
href = "javascript:void(0);",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon("question")
),
dashboardBody(
tabItems(
tabItem(
tabName = "1", h2("Introduction"),
tags$p(
style = "font-size: 12pt",
"This website is provided for the Joint Nature Conservation Committee (JNCC) and is provided by",
tags$a(href = "https://avsdev.uk", "AVS Developments", target = "_BLANK"),
", working under contract to ",
tags$a(href = "https://www.mba.ac.uk", "the Marine Biology Association.", target = "_BLANK")
),
tags$p(
style = "font-size: 12pt",
"This website provides a Proof of Concept visualisation tool to assist in understanding the probabilitic impact that
Anthropogenic Pressures (i.e. human activities) has on the habitats of sub-littoral areas of the United Kingdom."
),
tags$p(
style = "font-size: 12pt",
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
Anthropogenic Pressures through the biotopes and to the Ecosystem processes and ultimately the
Ecosystem services, to which the habitat supports."
),
tags$p(
style = "font-size: 12pt",
"By selecting combinations of pressures on the left hand side bar, the impact on biotopes and functions of the
habitat can be estimated on the graphs shown on the Pressure test page.
The Bayesian Network page shows the structure of the Bayesian Network itself. "
),
tags$p(
style = "font-size: 12pt",
"Five substrate types have been modelled (coarse sediment, mixed sediment, mud, rock and sand)."
),
tags$p(
style = "font-size: 12pt",
"Impact of pressures are as defined in ",
tags$a(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",
"Further information on the rationalale and supporting information can be found in the Studiy's Final Report
available as a download from the Help pages selectable from the Question Mark logo on the
top right hand side of the website."
),
tags$p(
style = "margin-top: 150px; font-size: 10pt",
"GDPR Notice: This website only uses cookies to provide core functionality. No personal data cookies are used."
),
tags$p(
style = "font-size: 10pt",
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
tags$ul(
class = "dropdown-menu",
style = "left: auto; right: 0; min-width: 200px",
tags$li(
tags$div(
style = "margin-left: auto; margin-right: auto; width: 90%;",
tags$a(
href = "Manual.pdf",
target = "_BLANK",
"Open user guide in tab"
)
),
tabItem(tabName = "2", h2("Impact Distribution"),
fluidRow(
column(
width = 6,
h4("Effect on Functional Groups")
),
column(
width = 1,
actionButton("layer1Slider", "1", icon = icon("sliders-h"))
),
column(
width = 2,
p("Custom sense weighting")
),
column(
width = 1,
downloadButton("download", "", icon = icon("download")),
shinyBS::bsTooltip("download", "Template provides for decimal values in degs column OR degs:mins:secs. Longitude west of meridian must be negative.")
),
column(
width = 2,
p("Download results as Excel workbook")
)
),
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner()
),
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(
column(
width = 4,
checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE),
shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far")
),
column(
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE),
shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed")
),
column(
width = 4,
selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All")
)
),
fluidRow(
visNetworkOutput("bbnGraphPlot", width = "100%", height = "1000px")
),
fluidRow(
column(
width = 6,
h4("Ecoservice nodes"),
DT::dataTableOutput("nodeTable")
),
column(
width = 6,
h4("Ecoservice influences"),
DT::dataTableOutput("edgeTable")
)
)
)
),
tags$li(
tags$div(
style = "margin-left: auto; margin-right: auto; width: 90%;",
tags$a(
href = "Report.pdf",
target = "_BLANK",
"Open Final Report in tab"
)
)
)
)
)
),
dashboardSidebar(
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")),
# 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")),
uiOutput("pressureList")
)
),
dashboardBody(
tabItems(
tabItem(
tabName = "1", h2("Introduction"),
tags$p(
style = "font-size: 12pt",
"This website is provided for the Joint Nature Conservation Committee (JNCC) and is provided by",
tags$a(href = "https://avsdev.uk", "AVS Developments", target = "_BLANK"),
", working under contract to ",
tags$a(href = "https://www.mba.ac.uk", "the Marine Biology Association.", target = "_BLANK")
),
tags$p(
style = "font-size: 12pt",
"This website provides a Proof of Concept visualisation tool to assist in understanding the probabilitic impact that
Anthropogenic Pressures (i.e. human activities) has on the habitats of sub-littoral areas of the United Kingdom."
),
tags$p(
style = "font-size: 12pt",
"The tool provides a mapping using a Continuous Gaussian Bayesian Belief Network from the
Anthropogenic Pressures through the biotopes and to the Ecosystem processes and ultimately the
Ecosystem services, to which the habitat supports."
),
tags$p(
style = "font-size: 12pt",
"By selecting combinations of pressures on the left hand side bar, the impact on biotopes and functions of the
habitat can be estimated on the graphs shown on the Pressure test page.
The Bayesian Network page shows the structure of the Bayesian Network itself. "
),
tags$p(
style = "font-size: 12pt",
"Five substrate types have been modelled (coarse sediment, mixed sediment, mud, rock and sand)."
),
tags$p(
style = "font-size: 12pt",
"Impact of pressures are as defined in ",
tags$a(
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",
"Further information on the rationalale and supporting information can be found in the Studiy's Final Report
available as a download from the Help pages selectable from the Question Mark logo on the
top right hand side of the website."
),
tags$p(
style = "margin-top: 150px; font-size: 10pt",
"GDPR Notice: This website only uses cookies to provide core functionality. No personal data cookies are used."
),
tags$p(
style = "font-size: 10pt",
"Copyright Notice: All images, logos and sources are property and copyright of their respected owners"
)
),
tabItem(
tabName = "2", h2("Impact Distribution"),
fluidRow(
column(
width = 6,
h4("Effect on Functional Groups")
),
column(
width = 1,
actionButton("layer1Slider", "1", icon = icon("sliders-h"))
),
column(
width = 2,
p("Custom sense weighting")
),
column(
width = 1,
downloadButton("download", "", icon = icon("download")),
shinyBS::bsTooltip("download", "Template provides for decimal values in degs column OR degs:mins:secs. Longitude west of meridian must be negative.")
),
column(
width = 2,
p("Download results as Excel workbook")
)
),
plotlyOutput("layer1", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Processes"),
plotlyOutput("layer2", height = "270px") %>% withSpinner(),
h4("Effect on Ecosystem Services"),
plotlyOutput("layer3", height = "270px") %>% withSpinner()
),
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(
column(
width = 4,
checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE),
shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far")
),
column(
width = 4,
checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE),
shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed")
),
column(
width = 4,
selectInput("bbnImpactSelect", "Impact Threshold", choices = impacts, selected = "All")
)
),
fluidRow(
visNetworkOutput("bbnGraphPlot", width = "100%", height = "1000px")
),
fluidRow(
column(
width = 6,
h4("Ecoservice nodes"),
DT::dataTableOutput("nodeTable")
),
column(
width = 6,
h4("Ecoservice influences"),
DT::dataTableOutput("edgeTable")
)
)
)
)
)
)
)
server <- function(input, output, session) {
#SERVER Constants
# SERVER Constants
print("Loading data")
dataStorage <- "data/"
palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue")
palette <- c("firebrick", "coral", "rosybrown", "tan", "salmon", "olivedrab", "seagreen", "aquamarine", "darkcyan", "dodgerblue", "steelblue", "royalblue")
models <- NULL
@@ -254,7 +259,7 @@ server <- function(input, output, session) {
.selections <- reactiveValues(
model = 1,
#runOnce = FALSE,
# runOnce = FALSE,
bbnImpact = 1,
bbnNames = FALSE,
bbnEdges = FALSE,
@@ -262,11 +267,21 @@ server <- function(input, output, session) {
)
getImpact <- function(v) {
if ((v == "INS") || (v == "IV")) return(.resistanceScores[1])
if ((v == "HR") || (v == "III")) 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])
if ((v == "INS") || (v == "IV")) {
return(.resistanceScores[1])
}
if ((v == "HR") || (v == "III")) {
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)
}
@@ -274,10 +289,11 @@ server <- function(input, output, session) {
dplyr::select(hab, nodeType, Suggestion, node, newname)
newNameMap$hab <- stringr::str_replace_all(newNameMap$hab, "_", " ")
#save(newNameMap, file="nameMap.RData")
# 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("\\)", "") %>%
@@ -287,14 +303,14 @@ server <- function(input, output, session) {
setNewNames <- function(wb, habName) {
#habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
# habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5))
print(habName)
possNames <- newNameMap %>%
dplyr::filter(hab==habName) %>%
dplyr::mutate(node=stripStr(node))
dplyr::filter(hab == habName) %>%
dplyr::mutate(node = stripStr(node))
newNodes <- wb$p_es$nodes %>% dplyr::mutate(node=stripStr(name))
newNodes <- wb$p_es$nodes %>% dplyr::mutate(node = stripStr(name))
print(possNames$node)
print(newNodes$node)
@@ -318,13 +334,12 @@ server <- function(input, output, session) {
print(paste("attempting to load", paste0(dataStorage, fileList[idx])))
wb <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
#print(tmp)
# print(tmp)
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)) %>%
habName <- substr(fileList[idx], 1, (nchar(fileList[idx]) - 5)) %>%
stringr::str_replace_all("_", " ")
print(habName)
@@ -334,27 +349,25 @@ 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(tmp, file = "tmp.RData")
cnt <- cnt + 1
}
}
#save(modelList, file="models.RData")
# save(modelList, file="models.RData")
updateSelectInput(session, "modelSelect", choices = models)
return(modelList)
}
#parse on load sheets in the input sheet folder - replace with R Data
# 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"))
# 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"]
@@ -374,27 +387,27 @@ server <- function(input, output, session) {
expr <- paste0(expr, "\"", pressStatus$code[p], "\" = ", threshold, ", ")
}
expr <- substr(expr, 1, nchar(expr)-2)
expr <- substr(expr, 1, nchar(expr) - 2)
expr <- paste0(expr, ")")
print(names(thisModel))
#Now do it in stages with one assessment per stage
# 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")
# save(pressStatus, thisModel, file="beforeWeight.RData")
if (sum(pressStatus$status=="On")>0) {
if (sum(pressStatus$status == "On") > 0) {
thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus)
} #else nothing to do
} # else nothing to do
#save(pressStatus, thisModel, file="afterWeight.RData")
# save(pressStatus, thisModel, file="afterWeight.RData")
thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es")))
@@ -408,17 +421,17 @@ server <- function(input, output, session) {
)
})
#print(sampleDists)
# print(sampleDists)
#displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- round(sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits=2)
# displayCols <- match(nodeCodes, colnames(sampleDists))
sampleDists <- round(sampleDists[, match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits = 2)
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)))
# quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99)))
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)
# str(quantiles)
if (forPlotly) {
return(data.frame(
@@ -426,19 +439,18 @@ server <- function(input, output, session) {
code = thisModel$p_es$nodes$code,
layer = thisModel$p_es$nodes$layer,
range = c(
#apply(sampleDists, 2, min),
quantiles[,1],
quantiles[,2],
quantiles[,2],
quantiles[,3],
quantiles[,4],
quantiles[,4],
quantiles[,5]
# apply(sampleDists, 2, min),
quantiles[, 1],
quantiles[, 2],
quantiles[, 2],
quantiles[, 3],
quantiles[, 4],
quantiles[, 4],
quantiles[, 5]
),
stringsAsFactors = FALSE
))
} else {
return(data.frame(
name = thisModel$p_es$nodes$name,
code = thisModel$p_es$nodes$code,
@@ -449,19 +461,18 @@ server <- function(input, output, session) {
maxes = apply(sampleDists, 2, max),
stringsAsFactors = FALSE
))
}
}
observeEvent(input$modelSelect, {
.selections$model <<- match(input$modelSelect, models)
#.selections$runOnce <<- TRUE
# .selections$runOnce <<- TRUE
})
observeEvent(reactiveValuesToList(input), {
isolate(myList <- reactiveValuesToList(input))
matches <- match(pressures$code, names(myList))
matches <- match(pressures$code, names(myList))
if (length(matches) > 0) {
status <- NULL
@@ -471,14 +482,13 @@ server <- function(input, output, session) {
newStatus <- data.frame(code = pressures$code, status = status, stringsAsFactors = FALSE)
if (!identical(newStatus, .selections$pressStatus)) { #} || .selections$runOnce) {
#.selections$runOnce = FALSE
if (!identical(newStatus, .selections$pressStatus)) { # } || .selections$runOnce) {
# .selections$runOnce = FALSE
print("Running calc")
.likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE)
.selections$pressStatus <<- newStatus
}
}
})
@@ -487,19 +497,19 @@ server <- function(input, output, session) {
}
output$pressureList <- renderUI({
#isolate({
# isolate({
if (!is.null(modelList[[.selections$model]]$p_es$nodes)) {
pressCodes <- which(startsWith(modelList[[.selections$model]]$p_es$nodes$code, "p"))
#if (is.null(.selections$pressStatus)) status <- rep("Off", length(pressCodes)) else status <- .selections$pressStatus$status
# if (is.null(.selections$pressStatus)) status <- rep("Off", length(pressCodes)) else status <- .selections$pressStatus$status
pressures <- data.frame(
code = modelList[[.selections$model]]$p_es$nodes$code[pressCodes],
name = modelList[[.selections$model]]$p_es$nodes$name[pressCodes],
#status = status,
# status = status,
stringsAsFactors = FALSE
)
#This assumes all pressures are the same...
# This assumes all pressures are the same...
setPressures(pressures)
btnList <- apply(pressures, 1, makeRadioButtons)
@@ -507,7 +517,7 @@ server <- function(input, output, session) {
})
observeEvent(input$bbnImpactSelect, {
#filter nodes and edges to
# filter nodes and edges to
.selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)]
})
@@ -517,35 +527,34 @@ server <- function(input, output, session) {
observeEvent(input$bbnDisplayEdges, {
.selections$bbnEdges <- input$bbnDisplayEdges
})
observeEvent(input$layer1Slider, {
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", "Zero intercept", -0.1, 0.1,.resistanceScores[6], step = 0.01),
sliderInput("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01)
)
},
title = "Layer 1 controls",
footer = tagList(
modalButton("Cancel"),
actionButton("modalOK", "OK")
),
size = "s")
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", "Zero intercept", -0.1, 0.1, .resistanceScores[6], step = 0.01),
sliderInput("l1PressSD", "Std Dev", 0.1, 1.0, .resistanceScores[7], step = 0.01)
)
},
title = "Layer 1 controls",
footer = tagList(
modalButton("Cancel"),
actionButton("modalOK", "OK")
),
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()
})
@@ -622,29 +630,28 @@ server <- function(input, output, session) {
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) {
#do pressures
# do pressures
edgeNet <- edges[edges$from %in% nodeNet$id, ]
idx <- 1
repeat {
nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),]
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id), ]
edgesToAdd <- edges[edges$from %in% nodesToAdd$id, ]
edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id),]
edgesToAdd <- edgesToAdd[!(edgesToAdd$id %in% edgeNet$id), ]
idx <- idx + 1
if ((idx > 20) || ((nrow(nodesToAdd) == 0) && (nrow(edgesToAdd) == 0))) break
nodeNet <- rbind(nodeNet, nodesToAdd)
edgeNet <- rbind(edgeNet, edgesToAdd)
} #until finished
} # until finished
} else {
edgeNet <- edges
}
@@ -662,18 +669,18 @@ server <- function(input, output, session) {
visExport() %>%
visLegend(useGroups = FALSE, addNodes = legendDF) %>%
visHierarchicalLayout(nodeSpacing = nodeSpacing, direction = "LR") %>%
visOptions(highlightNearest = TRUE) #%>%
#visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
visOptions(highlightNearest = TRUE) # %>%
# visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
}
output$bbnGraphPlot <- renderVisNetwork({
makeBbnGraph(modelList[[.selections$model]])
})
#observe({
# observe({
# visNetworkProxy("bbnGraphPlot") %>%
# visStabilize(iterations = 10)
#})
# })
getModelName <- function() {
paste0("data/", input$modelSelect, ".xlsx")
@@ -682,34 +689,35 @@ server <- function(input, output, session) {
genPlot <- function(boxPlot, title, paletteLength) {
if (nrow(boxPlot) > 0) {
#print(paste('Palette length', paletteLength))
# print(paste('Palette length', paletteLength))
#palette <- brewer.pal(paletteLength, "Set3")
# palette <- brewer.pal(paletteLength, "Set3")
#palette <- c("red", "sienna3", "plum2", "rosybrown4", "sandybrown", "yellow", "seashell3", "palegreen", "springgreen4", "steelblue", "azure")
# 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)
# 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)
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)
}
}
prepPlot <- function(code = "ba", name = "Functional Group") {
if (!is.null(.likelihoods$p_es)) {
inScope <- startsWith(.likelihoods$p_es$code, code)
thisPlot <- .likelihoods$p_es[inScope, c(1,3,4)]
thisPlot <- .likelihoods$p_es[inScope, c(1, 3, 4)]
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)
}
}
@@ -727,16 +735,20 @@ server <- function(input, output, session) {
})
isAbsolutePath = function( path ){
if( path == "~" )
return(TRUE);
if( grepl("^~/", path) )
return(TRUE);
if( grepl("^.:(/|\\\\)", path) )
return(TRUE);
if( grepl("^(/|\\\\)", path) )
return(TRUE);
return(FALSE);
isAbsolutePath <- function(path) {
if (path == "~") {
return(TRUE)
}
if (grepl("^~/", path)) {
return(TRUE)
}
if (grepl("^.:(/|\\\\)", path)) {
return(TRUE)
}
if (grepl("^(/|\\\\)", path)) {
return(TRUE)
}
return(FALSE)
}
output$linkBackgroundData <- downloadHandler(
@@ -748,66 +760,68 @@ 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)))
else as.numeric(substring(str, 3, nchar(str)))
if (startsWith(str, "p")) {
as.numeric(substring(str, 2, nchar(str)))
} else {
as.numeric(substring(str, 3, nchar(str)))
}
}
)),
stringsAsFactors=FALSE
)
),
stringsAsFactors = FALSE
)
likeliTab <- arrange(likeliTab, layer, codeVal)
outputRows <- trunc(nrow(likeliTab)/7)
outputRows <- trunc(nrow(likeliTab) / 7)
outputTab <- NULL
for (idx in 1:outputRows) {
elementRow <- (idx - 1) * 7 + 1
tabRow <-c(
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]
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]),
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") },
filename = function() {
paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx")
},
content = function(file) {
showModal(
modalDialog(
fluidRow(
column(width = 12) %>% withSpinner(type = 5, proxy.height = "200px")
),
footer=div()
footer = div()
)
)
@@ -826,13 +840,13 @@ server <- function(input, output, session) {
settings = as.data.frame(cbind(names(.resistanceScores), .resistanceScores), stringsAsFactors = FALSE),
likelihoods = makeLikelihoods()
)
xl <- write.xlsx(l, "dataset.xlsx")
xl <- write.xlsx(l, "dataset.xlsx")
#zipFile <- zipr(file, c("dataset.xlsx"))
# zipFile <- zipr(file, c("dataset.xlsx"))
file.copy("dataset.xlsx", file)
#print(paste("zip file complete", zipFile))
# print(paste("zip file complete", zipFile))
setwd(oldDir)
unlink(tmp)
@@ -841,8 +855,6 @@ server <- function(input, output, session) {
},
contentType = "application/xlsx"
)
}
shinyApp(ui, server)