R/shiny-widgets.R

In atusy/qntmap: Enhance quantitative analysis of EPMA map

menu_map <- function(id, dropdown = NULL) {
  ids <- paste0(id, "_", c("elem_selecter", "min", "max"))
  cssgrid::grid_layout(
    shiny::uiOutput(ids[[1L]]), # selectInput of elements generated by select_elem
    shiny::numericInput(ids[[2L]], "Min", value = NA_real_, width = "100%"),
    shiny::numericInput(ids[[3L]], "Max", value = NA_real_, width = "100%"),
    dropdown,
    cols = "8em 1fr 1fr auto",
    column_gap = "3px",
    style = "width: 100%;",
    class = "cssgrid"
  )
}

picker_input <- function(
  inputId, label = NULL, choices,
  options = list(style = "form-control shiny-bound-input"),
  ...
) {
  shinyWidgets::pickerInput(
    inputId = inputId, label = label, choices = choices, 
    options = options, ...
  )
}

drop_menu <- function(..., circle = FALSE, right = TRUE, width = "200px") {
  shinyWidgets::dropdown(..., circle = circle, right = right, width = width)
}

drop_map <- function(id, ...) {
  drop_menu(
    tagList(
      tags$p(
        "Color",
        tippy_info(
          paste0(id, "_colors_tippyinfo"),
          "Choices are perceptually uniform palletes.<br />cf. <a href='https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html', target = _blank>https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html</a>",
          interactive = TRUE
        )
      ),
      picker_input(
        paste0(id, "_color"), label = NULL, 
        choices = setdiff(names(lookup), "discrete"),
        selected = "magma", width = "100%"
      )
    ),
    tags$p("Scale"),
    picker_scale(id),
    ...
  )
}

picker_scale <- function(id, label = NULL, width = "100%") {
  picker_input(
    paste0(id, "_scale"), label = label,
    choices = c(px = "px", "\u00b5m" = "um", mm = "mm", cm = "cm"),
    selected = "px", width = width
  )
}

select_action <- function(id) {
  choices = c("Zoom", "Move", "Summarize")
  shinyWidgets::radioGroupButtons(
    inputId = id,
    label = "Mouse actions",
    choiceNames = map2(choices, message_action[choices], tippy::tippy, arrow = TRUE),
    choiceValues = choices,
    selected = "Zoom",
    status = "secondary",
    individual = TRUE
  )
}

message_action <- c(
  Zoom = "Zoom by double click selected area.<br />Unzoom by double click without selecting area..",
  Move = "Move by double click within zoomed area.",
  Summarize = "Double click or select area to summarize data."
)

icons <- list(
  info = icon("info-circle"),
  open = icon("folder-open")
)

#' @importFrom shinyFiles shinyDirButton
shiny_dir_btn <- function(id, title = "Choose a directory from the left pane") {
  shinyDirButton(
    id, label = NULL, title = title, icon = icons$open,
    style = "margin-bottom: 15px"
  )  
}

#' @importFrom shinyFiles shinyFilesButton
shiny_files_btn <- function(id, title = "Choose a file", multiple = FALSE) {
  shinyFilesButton(
    id, label = NULL, title = title, icon = icons$open,
    style = "margin-bottom: 15px", multiple = multiple
  )
}

#' @importFrom tippy tippy_this
tippy_icon <- function(id, tooltip, ..., type = "info") {
  tagList(
    tags$span(icons[[type]], id = id),
    tippy_this(id, tooltip, ...)
  )
}

tippy_info <- tippy_icon