small bugfixes in shiny app

gluc · Jan 12, 2016 · 11e849b · 11e849b
1 parent 3784d89
commit 11e849b
Show file tree

Hide file tree

Showing 7 changed files with 152 additions and 54 deletions.
diff --git a/NEWS b/NEWS
@@ -1,5 +1,11 @@
 # All changes to ahp are documented here.
 
+## Version 0.2.2
+- ADD: Navbar in Shiny app is now floating
+- ADD: tom_dick_harry.ahp converted to v2.0
+- FIX: Removed old v1.0 tom_dick_harry.ahp from examples
+- FIX: score is now displayed also for single decision maker model
+
 ## Version 0.2.1
 - ADD: enable Shiny app as stand-alone
 - ADD: Visualize: Show decision makers in tool tip of root

diff --git a/R/analyze.R b/R/analyze.R
@@ -62,14 +62,13 @@ GetDataFrame <- function(ahpTree,
                          sort = c("priority", "totalPriority", "orig"),
                          pruneFun = function(node, decisionMaker) TRUE) {
 
-
+  dms <- GetDecisionMakers(ahpTree)
   if (!class(ahpTree)[1] == "Node") stop("Argument ahpTree must be a data.tree structure")
-  if (!(decisionMaker == "Total" || decisionMaker %in% GetDecisionMakers(ahpTree))) stop(paste0("decisionMaker ", decisionMaker, " is not a decision maker of ahpTree"))
+  if (!(decisionMaker == "Total" || decisionMaker %in% dms)) stop(paste0("decisionMaker ", decisionMaker, " is not a decision maker of ahpTree"))
   if (!variable[1] %in% c("weightContribution", "priority", "score")) stop(paste0("variable must be weightContribution, priority, or score, but is ", variable))
   if (!sort[1] %in% c("priority", "totalPriority", "orig")) stop(paste0("sort must be priority, totalPriority, or orig, but is ", sort))
   if (length(formals(pruneFun))!=2) stop(paste0("pruneFun must have two arguments: node and decisionMaker"))  
 
-
   if (sort[1] == "priority" || sort[1] == "totalPriority") ahpTree <- Clone(ahpTree)
   if (sort[1] == "priority") ahpTree$Sort(function(x) ifelse(x$isLeaf, x$position, x$parent$priority[decisionMaker, x$name]), decreasing = TRUE)
   else if (sort[1] == "totalPriority") ahpTree$Sort(function(x) ifelse(x$isLeaf, x$position, x$parent$priority[decisionMaker, x$name]), decreasing = TRUE)
@@ -79,6 +78,8 @@ GetDataFrame <- function(ahpTree,
   else if (sort[1] == "totalPriority") nms <- names(sort( ahpTree$weightContribution["Total", ], decreasing = TRUE))
   else nms <- names(ahpTree$weightContribution["Total", ])
 
+  if (decisionMaker == "Total" && length(dms) == 1) decisionMaker <- "DecisionMaker" #otherwise score is not shown
+
   df <- do.call(ToDataFrameTree, 
                 c(ahpTree,
                   'name',

diff --git a/inst/extdata/old/tom_dick_harry_v1_0.ahp b/inst/extdata/old/tom_dick_harry_v1_0.ahp
@@ -0,0 +1,92 @@
+Version: 1.0
+#NOTE: Version 1.0 of the ahp file format is now deprecated. This version
+#of the file is only included in the package to test backward compatibility. 
+#Please use the latest format! 
+
+#########################
+# Alternatives Section
+# THIS IS FOR The Tom, Dick, & Harry problem at
+# https://en.wikipedia.org/wiki/Analytic_hierarchy_process_%E2%80%93_leader_example
+#
+# This example is provided by Nicole Radziwill, see
+# http://qualityandinnovation.com/2016/01/04/analytic-hierarchy-process-ahp-with-the-ahp-package/
+#
+Alternatives: &alternatives
+# 1= not well; 10 = best possible
+# Your assessment based on the paragraph descriptions may be different.
+  Tom:
+    age: 50
+    experience: 7
+    education: 4
+    leadership: 10
+  Dick:
+    age: 60
+    experience: 10
+    education: 6
+    leadership: 6
+  Harry:
+    age: 30
+    experience: 5
+    education: 8
+    leadership: 6
+#
+# End of Alternatives Section
+#####################################
+# Goal Section
+#
+Goal:
+# A Goal HAS preferences (within-level comparison) and HAS Children (items in level)
+  name: Choose the Most Suitable Leader
+  preferences:
+    # preferences are defined pairwise
+    # 1 means: A is equal to B
+    # 9 means: A is highly preferrable to B
+    # 1/9 means: B is highly preferrable to A
+    - [Experience, Education, 4]
+    - [Experience, Charisma, 3]
+    - [Experience, Age, 7]
+    - [Education, Charisma, 1/3]
+    - [Education, Age, 3]
+    - [Age, Charisma, 1/5]
+  children: 
+    Experience:
+      preferenceFunction: >
+        ExperiencePreference <- function(a1, a2) {
+          if (a1$experience < a2$experience) return (1/ExperiencePreference(a2, a1))
+          ratio <- a1$experience / a2$experience
+          if (ratio < 1.05) return (1)
+          if (ratio < 1.2) return (2)
+          if (ratio < 1.5) return (3)
+          if (ratio < 1.8) return (4)
+          if (ratio < 2.1) return (5) 
+          return (6) 
+        } 
+      children: *alternatives 
+    Education: 
+      preferenceFunction: >
+        EducPreference <- function(a1, a2) {
+          if (a1$education < a2$education) return (1/EducPreference(a2, a1))
+          ratio <- a1$education / a2$education
+          if (ratio < 1.05) return (1)
+          if (ratio < 1.15) return (2)
+          if (ratio < 1.25) return (3)
+          if (ratio < 1.35) return (4)
+          if (ratio < 1.55) return (5)
+          return (5)
+        }
+      children: *alternatives
+    Charisma:
+      preferences:
+        - [Tom, Dick, 5]
+        - [Tom, Harry, 9]
+        - [Dick, Harry, 4]
+      children: *alternatives
+    Age:
+      preferences:
+        - [Tom, Dick, 1/3]
+        - [Tom, Harry, 5]
+        - [Dick, Harry, 9]
+      children: *alternatives
+#
+# End of Goal Section
+#####################################
diff --git a/inst/extdata/tom_dick_harry.ahp b/inst/extdata/tom_dick_harry.ahp
@@ -1,6 +1,4 @@
-Version: 1.0
-#NOTE: Version 1.0 of the ahp file format is now deprecated. Please use the latest format. 
-
+Version: 2.0
 #########################
 # Alternatives Section
 # THIS IS FOR The Tom, Dick, & Harry problem at
@@ -36,54 +34,49 @@ Goal:
 # A Goal HAS preferences (within-level comparison) and HAS Children (items in level)
   name: Choose the Most Suitable Leader
   preferences:
-    # preferences are defined pairwise
-    # 1 means: A is equal to B
-    # 9 means: A is highly preferrable to B
-    # 1/9 means: B is highly preferrable to A
-    - [Experience, Education, 4]
-    - [Experience, Charisma, 3]
-    - [Experience, Age, 7]
-    - [Education, Charisma, 1/3]
-    - [Education, Age, 3]
-    - [Age, Charisma, 1/5]
+    pairwise:
+      # preferences are defined pairwise
+      # 1 means: A is equal to B
+      # 9 means: A is highly preferrable to B
+      # 1/9 means: B is highly preferrable to A
+      - [Experience, Education, 4]
+      - [Experience, Charisma, 3]
+      - [Experience, Age, 7]
+      - [Education, Charisma, 1/3]
+      - [Education, Age, 3]
+      - [Age, Charisma, 1/5]
   children: 
     Experience:
-      preferenceFunction: >
-        ExperiencePreference <- function(a1, a2) {
-          if (a1$experience < a2$experience) return (1/ExperiencePreference(a2, a1))
-          ratio <- a1$experience / a2$experience
-          if (ratio < 1.05) return (1)
-          if (ratio < 1.2) return (2)
-          if (ratio < 1.5) return (3)
-          if (ratio < 1.8) return (4)
-          if (ratio < 2.1) return (5) 
-          return (6) 
-        } 
+      preferences:
+        pairwiseFunction: >
+          ExperiencePreference <- function(a1, a2) {
+            if (a1$experience < a2$experience) return (1/ExperiencePreference(a2, a1))
+            ratio <- a1$experience / a2$experience
+            if (ratio < 1.05) return (1)
+            if (ratio < 1.2) return (2)
+            if (ratio < 1.5) return (3)
+            if (ratio < 1.8) return (4)
+            if (ratio < 2.1) return (5) 
+            return (6) 
+          } 
       children: *alternatives 
-    Education: 
-      preferenceFunction: >
-        EducPreference <- function(a1, a2) {
-          if (a1$education < a2$education) return (1/EducPreference(a2, a1))
-          ratio <- a1$education / a2$education
-          if (ratio < 1.05) return (1)
-          if (ratio < 1.15) return (2)
-          if (ratio < 1.25) return (3)
-          if (ratio < 1.35) return (4)
-          if (ratio < 1.55) return (5)
-          return (5)
-        }
+    Education:
+      preferences:
+        scoreFunction: function(a) a$education
       children: *alternatives
     Charisma:
       preferences:
-        - [Tom, Dick, 5]
-        - [Tom, Harry, 9]
-        - [Dick, Harry, 4]
+        pairwise:
+          - [Tom, Dick, 5]
+          - [Tom, Harry, 9]
+          - [Dick, Harry, 4]
       children: *alternatives
     Age:
       preferences:
-        - [Tom, Dick, 1/3]
-        - [Tom, Harry, 5]
-        - [Dick, Harry, 9]
+        pairwise:
+          - [Tom, Dick, 1/3]
+          - [Tom, Harry, 5]
+          - [Dick, Harry, 9]
       children: *alternatives
 #
 # End of Goal Section

diff --git a/inst/gui/shiny/server.R b/inst/gui/shiny/server.R
@@ -141,15 +141,18 @@ shinyServer(function(input, output, session) {
   # Show Upload
   observeEvent(input$showUpload ,{
     print("event: showUpload")
+    sampleFiles <- list.files(system.file("extdata", package="ahp"), full.names = TRUE)
+    sampleFiles <- basename(sampleFiles[!file.info(sampleFiles)$isdir])
     output$uploadFileOutput <- renderUI({
       #input$uploadFile
       fluidRow(
         column(
           4,
           selectInput("examples", 
                       "Load package example: ", 
-                      choices = c("", list.files(system.file("extdata", package="ahp"), full.names = FALSE)), 
-                      selected = "")
+                      choices = c("", sampleFiles), 
+                      selected = ""
+                      )
         ),
         column(
           8,

diff --git a/inst/gui/shiny/ui.R b/inst/gui/shiny/ui.R
@@ -5,36 +5,37 @@ library(formattable)
 library(shinyjs)
 library(DiagrammeR)
 
-# Define UI for application that draws a histogram
+
 shinyUI(
 
   navbarPage(
     "AHP",
     tabPanel(
       "Model", 
 
-      mainPanel(
+
         fluidPage(
           useShinyjs(),
           fluidRow(
             column(2, actionButton("showUpload", "Load", icon = icon("upload"))),
             column(2, downloadButton('downloadFile', 'Save'))
           ),
           fluidRow(uiOutput("uploadFileOutput")),
+          br(),
           fluidRow(aceEditor("ace", mode = "yaml", theme = "clouds", value = "define ahp model here"))
         )
-      )
+
     ),
 
     tabPanel(
       "Visualize", 
-      mainPanel(grVizOutput("visualizeTree")),
+      grVizOutput("visualizeTree"),
       value = "visualizePanel"
     ),
 
     tabPanel(
       "Analyze", 
-      mainPanel(
+
         sidebarLayout(
           sidebarPanel(
             radioButtons(
@@ -63,7 +64,7 @@ shinyUI(
             textInput(inputId = "level", label = "Filter n levels: ", value = "0")
           ),
           mainPanel(formattableOutput("table"))
-        )
+
       ),
       value = "analysis"
     ),
@@ -87,7 +88,9 @@ shinyUI(
     ),
     position = "fixed-top",
     theme = shinytheme("flatly"),
+    tags$style(type="text/css", "body {padding-top: 70px;}"),
     id = "navbar"
+
   )
 
 

diff --git a/tests/testthat/test-Load.R b/tests/testthat/test-Load.R
@@ -34,7 +34,7 @@ test_that("Load vacation", {
 
 
 test_that("Load all examples", {
-  for ( ahpFile in list.files(system.file("extdata", package="ahp"), full.names = TRUE) ) {
+  for ( ahpFile in list.files(system.file("extdata", package = "ahp"), recursive = TRUE, include.dirs = FALSE, full.names = TRUE) ) {
     ahpTree <- Load(ahpFile)
     Calculate(ahpTree)
     df <- Analyze(ahpTree)