R/utils.R

In shinydashboardPlus: Add More 'AdminLTE2' Components to 'shinydashboard'

# Returns TRUE if a status is valid; throws error otherwise.
validateStatus <- function(status) {
  
  if (status %in% validStatuses) {
    return(TRUE)
  }
  
  stop("Invalid status: ", status, ". Valid statuses are: ",
       paste(validStatuses, collapse = ", "), ".")
}


#' Valid statuses
#'
#' These status strings correspond to colors as defined in Bootstrap's CSS.
#' Although the colors can vary depending on the particular CSS selector, they
#' generally appear as follows:
#'
#' \itemize{
#'   \item \code{primary} Blue (sometimes dark blue)
#'   \item \code{success} Green
#'   \item \code{info} Blue
#'   \item \code{warning} Orange
#'   \item \code{danger} Red
#' }
#'
#' @usage NULL
#' @format NULL
#'
#' @keywords internal
validStatuses <- c("primary", "success", "info", "warning", "danger")


# Returns TRUE if a status is valid; throws error otherwise.
validateStatusPlus <- function(status) {
  
  if (status %in% validStatusesPlus) {
    return(TRUE)
  }
  
  stop("Invalid status: ", status, ". Valid statuses are: ",
       paste(validStatusesPlus, collapse = ", "), ".")
}


#' Valid statuses extra
#'
#' These status strings correspond to colors as defined in adminLTE extra colors.
#' Although the colors can vary depending on the particular CSS selector, they
#' generally appear as follows:
#'
#' \itemize{
#'   \item \code{primary} Blue (sometimes dark blue)
#'   \item \code{success} Green
#'   \item \code{info} Blue
#'   \item \code{warning} Orange
#'   \item \code{danger} Red
#'   \item \code{navy} Dark Grey/Blue
#'   \item \code{teal} Blue/Green
#'   \item \code{orange} Orange
#'   \item \code{purple} Purple
#'   \item \code{maroon} Pink
#'   \item \code{black} Black
#' }
#'
#' @usage NULL
#' @format NULL
#'
#' @keywords internal
validStatusesPlus <- c("primary", "success", "info", "warning", "danger", 
                       "navy", "teal", "purple", "orange", "maroon", "black")


# all AdminLTE2 skins
validSkins <- c("blue", "blue-light","black","black-light", 
                "purple","purple-light", "green","green-light",
                "red","red-light", "yellow","yellow-light")

# Returns TRUE if a color is a valid color defined in AdminLTE, throws error
# otherwise.
validateColor <- function(color) {
  if (color %in% validColors) {
    return(TRUE)
  }
  
  stop("Invalid color: ", color, ". Valid colors are: ",
       paste(validColors, collapse = ", "), ".")
}

#' Valid colors
#'
#' These are valid colors for various dashboard components. Valid colors are
#' listed below.
#'
#' \itemize{
#'   \item \code{red}
#'   \item \code{yellow}
#'   \item \code{aqua}
#'   \item \code{blue}
#'   \item \code{light-blue}
#'   \item \code{green}
#'   \item \code{navy}
#'   \item \code{teal}
#'   \item \code{olive}
#'   \item \code{lime}
#'   \item \code{orange}
#'   \item \code{fuchsia}
#'   \item \code{purple}
#'   \item \code{maroon}
#'   \item \code{black}
#' }
#'
#' @usage NULL
#' @format NULL
#'
#' @keywords internal
validColors <- c("red", "yellow", "aqua", "blue", "light-blue", "green",
                 "navy", "teal", "olive", "lime", "orange", "fuchsia",
                 "purple", "maroon", "black", "gray")

