Nothing
R/aaa.R
In shidashi: A Shiny Dashboard Template System
Defines functions
show_ui_code
html_highlight_code
format_text_r
get_construct_string
guess_body_class
remove_html_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, 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
}
Try the shidashi package in your browser
Any scripts or data that you put into this service are public.
shidashi documentation built on April 4, 2023, 5:16 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions show_ui_code html_highlight_code format_text_r get_construct_string guess_body_class remove_html_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, 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
}
Try the shidashi package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.