bulma/R/utils.R

apply_tag <- function(ll, tag, class = NULL, extra_attributes = NULL) {
  lapply(ll, function(x) htmltools::tag(tag, c(x, class = class, extra_attributes)))
}

dots2list <- function(...) {
  # Convert dots to list, but return first element if the first element is a list
  # and the length of ... is 1
  x <- list(...)
  if (length(x) == 1 && is.list(x[[1]])) return(x[[1]])
  x
}

map_arg <- function(..., .f, .args = NULL) {
  .args <- compact(.args)
  if (is.null(.args)) {
    mapply(.f, ..., SIMPLIFY = FALSE, USE.NAMES = TRUE)
  } else {
    mapply(.f, ..., MoreArgs = compact(.args), SIMPLIFY = FALSE, USE.NAMES = TRUE)
  }
}

compact <- function(x) {
  x <- x[!vapply(x, is.null, logical(1))]
  if (length(x)) x else NULL
}

tag_function <- function(.tag = "div") {
  function(...) htmltools::tag(.tag, list(...))
}

tag_div <- tag_function("div")
tag_p   <- tag_function("p")
tag_a   <- tag_function("a")


validate_value <- function(value = NULL, choices, several.ok = TRUE, value_name = "") {
  if (!is.null(value) && length(value)) {
    value_name <- if (nchar(value_name) > 0) glue("`{value_name}` - ") else ""
    warnings <- c()
    not_in_choices <- setdiff(value, choices)
    if (length(not_in_choices)) {
      warnings <- glue("{value_name}Ignoring invalid choices: ",
                  "\"{paste(not_in_choices, collapse = '\", \"')}\"")
      value <- intersect(value, choices)
    }
    if (!several.ok && length(value) > 1) {
      warnings <- c(
        warnings,
        glue("{value_name}Using the first of {length(value)} values: {value[1]}")
      )
      value <- value[1]
    }
    if (length(value)) {
      if (length(warnings)) {
        rlang::warn(paste(warnings, collapse = "\n"))
      }
      value
    } else {
      rlang::abort(glue("{value_name}Must be one of the following valid choices: ",
                        "\"{paste(choices, collapse = '\", \"')}\""))
    }
  } else if (!is.null(value) && !length(value)) NULL
}

is_html <- function(x) inherits(x, "html")
is_tagList <- function(x) inherits(x, "shiny.tag.list")
is_tag <- function(x) inherits(x, "shiny.tag")
is_htmlish <- function(x) is_html(x) | is_tag(x) | is_tagList(x)

c_is <- function(x) {
  if (is.null(x)) return(NULL)
  str_trim(paste("is-", x, sep = "", collapse = " "))
}

c_has <- function(x) {
  if (is.null(x)) return(NULL)
  str_trim(paste("has-", x, sep = "", collapse = " "))
}

c_prefix <- function(x = NULL, prefix = NULL) {
  if (is.null(x)) return(NULL)
  paste0(prefix, x)
}

c_str <- function(...) {
  str_trim(paste(..., sep = " ", collapse = " "))
}

str_trim <- function(x) {
  x <- gsub("^\\s*|\\s*$", "", x)
  gsub("\\s+", " ", x)
}

#' Font Awesome Icon
#'
#' Create the correct Font Awesome class.
#' @param name Name of the Font Awesome icon
#' @param solid Should the solid or the regular icon be used?
#' @param as_html If `FALSE` (default), only the icon class is returned.
#' @examples
#' fa_icon("github")
#' fa_icon("star")
#' fa_icon("star", FALSE)
#'
#' @references <https://fontawesome.com/icons>
#' @export
fa_icon <- function(name, solid = TRUE, as_html = FALSE) {
  iconClass <- if (name %in% font_awesome_brands) "fab" else {
    if (solid) "fas" else "far"
  }
  iconClass <- paste(iconClass, paste0("fa-", name))
  if (!as_html) return(iconClass)

  icon <- tag_function("i")(class = iconClass)
  htmltools::htmlDependencies(icon) <- rmarkdown::html_dependency_font_awesome()
  icon
}