R/aaa.R

Defines functions show_ui_code html_highlight_code format_text_r get_construct_string guess_body_class remove_class combine_class set_attr_call

Documented in format_text_r get_construct_string guess_body_class html_highlight_code show_ui_code

#' @importFrom fastmap fastmap
#' @importFrom digest digest
#' @importFrom formatR tidy_source
#' @importFrom httr parse_url
#' @importFrom httr modify_url
#' @importFrom yaml read_yaml
#' @importFrom jsonlite fromJSON
NULL

rand_string <- function (length = 10) {
  paste(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_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
}

Try the shidashi package in your browser

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

shidashi documentation built on Nov. 18, 2021, 1:10 a.m.