R/shiny-compoundInput2.R

In dipsaus: A Dipping Sauce for Data Analysis and Visualizations

#' Compound input that combines and extends shiny inputs
#' @name compoundInput2
#' @param inputId character, shiny input ID
#' @param label character, will show on each groups
#' @param components `HTML` tags that defines and combines HTML components within groups
#' @param initial_ncomp numeric initial number of groups to show, non-negative
#' @param min_ncomp minimum number of groups, default is 0, non-negative
#' @param max_ncomp maximum number of groups, default is 10, greater or equal
#' than \code{min_ncomp}
#' @param label_color integer or characters, length of 1 or \code{max_ncomp}, assigning colors to each group labels; default is \code{NA}, and try to get color from foreground \code{par("fg")}
#' @param value list of lists, initial values of each inputs, see examples.
#' @param max_height maximum height of the widget
#' @param ... will be ignored
#' @examples
#' library(shiny); library(dipsaus)
#' compoundInput2(
#'   'input_id', 'Group',
#'     div(
#'     textInput('text', 'Text Label'),
#'     sliderInput('sli', 'Slider Selector', value = 0, min = 1, max = 1)
#'   ),
#'   label_color = 1:10,
#'   value = list(
#'     list(text = '1'),  # Set text first group to be "1"
#'     list(),                # no settings for second group
#'     list(sli = 0.2)    # sli = 0.2 for the third group
#'   ))
#'
#' # Source - system.file('demo/example-compountInput2.R', package='dipsaus')
#'
#' # demo('example-compountInput2', package='dipsaus')
#'
#' library(shiny)
#' library(dipsaus)
#' ui <- fluidPage(
#'   fluidRow(
#'     column(
#'       width = 4,
#'       compoundInput2(
#'         'compound', 'Group Label', label_color = c(NA,1:9),
#'         components = div(
#'           textInput('txt', 'Text'),
#'           selectInput('sel', 'Select', choices = 1:10, multiple = TRUE),
#'           sliderInput('sli', 'Slider', max=1, min=0, val=0.5)
#'         ),
#'         value = list(
#'           list(txt = '1'),  # Set text first group to be "1"
#'           '',                # no settings for second group
#'           list(sli = 0.2)    # sli = 0.2 for the third group
#'         )
#'       ),
#'       hr(),
#'       actionButton('action', 'Update compound input')
#'     )
#'   )
#' )
#'
#' server <- function(input, output, session) {
#'   observe({
#'     print(input$compound)
#'   })
#'   observe({
#'     # Getting specific input at group 1
#'     print(input$compound_txt_1)
#'   })
#'   observeEvent(input$action, {
#'     updateCompoundInput2(
#'       session, 'compound',
#'       # Update values for each components
#'       value = lapply(1:5, function(ii) {
#'         list(
#'           txt = sample(LETTERS, 1),
#'           sel = sample(1:10, 3),
#'           sli = runif (1)
#'         )
#'       }), ncomp = NULL, txt = list(label = as.character(Sys.time())))
#'   })
#' }
#'
#' if ( interactive() ) {
#'   shinyApp(ui, server, options = list(launch.browser = TRUE))
#' }
#'
#' @seealso \code{\link[dipsaus]{updateCompoundInput2}} for how to update inputs
#' @return `HTML` tags
NULL

# compound_inputs <- fastmap::fastmap()

