R/aaa.R
In shidashi: A Shiny Dashboard Template Modular System with Chat Bot Support

Documented in bslib_dependency combine_html_class format_text_r get_construct_string guess_body_class html_asis html_highlight_code remove_html_class show_ui_code

#' @importFrom fastmap fastmap
#' @importFrom digest digest
#' @importFrom formatR tidy_source
#' @importFrom httr2 url_modify
#' @importFrom yaml read_yaml
#' @importFrom jsonlite fromJSON
#' @importFrom ellmer tool
NULL

#' Get Bootstrap 5 dependencies via \pkg{bslib}
#' @description Returns Bootstrap 5 HTML dependencies provided by
#' \pkg{bslib}. Intended to be called from HTML templates so that
#' \code{headContent()} renders Bootstrap 5 CSS and JavaScript.
#' @param ... additional arguments passed to \code{bslib::bs_theme}
#' @return An \code{\link[shiny]{tagList}} containing Bootstrap 5 dependencies
#' @export
bslib_dependency <- function(...) {
  theme <- bslib::bs_theme(version = 5, ...)
  deps <- bslib::bs_theme_dependencies(theme)
  shiny::tagList(deps)
}

rand_string <- function(length = 10, prefix = NULL) {
  paste(c(prefix, sample(c(letters, LETTERS, 0:9), length, replace = TRUE)),
        collapse = "")
}

R_user_dir <- function(package, which = c("data", "config", "cache")) {
  stopifnot(is.character(package), length(package) == 1L)
  which <- match.arg(which)
  home <- normalizePath("~")
  path <- switch(which, data = {
    p <- Sys.getenv("R_USER_DATA_DIR")
    if (!nzchar(p)) {
      p <- Sys.getenv("XDG_DATA_HOME")
      if (!nzchar(p)) {
        if (.Platform$OS.type == "windows") {
          p <- file.path(Sys.getenv("APPDATA"), "R",
                         "data")
        } else if (Sys.info()["sysname"] == "Darwin") {
          p <- file.path(home, "Library", "Application Support",
                         "org.R-project.R")
        } else {
          p <- file.path(home, ".local", "share")
        }
      }
    }
    p
  }, config = {
    p <- Sys.getenv("R_USER_CONFIG_DIR")
    if (!nzchar(p)) {
      p <- Sys.getenv("R_USER_CONFIG_DIR")
      if (!nzchar(p)) {
        p <- Sys.getenv("XDG_CONFIG_HOME")
        if (!nzchar(p)) {
          if (.Platform$OS.type == "windows") {
            p <- file.path(Sys.getenv("APPDATA"), "R",
                           "config")
          } else if (Sys.info()["sysname"] == "Darwin") {
            p <- file.path(home, "Library", "Preferences",
                           "org.R-project.R")
          } else {
            p <- file.path(home, ".config")
          }
        }
      }
    }
    p
  }, cache = {
    p <- Sys.getenv("R_USER_CACHE_DIR")
    if (!nzchar(p)) {
      p <- Sys.getenv("XDG_CACHE_HOME")
      if (!nzchar(p)) {
        if (.Platform$OS.type == "windows") {
          p <- file.path(Sys.getenv("LOCALAPPDATA"),
                         "R", "cache")
        } else if (Sys.info()["sysname"] == "Darwin") {
          p <- file.path(home, "Library", "Caches", "org.R-project.R")
        } else {
          p <- file.path(home, ".cache")
        }
      }
    }
    p
  })
  file.path(path, "R", package)
}

set_attr_call <- function(x, call, collapse = "\n", ...) {
  if (!is.character(call)) {
    call <- deparse(call)
  }
  call <- paste(call, collapse = collapse, ...)
  attr(x, "shidashi.code") <- call
  x
}

