R/shiny-inputbindings.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

# Defines shiny bindings

get_shiny_input_bindings <- function() {
  bindings <- get(".shiny_input_bindings")
  if(bindings$size() == 0) {
    bindings$mset(
      'shiny.textInput' = list(
        binding = "shiny.textInput",
        update_function = "shiny::updateTextInput"
      ),
      'shiny.textAreaInput' = list(
        binding = "shiny.textareaInput",
        update_function = "shiny::updateTextAreaInput"
      ),
      'shiny.passwordInput' = list(
        binding = "shiny.passwordInput",
        update_function = "shiny::updateTextInput"
      ),
      'shiny.numericInput' = list(
        binding = "shiny.numberInput",
        update_function = "shiny::updateNumericInput"
      ),
      'shiny.checkboxInput' = list(
        binding = "shiny.checkboxInput",
        update_function = "shiny::updateCheckboxInput"
      ),
      'shiny.sliderInput' = list(
        binding = "shiny.sliderInput",
        update_function = "shiny::updateSliderInput"
      ),
      'shiny.dateInput' = list(
        binding = "shiny.dateInput",
        update_function = "shiny::updateDateInput"
      ),
      'shiny.dateRangeInput' = list(
        binding = "shiny.dateRangeInput",
        update_function = 'shiny::updateDateRangeInput'
      ),
      'shiny.selectInput' = list(
        binding = "shiny.selectInput",
        update_function = 'shiny::updateSelectInput'
      ),
      'shiny.selectizeInput' = list(
        binding = "shiny.selectInput",
        update_function = 'shiny::updateSelectizeInput'
      ),
      'shiny.varSelectInput' = list(
        binding = "shiny.selectInput",
        update_function = 'shiny::updateVarSelectInput'
      ),
      'shiny.varSelectizeInput' = list(
        binding = "shiny.selectInput",
        update_function = 'shiny::updateVarSelectizeInput'
      ),
      'shiny.radioButtons' = list(
        binding = "shiny.radioInput",
        update_function = 'shiny::updateRadioButtons'
      ),
      'shiny.checkboxGroupInput' = list(
        binding = "shiny.checkboxGroupInput",
        update_function = 'shiny::updateCheckboxGroupInput'
      ),
      'shiny.actionButton' = list(
        binding = "shiny.actionButtonInput",
        update_function = 'shiny::updateActionButton'
      ),
      'shiny.actionLink' = list(
        binding = "shiny.actionButtonInput",
        update_function = 'shiny::updateActionButton'
      ),
      'shiny.fileInput' = list(
        binding = "shiny.fileInputBinding",
        update_function = NULL
      ),
      'shiny.fileInput' = list(
        binding = "shiny.fileInputBinding",
        update_function = NULL
      ),
      'shiny.textOutput' = list(
        binding = "shiny.textOutput",
        update_function = NULL
      ),
      'dipsaus.compoundInput2' = list(
        binding = "dipsaus.compoundInput2",
        update_function = 'dipsaus.updateCompoundInput2'
      ),
      'dipsaus.actionButtonStyled' = list(
        binding = "shiny.actionButtonInput",
        update_function = 'dipsaus.updateActionButtonStyled'
      )
    )
  }
  bindings
}


#' Register customized input to enable support by compound input
#' @param fname character, function name, such as \code{"textInput"}
#' @param pkg character, package name, like \code{"shiny"}
#' @param shiny_binding character, 'JavaScript' binding name.See examples
#' @param update_function character, update function such as \code{"shiny::textInput"}
#' @param quiet logical, whether to suppress warnings
#' @return a list of binding functions, one is `JavaScript` object key in
#' \code{Shiny.inputBindings}, the other is `shiny` update function in R end.
#' @examples
#'
#' # register shiny textInput
#' registerInputBinding('textInput', 'shiny',
#'                      'shiny.textInput', 'shiny::updateTextInput')
#'
#' # Register shiny actionLink
#' # In "Shiny.inputbindings", the binding name is "shiny.actionButtonInput",
#' # Shiny update function is "shiny::updateActionButton"
#' registerInputBinding('actionLink', 'shiny',
#'                      'shiny.actionButtonInput', 'shiny::updateActionButton')
#'
#' @export
registerInputBinding <- function(fname, pkg, shiny_binding, update_function = NULL, quiet = FALSE){
  ns <- asNamespace(pkg)
  if( !is.function(ns[[fname]]) ){
    if(!quiet){
      stop(sprintf('%s::%s is not a function', pkg, fname))
    }
    return(invisible())
  }
  binding <- list(
    binding = shiny_binding,
    update_function = update_function
  )
  # shiny_input_bindings[[sprintf('%s.%s', pkg, fname)]] <- binding
  bindings <- get_shiny_input_bindings()
  bindings$set(key = sprintf('%s.%s', pkg, fname), value = binding)
  invisible(binding)
}