#' @rdname compoundInput2
#' @export
compoundInput2 <- function(
  inputId, label = "Group", components = shiny::tagList(),
  initial_ncomp = 1, min_ncomp = 0, max_ncomp = 10,
  value = NULL, label_color = NA, max_height = NULL, ...
) {
  # add_js_script()

  if ( length(label_color) == 0 ) { label_color <- NA }
  if ( !length(label_color) %in% c(1, max_ncomp)) {
    cat2("label_color must be length of 1 or equal to max_ncomp", level = "FATAL")
  }
  if ( any(is.na(label_color)) ) {
    label_color[is.na(label_color)] <- par("fg")
  }
  label_color <- col2hexStr( label_color )
  if ( length(label_color) == 1 ) {
    label_color <- rep(label_color, max_ncomp)
  }
  # Add css, js


  components <- substitute(components)

  parent_env <- parent.frame()
  ...this_env <- new.env()
  ...this_env$bind_infos <- list()
  min_ncomp <- max(min_ncomp, 0)
  max_ncomp <- max(min_ncomp, max_ncomp)
  initial_ncomp <- max(initial_ncomp, min_ncomp)

  ...make_ui <- function(ind) {
    nest_inputids <- function(id, call) {
      fname <- call[[1]]
      bind_info <- getInputBinding(fname)

      id <- eval(id)
      ...this_env$bind_infos[[ id ]] <- bind_info


      inner_id <- paste0(inputId, "_", id, "_", ind)

      inner_id
    }
    comp <- match_calls(components, quoted = TRUE, envir = parent_env,
                        replace_args = list(
                          inputId = nest_inputids,
                          outputId = nest_inputids
                        ))

    as.call(list(
      quote(shiny::div),
      class = "dipsaus-compound-input-item col-xs-12",
      `data-value` = sprintf("%s", ind),
      as.call(list(
        quote(shiny::tags$fieldset),
        as.call(list(
          quote(shiny::tags$legend),
          style = sprintf(
            "border:none; margin: 0; padding: 0 10px; font-size: 14px; color: ${{label_color}}"),
          sprintf("%s - %s", label, ind)
        )),
        style = "border: 1px solid #efefef; padding:.35em .625em .75em; margin-bottom: 15px;",
        comp
      ))
    ))
  }

  if (!is.list(value)) {
    value <- list()
  } else {
    names(value) <- NULL
  }

  value <- shiny::restoreInput(id = inputId, default = value)

  if (length(max_height)) {
    ...style <- sprintf("max-height:%s;overflow-x:hidden;overflow-y:auto", max_height)
  } else {
    ...style <- NULL
  }
  comp_ui <- quote(shiny::div(
    id = inputId,
    class = "dipsaus-compound-input",
    style = ...style,
    # shiny::singleton(shiny::tags$head(
    #   shiny::tags$link(rel="stylesheet", type="text/css", href="dipsaus/dipsaus.css"),
    #   shiny::tags$script(src="dipsaus/dipsaus-dipterix-lib.js")
    # )),
    shiny::div(
      class = "dipsaus-compound-input-header force-hidden", style = "display:none!important;",
      # Input information

      jsonlite::toJSON(list(
        template = as.character(eval(...make_ui("${{ind}}"))),
        initial_ncomp = ...initial_ncomp,
        min_ncomp = ...min_ncomp,
        max_ncomp = ...max_ncomp,
        bind_infos = ...this_env$bind_infos,
        label_color = ...label_color,
        initial_value = ...value
      ))
    ),
    shiny::div(
      class = "dipsaus-compound-input-body row m-0"
    ),
    shiny::div(
      class = "dipsaus-compound-input-foot",
      shiny::div(
        class = "dipsaus-compound-input-foot-ctrl"
      )
    ),
    shiny::div(
      class = "force-hidden",
      # Make sure some plugins are loaded
      eval(...make_ui("...junk..."))
    )
  ))



  re <- eval(comp_ui, envir = list(
    inputId = inputId, ...make_ui = ...make_ui, ...initial_ncomp = initial_ncomp,
    ...min_ncomp = min_ncomp, ...max_ncomp = max_ncomp, ...label = label,
    ...label_color = label_color, ...value = value, ...this_env = ...this_env,
    ...style = ...style
  ), enclos = parent_env)


  value <- as.list(value)
  value$meta <- list(
    initial_ncomp = initial_ncomp,
    min_ncomp = min_ncomp,
    max_ncomp = max_ncomp,
    template = "",
    bind_infos = ...this_env$bind_infos,
    label_color = label_color
  )


  session <- shiny::getDefaultReactiveDomain()
  if (!is.null(session)) {
    value <- translate_compoundInput(value, session$rootScope(), inputId)
    env <- ensure_shiny_proxy(session = session)
    env$compount_inputs$set(inputId, value)
  }

  shiny::tagList(
    use_shiny_dipsaus(),
    re
  )
  # use_shiny_dipsaus(re)
}


translate_compoundInput <- function(data, session, name) {
  if (is.null(data)) { return(list()) }

  # restoreInput(id = , NULL)
  meta <- as.list(data$meta)
  data$meta <- NULL
  # shinysession$ns(name)
  mis_sess <- missing(session)

  if (!mis_sess && !length(meta)) {
    env <- ensure_shiny_proxy(session = session)
    default_val <- env$compount_inputs$get(session$ns(name))
    meta <- as.list(default_val$meta)
  }

  # session_scope = character(0)
  # if ( !mis_sess ) {
  #   session_scope = session$ns(NULL)
  # }

  inner_ids <- names(meta$bind_infos)
  update_functions <- sapply(inner_ids, function(id, ...) {
    bind_info <- meta$bind_infos[[id]]
    if (is.list(bind_info) && "update_function" %in% names(bind_info)) {
      update_function <- bind_info$update_function
      if (length(update_function)) {
        update_function <- str2lang(update_function[[1]])
        input_names <- names(formals(eval(update_function)))

        # in case R says ii not found when checking
        ii <- NULL
        .session <- NULL
        fbody <- rlang::quo({
          session_scope <- .session$ns(NULL)
          session <- .session
          widget_name <- !!name
          if ((length(session_scope) == 1) && session_scope != "") {
            # check whether name starts with session_scope if yes, this means
            # we register submodule in root session,
            # and we need to go back and remove session_scope in name
            slen <- nchar(session_scope, allowNA = TRUE, keepNA = TRUE)
            nlen <- nchar(widget_name, allowNA = TRUE, keepNA = TRUE)
            if ( slen < nlen - 1 ) {
              if ( substr(widget_name, start = 1L, stop = slen + 1L) ==
                  sprintf("%s-", session_scope) ) {
                # need to remove scope from widget_name
                widget_name <- substr(widget_name, start = slen + 2, stop = nchar(widget_name))
              }
            }
          }

          inputId <- sprintf("%s_%s_%s", widget_name, !!id, ii)
          call <- as.call(list(!!update_function, session = quote(session),
                               inputId = inputId, ...))
          if ( !"..." %in% !!input_names) {
            # Need to match call
            nms <- names(call)
            sel <- nms %in% c("", !!input_names)
            if (!all(sel)) {
              call <- call[sel]
            }
          }
          re <- eval(call)
          # clean up in case of large memory leak?
          rm(session)
          re
        })

        f <- function(ii, ..., .session = shiny::getDefaultReactiveDomain()) {
          # if (mis_sess) {
          #   session <- shiny::getDefaultReactiveDomain()
          # }
          # inputId <- sprintf("%s_%s_%s", name, id, ii)
          # call <- as.call(list(update_function, session = quote(session),
          #                      inputId = inputId, ...))
          # if ( !"..." %in% input_names) {
          #   # Need to match call
          #   nms <- names(call)
          #   sel <- nms %in% c("", input_names)
          #   if (!all(sel)) {
          #     call <- call[sel]
          #   }
          # }
          # eval(call)
        }

        body(f) <- rlang::quo_squash(fbody)
        environment(f) <- baseenv()
        return( f )
      }
    }
    return(NULL)
  }, simplify = FALSE, USE.NAMES = TRUE)
  attr(data, "update_functions") <- update_functions
  attr(data, "meta") <- meta
  class(data) <- c("dipsaus_compoundInput_data", "list")
  return(data)
}

