# ------------------------------------------------------------------------
#
# Title : shinyWidgets Gallery - global
# By : Victor
# Date : 2020-12-01
#
# ------------------------------------------------------------------------
library(htmltools)
library(bslib)
library(shinyWidgets)
if (any(ls(".GlobalEnv") %in% ls("package:shinyWidgets")))
warning("Some function(s) from GlobalEnv will override those from shinyWidgets")
# ids <- paste0("Id", sprintf("%03d", 1:81))
.shinyWidgetGalleryId <- 1
# idss <- ids
# Funs --------------------------------------------------------------------
# Widget wrapper ----
.shinyWidgetGalleryFuns <- new.env()
.shinyWidgetGalleryFuns$widget_wrapper <- function(fun, args){
raw <- paste0(
deparse(substitute(fun)),
gsub(
pattern = "^list", replacement = "",
x = paste(deparse(substitute(args)), collapse = "\n")
)
)
raw <- gsub(pattern = "ID\\(\\.shinyWidgetGalleryId\\)", replacement = paste0("\"", args$inputId, "\""), x = raw)
formatted <- sub(pattern = "\\(", replacement = "\\(\n ", x = raw)
formatted <- gsub(pattern = "\\)$", replacement = "\n\\)", x = formatted)
formatted <- gsub(pattern = ",(\\s[[:graph:]]+\\s=)", replacement = ",\n \\1", x = formatted)
formatted <- gsub(pattern = "list\\(", replacement = "list\\(\n ", x = formatted)
formatted <- trimws(formatted)
htmltools::tagList(
do.call(fun, args), htmltools::hr(),
htmltools::tags$b("Value :"),
shiny::verbatimTextOutput(outputId = paste0("res", args$inputId)),
tags$a(
icon("code"),
"Show code",
`data-bs-toggle` = "collapse",
href = paste0("#showcode", args$inputId)
),
htmltools::tags$div(
class="collapse", id=paste0("showcode", args$inputId),
.shinyWidgetGalleryFuns$rCodeContainer(
id=paste0("code", args$inputId),
formatted
)
)
)
}
.shinyWidgetGalleryFuns$box_wrapper <- function(title, ..., footer = NULL) {
bslib::card(
if (!is.null(title)) bslib::card_header(title, class = "bg-primary text-light"),
bslib::card_body(...),
if (!is.null(footer)) bslib::card_footer(footer)
)
}
.shinyWidgetGalleryFuns$pb_code <- function(id, ui, server) {
htmltools::tagList(
tags$a(
icon("code"),
"Show code",
`data-bs-toggle` = "collapse",
href = paste0("#showcode", id)
),
htmltools::tags$div(
class = "collapse",
id = paste0("showcode", id),
.shinyWidgetGalleryFuns$rCodeContainer(
id=paste0("code", id),
paste(
"# ui",
ui,
"# server",
server,
sep = "\n"
)
)
)
)
}
# Highlight functions ----
.shinyWidgetGalleryFuns$injectHighlightHandler <- function() {
code <- "
Shiny.addCustomMessageHandler('highlight-code', function(message) {
var id = message['id'];
setTimeout(function() {
var el = document.getElementById(id);
hljs.highlightBlock(el);
}, 100);
});
"
htmltools::tags$script(code)
}
.shinyWidgetGalleryFuns$includeHighlightJs <- function() {
resources <- system.file("www/shared/highlight", package = "shiny")
list(
htmltools::includeScript(file.path(resources, "highlight.pack.js")),
htmltools::includeCSS(file.path(resources, "rstudio.css")),
.shinyWidgetGalleryFuns$injectHighlightHandler()
)
}
.shinyWidgetGalleryFuns$highlightCode <- function(session, id) {
session$sendCustomMessage("highlight-code", list(id = id))
}
.shinyWidgetGalleryFuns$rCodeContainer <- function(...) {
code <- htmltools::HTML(as.character(tags$code(class = "language-r", ...)))
htmltools::tags$div(htmltools::tags$pre(code))
}
.shinyWidgetGalleryFuns$renderCode <- function(expr, env = parent.frame(), quoted = FALSE) {
func <- NULL
shiny::installExprFunction(expr, "func", env, quoted)
shiny::markRenderFunction(shiny::textOutput, function() {
paste(func(), collapse = "\n")
})
}
ID <- function(.shinyWidgetGalleryId) {
tmp <- paste0("Id", sprintf("%03d", .shinyWidgetGalleryId))
.shinyWidgetGalleryId <<- .shinyWidgetGalleryId + 1
return(tmp)
}
# load tabs UI
for (tab in list.files("tabs/")) {
source(file = file.path("tabs", tab))
}
rm(tab)
# Message for tests
message("Running shinyWidgets gallery...")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.