combine_class <- function(...) {
  s <- paste(c(...), collapse = " ", sep = " ")
  s <- unlist(strsplit(s, " "))
  s <- unique(s)
  s <- s[!s %in% ""]
  paste(s, collapse = " ")
}
remove_html_class <- function(target, class) {
  if (!length(target)) { return("") }
  s <- unlist(strsplit(target, " "))
  s <- unique(s)
  s <- s[!s %in% c("", class)]
  paste(s, collapse = " ")
}

#' Guess the 'AdminLTE' body class for modules, used internally
#' @param cls the class string of the \code{<body>} tag in \code{'index.html'}
#' @return The proposed class for \code{<body>} tag
#' @export
guess_body_class <- function(cls) {
  if (missing(cls)) {
    cls <- "fancy-scroll-y darm-mode"
  } else {
    cls <- unlist(strsplit(paste(cls, collapse = " "), " "))
    combine_class(cls[startsWith(cls, "fancy-scroll-") | cls %in% "dark-mode"])
  }
}

#' Get \code{R} expression used to generate the 'HTML' tags
#' @description This function only works on the elements generated by this
#' package
#' @param x 'HTML' tags
#' @return Quoted \code{R} expressions that can generate the 'HTML' tags
#'
#' @seealso \code{\link{format_text_r}}
#' @examples
#'
#' x <- info_box("Message")
#' get_construct_string(x)
#'
#' @export
get_construct_string <- function(x) {
  attr(x, "shidashi.code")
}

#' Get re-formatted \code{R} expressions in characters
#' @seealso \code{\link{get_construct_string}}
#' @param expr \code{R} expressions
#' @param quoted whether \code{expr} is quoted
#' @param reformat whether to reformat
#' @param class class of \code{<pre>} tag
#' @param copy_on_click whether to copy to clipboard if user clicks on the
#' code; default is true
#' @param hover mouse hover behavior
#' @param width.cutoff,indent,wrap,args.newline,blank,... passed to
#' \code{\link[formatR]{tidy_source}}
#' @return \code{format_text_r} returns characters,
#' \code{html_highlight_code} returns the 'HTML' tags wrapping expressions
#' in \code{<pre>} tag
#' @examples
#'
#' s <- format_text_r(print(local({a<-1;a+1})))
#' cat(s)
#'
#' x <- info_box("Message", icon = "cogs")
#' s <- format_text_r(get_construct_string(x),
#'                    width.cutoff = 15L, quoted = TRUE)
#' cat(s)
#'
#'
#' @export
format_text_r <- function(expr, quoted = FALSE, reformat = TRUE,
                          width.cutoff = 80L, indent = 2, wrap = TRUE,
                          args.newline = TRUE, blank = FALSE, ...) {
  if (!quoted) {
    expr <- substitute(expr)
  }

  if (length(expr) != 1 ||
      !is.character(expr)) {
    expr <- paste(deparse(expr), collapse = "\n")
  }

  if (reformat) {
    expr <- formatR::tidy_source(
      text = expr,
      output = FALSE,
      width.cutoff = width.cutoff,
      indent = indent,
      wrap = wrap,
      args.newline = args.newline,
      blank = blank,
      ...
    )$text.tidy
  }
  paste(expr, collapse = "\n")
}

#' @rdname format_text_r
#' @export
html_highlight_code <- function(
  expr, class = NULL, quoted = FALSE,
  reformat = TRUE, copy_on_click = TRUE,
  width.cutoff = 80L, indent = 2, wrap = TRUE,
  args.newline = TRUE, blank = FALSE,
  ..., hover = c("overflow-visible-on-hover", "overflow-auto")) {

  hover <- match.arg(hover)
  if (!quoted) {
    expr <- substitute(expr)
  }
  expr <- format_text_r(expr = expr, quoted = TRUE,
                reformat = reformat, width.cutoff = width.cutoff,
                indent = indent, wrap = wrap, args.newline = args.newline,
                blank = blank, ...)

  shiny::HTML(
    sprintf(
      "<pre class='pre-compact no-padding bg-gray-90 %s %s %s' %s><code class='r'>%s</code></pre>",
      hover,
      paste(class, collapse = " "),
      ifelse(copy_on_click, "clipboard-btn shidashi-clipboard-output", ""),
      ifelse(copy_on_click,
             sprintf("data-clipboard-text='%s' role='button' title='Click to copy!'", expr),
             ""),
      expr
    )
  )
}

