R/fct_ui.R

In Ottis1/fieldactivity: An app for keeping track of field activity

# Builds the ui based on a json file
# e.g. builds additional options for the different activity types
# Otto Kuusela 2021

structure_file_path <- function() system.file("extdata", "ui_structure.json", 
                                   package = "fieldactivity")
structure <- jsonlite::fromJSON(structure_file_path(), simplifyMatrix = FALSE)
activity_options <- structure$form$mgmt_operations_event$sub_elements


#' Recursively apply function to lists in a list
#' @description Recursively apply a function to the elements of a list that
#' are themselves lists.
#' @param x The list of lists to apply the function to
#' @param fun The function to apply to lists
#' @param name_fun Function used to name the elements of the returned list.
#' Should take a list as argument and return the name
#' @param ... arguments to pass to fun
#' @return A one-level list where each element is the value fun returns for a
#' given list in x
rlapply <- function(x, fun, name_fun = NULL, ...) {
  
  results <- list()
  
  for (element in x) {
    if (!is.list(element)) {
      next
    }
    
    # x is a list, so let's test it
    result <- fun(element, ...)
    
    if (!is.null(result)) {
      
      # if we have a naming function defined, use that
      # index is either an actual index or name of the element
      if (is.null(name_fun)) {
        index <- length(results) + 1
      } else {
        index <- name_fun(element)
      }
      
      results[[index]] <- result
    }
    
    # more results might lurk on lower levels of the list. 
    # So let's investigate those
    more_results <- rlapply(element, fun, name_fun, ...)
    
    if (length(more_results) > 0) {
      results <- append(results, more_results)
    }
  }
  
  if (length(results) > 1) {
    return(results)
  } else if (length(results) == 1) {
    return(results)
    #return(results[[1]])
  } else {
    return(NULL)
  }
  
}

#' Build lookup list for UI elements
#' @description Build a list where the names are the code names of UI elements
#' and the values are the corresponding element structures (lists) found in 
#' ui_structure.json
#' @return The lookup list.
build_structure_lookup_list <- function() {
  element_fetcher <- function(x) {
    if (!is.null(x$code_name)) {
      # we don't need the sub_elements listed, those will come separately
      x$sub_elements <- NULL
      return(x)
    } else {
      return(NULL)
    }
  }
  
  element_name_fetcher <- function(x) x$code_name
  
  lookup_list <- rlapply(structure, fun = element_fetcher,
                         name_fun = element_name_fetcher)
  return(lookup_list)
}

structure_lookup_list <- build_structure_lookup_list()

# help texts (technically textOutputs) have a different method of updating
# when the language is changed because they are outputs rather than inputs,
# and for that we need a list of the code names of these objects.
# The same goes for data tables (excluding event table).
# We also need the code names of fileInput delete buttons to set up observers
# for them
text_output_code_names <- NULL
data_table_code_names <- NULL
fileInput_code_names <- NULL
for (element in structure_lookup_list) {
  if (element$type == "textOutput") {
    text_output_code_names <- c(text_output_code_names, element$code_name)
  } else if (element$type == "dataTable") {
    data_table_code_names <- c(data_table_code_names, element$code_name)
  } else if (element$type == "fileInput") {
    fileInput_code_names <- c(fileInput_code_names, element$code_name)
  }
}

#' Generate the UI for a list of elements in the structure file.
#' 
#' For a given list of widget structures as read from ui_structure.json, 
#' create_ui applies create_widget to each widget in the list
#' 
#' @param widget_structure_list The list of widget structures (from
#'   ui_structure.json) to generate as UI
#' @param ns A namespacing function generated by shiny::NS to apply to the id's
#'   of each generated widget
#'   
#' @return A list of Shiny widgets
create_ui <- function(widget_structure_list, ns) {
  new_elements <- lapply(widget_structure_list, create_widget, ns = ns)
  
  # if there is a visibility condition, apply it
  if (!is.null(widget_structure_list$condition)) {
    new_elements <- conditionalPanel(
      condition = widget_structure_list$condition, 
      new_elements, 
      ns = ns)
  }
  
  return(new_elements)
}