registerCompoundInput2 <- function() {
  # register input
  shiny::registerInputHandler("dipsaus.compoundInput2", function(data, shinysession, name) {
    translate_compoundInput(data, shinysession, name)
    # data
  }, force = TRUE)
}

#' @export
print.dipsaus_compoundInput_data <- function(x, ...) {
  local({
    attributes(x) <- NULL
    base::print(x)
  })
  invisible(x)
}

#' Update compound inputs
#' @param session shiny session or session proxy
#' @param inputId character see \code{compoundInput2}
#' @param value list of lists, see \code{compoundInput2} or examples
#' @param ncomp integer, non-negative number of groups to update, \code{NULL} to
#' remain unchanged
#' @param initialization,... named list of other updates
#' @return none
#' @examples
#'
#' \dontrun{
#' library(shiny); library(dipsaus)
#'
#' ## UI side
#' compoundInput2(
#'   'input_id', 'Group',
#'     div(
#'     textInput('text', 'Text Label'),
#'     sliderInput('sli', 'Slider Selector', value = 0, min = 1, max = 1)
#'   ),
#'   label_color = 1:10,
#'   value = list(
#'     list(text = '1'),  # Set text first group to be "1"
#'     '',                # no settings for second group
#'     list(sli = 0.2)    # sli = 0.2 for the third group
#'   ))
#'
#' ## server side:
#' updateCompoundInput2(session, 'inputid',
#'                      # Change the first 3 groups
#'                      value = lapply(1:3, function(ii) {
#'                        list(sli = runif (1))
#'                      }),
#'                      # Change text label for all groups
#'                      initialization = list(
#'                        text = list(label = as.character(Sys.time()))
#'                      ))
#' }
#'
#' @seealso \code{\link[dipsaus]{compoundInput2}} for how to define components.
#'
#' @export
updateCompoundInput2 <- function(session, inputId, value = NULL, ncomp = NULL,
                                 initialization = NULL, ...) {
  if (!is.list(value)) {
    value <- list()
  }
  value <- lapply(seq_along(value), function(ii) {
    g <- value[[ii]]
    if (is.list(g)) {
      g$.__item <- ii
    } else {
      g <- NULL
    }
    g
  })
  if (is.null(ncomp)) {
    ncomp <- length(value)
  }
  initialization <- c(initialization, list(...))

  sample <- shiny::isolate(session$input[[ inputId ]])
  if (is.null(sample)) {
    env <- ensure_shiny_proxy(session = session)
    sample <- env$compount_inputs$get(session$ns(inputId))
  }

  update_functions <- attr(sample, "update_functions")
  meta <- attr(sample, "meta")
  max_ncomp <- meta$max_ncomp
  if (!length(max_ncomp) || !is.numeric(max_ncomp) || max_ncomp <= 0) {
    max_ncomp <- 100
  }

  if (!is.list(update_functions)) {
    update_functions <- list()
  }

  # Make n-components, and subscribe events
  session$sendInputMessage(inputId, list(value = value, ncomp = ncomp))

  for (nm in names(initialization)) {
    uf <- update_functions[[ nm ]]
    if (is.function(uf)) {
      lapply(seq_len(max_ncomp), function(ii) {
        do.call(uf, c(list(ii = ii), initialization[[nm]]))
      })
    }
  }

  session$sendInputMessage(inputId, list(value = value, ncomp = ncomp))
  invisible()
}