#' Used by demo project to show the generating code
#' @seealso \code{html_highlight_code}
#' @description Please write your own version. This function is designed for
#' demo-use only.
#' @param x 'HTML' tags generated by this package
#' @param class additional 'HTML' class
#' @param code_only whether to show code only
#' @param as_card whether to wrap results in \code{\link{card}}
#' @param card_title,class_body used by \code{\link{card}} if \code{as_card=TRUE}
#' @param width.cutoff,indent,wrap,args.newline,blank,copy_on_click,... passed
#' to \code{\link{html_highlight_code}}
#' @return 'HTML' tags
#' @export
show_ui_code <- function(
  x, class = NULL, code_only = FALSE,
  as_card = FALSE, card_title = "", class_body = "bg-gray-70",
  width.cutoff = 80L, indent = 2, wrap = TRUE,
  args.newline = TRUE, blank = FALSE, copy_on_click = TRUE,
  ...)
{
  code <- format_text_r(
    get_construct_string(x),
    quoted = TRUE,
    width.cutoff = width.cutoff,
    indent = indent,
    wrap = wrap,
    args.newline = args.newline,
    blank = blank,
    ...
  )

  res <- info_box(
    class = combine_class("no-margin overflow-visible-on-hover", class),
    class_content = "display-block bg-gray-90 no-padding code-display",
    icon = NULL,
    html_highlight_code(code, quoted = TRUE, reformat = FALSE,
                        copy_on_click = copy_on_click)
  )


  if (as_card) {
    res <- card(
      title = card_title, class_body = class_body,
      tools = clipboardOutput(
        clip_text = code,
        as_card_tool = TRUE),
      footer = res,
      class_foot = "display-block bg-gray-90 no-padding code-display fill-width",
      if (code_only) {
        NULL
      } else {
        x
      }
    )
  }
  res
}


truc_string <- function(x, max_char, annot = "(truncated)", side = c("end", "begin", "both"), collapse = "\n") {
  side <- match.arg(side)

  # x <- "asdbkawjhrgfbqwierkfbwlairefb"
  # max_char <- 10
  # side <- "end"
  # annot = "(truncated)"

  if (side == "both" && max_char < nchar(annot) + 10) {
    side <- "end"
  }

  annot <- switch(
    side,
    both = sprintf("|...%s...|", annot),
    end = sprintf("|...%s", annot),
    begin = sprintf("%s...|", annot)
  )

  alen <- nchar(annot)

  max_char <- max(max_char, nchar(annot) + 2)

  x <- trimws(paste(x, collapse = collapse))
  xlen <- nchar(x)
  if (xlen <= max_char) {
    return(x)
  }

  tlen <- max_char - alen

  switch(
    side,
    both = {
      n_pre <- ceiling(tlen / 2)
      n_post <- tlen - n_pre
      sprintf("%s%s%s", substr(x, 1L, n_pre), annot, substr(x, xlen - n_post + 1, xlen))
    },
    end = {
      sprintf("%s%s", substr(x, 1L, tlen), annot)
    },
    begin = {
      sprintf("%s%s", annot, substr(x, xlen - tlen + 1L, xlen))
    }
  )

}


`%||%` <- function(a, b) if (is.null(a)) b else a

drop_null <- function(x) {
  as.list(x[!vapply(x, is.null, FALSE)])
}