#' Assert that a tag has specified properties
#' @param tag A tag object.
#' @param type The type of a tag, like "div", "a", "span".
#' @param class An HTML class.
#' @param allowUI If TRUE (the default), allow dynamic outputs generated by
#'   \code{\link[shiny]{uiOutput}} or \code{\link[shiny]{htmlOutput}}. When a
#'   dynamic output is provided, \code{tagAssert} won't try to validate the the
#'   contents.
#' @keywords internal
tagAssert <- function(tag, type = NULL, class = NULL, allowUI = TRUE) {
  if (!inherits(tag, "shiny.tag")) {
    print(tag)
    stop("Expected an object with class 'shiny.tag'.")
  }
  
  # Skip dynamic output elements
  if (allowUI &&
      (hasCssClass(tag, "shiny-html-output") ||
       hasCssClass(tag, "shinydashboard-menu-output") ||
       hasCssClass(tag, "ygdashboard-module-output"))) {
    return()
  }
  
  if (!is.null(type) && tag$name != type) {
    stop("Expected tag to be of type ", type)
  }
  
  if (!is.null(class)) {
    if (is.null(tag$attribs$class)) {
      stop("Expected tag to have class '", class, "'")
      
    } else {
      tagClasses <- strsplit(tag$attribs$class, " ")[[1]]
      if (!(class %in% tagClasses)) {
        stop("Expected tag to have class '", class, "'")
      }
    }
  }
}


"%OR%" <- function(a, b) if (!is.null(a)) a else b

# Return TRUE if a shiny.tag object has a CSS class, FALSE otherwise.
hasCssClass <- function(tag, class) {
  if (is.null(tag$attribs) || is.null(tag$attribs$class))
    return(FALSE)
  
  classes <- strsplit(tag$attribs$class, " +")[[1]]
  return(class %in% classes)
}


# Make sure a tab name is valid (there's no "." in it).
validateTabName <- function(name) {
  if (grepl(".", name, fixed = TRUE)) {
    stop("tabName must not have a '.' in it.")
  }
}

dropNulls <- function(x) {
  x[!vapply(x, is.null, FUN.VALUE = logical(1))]
}


# used to generate color tags in the documentation
rd_color_tag <- function(color, label = color) {
  style <- sprintf(
    "width:12px;height:12px;background:%s;border-radius:2px;display:inline-block;margin-right:5px;",
    color
  )
  sprintf(
    "\\ifelse{html}{\\out{<span style='%s'></span>%s}}{%s}",
    style, label, label
  )
}



processDeps <- function (tags, session) {
  ui <- htmltools::takeSingletons(tags, session$singletons, desingleton = FALSE)$ui
  ui <- htmltools::surroundSingletons(ui)
  dependencies <- lapply(htmltools::resolveDependencies(htmltools::findDependencies(ui)), 
                         shiny::createWebDependency)
  names(dependencies) <- NULL
  list(html = htmltools::doRenderTags(ui), deps = dependencies)
}



validateBoxProps <- function(title, label, sidebar, dropdownMenu, status, gradient, collapsible, 
                             collapsed, solidHeader, background, width) {
  
  if (!is.null(status)) validateStatusPlus(status)
  if (!is.null(background)) validateColor(background)
  
  if (is.null(title) && 
      (!is.null(label) || !is.null(sidebar) || !is.null(dropdownMenu))) {
    stop("Cannot use box tools without a title")
  }
  
  if (!collapsible && collapsed) {
    stop("Cannot collapse a card that is not collapsible.")
  }
  
  if (!is.null(status) && !is.null(background) && !solidHeader) {
    stop("solidHeader must be TRUE whenever background and status are not NULL at the same time.")
  }
  if (gradient && is.null(background)) stop("gradient cannot be used when background is NULL.")
  
  if (!is.null(width)) {
    stopifnot(is.numeric(width))
    # respect the bootstrap grid
    stopifnot(width <= 12)
    stopifnot(width >= 0)
  }
}



setBoxStyle <- function(height, sidebar) {
  style <- NULL
  if (!is.null(height)) {
    style <- paste0("height: ", shiny::validateCssUnit(height))
  }
  # add padding if box sidebar
  if (!is.null(sidebar)) {
    style <- paste(style, "padding: 10px;")
  }
}



setBoxClass <- function(status, solidHeader, collapsible, collapsed,
                        gradient, background, sidebar) {
  
  boxClass <- "box"
  if (solidHeader) {
    boxClass <- paste(boxClass, "box-solid")
  }
  
  if (!is.null(status)) {
    boxClass <- paste0(boxClass, " box-", status)
  }
  
  if (collapsible && collapsed) {
    boxClass <- paste(boxClass, "collapsed-box")
  }
  
  if (!is.null(background)) {
    boxClass <- paste0(boxClass, " bg-", background, if (gradient) "-gradient")
  }
  
  if (!is.null(sidebar)) {
    sidebarToggle <- sidebar[[1]]
    startOpen <- sidebarToggle$attribs$`data-start-open`
    if (startOpen == "true") {
      boxClass <- paste0(boxClass, " direct-chat direct-chat-contacts-open")
    } else {
      boxClass <- paste0(boxClass, " direct-chat")
    }
  }
  
  boxClass
}



