R/resultsTable.R

In lajh87/tessa: Tender Evaluation Strategy Scenario Analysis

resultsTableUI <- function(id, width = NULL){
  ns <- NS(id)
  box(
    width = width,
    status = "primary",
    title = "Results",
    rHandsontableOutput(ns("table"))
  )
}

resultsTable <- function(input, output, session,
                         defaults, strategy, criteria, technical, scoring){

  results <- reactiveValues()

  observe({
    results$data <- get_results(strategy, defaults, results, technical)
    results$winning_bid <- get_winning_bid(results$data, scoring$output$tiebreak)
  })

  output$table <- renderRHandsontable({

    req(results$data$Rank)
    req(results$data$Compliant)

    rhandsontable(
      results$data,
      rowHeader = FALSE,
      height = 150
    ) %>%
      hot_cols(readOnly = TRUE) %>%
      hot_col("Price", readOnly = FALSE)  %>%
      hot_col("Compliant", halign = "htCenter") %>%
      hot_context_menu(allowRowEdit = FALSE, allowColEdit = FALSE)
  })

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

  get_results <- function(strategy, defaults, results, technical){
    req(strategy$output$select)

    if(is.null(results$data))
      results$data <- defaults$price

    tech <- technical$data %>%
      dplyr::group_by(Scenario) %>%
      dplyr::summarise("Technical" = sum(`Weighted Score`))  %>%
      dplyr::ungroup()

    price <- results$data %>%
      dplyr::select(Scenario, Price)

    results <- dplyr::right_join(price, tech, by = "Scenario")

    results$Compliant <- NA

    if(strategy$output$select == "Value for Money Index"){
      results$Score <- round(results$Technical / results$Price, 2)
    }

    if(strategy$output$select == "Weighted Value for Money Index"){
      wQ <- strategy$output$wvfm$wq
      wQ <- ifelse(is.null(wQ), 50, wQ)
      wC <- 100-wQ
      results$Score <- round(results$Technical^(wQ/wC) / results$Price, 2)
    }

    if(strategy$output$select == "Monetising Non-Cost Score"){
       req(strategy$output$wtp$gradient)
        wtp <- 1/strategy$output$wtp$gradient
      results$Score <- round(results$Price - (results$Technical * wtp),2)
    }

    if(strategy$output$select == "Relative Assessment (Cost to Quality Scoring)"){
      req(strategy$output$ra$wq)
      wQ <- strategy$output$ra$wq/100

      results$PScore <- (min(results$Price)/results$Price) * (1-wQ) * 100
      results$TScore <- results$Technical * wQ
      req(results$PScore)
      results$Score <- results$TScore + results$PScore

    }

    results$Compliant <- NA
    results$Rank <- NA

    results[,"Compliant"] <- get_compliant(strategy, results, technical)
    results[,"Rank"] <- get_rank(strategy, results)

    return(results)

  }

  get_compliant <- function(strategy, results, technical){

    qC <- strategy$output$quality_threshold
    bC <- strategy$output$budget_constraint
    qV <- strategy$output$quality_val
    bV <- strategy$output$budget_val

    if(is.null(qC)) return(NULL)
    if(is.null(bC)) return(NULL)

    price <- results$Price <=  bV
    quality <- results$Technical >= qV

    n <- nrow(results)

    if(!qC) quality <- rep(TRUE, n)
    if(!bC & strategy$output$select != "Best Technically Affordable")
      price <- rep(TRUE, n)

    if("Threshold" %in% names(technical$data)){
      tech <- technical$data %>%
        dplyr::group_by(Scenario) %>%
        dplyr::summarise(Compliant2 = sum(Compliant == FALSE)>0) %>%
        dplyr::ungroup() %>%
        dplyr::select(Compliant2) %>%
        dplyr::pull()

    } else tech <- rep(FALSE, n)

    compliant <- ifelse(price == FALSE | quality == FALSE | tech == TRUE, FALSE, TRUE)

    if(length(compliant) == 0) return(NULL)
    return(compliant)
  }

  get_rank <- function(strategy, results){
    req(strategy$output$select)
    req(results$Compliant)


    if(strategy$output$select == "Lowest Priced Tender"){
      price <- ifelse(results$Compliant == FALSE, NA, results$Price)
      res <- rank(price,na.last = TRUE, ties.method = "min")
    } else{
      if(strategy$output$select %in% c("Value for Money Index",
                                       "Weighted Value for Money Index",
                                       "Relative Assessment (Cost to Quality Scoring)")){
        score <- ifelse(results$Compliant == FALSE, NA, results$Score)
        res <- rank(-score, na.last = TRUE, ties.method = "min")
      } else{
        if(strategy$output$select == "Best Technically Affordable"){
          score <- ifelse(results$Compliant == FALSE, NA, results$Technical)
          res <- rank(-score, na.last = TRUE, ties.method = "min")
        } else{
          if(strategy$output$select == "Monetising Non-Cost Score"){
            score <- ifelse(results$Compliant == FALSE, NA, results$Score)
            res <- rank(score, na.last = TRUE, ties.method = "min")
          }
        }
      }
    }
    return(res)
  }

  get_winning_bid <- function(results, tiebreak){

    req(results$Rank)

    win <- results %>%
      dplyr::filter(Rank == min(Rank)) %>%
      dplyr::select(Scenario, Price, Technical, Rank)

    if(tiebreak == "Lowest Cost"){

      win <- win %>%
        dplyr::filter(Price == min(Price)) %>%
        dplyr::select(Scenario) %>%
        dplyr::pull()

    } else{

      win <- win %>%
        dplyr::filter(Technical == max(Technical)) %>%
        dplyr::select(Scenario) %>%
        dplyr::pull()

    }

   if(length(win)>1) win <- sample(win, 1)
   return(win)

  }

  return(results)

}