R/utils.R

In RX-PBB/bs4Mash: A 'Bootstrap 4' Version of 'shinydashboard'

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


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 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`
}

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

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


createWebDependency <- function (dependency, scrubFile = TRUE) {
  if (is.null(dependency)) 
    return(NULL)
  if (!inherits(dependency, "html_dependency")) 
    stop("Unexpected non-html_dependency type")
  if (is.null(dependency$src$href)) {
    prefix <- paste(dependency$name, "-", dependency$version, 
                    sep = "")
    shiny::addResourcePath(prefix, dependency$src$file)
    dependency$src$href <- prefix
  }
  if (scrubFile) 
    dependency$src$file <- NULL
  return(dependency)
}

# Given a Shiny tag object, process singletons and dependencies. Returns a list
# with rendered HTML and dependency objects.
processDeps <- function (tags, session) {
  ui <- htmltools::takeSingletons(tags, session$singletons, desingleton = FALSE)$ui
  ui <- htmltools::surroundSingletons(ui)
  dependencies <- lapply(htmltools::resolveDependencies(htmltools::findDependencies(ui)), 
                         createWebDependency)
  names(dependencies) <- NULL
  list(html = htmltools::doRenderTags(ui), deps = dependencies)
}