# create box icons and return a list of icons
createBoxTools <- function(collapsible, collapsed, closable, 
                           sidebar, dropdownMenu, boxToolSize, status, 
                           background, solidHeader) {
  
  btnClass <- paste0(
    "btn btn-box-tool", 
    if (!is.null(boxToolSize)) paste0(" btn-", boxToolSize)
  )
  
  if (is.null(status) && !is.null(background)) {
    btnClass <- paste0(
      btnClass,
      if (background %in% validStatusesPlus) {
        paste0(" bg-", background)
      }
    )
  }
  
  # status has always priority compared to background
  if (!is.null(status) && solidHeader) {
    btnClass <- paste0(
      btnClass,
      if (status %in% validStatuses) {
        paste0(" btn-", status)
      }
    )
  }
  
  collapseTag <- NULL
  if (collapsible) {
    collapseIcon <- if (collapsed) 
      "plus"
    else "minus"
    collapseTag <- shiny::tags$button(
      class = btnClass, 
      type = "button",
      `data-widget` = "collapse", 
      shiny::icon(collapseIcon)
    )
  }
  
  closableTag <- NULL
  if (closable) {
    closableTag <- shiny::tags$button(
      class = btnClass, 
      `data-widget` = "remove", 
      type = "button",
      shiny::icon("xmark")
    )
  } 
  
  sidebarToolTag <- NULL
  if (!is.null(sidebar)) {
    sidebar[[1]]$attribs$class <- btnClass
    sidebarToolTag <- sidebar[[1]]
  }
  
  dropdownMenuToolTag <- NULL
  if (!is.null(dropdownMenu)) {
    dropdownMenu$children[[1]]$attribs$class <- paste0(btnClass, " dropdown-toggle")
    dropdownMenuToolTag <- dropdownMenu
  }
  
  dropNulls(list(dropdownMenuToolTag, collapseTag, closableTag, sidebarToolTag))
}



# extract social item in socialBox
extractSocialItem <- function(items, isComment = TRUE) {
  
  if (length(items) > 0) {
    dropNulls(lapply(items, function(item) {
      if (inherits(item, "list")) {
        lapply(item, function(nested) {
          cond <- if (isComment) {
            inherits(nested, "box-comment")
          } else {
            !inherits(nested, "box-comment")
          }
          if (cond) nested
        })
      } else {
        cond <- if (isComment) {
          inherits(item, "box-comment")
        } else {
          !inherits(item, "box-comment")
        }
        if (cond) item
      }
    }))
  } else {
    NULL
  }
}


# Insert HTML tag at any position
tagInsertChild <- function(tag, child, position) {
  tag$children <- append(tag$children, list(child), position - 1)
  tag
}


status_2_color <- function(status) {
  switch(
    status, 
    "primary" = "light-blue",
    "success" = "green",
    "danger" = "red",
    "warning" = "yellow",
    "info" = "aqua",
    "navy" = "navy",
    "teal" = "teal",
    "purple" = "purple",
    "orange" = "orange",
    "maroon" = "maroon",
    "black" = "black"
  )
}

color_2_status <- function(color) {
  switch(
    color, 
    "light-blue" = "primary",
    "green" = "success",
    "red" = "danger",
    "yellow" = "warning",
    "aqua" = "info",
    "navy" = "navy",
    "teal" = "teal",
    "purple" = "purple",
    "orange" = "orange",
    "maroon" = "maroon",
    "black" = "black"
  )
}


waiterShowOnLoad <- function(
  html = waiter::spin_1(), color = "#333e48"
){
  
  html <- as.character(html)
  html <- gsub("\n", "", html)
  
  show <- sprintf(
    "waiter.show({
      id: null,
      html: '%s', 
      color: '%s'
    });",
    html, color
  )
  
  shiny::HTML(sprintf("<script>%s</script>", show))
  
}