R/scenarioTable.R

In lajh87/tessa: Tender Evaluation Strategy Scenario Analysis

scenarioTableUI <- function(id) {
  ns <- NS(id)

  fluidRow(
    column(
      width = 12,
      tags$div(
        id = "tessa-scenarios-options",
        actionLink(ns("add"), NULL, icon("plus"), title = "Add Scenario"),
        HTML("&nbsp"),
        actionLink(ns("edit"), NULL, icon("edit"), title = "Rename Scenario"),
        HTML("&nbsp"),
        actionLink(ns("delete"), NULL, icon("minus"), title = "Remove Scenario"),
        HTML("&nbsp"),
        actionLink(ns("reset"), NULL, icon("undo"), title = "Reset Scenarios"),
        tags$br(),
        HTML("&nbsp")
        )
      ),
      column(12, rhandsontable::rHandsontableOutput(ns("table"))),
    tags$br()
    )
}

scenarioTable <- function(input, output, session, defaults,
                          criteria, scoring) {
  ns <- session$ns

  scenarios <- reactiveValues()

  observeEvent(criteria$static,{

    if(is.null(scenarios$data)) {
      scenarios$data <- defaults$scenarios
    } else{
      scenarios$data <- mergeData(criteria$static, scenarios$data)
    }

    req(scoring$data$Confidence)
    scenarios$data[,-c(1:2)] <- lapply(scenarios$data[,-c(1:2)], function(x){
      factor(x, levels = scoring$data$Confidence)
    })

  })



  output$table <- renderRHandsontable({
    cW <- c(25, 100, rep(50, (ncol(scenarios$data)-2)))

    rhandsontable(
      scenarios$data,
      stretchH = "all",
      rowHeaders = NULL
    ) %>%
      hot_cols(colWidths = cW) %>%
      hot_col("ID", readOnly = TRUE) %>%
      hot_col("Description", readOnly = TRUE) %>%
      hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE)
  })

  observe({
    if(is.null(input$table)) return(NULL)
    scenarios$data <- hot_to_r(input$table)
  })

  observeEvent(input$add, {
    scenarios$error <- " "
    showModal(
      modalDialog(
        title = list(icon("plus"), "Add New Scenario"),
        textInput(
          inputId = ns("name"),
          label = "Scenario Name",
          placeholder = "Between 1 and 16 characters"
          ),
        selectInput(ns("default"), "Default Value", scoring$data$Confidence),
        footer = tagList(
          column(width = 6,
                 div(style = "text-align: left; color: red;",
                     renderText(scenarios$error))),
          actionButton(
            inputId = ns("add_confirm"),
            label =  "Confirm",
            icon = icon("check")
            ),
          modalButton(
            label = "Close",
            icon = icon("close")
            )
        )
      )
    )
  }, ignoreInit = TRUE)

  observe({
    if(!length(input$name))
      return(NULL)

    if(nchar(input$name)>16){
      updateTextInput(
        session = session,
        inputId = "name",
        value = substr(input$name, 1,16)
      )
    }
  })

  observeEvent(input$add_confirm,{

    if(length(input$name)==0 || nchar(input$name)==0)
      return(scenarios$error <- "Scenario must have a name.")

    scenarios$data[,input$name] <- factor(input$default, levels = scoring$data$Confidence)
    removeModal()

  }, ignoreInit = TRUE)


  observeEvent(input$edit,{
    scenarios$error <- NULL
    showModal(
      modalDialog(
        title = list(icon("edit"), "Edit Name"),
        footer = tagList(
          column(6, div(style = "text-align: left; color: red;",
                        renderText(scenarios$error))),
          column(
            width = 6,
            actionButton(
              inputId = ns("edit_confirm"),
              label = "Confirm",
              icon = icon("check")
            ),
            modalButton(
              label = "Close",
              icon = icon("close")
            )
          )
        ),
        tagList(
          selectInput(
            inputId = ns("old_name"),
            label = "Old Scenario Name",
            choices = names(scenarios$data)[-c(1:2)]
          ),
          textInput(
            inputId = ns("new_name"),
            label = "New Scenario Name",
            placeholder = "Between 1 and 16 characters"
          )
        )
      )
    )
  }, ignoreInit = TRUE)

  observe({
    if(!length(input$new_name))
      return(NULL)

    if(nchar(input$new_name)>16){
      updateTextInput(
        session = session,
        inputId = "new_name",
        value = substr(input$new_name, 1,16)
      )
    }
  })

  observeEvent(input$edit_confirm,{
    req(input$old_name)

    if(length(input$new_name)==0 || nchar(input$new_name)==0)
      return(scenarios$error <- "Scenario must have a name.")

    names(scenarios$data)[which(names(scenarios$data) == input$old_name)] <-
      input$new_name
    removeModal()

  }, ignoreInit = TRUE)

  observeEvent(input$delete,{
    scenarios$error <- NULL
    showModal(
      modalDialog(
        title = list(icon("minus"), "Delete Scenario"),
        selectInput(
          inputId = ns("delete_name"),
          label = "Scenario",
          choices = names(scenarios$data)[-c(1:2)]
        ),
        footer = tagList(
          column(
            width = 6,
            div(style = "text-align: left; color: red;",
                renderText(scenarios$error))
            ),
          column(
            width = 6,
            actionButton(
              inputId = ns("delete_confirm"),
              label = "Confirm",
              icon = icon("check")
            ),
            modalButton(
              label = "Close",
              icon = icon("close")
            )
          )
        )
      )
    )
  }, ignoreInit = TRUE)

  observeEvent(input$delete_confirm,{
    if(length(names(scenarios$data))<=3)
      return(scenarios$error <- "There must be at least one scenario.")
    scenarios$data[,input$delete_name] <- NULL
    removeModal()
  },
  ignoreInit = TRUE)

  observeEvent(input$reset,{
    showModal(
      modalDialog(
        title = "Confirm",
        size = "s",
        "Are you sure? This action can't be undone",
        footer = tagList(
          actionButton(
            inputId = ns("reset_confirm"),
            label = "Confirm",
            icon = icon("check")
          ),
          modalButton(
            label = "Close",
            icon = icon("close")
          )
        )
      )
    )
  }, ignoreInit = TRUE)

  observeEvent(input$reset_confirm,{
    df_f <- criteria$static[criteria$static[,"Pass/Fail"]==FALSE,]
    n <- nrow(df_f)

    df <- data.frame(
      ID = as.integer(row.names(df_f)),
      Description = df_f$Description,
      stringsAsFactors = F
    )

    df$A <- factor(rep("Very High", n), levels = scoring$data$Confidence)
    df$B <- factor(rep("High", n), levels = scoring$data$Confidence)
    df$C <- factor(rep("Low", n), levels = scoring$data$Confidence)

    scenarios$data <- df
    removeModal()

  }, ignoreInit = TRUE)

  mergeData <- function(criteria, scenarios){
    req(scoring)
    df_f <- criteria[criteria[,"Pass/Fail"]==FALSE,]
    n <- nrow(df_f)

    scenarios$ID <- as.integer(scenarios$ID)
    df <- merge(data.frame(
      ID = as.integer(row.names(df_f)),
      Description = df_f$Description,
      stringsAsFactors = F
    ),
    scenarios[,-2],
    by = "ID",
    all.x = T)

    vars <- names(df)
    vars <- vars[!vars %in% c("ID", "Description")]

    df[,vars] <- lapply(df[,vars], function(x){
      x <- as.character(x)
      x[is.na(x)] <- get_mode(x[!is.na(x)])[1]
      return(x)
    })

    df <- df[order(df$ID),c("ID", "Description", vars)]

    return(df)
  }

  return(scenarios)
}