#' Generate CSS string representing grid template areas.
#' @param areas_dataframe data.frame of character representing grid areas
#' @return character
#' @details This is a helper function used in grid_template()
#'
#' \preformatted{
#' areas_dataframe <- rbind(
#' c("header", "header", "header"),
#' c("menu", "main", "right1"),
#' c("menu", "main", "right2")
#' )
#'
#' result == "'header header header' 'menu main right1' 'menu main right2'"
#' }
#'
#' @keywords internal
data_frame_to_css_grid_template_areas <- function(areas_dataframe) {
apply(areas_dataframe, 1, function(row) paste(row, collapse = ' ')) %>%
lapply(function(row) glue::glue("'{row}'")) %>%
paste(collapse = ' ')
}
#' Generate template string representing CSS styles of grid container div.
#'
#' @param css_grid_template_areas character, CSS value for grid-template-areas
#' @param rows_height vector of character
#' @param cols_width vector of character
#'
#' @return character
#' @details This is a helper function used in grid_template()
#' \preformatted{
#' grid_container_css(
#' "'a a a' 'b b b'",
#' c("50\%", "50\%"),
#' c("100px", "2fr", "1fr")
#' )
#' }
#' returns
#' \preformatted{
#' "display: grid;
#' height: 100\%;
#' grid-template-rows: 50\% 50\%;
#' grid-template-columns: 100px 2fr 1fr;
#' grid-template-areas: 'a a a' 'b b b';
#' {{ custom_style_grid_container }}"
#' }
#'
#' @keywords internal
grid_container_css <- function(css_grid_template_areas, rows_height, cols_width) {
grid_container_styles <- c(
"display: grid",
"height: 100%",
glue::glue("grid-template-rows: {paste(rows_height, collapse = ' ')}"),
glue::glue("grid-template-columns: {paste(cols_width, collapse = ' ')}"),
glue::glue("grid-template-areas: {css_grid_template_areas}"),
"{{ custom_style_grid_container }}" # To be rendered by htmltools::htmlTemplate() later
)
paste(grid_container_styles, collapse = "; ")
}
#' Generate list of HTML div elements representing grid areas.
#'
#' @param area_names vector with area names
#'
#' @return list of \code{shiny::tags$div}
#'
#' @details This is a helper function used in grid_template()
#' \preformatted{
#' list_of_area_tags(c("header", "main", "footer"))
#' }
#' returns the following list:
#' \preformatted{
#' [[1]] <div id="{{ grid_id }}-header" style="grid-area: header; {{ header_custom_css }}">{{ header }}</div>
#' [[2]] <div id="{{ grid_id }}-main" style="grid-area: main; {{ main_custom_css }}">{{ main }}</div>
#' [[3]] <div id="{{ grid_id }}-footer" style="grid-area: footer; {{ footer_custom_css }}">{{ footer }}</div>
#' }
#'
#' @keywords internal
list_of_area_tags <- function(area_names) {
lapply(area_names,
function(name) {
mustache_id <- "{{ grid_id }}"
mustache_css <- paste0("{{ ", name, "_custom_css }}")
mustache_area <- paste("{{", name, "}}")
return(HTML(
glue::glue('<div id="{mustache_id}-{name}" style="grid-area: {name}; {mustache_css}">{mustache_area}</div>')
))
}
)
}
#' Define a template of a CSS grid
#'
#' @param default (required)
#' Template for desktop:
#' list(areas = [data.frame of character],
#' rows_height = [vector of character],
#' cols_width = [vector of character])
#' @param mobile (optional)
#' Template for mobile (screen width below 768px):
#' list(areas = [data.frame of character],
#' rows_height = [vector of character],
#' cols_width = [vector of character])
#'
#' @return
#' list(template = [character], area_names = [vector of character])
#'
#' template - contains template that can be parsed by htmlTemplate() function
#'
#' area_names - contains all unique area names used in grid definition
#'
#' @examples
#' myGrid <- grid_template(
#' default = list(
#' areas = rbind(
#' c("header", "header", "header"),
#' c("menu", "main", "right1"),
#' c("menu", "main", "right2")
#' ),
#' rows_height = c("50px", "auto", "100px"),
#' cols_width = c("100px", "2fr", "1fr")
#' ),
#' mobile = list(
#' areas = rbind(
#' "header",
#' "menu",
#' "main",
#' "right1",
#' "right2"
#' ),
#' rows_height = c("50px", "50px", "auto", "150px", "150px"),
#' cols_width = c("100%")
#' )
#' )
#' if (interactive()) display_grid(myGrid)
#' subGrid <- grid_template(default = list(
#' areas = rbind(
#' c("top_left", "top_right"),
#' c("bottom_left", "bottom_right")
#' ),
#' rows_height = c("50%", "50%"),
#' cols_width = c("50%", "50%")
#' ))
#'
#' if (interactive()) display_grid(subGrid)
#' @export
grid_template <- function(default = NULL, mobile = NULL) {
if (!("areas" %in% names(default))) {
stop(paste("grid_template() default argument must contain list with `areas` definition.",
"See documentation for examples."))
}
area_names <- default$areas %>% as.vector %>% unique
area_tags <- shiny::tagList(list_of_area_tags(area_names))
css_grid_template_areas <- data_frame_to_css_grid_template_areas(default$areas)
css_default <- shiny::tags$style(paste(
"#{{ grid_id }} {",
grid_container_css(css_grid_template_areas, default$rows_height, default$cols_width),
"}"
))
css_mobile <- NULL
if (!is.null(mobile)) {
if (!("areas" %in% names(mobile))) {
stop(paste("grid_template() mobile argument must contain list with `areas` definition.",
"See documentation for examples."))
}
css_grid_template_areas <- data_frame_to_css_grid_template_areas(mobile$areas)
css_mobile <- shiny::tags$style(paste(
"@media screen and (max-width: 768px) {",
"#{{ grid_id }} {",
grid_container_css(css_grid_template_areas, mobile$rows_height, mobile$cols_width),
"}",
"}"
))
}
template <- shiny::tagList(
css_default,
css_mobile,
shiny::tags$div(id = "{{ grid_id }}", area_tags)
) %>% htmltools::renderTags()
return(list(template = template$html, area_names = area_names))
}
#' Use CSS grid template in Shiny UI
#'
#' @param grid_template grid template created with grid_template() function
#' @param id id of grid
#' @param container_style character - string of custom CSS for the main grid container
#' @param area_styles list of custom CSS styles for provided area names
#' @param display_mode replaces areas HTML content with <area name> text. Used by display_grid() function
#' @param ... areas HTML content provided by named arguments
#'
#' @return Rendered HTML ready to use by Shiny UI. See \code{htmltools::htmlTemplate()} for more details.
#'
#' @details
#' Grids can be nested.
#'
#' @importFrom stats setNames
#'
#' @examples
#' myGrid <- grid_template(default = list(
#' areas = rbind(
#' c("header", "header", "header"),
#' c("menu", "main", "right1"),
#' c("menu", "main", "right2")
#' ),
#' rows_height = c("50px", "auto", "100px"),
#' cols_width = c("100px", "2fr", "1fr")
#' ))
#'
#' subGrid <- grid_template(default = list(
#' areas = rbind(
#' c("top_left", "top_right"),
#' c("bottom_left", "bottom_right")
#' ),
#' rows_height = c("50%", "50%"),
#' cols_width = c("50%", "50%")
#' ))
#'
#' if (interactive()){
#' library(shiny)
#' library(shiny.semantic)
#' shinyApp(
#' ui = semanticPage(
#' grid(myGrid,
#' container_style = "border: 1px solid #f00",
#' area_styles = list(header = "background: #0099f9",
#' menu = "border-right: 1px solid #0099f9"),
#' header = div(shiny::tags$h1("Hello CSS Grid!")),
#' menu = checkbox_input("example", "Check me", is_marked = FALSE),
#' main = grid(subGrid,
#' top_left = calendar("my_calendar"),
#' top_right = div("hello 1"),
#' bottom_left = div("hello 2"),
#' bottom_right = div("hello 3")
#' ),
#' right1 = div(
#' toggle("toggle", "let's toggle"),
#' multiple_checkbox("mycheckbox", "mycheckbox",
#' c("option A","option B","option C"))),
#' right2 = div("right 2")
#' )
#' ),
#' server = shinyServer(function(input, output) {})
#' )
#' }
#' @export
grid <- function(grid_template, id = paste(sample(letters, 5), collapse = ''),
container_style = "", area_styles = list(), display_mode = FALSE, ...) {
if (display_mode) {
# For debugging mode just display area name
template_values <- as.list(setNames(grid_template$area_names, grid_template$area_names))
} else {
template_values <- list(...)
}
template_values$grid_id <- id
template_values$custom_style_grid_container <- container_style
for (name in grid_template$area_names) {
key <- glue::glue("{name}_custom_css")
template_values[[key]] <- ifelse(name %in% names(area_styles), area_styles[[name]], "")
}
do.call(function(...) htmltools::htmlTemplate(text_ = grid_template$template, ...), template_values)
}
#' Display grid template in a browser for easy debugging
#'
#' @param grid_template generated by grid_template() function
#' @details
#' Opens a browser and displays grid template with styled border to highlight existing areas.
#'
#' Warning: CSS can't be displayed in RStudio viewer pane. CSS grid is supported only by modern browsers.
#' You can see list of supported browsers here: https://www.w3schools.com/css/css_grid.asp
#' @importFrom stats setNames
#' @importFrom grDevices rainbow
#' @export
display_grid <- function(grid_template) {
# Apply style for debugging
n <- length(grid_template$area_names)
styles <- lapply(
rainbow(n), # Pick rainbow colors and then change opacity to 44
function(color) glue::glue(
"border: 1px dotted #888;",
"font-size: 2em;",
"padding: 20px;",
"background: {substr(color, 1, 7)}44"
)
) %>% unlist
area_styles <- as.list(setNames(styles, grid_template$area_names))
shiny::runApp(list(
ui = semanticPage(
grid(
grid_template,
container_style = "border: 1px dashed #000",
area_styles = area_styles,
display_mode = TRUE
)
),
server = function(input, output) {}
),
launch.browser = T
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.