# creates the individual elements
# the override_label and ... functionalities are used for creating elements
# in dynamic (e.g. multi-crop) data tables. Do NOT supply the label argument in
# the unnamed arguments (...)!
# TODO: refactor. Get rid of those ugly override arguments
create_widget <- function(element, ns = NS(NULL),
                           override_label = NULL, 
                           override_code_name = NULL, 
                           override_value = NULL,
                           override_choices = NULL,
                           override_selected = NULL,
                           override_placeholder = NULL, ...) {
  
  # element is a string, i.e. a visibility condition for a element set
  # it has already been handled in create_ui
  if (!is.list(element)) {
    return()
  }
  
  # element is a list of elements, because it doesn't have the type
  # attribute. In that case we want to create all of the elements in that list
  if (is.null(element$type)) {
    return(create_ui(element, ns))
  }
  
  # the labels will be set to element$label which is a code_name, not a 
  # display_name, but this is okay as the server will update this as the
  # language changes (which also happens when the program starts)
  # the following allows overwriting the label through ...
  element_label <- get_disp_name(element$label, init_lang)
  if (!is.null(override_label)) {
    element_label <- override_label
  }
  
  element_code_name <- ns(element$code_name)
  if (!is.null(override_code_name)) {
    element_code_name <- ns(override_code_name)
  }
  
  element_value <- ""
  if (!is.null(override_value)) {
    element_value <- override_value
  }
  
  element_choices <- get_selectInput_choices(element$code_name, init_lang)
  if (!is.null(override_choices)) {
    element_choices <- override_choices
  }
  
  element_placeholder <- get_disp_name(element$placeholder, init_lang)
  if (!is.null(override_placeholder)) {
    element_placeholder <- override_placeholder
  }
  
  new_element <- if (element$type == "checkboxInput") {
    checkboxInput(element_code_name, label = element_label, ...)
  } else if (element$type == "selectInput") {
    # if multiple is defined (=TRUE) then pass that to selectInput
    multiple <- identical(element$multiple, TRUE)
    # we don't enter choices yet, that will be handled by the server
    selectInput(element_code_name, label = element_label, 
                choices = element_choices, multiple = multiple,
                selected = override_selected, ...)
  } else if (element$type == "textOutput") {
    if (!is.null(element$style) && element$style == "label") {
      strong(textOutput(element_code_name, ...))
    } else {
      # these are inteded to look like helpTexts so make text gray
      tagList(
        span(textOutput(element_code_name, ...), style = "color:gray"),
        br()
      )
    }
  } else if (element$type == "textInput") {
    textInput(inputId = element_code_name, label = element_label, 
              value = element_value, placeholder = element_placeholder, ...)
  } else if (element$type == "numericInput") {
    numericInput(inputId = element_code_name, 
                 label = element_label, 
                 min = element$min,
                 max = ifelse(is.null(element$max),NA,element$max),
                 value = element_value,
                 step = ifelse(is.null(element$step),"any",element$step),
                 ...)
  } else if (element$type == "textAreaInput") {
    textAreaInput(element_code_name, 
                  label = element_label,
                  resize = "vertical", 
                  value = element_value,
                  placeholder = element_placeholder, ...)
  } else if (element$type == "dataTable") {
    mod_table_ui(element_code_name)
  } else if (element$type == "fileInput") {
    mod_fileInput_ui(element_code_name, element)
  } else if (element$type == "dateRangeInput") {
    dateRangeInput(element_code_name, 
                   label = element_label,
                   separator = "-",
                   weekstart = 1,
                   max = Sys.Date())
  } else if (element$type == "actionButton") {
    # 
  }
  
  # put the new element in a conditionalPanel. If no condition is specified,
  # the element will be visible by default
  #new_element <- conditionalPanel(condition = element$condition, new_element)
  
  # if there are sub-elements to create, do that
  if (!is.null(element$sub_elements)) {
    return(list(new_element, 
                create_ui(element$sub_elements, ns)))
  }
  
  return(new_element)
}

#' Find the choices for a selectInput given its code name
#'
#' @param selectInput_code_name The code name of the selectInput
#' @param language The language to show the options in. This will be passed to
#'   get_disp_name
#'
#' @return A vector of choices (code names). If language was supplied, the names
#'   will be the names of the vector.
get_selectInput_choices <- function(selectInput_code_name, language) {
  # the choices for a selectInput element can be stored in
  # three ways: 
  # 1) the code names of the choices are given as a vector
  # 2) for site and block selectors, there is IGNORE:
  # this means that the choices should not be updated here (return NULL)
  # 3) the category name for the choices is given.
  # in the following if-statement, these are handled
  # in this same order
  
  element_structure <- structure_lookup_list[[selectInput_code_name]]

  if (!identical(element_structure$type, "selectInput") || 
      is.null(element_structure$choices)) {
    return(NULL)
  }
  
  if (length(element_structure$choices) > 1) {
    choices <- c("", element_structure$choices)
    names(choices) <- c("", get_disp_name(element_structure$choices,
                                          language = language))
  } else if (element_structure$choices == "IGNORE") {
    choices <- NULL
  } else {
    # get_category_names returns both display names and 
    # code names
    choices <- c(
      "",
      get_category_names(element_structure$choices,
                         language = language)
    )
  }
  
  return(choices)
}

