Inclusion of visNetwork as bbn drawing package
This commit is contained in:
384
app.R
384
app.R
@@ -14,57 +14,113 @@ modules::import(knitr)
|
||||
modules::import(shinycssloaders)
|
||||
modules::import(googleway)
|
||||
modules::import(bnlearn)
|
||||
modules::import(visNetwork)
|
||||
|
||||
parser <- modules::use('Parses.R')
|
||||
|
||||
layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services")
|
||||
transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services")
|
||||
impacts <- c('Very High', '>=High', '>=Medium', '>=Low', 'All')
|
||||
thresholds <- c(0.97, 0.9, 0.7, 0.17, 0)
|
||||
impLabels <- c('Very High', 'High', 'Medium', 'Low', 'Very Low')
|
||||
|
||||
addResourcePath("js", "./www/js")
|
||||
|
||||
|
||||
|
||||
|
||||
ui<-dashboardPage(
|
||||
dashboardHeader(title = "JNCC MESO online"),
|
||||
|
||||
#tags$style(.times-circle {color:800000 }),
|
||||
#tags$style(.check-square {color:008000 }),
|
||||
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 a new tab"
|
||||
)
|
||||
)
|
||||
),
|
||||
tags$li(
|
||||
tags$div(
|
||||
style = "margin-left: auto; margin-right: auto; width: 90%;",
|
||||
downloadLink(
|
||||
"linkBackgroundData",
|
||||
"Download excel sheets"
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
),
|
||||
dashboardSidebar(
|
||||
sidebarMenu(id = "tabs",
|
||||
menuItem("Pressure Test", tabName = "1", icon = icon("arrow-down")),
|
||||
menuItem("Bayesian Network", tabName = "2", icon = icon("atom")),
|
||||
menuItem("Habitats", tabName = "3", icon = icon("atlas")),
|
||||
menuItem("Ingestion", tabName = "4", icon = icon("utensils")),
|
||||
#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),
|
||||
selectInput("layerSelect", "Select Transition",
|
||||
choices=transitions,
|
||||
selected=NULL, multiple=FALSE)
|
||||
uiOutput("pressureList")
|
||||
#selectInput("layerSelect", "Select Transition",
|
||||
# choices=transitions,
|
||||
# selected=NULL, multiple=FALSE)
|
||||
)
|
||||
),
|
||||
dashboardBody(
|
||||
tabItems(
|
||||
tabItem(tabName = "1",
|
||||
tabItem(tabName = "1", h2('Impact Distribution'),
|
||||
fluidRow(
|
||||
column(width=2,
|
||||
h4('Pressure Test'),
|
||||
actionButton("calcAB", "Calc"),
|
||||
uiOutput("pressureList")
|
||||
column(
|
||||
width=6,
|
||||
h4('Effect on bio-assemblage')
|
||||
),
|
||||
column(
|
||||
width=6,
|
||||
actionButton("layer1Slider", "1", icon=icon("sliders-h"))
|
||||
)
|
||||
),
|
||||
column(width=10,
|
||||
h4('Effect on bio-assemblage'),
|
||||
plotlyOutput("layer1", height="270px") %>% withSpinner(),
|
||||
h4('Effect on Output Processes'),
|
||||
plotlyOutput("layer2", height="270px") %>% withSpinner(),
|
||||
h4('Effect on Ecosystem services'),
|
||||
plotlyOutput("layer3", height="270px") %>% withSpinner()
|
||||
)
|
||||
),
|
||||
tabItem(tabName = "2",h2("Bayesian Network"),
|
||||
fluidPage(
|
||||
p('Graphical output of the Bayesian Network. Note: large networks may never stabilise!'),
|
||||
fluidRow(
|
||||
column(
|
||||
width=4,
|
||||
checkboxInput("bbnDisplayNames", "Display Node names", value=FALSE)
|
||||
),
|
||||
column(
|
||||
width=4,
|
||||
selectInput("bbnImpactSelect", "Impact Threshold", choices=impacts, selected='All')
|
||||
)
|
||||
),
|
||||
tabItem(tabName = "2",h4("Bayesian Network"),
|
||||
fluidPage(
|
||||
fluidRow(
|
||||
plotOutput("bbnGraphPlot")
|
||||
visNetworkOutput("bbnGraphPlot")
|
||||
),
|
||||
fluidRow(
|
||||
column(
|
||||
@@ -80,12 +136,12 @@ ui<-dashboardPage(
|
||||
)
|
||||
)
|
||||
),
|
||||
tabItem(tabName = "3",h4("Habitats"),
|
||||
fluidPage(
|
||||
google_mapOutput(outputId = "map", width = "100%", height = "750px")
|
||||
)
|
||||
),
|
||||
tabItem(tabName = "4",h4("Ingestion"),
|
||||
#tabItem(tabName = "3",h4("Habitats"),
|
||||
# fluidPage(
|
||||
# google_mapOutput(outputId = "map", width = "100%", height = "750px")
|
||||
# )
|
||||
#),
|
||||
tabItem(tabName = "3",h4("Ingestion"),
|
||||
fluidPage(
|
||||
p("Select a spreadsheet from your network for input into the JNCC Bayesian Network Analyser:"),
|
||||
fileInput("fileSelect", "Choose Excel Spreadsheet File (xlsx format)", multiple = FALSE, accept = "xlsx"),
|
||||
@@ -102,12 +158,13 @@ server <- function(input, output, session) {
|
||||
|
||||
print('Loading data')
|
||||
|
||||
set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
||||
#set_key("AIzaSyAw8_btgGN1drf8qhCxNcotP6r11qEXA_M")
|
||||
dataStorage <- 'data/'
|
||||
|
||||
models<-NULL
|
||||
pressures <- NULL
|
||||
|
||||
|
||||
#disable(input$loadAb)
|
||||
|
||||
.loadStatus <- reactiveValues(
|
||||
@@ -140,11 +197,11 @@ server <- function(input, output, session) {
|
||||
|
||||
for (idx in 1:length(fileList)) {
|
||||
print(paste('attempting to load', paste0(dataStorage, fileList[idx])))
|
||||
|
||||
tmp <- parser$parseSheet(paste0(dataStorage, fileList[idx]))
|
||||
|
||||
if (!is.null(tmp)) {
|
||||
modelList[[cnt]] <- tmp
|
||||
|
||||
models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5)))
|
||||
print(paste('Model file successfully loaded', fileList[idx]))
|
||||
cnt=cnt+1
|
||||
@@ -158,37 +215,24 @@ server <- function(input, output, session) {
|
||||
}
|
||||
|
||||
|
||||
.selections <- reactiveValues(model=1, layer=1)
|
||||
.selections <- reactiveValues(
|
||||
model=1,
|
||||
layer=1,
|
||||
bbnImpact=1,
|
||||
bbnNames=FALSE,
|
||||
pressStatus=NULL
|
||||
)
|
||||
|
||||
#parse on load sheets in the input sheet folder - replace with R Data
|
||||
modelList <- getAvailableModels()
|
||||
|
||||
calcLikelihood <- function(layer, pressStatus) {
|
||||
calcLikelihood <- function(layer, pressStatus, confLevels) {
|
||||
|
||||
# isolate({
|
||||
# if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else layerStr ='es'
|
||||
# nodeList <- modelList[[.selections$model]][[.selections$layer]]$nodes
|
||||
# str(nodeList)
|
||||
# nodeNames <- nodeList$name[startsWith(nodeList$code, layerStr)]
|
||||
# mean = runif(length(nodeNames), min=-1, max=1)
|
||||
# sd = runif(length(nodeNames), min=-0.25, max=0.25)
|
||||
#
|
||||
# df <- data.frame(
|
||||
# nodeNames = nodeNames,
|
||||
# range = c((mean - (3*sd)), (mean - (2*sd)), (mean - sd), mean,
|
||||
# (mean + sd), (mean + (2*sd)), (mean + (3*sd))),
|
||||
# stringsAsFactors=FALSE
|
||||
# )
|
||||
# print(df)
|
||||
# })
|
||||
# return(
|
||||
# df
|
||||
# )
|
||||
isolate({
|
||||
|
||||
if (layer==1) layerStr='ba' else if (layer==2) layerStr='op' else if (layer==3) layerStr='es'
|
||||
|
||||
layerRange <- which(startsWith(modelList[[.selections$model]][[layer]]$nodes$code, layerStr))
|
||||
layerRange <- which(startsWith(modelList[[.selections$model]][[3]]$nodes$code, layerStr))
|
||||
|
||||
nodeCodes <- modelList[[.selections$model]][[layer]]$nodes$code[layerRange]
|
||||
nodeNames <- modelList[[.selections$model]][[layer]]$nodes$name[layerRange]
|
||||
@@ -196,21 +240,6 @@ server <- function(input, output, session) {
|
||||
MEANPOS=1
|
||||
MEANNEG=0
|
||||
|
||||
# expr <- "("
|
||||
# for (p in 1:nrow(pressStatus)) {
|
||||
# if (pressStatus$status[p] == 'On') {
|
||||
# threshold = MEANPOS
|
||||
# } else {
|
||||
# threshold = MEANNEG
|
||||
# }
|
||||
#
|
||||
# expr <- paste0(expr, "(\"", pressStatus$code[p], "\">=", threshold, ") & ")
|
||||
# }
|
||||
# expr <-substr(expr, 1, nchar(expr)-2)
|
||||
# expr<-paste0(expr, ')')
|
||||
#
|
||||
# print(expr)
|
||||
|
||||
expr <- "list("
|
||||
for (p in 1:nrow(pressStatus)) {
|
||||
if (pressStatus$status[p] == 'On') {
|
||||
@@ -224,11 +253,9 @@ server <- function(input, output, session) {
|
||||
expr <-substr(expr, 1, nchar(expr)-2)
|
||||
expr<-paste0(expr, ')')
|
||||
|
||||
print(expr)
|
||||
|
||||
#txtStringWkg = "((\"p1\">=0.5) & (\"p10\">=0.5) & (\"p2\">=0.5))"
|
||||
|
||||
print(bnlearn::nodes(modelList[[.selections$model]][[layer]]$cfit))
|
||||
#build the graph
|
||||
#parser$buildGraph(p_es, desc=list(inputCode='p', outputCodes=c('ba', 'op', 'es')))
|
||||
|
||||
sampleDists <- cpdist(
|
||||
fitted = modelList[[.selections$model]][[layer]]$cfit,
|
||||
@@ -240,20 +267,11 @@ server <- function(input, output, session) {
|
||||
)
|
||||
})
|
||||
|
||||
#print (sum(res[, 1] * attr(res, "weights")) / sum(attr(res, "weights")))
|
||||
|
||||
print("Sample dists")
|
||||
print(sampleDists)
|
||||
|
||||
print("Weights")
|
||||
print(unique(attr(sampleDists, "weights")))
|
||||
displayCols <- match(nodeCodes, colnames(sampleDists))
|
||||
sampleDists <- sampleDists[,displayCols]
|
||||
means <- apply(sampleDists, 2, mean)
|
||||
stdDev <- apply(sampleDists, 2, sd)
|
||||
|
||||
print(modelList[[.selections$model]][[layer]]$nodes$name)
|
||||
|
||||
return(data.frame(
|
||||
nodeNames = nodeNames,
|
||||
range = c(
|
||||
@@ -289,53 +307,63 @@ server <- function(input, output, session) {
|
||||
column(width=3, icon(renderStatus(2))),
|
||||
column(width=3, icon(renderStatus(3))),
|
||||
column(width=3, icon(renderStatus(4)))
|
||||
)#,
|
||||
#fluidRow(
|
||||
# verbatimTextOutput("msgBoard", .loadStatus$msg, placeholder=TRUE)
|
||||
#)
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
observeEvent(input$loadAB, {
|
||||
#TO DO get spreadsheet
|
||||
#copy validated sheet into the data folder and either add or replace the sheet in the RData file
|
||||
#reload the RData file
|
||||
print('Load button pressed')
|
||||
})
|
||||
|
||||
observeEvent(input$modelSelect, {
|
||||
.selections$model <<- match(input$modelSelect, models)
|
||||
})
|
||||
|
||||
observeEvent(input$layerSelect, {
|
||||
.selections$layer <<- match(input$layerSelect, transitions)
|
||||
})
|
||||
#observeEvent(input$layerSelect, {
|
||||
# .selections$layer <<- match(input$layerSelect, transitions)
|
||||
#})
|
||||
|
||||
|
||||
observeEvent(input$calcAB, {
|
||||
#get the status of action buttons
|
||||
observeEvent(reactiveValuesToList(input), {
|
||||
isolate(myList <- reactiveValuesToList(input))
|
||||
matches <- match(pressures$code, names(myList))
|
||||
|
||||
if (length(matches)>0) {
|
||||
status <-NULL
|
||||
for (n in 1:length(matches)) status[n] = myList[[matches[n]]]
|
||||
|
||||
pressStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE)
|
||||
newStatus <- data.frame(code=pressures$code, status=status, stringsAsFactors = FALSE)
|
||||
|
||||
.likelihoods$p_ba <<- calcLikelihood(1, pressStatus)
|
||||
.likelihoods$ba_os <<- calcLikelihood(2, pressStatus)
|
||||
.likelihoods$os_es <<- calcLikelihood(3, pressStatus)
|
||||
if (!identical(newStatus, .selections$pressStatus)) {
|
||||
print('Running calc')
|
||||
.likelihoods$p_ba <<- calcLikelihood(1, newStatus)
|
||||
.likelihoods$ba_os <<- calcLikelihood(2, newStatus)
|
||||
.likelihoods$os_es <<- calcLikelihood(3, newStatus)
|
||||
|
||||
.selections$pressStatus <<- newStatus
|
||||
}
|
||||
|
||||
}
|
||||
sliderControls <- c("l1VH", "l1H", "l1M", "l1L", "l1VL", "l1Conf")
|
||||
matches <- match(sliderControls, names(myList))
|
||||
if (length(matches)>0) {
|
||||
print(matches)
|
||||
}
|
||||
})
|
||||
|
||||
output$map <- renderGoogle_map({
|
||||
google_map(location = c(55, 0), zoom = 7)
|
||||
})
|
||||
#output$map <- renderGoogle_map({
|
||||
# google_map(location = c(55, 0), zoom = 7)
|
||||
#})
|
||||
|
||||
makeRadioButtons <- function(row) {
|
||||
radioButtons(row['code'], row['name'], choices=c('Off', 'On'), selected='Off', inline=TRUE)
|
||||
}
|
||||
|
||||
output$linkBackgroundData <- downloadHandler(
|
||||
filename = "JNCC MESO.xlsx",
|
||||
content = function(file) {
|
||||
file.copy("JNCC MESO.xlsx", file)
|
||||
},
|
||||
contentType = "application/xlsx"
|
||||
)
|
||||
|
||||
|
||||
output$pressureList <- renderUI({
|
||||
#isolate({
|
||||
if (!is.null(modelList[[.selections$model]][[1]]$nodes)) {
|
||||
@@ -347,6 +375,36 @@ server <- function(input, output, session) {
|
||||
}
|
||||
})
|
||||
|
||||
observeEvent(input$bbnImpactSelect, {
|
||||
#filter nodes and edges to
|
||||
.selections$bbnImpact <- thresholds[match(input$bbnImpactSelect, impacts)]
|
||||
print(paste("Setting bbn impact", .selections$bbnImpact))
|
||||
})
|
||||
|
||||
observeEvent(input$bbnDisplayNames, {
|
||||
.selections$bbnNames <- input$bbnDisplayNames
|
||||
print(.selections$bbnNames)
|
||||
})
|
||||
|
||||
observeEvent(input$layer1Slider, {
|
||||
showModal(
|
||||
modalDialog({
|
||||
tagList(
|
||||
sliderInput("l1VH", "Very High Sensitivity", 0.9, 1.0, 0.99, step=0.01),
|
||||
sliderInput("l1H", "High Sensitivity", 0.75, 1.0, 0.95, step=0.01),
|
||||
sliderInput("l1M", "Medium Sensitivity", 0.5, 0.75, 0.95, step=0.01),
|
||||
sliderInput("l1L", "Low Sensitivity", 0.15, 0.5, 0.2, step=0.01),
|
||||
sliderInput("l1VL", "Very Low Sensitivity", 0.01, 0.2, 0.15, step=0.01),
|
||||
sliderInput("pressStdDev", "Pressure SD", 0.1, 1, 0.5, step=0.1),
|
||||
sliderInput("baStdDev", "Bio-Assemblage SD", 0.1, 1, 0.5, step=0.1)
|
||||
)
|
||||
}, title='Layer 1 controls', size='s')
|
||||
)
|
||||
})
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
output$nodeTable <- DT::renderDataTable(
|
||||
|
||||
@@ -360,31 +418,133 @@ server <- function(input, output, session) {
|
||||
selection = 'single',options = list(searching = TRUE, pageLength = 10, editable=TRUE),server = TRUE, escape = FALSE,rownames= TRUE
|
||||
)
|
||||
|
||||
output$bbnGraphPlot <- renderPlot({
|
||||
graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
|
||||
getLabel <- function(impact) {
|
||||
sign <- ifelse(impact<0, "-", "+")
|
||||
idx <- min(which((abs(impact)>=thresholds)==TRUE))
|
||||
return(paste0(sign, impLabels[idx]))
|
||||
}
|
||||
|
||||
getLevels <- function(code) {
|
||||
if (startsWith(code, 'p')) return(1)
|
||||
else if (startsWith(code, 'ba')) return(2)
|
||||
else if (startsWith(code, 'op')) return(3)
|
||||
else if (startsWith(code, 'es')) return(4)
|
||||
else return(5)
|
||||
}
|
||||
|
||||
|
||||
output$bbnGraphPlot <- renderVisNetwork({
|
||||
#graphviz.plot(modelList[[.selections$model]][[.selections$layer]]$net)
|
||||
|
||||
nodes <- modelList[[.selections$model]][[.selections$layer]]$nodes
|
||||
|
||||
edges <- data.frame(
|
||||
id = rownames(modelList[[.selections$model]][[.selections$layer]]$edges),
|
||||
from=match(modelList[[.selections$model]][[.selections$layer]]$edges$input, nodes$name),
|
||||
to=match(modelList[[.selections$model]][[.selections$layer]]$edges$output, nodes$name),
|
||||
impact=modelList[[.selections$model]][[.selections$layer]]$edges$impact,
|
||||
label=sapply(modelList[[.selections$model]][[.selections$layer]]$edges$impact, getLabel),
|
||||
arrows="to",
|
||||
stringsAsFactors=FALSE
|
||||
)
|
||||
if (.selections$bbnNames) {labels <- nodes$name} else {labels <- nodes$code}
|
||||
|
||||
nodeSpacing <- ifelse(.selections$bbnNames, 600, 150)
|
||||
|
||||
nodes <- data.frame(
|
||||
id = rownames(nodes),
|
||||
label = labels,
|
||||
level = sapply(nodes$code, getLevels),
|
||||
code = nodes$code,
|
||||
stringsAsFactors=FALSE
|
||||
)
|
||||
|
||||
|
||||
|
||||
edges <- edges[(abs(edges$impact)>=.selections$bbnImpact),]
|
||||
|
||||
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, ]
|
||||
idx = 1
|
||||
repeat {
|
||||
nodesToAdd <- nodes[nodes$id %in% edgeNet$to, ]
|
||||
nodesToAdd <- nodesToAdd[!(nodesToAdd$id %in% nodeNet$id),]
|
||||
|
||||
edgesToAdd <- edges[edges$from %in% nodesToAdd$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
|
||||
} else edgeNet <- edges
|
||||
|
||||
visNetwork(nodeNet, edgeNet, width = "100%") %>%
|
||||
visHierarchicalLayout(nodeSpacing=nodeSpacing) %>%
|
||||
visOptions(highlightNearest = TRUE) %>%
|
||||
#visPhysics(hierarchicalRepulsion = nodeSpacing) %>%
|
||||
visInteraction(navigationButtons = TRUE, dragNodes = TRUE, dragView = TRUE, zoomView = TRUE)
|
||||
})
|
||||
|
||||
observe({
|
||||
visNetworkProxy("bbnGraphPlot") %>%
|
||||
visStabilize(iterations=10)
|
||||
})
|
||||
|
||||
|
||||
output$layer1 <- renderPlotly({
|
||||
if (length(.likelihoods$p_ba)>0) {
|
||||
|
||||
.likelihoods$p_ba$nodeNames <- factor(.likelihoods$p_ba$nodeNames, levels = unique(.likelihoods$p_ba$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$p_ba$nodeNames,
|
||||
zerolinewidth=10)
|
||||
|
||||
plot_ly(.likelihoods$p_ba, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = list(zerolinewidth=2))
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
})
|
||||
|
||||
output$layer2 <- renderPlotly({
|
||||
if (.selections$layer>1) {
|
||||
if (length(.likelihoods$ba_os)>0) {
|
||||
|
||||
.likelihoods$ba_os$nodeNames <- factor(.likelihoods$ba_os$nodeNames, levels = unique(.likelihoods$ba_os$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$ba_os$nodeNames,
|
||||
zerolinewidth=5)
|
||||
|
||||
|
||||
plot_ly(.likelihoods$ba_os, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = list(zerolinewidth=2))
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
})
|
||||
|
||||
output$layer3 <- renderPlotly({
|
||||
|
||||
if (.selections$layer>2) {
|
||||
if (length(.likelihoods$os_es)>0) {
|
||||
|
||||
.likelihoods$os_es$nodeNames <- factor(.likelihoods$os_es$nodeNames, levels = unique(.likelihoods$os_es$nodeNames))
|
||||
|
||||
xform <- list(categoryorder = "array",
|
||||
categoryarray = .likelihoods$os_es$nodeNames,
|
||||
zerolinewidth=5)
|
||||
|
||||
|
||||
plot_ly(.likelihoods$os_es, y = ~range, color = ~nodeNames, type = "box") %>%
|
||||
layout(xaxis = list(zerolinewidth=2))
|
||||
layout(xaxis = xform)
|
||||
|
||||
}
|
||||
})
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Reference in New Issue
Block a user