R/rate_inputs.R

In California-Data-Collaborative/RateComparison: Analyze The Revenue, Demand And Equity Effects Of A Water Rate Change

#****************************************************************************************** 
#rate_inputs.R
#
# This file defines two modules (tierBox and ratePart) corresponding to two different types of inputs found on the
# input panel of the classGraph module.
#
# tierBox is a module that defines a text input box for displaying tier starts and prices.
# 
# ratePart is a module that defines a more complex, multi-input for specifying either 
# simple values like landscape factors and flat rate charges, or more complex values that
# depend on other columns in the source data. For example it is possible to define a fixed
# service charge that is dependent on the meter size of a customer.
#
#******************************************************************************************


#********************************************
# tierBox
#********************************************
tierBoxInput <- function(id){
  ns <- NS(id)
  tagList(uiOutput(ns("tierInfoBox")))
}

tierBox <- function(input, output, session, part_name, part_name_long, 
                    rate_type, rate_type_provided, rate_part){
  
  output$tierInfoBox <- renderUI({
    ns <- session$ns

    # should use defaults?
    if(is.null(rate_part) || rate_type != rate_type_provided){
      box_info <- defaults[[rate_type]][[part_name]]
    }else{
      box_info <- paste0(rate_part, collapse="\n")
      print(paste0("BOX INFO: ", box_info))
    }
    
    tagList(
      textAreaInput(ns("tier_box"), label=part_name_long, value=box_info,
                    height=150)#text_height(input$depend_cols))
    )
  })
  
  return(input)
} 



#********************************************
# ratePart
#********************************************
ratePartInput <- function(id){
  ns <- NS(id)
  
  tagList(
    uiOutput(ns("inputRow")),
    uiOutput(ns("inputDropdown"))
  )
}

ratePart <- function(input, output, session, part_name, part_name_long="", depends_col_list, 
                     current_selected=NULL, simple_value_provided=NULL, is_expanded=FALSE, value_map=list(),
                     rate_part=NULL){
  
  
  output$inputRow <- renderUI({
    ns <- session$ns
    
    if(!is.null(rate_part)){
      if(is_map(rate_part)){
        print(paste0(part_name, " is a map!"))
        current_selected <- c(rate_part$depends_on)
        value_map <- rate_part$values
        is_expanded <- TRUE
      }else{
        simple_value_provided <- rate_part
      }
    }
    
    tagList(
      fluidRow(
         column(1, checkboxInput(ns("expanded"), label=NULL, value = is_expanded)),
         conditionalPanel(condition = sprintf("input['%s'] == false", ns("expanded")),
           column(5, strong( paste0(part_name_long, ":" ) )),
           column(5, numericInput(ns("simpleValue"), label=NULL, value=simple_value(simple_value_provided, part_name)) )
         ),
         conditionalPanel(condition = sprintf("input['%s'] == true", ns("expanded")),
           column(5, strong( paste0(part_name_long, ":\n(depends on...)") ) ),
           column(5, selectInput(ns("depend_cols"), label=NULL, choices=depends_col_list, 
                       selected=c(current_selected), multiple=TRUE)
           )
         )
      ),
      
      # Make the dropdown the proper height to match other input boxes
      tags$style(
        ".selectize-dropdown, .selectize-input, .selectize-input { 
        line-height: 29px; 
        }"
      )
    )
    
  })
  
  output$inputDropdown <- renderUI({
    ns <- session$ns
    
    if(!is.null(rate_part)){
      if(is_map(rate_part)){
        print(paste0(part_name, " is a map!"))
        current_selected <- c(rate_part$depends_on)
        value_map <- rate_part$values
        is_expanded <- TRUE
      }else{
        simple_value_provided <- rate_part
      }
    }
    
    tagList(
      # Display text entry boxes if the values depends on another
      conditionalPanel(condition = sprintf("input['%s'] == true", ns("expanded")),
         fluidRow(
           column(7, textAreaInput(ns("depend_values"), label="Values", 
                                   value=unique_values(input$depend_cols, value_map),
                                   height=text_height(input$depend_cols, value_map) )),
           column(5, textAreaInput(ns("depend_charges"), label="Charges ($)", 
                                   value=eval_uniques(input$depend_cols, value_map),
                                   height=text_height(input$depend_cols, value_map)))
         )
      )
    )
    
  })

  return(input)
}


simple_value <- function(simple_value_provided, part_name){
  if(is.null(simple_value_provided)){
    ls <- list("flat_rate"=3, "gpcd"=55, "landscape_factor"=0.7)
    value <- ls[[part_name]]
  }else{
    value <- simple_value_provided
  }
  
  value
}

# Generate a vector of the unique values that will populate the dropdown
# when a charge "depends on" a df column
unique_value_list <- function(colList, value_map){
  
#   uniqueList <- list()
#   
#   for(i in 1:length(colList)){
#     col <- colList[i]
#   }
#   
#   expand.grid(unique(df$meter_size), unique(df$meter_size), stringsAsFactors=FALSE)
  
  
  if(is.null(colList)){
    retVal <- ""
  }else if(!is.null(value_map)){
    keys <- names(value_map)
    all_uniques <- unique(df[[colList[1]]])
    keys_not_in_map <- all_uniques[!(all_uniques %in% keys)]
    retVal <- c(keys, keys_not_in_map)
  }else{
    sorted <- df %>%group_by_(colList[1]) %>% summarise_(count=sprintf("length(%s)", colList[1]) ) %>% 
                arrange(desc(count))
    retVal <- sorted[[colList[1]]]
  }
  
  return(retVal)
}

unique_values <- function(colList, value_map){
  ls <- unique_value_list(colList, value_map)
  return(paste0(ls, collapse="\n"))
}

num_uniques <- function(colList, value_map){
  ls <- unique_value_list(colList, value_map)
  return(length(ls))
}

# Evaluate the unique values given by unique_value_list to get the
# charges associated with each value
eval_uniques <- function(colList, value_map){
  ls <- unique_value_list(colList, value_map)
  retVal <- c()
  
  for(v in ls){
    print(v)
    if(v != "" & !is.na(v) & !is.null(v)){
      value <- value_map[[v]]
      
      if(!is.null(value)){
        retVal <- c(retVal, value)
      }else{
        retVal <- c(retVal, 0.0)
      }
      
    }else{
      retVal <- c(retVal, 0.0)
    }
  }
  return( paste0(retVal, collapse="\n") )
}

# return height (in pixels?) as a function 
# of number of elements to display
text_height <- function(colList, value_map){
  return(26+21*num_uniques(colList, value_map))
}