#' Update value, label etc. of a UI element.
#'
#' Determines the type of the element and updates its value using shiny's update
#'   functions.
#' @param session Current shiny session
#' @param code_name The code name of the UI element to update
#' @param value An atomic vector holding the desired value of the UI element. If
#'   NULL, the value of the element is not altered.
#' @param clear_value If set to TRUE, the value of the element is cleared (and
#'   any value supplied to value is ignored)
#' @param ... Additional arguments (such as label) to pass to Shiny's update-
#'   functions.
#' @importFrom glue glue
update_ui_element <- function(session, code_name, value = NULL, 
                              clear_value = FALSE, ...) {
  # find the element from the UI structure lookup list, which has been
  # generated in ui_builder.R 
  element <- structure_lookup_list[[code_name]]
  
  # didn't find the element corresponding to code_name
  # this should not happen if the element is in 
  # sidebar_ui_structure.json
  if (is.null(element$type)) {
    stop("UI element type not found, could not update")
  }
  if (!is.atomic(value)) {
    stop("The value given to update_ui_element should be an atomic vector")
  }
  
  # if value is NULL, we need to determine on a widget type basis how to 
  # clear the value. If it isn't, replace missingvals with ""
  if (!is.null(value)) {
    # replace missingvals with empty strings
    missing_indexes <- identical(value, missingval)
    if (any(missing_indexes)) {
      value[missing_indexes] <- ""
    }
  } 
  
  
  if (element$type == "selectInput") {
    if (clear_value) value <- ""
    # setting the selected value to NULL doesn't change the widget's value
    updateSelectInput(session, code_name, selected = value,  ...)
  } else if (element$type == "dateInput") {
    # setting value to NULL will reset the date to the current date
    value <- if (clear_value) {
      NULL
    } else {
      tryCatch(expr = as.Date(value, format = date_format_json),
               warning = function(cnd) NULL)
    }
    updateDateInput(session, code_name, value = value, ...)
  } else if (element$type == "textAreaInput") {
    if (clear_value) value <- ""
    updateTextAreaInput(session, code_name, value = value, ...)
    #} else if (element$type == "checkboxInput") {
    #    updateCheckboxInput(session, code_name, value = value, ...)
  } else if (element$type == "actionButton") {
    updateActionButton(session, code_name, ...)
  } else if (element$type == "textInput") {
    if (clear_value) value <- ""
    updateTextInput(session, code_name, value = value, ...)
  } else if (element$type == "numericInput") {
    # if we are given a non-numeric value, we don't want to start converting
    # it. Let's replace it with an empty string (the default value)
    # if (!is.numeric(value)) {value <- ""}
    if (clear_value) { value <- "" }
    updateNumericInput(session, code_name, value = value, ...)
  } else if (element$type == "dateRangeInput") {
    
    if (!is.null(value) & length(value) != 2) {
      value <- NULL
      warning(glue("Value supplied to the dateRangeInput was not of ", 
                   "length 2, resetting it"))
    }
    
    start <- if (is.null(value) | clear_value) NULL else value[1]
    end <- if (is.null(value) | clear_value) NULL else value[2]
    
    tryCatch(warning = function(cnd) {shinyjs::reset(code_name)},
             updateDateRangeInput(session, code_name, 
                                  start = start, end = end))
  } else if (element$type == "fileInput") {
    
    
  }
}

#' Reset the value of input fields
#' 
#' Set the specified input fields to their default empty values.
#' 
#' @param session The current Shiny session
#' @param fields_to_clear The names of the variables whose corresponding fields
#'   should be cleared
#' @param exceptions Optional vector of variable names which should not be
#'   cleared. This is useful if fields_to_clear is supplied with all variable
#'   names but there are a few that should not be cleared.
#' @return None, used for side effects.
#' @note This doesn't reset the tables (e.g. harvest_crop_table) -- they reset 
#'   themselves every time they become hidden. Also doesn't reset fileInputs,
#'   they have their own way of clearing their value.
# TODO: is exceptions necessary?
reset_input_fields <- function(session, fields_to_clear, exceptions = c("")) {
  
  # we never want to clear the site or block
  exceptions <- c(exceptions, "site", "block")
  
  for (code_name in fields_to_clear) {
    if (code_name %in% exceptions) next
    update_ui_element(session, code_name, clear_value = TRUE)
  }
  
}