#' @name html_class
#' @title Combine, add, or remove 'HTML' classes
#' @description Combine 'HTML' classes to produce nice, clean 'HTML' class
#' string via \code{combine_html_class}, or to remove a class via
#' \code{remove_html_class}
#' @param ... one or more characters, classes to combine; duplicated classes
#' will be removed
#' @param target characters, class list
#' @param class one or more characters, classes to be removed from \code{target}
#' @return A character string of new 'HTML' class
#' @examples
#'
#' # Combine classes "a b c d e"
#' combine_html_class("a", "b  a", c("c", " d", "b"), list("e ", "a"))
#'
#' # Remove class
#' remove_html_class("a b   c  e", c("b", "c "))
#'
#' @export
combine_html_class <- function(...) {
  s <- paste(c(...), collapse = " ", sep = " ")
  s <- unlist(strsplit(s, " "))
  s <- unique(s)
  s <- s[!s %in% ""]
  paste(s, collapse = " ")
}

#' @rdname html_class
#' @export
remove_html_class <- function(target, class) {
  if (!length(target)) {
    return("")
  }
  s <- unlist(strsplit(target, " "))
  s <- unique(s)
  class <- unlist(strsplit(class, " "))
  s <- s[!s %in% c("", class)]
  paste(s, collapse = " ")
}

#' Escape HTML strings
#' @description Escape HTML strings so that they will be displayed
#' 'as-is' in websites.
#' @param s characters
#' @param space whether to also escape white space, default is true.
#' @return An R string
#' @examples
#'
#' html_asis("<a><----> <b>")
#'
#' @export
html_asis <- function(s, space = TRUE) {
  if (space) {
    pattern <- "&|<|>| |\t" # or "&|<|>|'|\"|\r|\n"
    specials <- list(
      "&" = "&amp;",
      "<" = "&lt;",
      ">" = "&gt;",
      # "'" = "&#39;",
      # '"' = "&quot;",
      # "\r" = "&#13;",
      # "\n" = "&#10;",
      " " = "&nbsp;",
      "\t" = "&nbsp;&nbsp;&nbsp;&nbsp;"
    )
  } else {
    pattern <- "&|<|>|"
    specials <- list("&" = "&amp;", "<" = "&lt;", ">" = "&gt;")
  }

  s <- enc2utf8(as.character(s))
  if (any(grepl(pattern, s, useBytes = TRUE))) {
    for (chr in names(specials)) {
      s <- gsub(chr, specials[[chr]], s, fixed = TRUE, useBytes = TRUE)
    }
  }
  Encoding(s) <- "UTF-8"
  shiny::HTML(s)
}

Any scripts or data that you put into this service are public.

shidashi documentation built on April 10, 2026, 5:07 p.m.

rdrr.io home R language documentation Run R code online

CRAN packages Bioconductor packages R-Forge packages GitHub packages

Note that we can't provide technical support on individual packages. You should contact the package authors for that.

shidashi
A Shiny Dashboard Template Modular System with Chat Bot Support

R/aaa.R
In shidashi: A Shiny Dashboard Template Modular System with Chat Bot Support

Defines functions html_asis remove_html_class combine_html_class drop_null `%||%` truc_string show_ui_code html_highlight_code format_text_r get_construct_string guess_body_class remove_html_class combine_class set_attr_call R_user_dir rand_string bslib_dependency

Documented in bslib_dependency combine_html_class format_text_r get_construct_string guess_body_class html_asis html_highlight_code remove_html_class show_ui_code

Try the shidashi package in your browser

R Package Documentation

Browse R Packages

We want your feedback!

shidashi A Shiny Dashboard Template Modular System with Chat Bot Support

R/aaa.R In shidashi: A Shiny Dashboard Template Modular System with Chat Bot Support

Defines functions html_asis remove_html_class combine_html_class drop_null `%||%` truc_string show_ui_code html_highlight_code format_text_r get_construct_string guess_body_class remove_html_class combine_class set_attr_call R_user_dir rand_string bslib_dependency

Documented in bslib_dependency combine_html_class format_text_r get_construct_string guess_body_class html_asis html_highlight_code remove_html_class show_ui_code

Try the shidashi package in your browser

R Package Documentation

Browse R Packages

We want your feedback!

shidashi
A Shiny Dashboard Template Modular System with Chat Bot Support

R/aaa.R
In shidashi: A Shiny Dashboard Template Modular System with Chat Bot Support