R/criteriaTable.R

In lajh87/tessa: Tender Evaluation Strategy Scenario Analysis

#' Criteria Table
#'
#' Display a rhandsontable with criteria and weights
#' @name criteria-table-module
NULL

#' @describeIn criteria-table-module Criteria Table UI
criteriaTableUI <- function(id) {
  ns <- NS(id)
  uiOutput(ns("ui"))
}

#' @describeIn criteria-table-module Criteria Table Server Code
criteriaTable <- function(input, output, session,
                          defaults, scoring) {
  ns <- session$ns
  criteria <- reactiveValues(
    dynamic = defaults$weights,
    static = defaults$weights,
    options = c("Rescale", "Category")
  )

  output$ui <- renderUI({

    tagList(
      checkboxGroupInput(
        inputId = ns("options"),
        label = NULL,
        choices = c("Rescale", "Category", "Threshold"),
        selected = criteria$options,
        inline = TRUE
      ),
      rhandsontable::rHandsontableOutput(ns("table")),
      actionButton(
        inputId = ns("update"),
        label = "Update",
        icon = icon("refresh")
      )
    )

  })

  output$table <- rhandsontable::renderRHandsontable({
    colDat <- data.frame(
      Column = c(
        "Category", "Description",
        "Pass/Fail", "Weight", "Threshold"
      ),
      ColSize = c(200, 375, 75, 75, 75),
      ColType = c(
        as.character(NA), as.character(NA),
        as.logical(F), as.numeric(NA), factor(0, levels = scoring$data$Score)
      ),
      stringsAsFactors = F
    )

    sel <- c("Description", "Pass/Fail", "Weight")
    if ("Category" %in% input$options) sel <- c(sel, "Category")
    if ("Threshold" %in% input$options) sel <- c(sel, "Threshold")

    cols <- colDat$Column[colDat$Column %in% sel]
    cWidths <- as.numeric(colDat[colDat$Column %in% sel, "ColSize"])
    vars <- as.character(colDat[colDat$Column %in% sel, "Column"])
    cType <- as.character(colDat[colDat$Column %in% sel, "ColType"])

    df <- hot_data(
      criteria$dynamic,
      criteria$static,
      input$options,
      scoring$data$Score,
      cols
    )

    # Catch for if user deletes all rows
    if (nrow(df) == 0) {
      tmp <- data.frame(matrix(nrow = 1, ncol = length(cols)))
      tmp[1, ] <- cType
      names(tmp) <- cols
      df <- tmp
    }

    h <- (nrow(df) * 55 - (nrow(df) - 1) * 30)

    hot <- rhandsontable(
      data = df,
      height = h,
      useTypes = T,
      digits = 2,
      stretchH = "all"
    ) %>%
      hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE) %>%
      hot_cols(columnSorting = TRUE, colWidths = cWidths) %>%
      hot_col("Pass/Fail", halign = "htCenter")

    return(hot)
  })

  hot_data <- function(dynamic, static, options, scores, cols) {
    df <- dynamic

    if ("Category" %in% options & !"Category" %in% names(dynamic)) {
      if ("Category" %in% names(static)) {
        df$Category <- static$Category
      } else {
        df$Category <- df[, "Description"]
      }
    }

    if ("Threshold" %in% options & !"Threshold" %in% names(dynamic)) {
      if ("Threshold" %in% names(static)) {
        df$Threshold <- static$Threshold
      } else {
        df$Threshold <- factor(scores[length(scores)], levels = scores)
      }
    }

    return(df[, cols])
  }

  observe({
    if (is.null(input$table)) return(NULL)
    df <- hot_to_r(input$table)
    if ("Rescale" %in% input$options) {
      df$Weight <- rescale(df$Weight)
    }

    sS <- df[, "Pass/Fail"] == T
    if (!is.na(sum(sS)) & nrow(df)) {
      df[sS, "Weight"] <- NA
    }

    df[is.na(df[,"Pass/Fail"]), "Pass/Fail"] <- FALSE

    if ("Threshold" %in% input$options) {
      df[df[, "Pass/Fail"] == TRUE, "Threshold"] <- NA
      df$Threshold <- factor(df$Threshold , levels = scoring$data$Score)
    }


    criteria$dynamic <- df
  })

  observeEvent(input$update, {
    criteria$static <- criteria$dynamic
    criteria$options <- input$options
  })

  return(criteria)
}