R/accordion.R

In shidashi: A Shiny Dashboard Template System

#' @title 'Accordion' items
#' @param title character title to show in the header
#' @param ... body content
#' @param footer footer element, hidden if \code{NULL}
#' @param class the class of the item
#' @param collapsed whether collapsed at the beginning
#' @param parentId parent \code{\link{accordion}} id
#' @param itemId the item id
#' @param style_header,style_body 'CSS' style of item header and body
#' @param root_path see \code{template_root}
#' @return \code{'shiny.tag.list'} 'HTML' tags
#' @seealso \code{\link{accordion}}
#' @export
accordion_item <- function(
  title, ..., footer = NULL,
  class = "", collapsed = TRUE,
  parentId = rand_string(prefix = "accordion-"),
  itemId = rand_string(prefix = "accordion-item-"),
  style_header = NULL, style_body = NULL,
  root_path = template_root()){

  body <- shiny::tagList(...)

  template_path <- file.path(root_path, 'views', 'accordion-item.html')

  if(length(footer)){
    footer <- shiny::div(
      class = "card-footer",
      footer
    )
  } else {
    footer <- ''
  }

  if(length(title) >= 1){
    data_title <- trimws(as.character(title[[1]])[[1]])
  } else {
    data_title <- ""
  }

  shiny::htmlTemplate(
    template_path,
    document_ = FALSE,
    title = title,
    data_title = data_title,
    body = body,
    class = class,
    parentId = parentId,
    itemId = itemId,
    style_header = style_header,
    style_body = style_body,
    footer = footer,
    collapsed = collapsed
  )
}

#' @name accordion
#' @title Generates an 'accordion' tab-set
#' @description Generates an 'accordion' tab-set that only one tab is
#' expanded at a time. This feature is experimental and has bugs in
#' some situations. Please use it at your own risk.
#' @param ... 'accordion' items, generated by \code{\link{accordion_item}}
#' @param id the element id, must be unique
#' @param class the additional 'HTML' class
#' @param style_header additional 'CSS' styles for header
#' @param style_body additional 'CSS' styles for content body
#' @param env environment to evaluate \code{...}
#' @param extras key-value pairs that overrides the parameters in
#' \code{\link{accordion_item}}
#' @param root_path see \code{\link{template_root}}
#' @return \code{'shiny.tag.list'} 'HTML' tags
#' @seealso \code{\link{accordion_item}}
#'
#' @examples
#'
#'
#' if(interactive()) {
#'
#'   library(shiny)
#'   library(shidashi)
#'
#'   accordion(
#'     id = "input-set",
#'     accordion_item(
#'       title = "Input Group A",
#'       textInput("input_1", "Input 1"),
#'       collapsed = FALSE,
#'       footer = "Anim pariatur cliche reprehenderit dolor brunch."
#'     ),
#'     accordion_item(
#'       title = "Input Group B",
#'       textInput("input_2", "Input 2"),
#'       footer = actionButton("btn1", "OK"),
#'       collapsed = FALSE
#'     )
#'   )
#' }
#'
#' @export
accordion <- function(
  ..., id = rand_string(prefix = "accordion-"),
  class = NULL, style_header = NULL,
  style_body = NULL, env = parent.frame(), extras = list(),
  root_path = template_root()){

  call <- match.call(expand.dots = FALSE)

  force(root_path)
  parentId <- id

  items <- unname(lapply(call[['...']], function(item){
    item[["parentId"]] <- parentId
    item[["root_path"]] <- root_path

    if(!is.null(style_header)){
      item[["style_header"]] <- style_header
    }
    if(!is.null(style_body)){
      item[["style_body"]] <- style_body
    }
    eval(item, envir = env)
  }))

  extras <- as.list(extras)
  extras$id <- parentId
  extras$class <- combine_class("card-accordion", class)
  extras <- c(extras, items)

  do.call(shiny::div, extras)

}


#' @rdname accordion
#' @param itemId \code{\link{accordion_item}} id
#' @param item_title \code{\link{accordion_item}} title, if item id is
#' specified, this title will be ignored
#' @param method operation, choices are \code{'expand'} (default),
#' \code{'collapse'}, or \code{'toggle'}
#' @param session \code{shiny} session
#' @export
accordion_operate <- function(
    id, itemId, item_title,
    method = c("expand", "collapse", "toggle"),
    session = shiny::getDefaultReactiveDomain()) {

  method <- match.arg(method)
  if(missing(item_title) && missing(itemId)) {
    stop("accordion_operate: either accordion item title or id must be specified")
  }

  if(missing(itemId)) {
    selector <- sprintf("#%s .card-accordion-header [data-title='%s']", session$ns(id), item_title)
  } else {
    itemId <- session$ns(itemId)
    selector <- sprintf("#%s .card-accordion-item#%s-accordion-header .card-accordion-title", session$ns(id), itemId)
  }

  session$sendCustomMessage("shidashi.accordion", list(
    selector = selector,
    method = method
  ))

}