R/selectStrategy.R

In lajh87/tessa: Tender Evaluation Strategy Scenario Analysis

#' Select Tender Evaluation Strategy
#'
#' This shiny module and associated UI controls what happens when a tender
#' evaluation strategy is selected.
#'
#' @param id Shiny namespace identifier
#' @param defaults The default values to pass to the \code{input} list in
#' \code{strategy} reactive values.
#'
#' @return A reactive values object containing two lists: \code{input} and
#' \code{output} with the following values:
#' \itemize{
#'   \item{\code{select}}{Name of the selected tender evaluation strategy, character}
#'   \item{\code{choices}}{The available tender evaluation strategies, character}
#'   \item{\code{budget_constraint}}{Maximum budget constraint, boolean}
#'   \item{\code{quality_threshold}}{Minimum quality threshold, boolean}
#'   \item{\code{budget_val}}{Maximum budget constraint value, numeric}
#'   \item{\code{quality_val}}{Minimum quality threshold value, numeric}
#'   \item{\code{wvfm}}{Values for the 'Weighted Value for Money' strategy, list:
#'     \itemize{
#'       \item{\code{wq}}{The weighted on quality, numeric}
#'     }
#'   }
#'   \item{\code{wtp}}{Values for the 'Monetising Non-Cost Score' strategy, list:
#'     \itemize{
#'       \item{\code{cost}}{Values for the cost slider, list:
#'         \itemize{
#'          \item{\code{min}}{The minimum value for the cost slider, numeric}
#'          \item{\code{max}}{The maximum value for the cost slider, numeric}
#'          \item{\code{value}}{Selected values, numeric vector of length 2}
#'         }
#'       }
#'     }
#'     \itemize{
#'       \item{\code{non_cost}}{Values for the non-cost slider, list:
#'         \itemize{
#'          \item{\code{min}}{The minimum value for the cost slider, numeric}
#'          \item{\code{max}}{The maximum value for the cost slider, numeric}
#'          \item{\code{value}}{selected values, numeric of length 2}
#'         }
#'       }
#'       \item{\code{gradient}{The willingness to pay gradient, numeric (\code{strategy$output} only)}}
#'     }
#'   }
#'  \item{\code{ra}}{Values for the 'Relative Assessment' strategy, list:
#'    \itemize{
#'      \item{\code{wq}}{The weighted on quality, numeric}
#'    }
#'  }
#'
#' }
#'
#' @details
#' The following parameters are passed to shiny inputs through the \code{input} reactive values variable.
#' Changes to shiny inputs are observed and saved in the \code{output} reactive values.
#' The output parameters should be referenced in other modules.
#'
#' @seealso \code{\link{tessa-module}}, \code{\link{toaster}}
#' @name select-strategy-module
NULL

#' @describeIn select-strategy-module Select Strategy UI
selectStrategyUI <- function(id) {
  ns <- NS(id)
  uiOutput(ns("reactive_ui"))
}

#' @describeIn select-strategy-module Strategy Description UI
selectStrategyDescriptionUI <- function(id) {
  ns <- NS(id)
  uiOutput(ns("description"))
}

