# HDP-evaluate-shiny
# This shiny app is intended for experts to express their opinion by rating
# decision options against each other
library(shiny)
library(data.tree) #tree functionality
library(mongolite) #use Mongo for storage
library(DiagrammeR) #display the tree
library(DT) #interface for selecting models from the DB
library(rjson) #gives us more flexibility for storing and loading models
library(hdpr) #core modules
ui <- fluidPage(
titlePanel("HDP Model Evaluation"),
tabsetPanel(
tabPanel("Instructions",
h3("Instructions"),
p("If you have been invited to this page you are an expert in your field and we
greatly appreciate the time you're taking to give your input - Thanks!
To get started click the button at the bottom and then click on the
Comparisons tab to complete your evaluation."),
p("This evaluation is part of the Hierarchical Decision Making (HDM) method.
In this method a decision has been broken down into it's elements as a tree
and you have been asked to compare each element in the tree against the others in
proportion of their relative importance to the objective. Use the sliders
on the Comparisons page to rate each pair. For example:"),
tags$ul(
tags$li("If A is 3 times as important as B, A gets 75 points, B gets 25 points"),
tags$li("If the importance of A and B are the same, both get 50 points. This is
the case regardless of whether both are extremely important, mildly important
or unimportant."),
tags$li("If A is ΒΌ as important as B, A gets 20 points, B gets 80 points."),
tags$li("Zero is not used in the pairwise comparisons. If the importance of
A is negligible in comparison to B, A gets 1 point, B gets 99 points. ")
),
actionButton("btnLoadFromQueryString", "Ready? Load the evaluations!")
),
# Show a plot of the generated distribution
tabPanel("Comparisons",
h4("Compare each item against the other"),
fluidRow(
column(4, uiOutput("uiEvaluateCriteria")),
column(8,
actionButton("btnSaveAndCalculate", "Submit your evaluation"),
uiOutput("uiMessages"),
grVizOutput("modelTree")
)
)
)
)
)
server <- function(input, output, session) {
hdp=reactiveValues(tree=NULL, alternatives=NULL, evaluationId=NULL,
expertId=NULL, modelId=NULL)
dataUri <- "mongodb://localhost/hdp" #local db
#dataUri <- "mongodb://hdpdb/hdp" #when using docker use this
#Load the form from the query string
observeEvent(input$btnLoadFromQueryString, {
query <- getQueryString()
queryText <- paste(names(query), query,
sep = "=", collapse=", ")
#variables from the query string
requestedModelId <- query[["modelId"]]
currentExpert <- query[["expertId"]]
#get the tree
tree <- getExpertResultsAsTreeFromDb(requestedModelId, currentExpert, dataUri)
if(is.null(tree)) {
tree <- getModelAsTreeWithAlternativesFromDb(requestedModelId, dataUri)
}
ui.evaluation.build.byTree(tree)
ui.expertTab.observer.add()
hdp$tree <- tree
hdp$alternatives <- NULL# alternatives
hdp$expertId <- currentExpert
hdp$modelId <- requestedModelId
print("-----------StRT")
#Prune(hdp$tree, fiterFun = isNotLeaf)
ui.tree.render(hdp$tree)
})
################################################
# Get form values, calculate & save
###############################################
#generate the combo frames so I can save them for later
expert.comboFrames.generate <- function(currentNode) {
parent <- currentNode$parent
#get unique combinations
combos <- getUniqueChildCombinations(parent, NULL)
#put the combinations into frames
comboFrames <- comboFrames.buildFromNodeSliders(combos, parent)
comboFrames
}
#get the value of a slider based on the node
slider.get <- function(node) {
combos <- getUniqueChildCombinations(node, NULL)
nodeSliderValues <- lapply(1:nrow(combos), function(i) {
input[[paste0("slider_",node$name,"_",i)]]
})
#print("nodeliders")
#print(unlist(nodeSliderValues))
unlist(nodeSliderValues)
}
#when the button is clicked, calculate and save everything
observeEvent(input$btnSaveAndCalculate, {
#run the calculations across nodes in the tree
#used to reload the form with values later if we need to
comboFrameList <- hdp$tree$Get(expert.comboFrames.generate, filterFun = isNotRoot)
print("-------comboFrameList:")
print(comboFrameList)
#TODO delete this...
#saveRDS(comboFrameList, "calculateHDMWeights-comboFrames.rds")
#saveRDS(hdp$tree, "calculateHDMWeights-tree.rds")
hdp$tree <- calculateHDMWeights(hdp$tree, comboFrameList)
#get the raw slider values and save them so we can pre-populate the form
hdp$tree$Do(function(node) {
node$sliderValues <- slider.get(node)
}, filterFun = isNotLeaf)
#convert the tree to a data frame and save it to the DB
dfTreeAsNetwork <- ToDataFrameNetwork(hdp$tree, "pathString","level","weight","norm","sliderValues","inconsistency")
#I am not sure why I have to do this, annoying
dfTreeAsNetwork$from <- lapply(dfTreeAsNetwork$from,getLastElementInPath)
dfTreeAsNetwork$to <- lapply(dfTreeAsNetwork$to,getLastElementInPath)
dfTreeFlatResults <- ToDataFrameTree(hdp$tree,"pathString","level","weight","norm","sliderValues","inconsistency")
dfTreeFlatResults$pathString <- lapply(dfTreeFlatResults$pathString,getLastElementInPath)
dfTreeFlatResults$levelName <- NULL
#TODO add inconsistency to the flat results
print(dfTreeFlatResults)
fullJson <- paste0('{ "modelId" : "',hdp$modelId,'",
"expertId" : "',hdp$expertId,'",
"results":', toJSON(dfTreeAsNetwork),
',"alternatives":',toJSON(hdp$alternatives),
',"flatResults":',toJSON(dfTreeFlatResults),
',"comboFrames":',toJSON(comboFrameList),
'}')
saveHdmEvaluationToDb(fullJson, hdp$expertId, hdp$modelId, dataUri)
#TODO check tree to make sure we have reasonable values for everything
output$uiMessages <- renderUI({
h3("Thanks for taking the evaluation! Feel free to tweak your answers or just have a nice day :)")
})
})
#build the combo frames from the sliders
comboFrames.buildFromNodeSliders <- function(combos, node) {
dfCriteria <- split(combos,rep(1:nrow(combos),1))
criteriaDfList <- lapply(1:nrow(combos), function(i) {
dfOut <- data.frame(streOne = c(input[[paste0("slider_",node$name,"_",i)]]), streTwo = c(100 - input[[paste0("slider_",node$name,"_",i)]]))
colnames(dfOut) <- c(dfCriteria[[i]][[1]], dfCriteria[[i]][[2]])
return(dfOut)
})
criteriaDfList
}
#############################################
# TODO clean this up...
#############################################
#TODO probably need to add level here to accomodate duplicate node names
slider.new <- function(node) {
print(paste0("------Slider.New: ",node$name))
print("---slider values node:")
print(node$sliderValues)
combos <- getUniqueChildCombinations(node, NULL)
rawValues <- sapply(unlist(strsplit(as.character(node$sliderValues), ",")),trim)
print("---raw values:")
print(rawValues)
#TODO may need to make sure there are no spaces or special chars in the name
sliders <- lapply(1:nrow(combos), function(i) {
#print("--generating sliders")
#print(rawValues[i])
sliderValue <- 50
sliderValue <- if(!is.null(rawValues[i])) {
rawValues[i]
} else {
50
}
print("----sliderValue")
print(sliderValue)
fluidRow(
column(1,
span(combos[i,1]),
uiOutput(paste0("uiOutputValueA_",node$name,"_",i))
),
column(5,
sliderInput(paste0("slider_",node$name,"_",i),"",
value = sliderValue,
min = 1, max = 99)
),
column(1,
span(combos[i,2]),
uiOutput(paste0("uiOutputValueB_",node$name,"_",i))
)
)
})
sliders <- c(sliders, grVizOutput(paste0("treeNode_",node$name)))
}
ui.evaluation.build.byTree <- function(tree) {
print("ui.evaluation.build.byTree")
allNodeNames <- tree$Get(getNodeName, filterFun = isNotLeaf)
output$uiEvaluateCriteria <- renderUI({
sliders <- tree$Get(slider.new, filterFun = isNotLeaf)
tabSliders <- lapply(1:length(sliders), function(i) {
taby <- tabPanel(paste0(allNodeNames[i]), value = allNodeNames[i],sliders[i])
taby
})
do.call(tabsetPanel,c(id="nodePanels",tabSliders))
})
#modelTree
#add the observers
tree$Get(ui.nodesliders.observers.add.byNode, filterFun = isNotLeaf)
#TODO the tabPanel is input$nodePanels, need to add an observer or something
#tree$Do(ui.babytree.generate, filterFun = isNotLeaf)
#TODO can probably update style in the observer with Do...
#tree$Do(ui.tabs.observers.add, filterFun = isNotLeaf)
}
ui.expertTab.observer.add <- function() {
observeEvent(input$nodePanels, {
node <- FindNode(node=hdp$tree,name = input$nodePanels)
ui.tree.render(hdp$tree, node)
print(paste0("--rendering tree for node: ",input$nodePanels))
})
}
#add observers to the sliders here
ui.nodesliders.observers.add.byNode <- function(node) {
#tree$Get(ui.nodesliders.observers.add.byNode, filterFun = isNotLeaf)
combos <- getUniqueChildCombinations(node, NULL)
lapply(1:nrow(combos), function(i) {
observeEvent(input[[paste0("slider_",node$name,"_",i)]], {
output[[paste0("uiOutputValueA_",node$name,"_",i)]] <- renderUI({
span(input[[paste0("slider_",node$name,"_",i)]])
})
output[[paste0("uiOutputValueB_",node$name,"_",i)]] <- renderUI({
span(100 - input[[paste0("slider_",node$name,"_",i)]])
})
})
})
}
#render a nice tree
ui.tree.render <- function(tree, specialNode) {
SetNodeStyle(tree, style = "filled,rounded", shape = "box", fillcolor = "GreenYellow",
fontname = "helvetica", inherit = TRUE)
if(!missing(specialNode)) {
SetNodeStyle(specialNode, inherit = FALSE, fillcolor = "Thistle",
fontcolor = "Firebrick")
print("----Special Node: ")
print(specialNode)
}
output$modelTree=renderGrViz({
grViz(DiagrammeR::generate_dot(ToDiagrammeRGraph(tree)),engine = "dot")
})
}
}
# Run the application
shinyApp(ui = ui, server = server)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.