R/utils.R

In rstudio/shinydashboard: Create Dashboards with 'Shiny'

#' 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"))) {
    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, "'")
      }
    }
  }
}

# Given the name of an icon, like "fa-dashboard" or "glyphicon-user",
# return CSS classnames, like "fa fa-dashboard" or "glyphicon glyphicon-user".
getIconClass <- function(icon) {
  iconGroup <- sub("^((glyphicon)|(fa))-.*", "\\1", icon)
  paste(iconGroup, icon)
}


# 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")


# 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")


"%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.")
  }
}


# This is like a==b, except that if a or b is NULL or an empty vector, it won't
# return logical(0). If a AND b are NULL/length-0, this will return TRUE; if
# just one of them is NULL/length-0, this will FALSE. This is for use in
# conditionals where `if(logical(0))` would cause an error. Similar to using
# identical(a,b), but less stringent about types: `equals(1, 1L)` is TRUE, but
# `identical(1, 1L)` is FALSE.
equals <- function(a, b) {
  alen <- length(a)
  blen <- length(b)
  if (alen==0 && blen==0) {
    return(TRUE)
  }
  if (alen > 1 || blen > 1) {
    stop("Can only compare objects of length 0 or 1")
  }
  if (alen==0 || blen==0) {
    return(FALSE)
  }

  a == b
}


# Return TRUE if a tag object matches a specific id, and/or tag name, and/or
# class, and or other arbitrary tag attributes. Put the args after ... so that
# caller must use named arguments.
tagMatches <- function(item, ..., id = NULL, name = NULL, class = NULL) {
  dots <- list(...)
  if (!inherits(item, "shiny.tag")) {
    return(FALSE)
  }
  if (!is.null(id) && !equals(item$attribs$id, id)) {
    return(FALSE)
  }
  if (!is.null(name) && !equals(item$name, name)) {
    return(FALSE)
  }
  if (!is.null(class)) {
    if (is.null(item$attribs$class)) {
      return(FALSE)
    }
    classes <- strsplit(item$attribs$class, " ")[[1]]
    if (! class %in% classes) {
      return(FALSE)
    }
  }

  for (i in seq_along(dots)) {
    arg     <- dots[[i]]
    argName <- names(dots)[[i]]
    if (!equals(item$attribs[[argName]], arg)) {
      return(FALSE)
    }
  }

  TRUE
}

# This function takes a DOM element/tag object and reccurs within it until
# it finds a child which has an attribute called `attr` and with value `val`
# (and returns TRUE). If it finds an element with an attribute called `attr`
# whose value is NOT `val`, it returns FALSE. If it exhausts all children
# and it doesn't find an element with an attribute called `attr`, it also
# returns FALSE
findAttribute <- function(x, attr, val) {
  if (is.atomic(x)) return(FALSE) # exhausted this branch of the tree

  if (!is.null(x$attribs[[attr]])) { # found attribute called `attr`
    if (identical(x$attribs[[attr]], val)) return(TRUE)
    else return(FALSE)
  }

  if (length(x$children) > 0) { # recursion
    return(any(unlist(lapply(x$children, findAttribute, attr, val))))
  }

  return(FALSE) # found no attribute called `attr`
}