#' @describeIn select-strategy-module Select Strategy Service Code
#' @param input Shiny input variable (leave blank)
#' @param output Shiny output variable (leave blank)
#' @param session Shiny session variable (leave blank)
selectStrategy <- function(input, output, session, defaults) {
  ns <- session$ns

  strategy <- reactiveValues(
    input = defaults$strategy
  )

  observe(strategy$output <- strategy$input)

  strategies <- c(
    "Lowest Priced Tender",
    "Value for Money Index",
    "Weighted Value for Money Index",
    "Best Technically Affordable",
    "Monetising Non-Cost Score",
    "Relative Assessment (Cost to Quality Scoring)"
  )

  output$reactive_ui <- renderUI({
    fluidRow(
      column(
        width = 12,
        selectInput(
          inputId = ns("select"),
          label = "Select Strategy",
          choices = strategies,
          selected = strategy$input$select
        )
      ),
      column(
        width = 12,
        uiOutput(ns("strategy_config"))
      ),
      column(
        width = 12,
        checkboxInput(
          inputId = ns("quality_threshold"),
          label = tags$b("Quality Threshold"),
          value = strategy$input$quality_threshold
        )
      ),
      column(
        width = 6,
        uiOutput(ns("quality_config"))
      ),
      column(
        width = 12,
        uiOutput(ns("budget_checkbox"))
      ),
      column(
        width = 12,
        uiOutput(ns("budget_config"))
      )
    )
  })

  output$budget_checkbox <- renderUI({
    req(input$select)
    if (!length(input$select)) return(NULL)
    if (input$select == "Best Technically Affordable") {
      tags$label("Budget")
    } else {
      checkboxInput(
        inputId = ns("budget_constraint"),
        label = tags$b("Budget Constraint"),
        value = strategy$input$budget_constraint
      )
    }
  })

  output$quality_config <- renderUI({
    if (input$quality_threshold == FALSE) return(NULL)

    fluidRow(
      column(
        width = 12,
        sliderInput(
          inputId = ns("quality_val"),
          label = NULL,
          min = 0,
          max = 100,
          value = strategy$input$quality_val
        )
      )
    )
  })

  output$budget_config <- renderUI({
    req(input$select)
    if (length(input$select) == 0 || length(input$budget_constraint) == 0) return(NULL)
    if (input$select == "Best Technically Affordable" | input$budget_constraint == TRUE) {
      tagList(
        numericInput(
          inputId = ns("budget_val"),
          label = NULL,
          value = strategy$input$budget_val,
          width = "50%"
        )
      )
    } else {
      return(NULL)
    }
  })

  output$strategy_config <- renderUI({
    if (input$select == "Weighted Value for Money Index") {
      fluidRow(
        column(
          width = 6,
          sliderInput(
            inputId = ns("wvfm_wq"),
            label = "Quality Weight",
            min = 0,
            max = 100,
            value = strategy$input$wfvm$wq
          )
        )
      )
    } else {
      if (input$select == "Monetising Non-Cost Score") {
        tagList(
          fluidRow(
            column(
              width = 6,
              sliderInput(
                inputId = ns("wtp_noncost"),
                label = "Non Cost",
                min = strategy$input$wtp$non_cost$min,
                max = strategy$input$wtp$non_cost$max,
                value = strategy$input$wtp$non_cost$value
              )
            ),
            column(
              width = 6,
              sliderInput(
                inputId = ns("wtp_cost"),
                label = list("Cost"),
                min = strategy$input$wtp$cost$min,
                max = strategy$input$wtp$cost$max,
                value = strategy$input$wtp$cost$value
              )
            )
          ),
          fluidRow(
            valueBoxOutput(ns("wtp_value"), width = 6),
            column(
              width = 6,
              fluidRow(
                column(
                  width = 6,
                  numericInput(
                    inputId = ns("wtp_mincost"),
                    label = "Min Cost",
                    value = strategy$input$wtp$cost$min
                  )
                ),
                column(
                  width = 6,
                  numericInput(
                    inputId = ns("wtp_maxcost"),
                    label = "Max Cost",
                    value = strategy$input$wtp$cost$max
                  )
                )
              )
              # , // Commented out as functionality is not working yet.
              # fluidRow(
              #   column(6,actionLink(inputId = ns("wtp_info"), label = NULL,icon =  icon("info")))
              # )
            )
          )
        )
      } else {
        if (input$select == "Relative Assessment (Cost to Quality Scoring)") {
          fluidRow(
            column(
              width = 6,
              sliderInput(
                inputId = ns("ra_wq"),
                label = "Quality",
                min = 0,
                max = 100,
                value = strategy$input$ra$wq
              )
            )
          )
        }
      }
    }
  })

  output$wtp_value <- renderValueBox({
    valueBox(
      value = round(1/strategy$output$wtp$gradient,2),
      subtitle = "WTP Gradient",
      width = 12,
      icon = icon("chart-line"),
      color = "blue"
    )
  })

  observeEvent(input$wtp_mincost,{
   updateSliderInput(
     session = session,
     inputId = "wtp_cost",
     min = input$wtp_mincost
   )
  }, ignoreInit = TRUE)

  observeEvent(input$wtp_maxcost,{
    updateSliderInput(
      session = session,
      inputId = "wtp_cost",
      max = input$wtp_maxcost
    )
  }, ignoreInit = TRUE)

  output$description <- renderUI({
    fpth <- tolower(gsub("\\s", "_", input$select))

    withMathJax(includeMarkdown(
      system.file(
        file.path("strategy_description", paste0(fpth, ".md")),
        package = "tessa"
      )
    ))
  })

  observe({
    strategy$output$select <- input$select
    strategy$output$budget_constraint <- input$budget_constraint
    strategy$output$budget_val <- input$budget_val
    strategy$output$quality_threshold <- input$quality_threshold
    strategy$output$quality_val <- input$quality_val
    strategy$output$wvfm$wq <- input$wvfm_wq
    strategy$output$wtp$cost$min <- input$wtp_mincost
    strategy$output$wtp$cost$max <- input$wtp_maxcost
    strategy$output$wtp$cost$value <- input$wtp_cost
    strategy$output$wtp$non_cost$value <- input$wtp_noncost
    strategy$output$wtp$gradient <- get_wtpgradient(input$wtp_cost, input$wtp_noncost)
    strategy$output$ra$wq <- input$ra_wq
  })

  get_wtpgradient <- function(cost, non_cost) {
    (non_cost[2] - non_cost[1]) / (cost[2] - cost[1])
  }

  return(strategy)
}