# Initialize an HTML object with whichever
# `type`, `mode`, or `text` is required
#' @importFrom dplyr tibble
initialize_object <- function(x,
type,
mode,
level,
text) {
list(
stmts = dplyr::tibble(
type = type,
mode = mode,
level = level,
text = text))
}
# Get the tag name from the calling function
#' @importFrom stringr str_extract
get_tag_name <- function() {
calling_fcn <- deparse(sys.call(-1))
(calling_fcn %>% stringr::str_extract(pattern = "[a-z]*"))[1]
}
# Create a table based on an input list; this
# is to detect whether there is the main data
# object somewhere in the list
#' @importFrom purrr map_df
#' @importFrom dplyr tibble
#' @importFrom rlang has_name
get_input_component_tbl <- function(input_list) {
seq(input_list) %>%
purrr::map_df(
.f = function(x) {
dplyr::tibble(
list_item = x,
is_object = ifelse(
inherits(input_list[x], "list") &
input_list[[x]] %>% rlang::has_name(name = "stmts"),
TRUE, FALSE))})
}
# Get a count of input components in the
# table returned by `get_input_components()`
count_input_components <- function(component_tbl) {
nrow(component_tbl)
}
# Determine whether the input components contains
# an HTML object as the first item
#' @importFrom dplyr pull
is_object_in_input_x <- function(component_tbl) {
if (nrow(component_tbl) < 1) return(FALSE)
(component_tbl %>%
dplyr::pull(is_object))[1]
}
# Determine whether the input components contain
# an HTML object as the second item
#' @importFrom dplyr pull
is_object_in_input_y <- function(component_tbl) {
if (nrow(component_tbl) < 2) return(FALSE)
(component_tbl %>%
dplyr::pull(is_object))[2]
}
# Get a count of all input components
#' @importFrom dplyr filter
count_input_objects <- function(component_tbl) {
if (nrow(component_tbl) < 1) return(0)
component_tbl %>%
dplyr::filter(is_object) %>%
nrow()
}
# Get a list with information on the
# input components
get_input_component_list <- function(input_list) {
input_component_tbl <- get_input_component_tbl(input_list)
input_component_count <- count_input_components(input_component_tbl)
input_contains_obj_x <- is_object_in_input_x(input_component_tbl)
input_contains_obj_y <- is_object_in_input_y(input_component_tbl)
input_object_count <- count_input_objects(input_component_tbl)
list(
input_component_tbl = input_component_tbl,
input_component_count = input_component_count,
input_contains_obj_x = input_contains_obj_x,
input_contains_obj_y = input_contains_obj_y,
input_object_count = input_object_count)
}
# Strip away tags of the provided name
#' @importFrom stringr str_replace_all
#' @importFrom glue glue
strip_outer_tags <- function(text, to_strip) {
text %>%
stringr::str_replace_all(
pattern = glue::glue("(<{to_strip}>|</{to_strip}>)"),
replacement = "")
}
# Remove trailing linebreaks from a character vector
#' @importFrom stringr str_replace
remove_trailing_linebreaks <- function(text) {
text %>%
stringr::str_replace(
pattern = "\n$",
replacement = "")
}
# Are any components of the input list element attributes?
#' @importFrom rlang have_name
has_attr_components <- function(input_list) {
if (length(input_list) == 0) return(FALSE)
any(rlang::have_name(input_list[seq(length(input_list))]))
}
# Are any components of the input list entirely textual?
#' @importFrom rlang have_name
has_text_components <- function(input_list) {
if (length(input_list) == 0) return(FALSE)
are_text_components <- vector(mode = "logical")
for (i in seq(length(input_list))) {
are_text_components <-
c(are_text_components,
!rlang::have_name(input_list[i]) &
inherits(input_list[[i]], "character"))
}
any(are_text_components)
}
# Extract attribute components from an input list
#' @importFrom rlang is_named
#' @importFrom glue glue
get_attr_components <- function(input_list) {
html_attrs <- vector(mode = "character")
for (i in seq(length(input_list))) {
if (rlang::is_named(input_list[i])) {
html_attrs <-
c(html_attrs,
glue::glue("{names(input_list[i])}=\"{unname(input_list[i])}\"") %>%
as.character())
}
}
html_attrs
}
# Extract textual components from an input list
#' @importFrom rlang have_name
get_text_components <- function(input_list) {
are_text_components <- vector(mode = "logical")
for (i in seq(length(input_list))) {
are_text_components <-
c(are_text_components,
!rlang::have_name(input_list[i]) &
inherits(input_list[[i]], "character"))
}
input_list[which(are_text_components)] %>%
as.character()
}
# Extract the input HTML object that resides
# as the first item in the input component list
get_object_in_input_x <- function(input_list) {
input_list[[1]]
}
# Extract the input HTML object that resides
# as the second item in the input component list
get_object_in_input_y <- function(input_list) {
input_list[[2]]
}
# Generate a generic statement
generate_stmt <- function(attr_name, attr_value = NULL) {
if (!is.null(attr_value)) {
stmt <- paste0(attr_name, "=\"", as.character(attr_value[1]), "\"")
} else {
stmt <- ""
}
stmt
}
# Generate an `id` statement
generate_id_stmt <- function(id = NULL) {
if (!is.null(id)) {
id_statement <- paste0("id=\"", id[1], "\"")
} else {
id_statement <- ""
}
id_statement
}
# Generate a `class` statement
generate_class_stmt <- function(class = NULL) {
if (!is.null(class)) {
class_statement <- paste0("class=\"", paste(class, collapse = " "), "\"")
} else {
class_statement <- ""
}
class_statement
}
# Collect all attr statements (whichever they may
# be for a given tag) and generate a clean string
# to insert in the opening tag
#' @importFrom rlang squash_chr
collect_all_attrs <- function(...) {
list(...) %>%
rlang::squash_chr() %>%
paste(collapse = " ") %>%
trimws()
}
# Create an opening tag from a predefined type
# and an attribute string
#' @importFrom glue glue
create_opening_tag <- function(type, attrs_str) {
if (attrs_str != "" & attrs_str != " ") {
glue::glue("<{type} {attrs_str}>") %>%
as.character() %>% trimws()
} else {
glue::glue("<{type}>") %>% as.character()
}
}
# Create a closing tag from a predefined type
#' @importFrom glue glue
create_closing_tag <- function(type) {
glue::glue("</{type}>") %>% as.character()
}
# Generate a complete HTML element with opening and
# closing tags, and, the content
#' @importFrom glue glue
create_html_element <- function(opening_tag,
closing_tag = NULL,
content = NULL) {
if (is.null(closing_tag)) closing_tag <- ""
if (is.null(content)) content <- ""
glue::glue("{opening_tag}{content}{closing_tag}") %>%
as.character()
}
# Wrap text in tags and optionally strip away
# existing tags
#' @importFrom glue glue
wrap_in_tags <- function(text, tag, strip = NULL) {
if (!is.null(strip)) {
text <-
text %>%
strip_outer_tags(to_strip = strip)
}
glue::glue("<{tag}>{text}</{tag}>") %>%
as.character()
}
# With an input list, extract components with
# index greater than the `start` value and
# create a character vector from those
get_list_items_as_char <- function(input_list, start = 2) {
input_list[start:length(input_list)] %>%
as.character()
}
# Construct HTML using the HTML object
#' @importFrom dplyr mutate select pull
#' @importFrom stringr str_pad
#' @importFrom tibble add_row
generate_html_lines <- function(x) {
x$stmts %>%
tibble::add_row(
type = "body",
mode = "close",
level = 1L,
text = "</body>") %>%
tibble::add_row(
type = "html",
mode = "close",
level = 0L,
text = "</html>") %>%
dplyr::mutate(
text = stringr::str_pad(
string = text,
side = "left",
width = nchar(text) + (2 * level))) %>%
dplyr::select(text) %>%
dplyr::pull(text) %>%
paste(collapse = "\n")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.