#' Obtain registered input bindings
#' @param fname input function name, character or quoted expression
#' such as \code{'shiny::textInput'} or \code{numericInput}.
#' @param pkg (optional), name of package
#' @param envir environment to evaluate \code{fname} if \code{pkg} is not provided
#'
#' @return a list containing: 1. `JavaScript` input binding name; 2. `R` updating function name
#'
#' @examples
#'
#' library(dipsaus)
#'
#' # Most recommended usage
#' getInputBinding('compoundInput2', pkg = 'dipsaus')
#'
#' # Other usages
#' getInputBinding('shiny::textInput')
#'
#'
#' getInputBinding(shiny::textInput)
#'
#' getInputBinding(compoundInput2, pkg = 'dipsaus')
#'
#' # Bad usage, raise errors in some cases
#' \dontrun{
#' ## You need to library(shiny), or set envir=asNamespace('shiny'), or pkg='shiny'
#' getInputBinding('textInput')
#' getInputBinding(textInput) # also fails
#'
#' ## Always fails
#' getInputBinding('dipsaus::compoundInput2', pkg = 'dipsaus')
#' }
#'
#' @export
getInputBinding <- function(fname, pkg = NULL, envir = parent.frame()){
  if( length(pkg) != 1 || !is.character(pkg) ){
    # need to get package from fname

    if(is.character(fname)){
      fname <- str2lang(fname)
    }

    fname_quoted <- substitute(fname)
    if( !is.language(fname) ){
      fname <- fname_quoted
    }

    # now we have quoted fname
    if(is.call(fname) && all(as.character(fname[[1]]) %in% c('::', ':::'))){
      pkg <- deparse(fname[[2]])
      fname <- deparse(fname[[3]])
    }else{
      f <- eval(fname, envir = envir)
      fenv <- environment(f)
      if( isNamespace(fenv) ){
        pkg <- fenv$.__NAMESPACE__.$spec[['name']]
      }
      fname <- deparse(fname)
    }
  }else{
    fname_quoted <- substitute(fname)
    if(!is.character(fname)){
      fname <- deparse(fname_quoted)
    }
  }
  # Check whether fname exists
  if(is.null(pkg)){
    cat2(sprintf('Cannot find function %s in any package loaded from envir. Please provide package name', fname), level = 'FATAL')
  }
  ns <- asNamespace(pkg)
  if(!is.function(ns[[fname]])){
    cat2(sprintf('Cannot find function %s in namespace %s', fname, pkg), level = 'FATAL')
  }
  binding_key <- sprintf('%s.%s', pkg, fname)
  # binding_re <- shiny_input_bindings[[ binding_key ]]
  bindings <- get_shiny_input_bindings()
  binding_re <- bindings$get(key = binding_key, missing = NULL)
  if(is.null(binding_re)){
    cat2(sprintf('Cannot find input binding for %s. Please use\n\tdipsaus::registerInputBinding("%s", "%s", shiny_binding = "<JavaScript_binding>", update_function = "<R update function or NULL>")\n  to register this input type.', binding_key, fname, pkg), level = 'FATAL')
  }
  binding_re$call_function <- sprintf('%s::%s', pkg, fname)
  binding_re
}




#' Detect whether 'Shiny' is running
#' @return logical, true if current shiny context is active
#' @export
shiny_is_running <- function(){
  if(requireNamespace('shiny', quietly = TRUE)){
    return(isTRUE(!is.null(shiny::getDefaultReactiveDomain())))
  }
  return(FALSE)
}


#' Store/Get key-value pairs in 'shiny' session
#' @description If key is missing, it'll be created, otherwise ignored or
#' overwritten.
#' @param session 'Shiny' session
#' @param key character, key to store
#' @param val value to store
#' @param override if key exists, whether to overwrite its value
#' @return If session is shiny session, returns current value stored in
#' session, otherwise returns \code{NULL}
#' @export
add_to_session <- function(
  session, key = 'rave_id',
  val = paste(sample(c(letters, LETTERS, 0:9), 20), collapse = ''),
  override = FALSE
){
  if(missing(session)){
    if(requireNamespace('shiny', quietly = TRUE)){
      session <- shiny::getDefaultReactiveDomain()
    } else {
      stop('Please specify session')
    }
  }

  if(!is.null(session)){
    if(override || !exists(key, envir = session$userData)){
      assign(key, val, envir = session$userData)
    }
    return(get(key, envir = session$userData))
  }
  return(NULL)
}