Nothing
#
# _ _ _ _ _
# (_) | | | | | | | |
# _ __ ___ _ _ __ | |_ | |__ | | __ _ _ __ | | __
# | '_ \ / _ \ | || '_ \ | __|| '_ \ | | / _` || '_ \ | |/ /
# | |_) || (_) || || | | || |_ | |_) || || (_| || | | || <
# | .__/ \___/ |_||_| |_| \__||_.__/ |_| \__,_||_| |_||_|\_\
# | |
# |_|
#
# This file is part of the 'rich-iannone/pointblank' package.
#
# (c) Richard Iannone <riannone@me.com>
#
# For full copyright and license information, please look at
# https://rich-iannone.github.io/pointblank/LICENSE.html
#
#' Get a table information report from an *informant* object
#'
#' @description
#' We can get a table information report from an informant object that's
#' generated by the [create_informant()] function. The report is provided as a
#' **gt** based display table. The amount of information shown depends on the
#' extent of that added via the use of the `info_*()` functions or through
#' direct editing of a **pointblank** YAML file (an informant can be written
#' to **pointblank** YAML with `yaml_write(informant = <informant>, ...)`).
#'
#' @param informant An informant object of class `ptblank_informant`.
#' @param size The size of the display table, which can be either `"standard"`
#' (the default, with a width of 875px), `"small"` (width of 575px), or, a
#' pixel- or percent-based width of your choosing (supply an integer value for
#' the width in pixels, or values with `"px"` or `"%"` appended, like `"75%"`,
#' `"500px"`, etc.).
#' @param title Options for customizing the title of the report. The default is
#' the keyword `":default:"` which produces generic title text that refers to
#' the **pointblank** package in the language governed by the `lang` option.
#' Another keyword option is `":tbl_name:"`, and that presents the name of the
#' table as the title for the report. If no title is wanted, then the
#' `":none:"` keyword option can be used. Aside from keyword options, text can
#' be provided for the title and `glue::glue()` calls can be used to construct
#' the text string. If providing text, it will be interpreted as Markdown text
#' and transformed internally to HTML. To circumvent such a transformation,
#' use text in [I()] to explicitly state that the supplied text should not be
#' transformed.
#' @param lang The language to use for the *information report*.
#' By default, `NULL` will create English (`"en"`) text. Other options include
#' French (`"fr"`), German (`"de"`), Italian (`"it"`), Spanish (`"es"`),
#' Portuguese (`"pt"`), Turkish (`"tr"`), Chinese (`"zh"`), Russian (`"ru"`),
#' Polish (`"pl"`), Danish (`"da"`), Swedish (`"sv"`), and Dutch (`"nl"`).
#' This `lang` option will override any previously set language setting (e.g.,
#' by the [create_informant()] call).
#' @param locale An optional locale ID to use for formatting values in the
#' *information report* summary table according the locale's rules. Examples
#' include `"en_US"` for English (United States) and `"fr_FR"` for French
#' (France); more simply, this can be a language identifier without a country
#' designation, like `"es"` for Spanish (Spain, same as `"es_ES"`). This
#' `locale` option will override any previously set locale value (e.g., by the
#' [create_informant()] call).
#'
#' @return A **gt** table object.
#'
#' @examples
#' # Generate an informant object using
#' # the `small_table` dataset
#' informant <- create_informant(small_table)
#'
#' # This function creates some information
#' # without any extra help by profiling
#' # the supplied table object; it adds
#' # the sections 'table' and columns' and
#' # we can print the object to see the
#' # table information report
#'
#' # Alternatively, we can get the same report
#' # by using `get_informant_report()`
#' report <- get_informant_report(informant)
#' class(report)
#'
#' @family Incorporate and Report
#' @section Function ID:
#' 7-2
#'
#' @export
get_informant_report <- function(
informant,
size = "standard",
title = ":default:",
lang = NULL,
locale = NULL
) {
# nocov start
time_start <- Sys.time()
if (is.null(lang)) {
lang <- informant$lang
if (is.null(locale)) locale <- informant$locale
} else {
normalize_reporting_language(lang = lang)
# Set the `locale` to the `lang` value if `locale` isn't set
if (is.null(locale)) locale <- lang
}
if ("metadata_rev" %in% names(informant)) {
y <- informant$metadata_rev
} else {
y <- informant$metadata
}
if ("info_label" %in% names(informant)) {
info_label <- informant[["info_label"]]
} else {
info_label <- paste0("[", gsub(" ", "|", strftime(Sys.time())), "]")
}
info_label <- make_info_label_html(info_label = info_label)
meta_columns <- NULL
meta_rows <- NULL
y_names <- names(y)
priority_items <- c("table", "columns")
names_ordered <-
sort(base::intersect(y_names, priority_items), decreasing = TRUE)
names_others <- base::setdiff(y_names, priority_items)
y <- y[c(names_ordered, names_others)]
# Create empty table
tbl <- dplyr::tibble(group = character(0), item = character(0))
if ("table" %in% y_names) {
section <- y[["table"]]
section_names <- names(section)
if ("name" %in% section_names ||
"_type" %in% section_names ||
"type" %in% section_names) {
if ("type" %in% section_names || "_type" %in% section_names) {
if ("_type" %in% section_names) tbl_src <- section[["_type"]]
if ("type" %in% section_names) tbl_src <- section[["type"]]
} else {
tbl_src <- NA_character_
}
if ("name" %in% section_names) {
tbl_name <- section[["name"]]
} else {
tbl_name <- NA_character_
}
table_type_html <-
create_table_type_html(
tbl_src = tbl_src,
tbl_name = tbl_name
)
# Remove `name`, `type`, and `_type` from `section_names`
section_names <-
section_names[!(section_names %in% c("name", "type", "_type"))]
} else {
table_type_html <- ""
}
if ("columns" %in% section_names) {
meta_columns <- as.numeric(section[["columns"]][1])
}
if ("_columns" %in% section_names) {
meta_columns <- as.numeric(section[["_columns"]][1])
}
if ("rows" %in% section_names) {
meta_rows <- as.numeric(section[["rows"]][1])
}
if ("_rows" %in% section_names) {
meta_rows <- as.numeric(section[["_rows"]][1])
}
section_names <-
section_names[
!(section_names %in% c("columns", "_columns", "rows", "_rows"))
]
if (length(section_names) > 0) {
for (s_name in section_names) {
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(section[s_name], elements = "vertical"),
group = "Table"
)
}
}
} else {
table_type_html <- ""
}
if ("columns" %in% y_names) {
section <- y[["columns"]]
column_names <- names(section)
if (length(column_names) > 0) {
for (column in column_names) {
col_meta <- section[[column]]
col_meta_names <- names(col_meta)
miniheader_vec <- c()
if (inherits(col_meta, "character")) {
list_item <-
list(
a = paste0(
"<strong class=\"pb_sub_label\">INFO</strong> ",
unlist(col_meta)
)
)
names(list_item) <- column
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(
item = list_item,
elements = "vertical",
title_code = TRUE
),
group = "Columns"
)
} else {
if ("_type" %in% col_meta_names ||
"type" %in% col_meta_names) {
col_type_vec <- c("type", "_type", "sql_type", "_sql_type")
col_type <- NULL
if ("_type" %in% col_meta_names) {
col_type <- col_meta[["_type"]][1]
}
if ("type" %in% col_meta_names) {
col_type <- col_meta[["type"]][1]
}
if ("_sql_type" %in% col_meta_names ||
"sql_type" %in% col_meta_names) {
if ("_sql_type" %in% col_meta_names) {
sql_col_type <- col_meta[["_sql_type"]][1]
}
if ("sql_type" %in% col_meta_names) {
sql_col_type <- col_meta[["sql_type"]][1]
}
# Fashion the `col_type` text to show the SQL
# column type (LHS) and then the column type in R (RHS)
col_type <-
paste(
sql_col_type,
htmltools::tags$span(
style = htmltools::css(
`font-family` = "initial",
`font-size` = "large"
),
htmltools::HTML("→")
) %>%
as.character(),
col_type
)
}
col_meta <- col_meta[!(col_meta_names %in% col_type_vec)]
miniheader_vec <- c(miniheader_vec, col_type = col_type)
}
col_meta <-
lapply(col_meta, FUN = function(x) {
if (length(x) > 1) {
x <- paste0("\n", paste0("- ", x, "\n", collapse = ""))
}
x
})
list_item <-
list(
a = paste0(
"<strong class=\"pb_sub_label\">",
toupper(names(col_meta)),
"</strong> ", unlist(col_meta)
)
)
names(list_item) <- column
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(
item = list_item,
elements = "vertical",
title_code = TRUE
),
group = "Columns"
)
column_escaped <-
column %>%
gsub("(\\(|\\)|\\[|\\]|\\||\\.|\\^|\\?|\\+|\\$|\\*)", "\\\\\\1", .)
row_idx <-
which(grepl(paste0("^<code.*?>", column_escaped, "<.*?"), tbl$item))
if (length(miniheader_vec) > 0) {
tbl$item[[row_idx]] <-
gsub(
"(^.*?</code>)(.*)",
paste0(
"\\1 <code class=\"pb_col_type\">",
miniheader_vec, "</code>\\2"
),
tbl$item[[row_idx]]
)
}
}
}
}
}
# Modify `tbl` so that `group` values correspond to the set `lang`
tbl <-
tbl %>%
dplyr::mutate(group = dplyr::case_when(
group == "Table" ~ get_lsv(text = c(
"informant_report", "pointblank_table_text"
))[[lang]],
group == "Columns" ~ get_lsv(text = c(
"table_scan", "tbl_lab_columns"
))[[lang]],
TRUE ~ group
))
if (length(names_others) > 0) {
for (o_name in names_others) {
o_section <- y[[o_name]]
section_names <- names(o_section)
if (is.null(section_names) &&
is.character(o_section) &&
length(o_section) > 0) {
list_item <-
list(
a = paste0("- ", unlist(o_section))
)
names(list_item) <- o_name
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(
item = list_item,
elements = "vertical",
use_title = FALSE
),
group = o_name
)
}
for (section in section_names) {
section_meta <- o_section[section]
if (inherits(section_meta, "character")) {
list_item <-
list(
a = paste0("<strong>INFO</strong> ", unlist(section_meta))
)
names(list_item) <- column
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(
item = list_item,
elements = "vertical",
title_code = TRUE
),
group = o_name
)
} else {
tbl <-
add_to_tbl(
tbl = tbl,
item = title_text_md(
item = section_meta,
elements = "vertical",
use_title = TRUE
),
group = o_name
)
}
}
}
}
# Generate table dimensions HTML
table_dims <-
make_table_dims_html(
columns = meta_columns,
rows = meta_rows,
lang = lang,
locale = locale
)
# Combine label, table type, and table dimensions into
# a table subtitle <div>
combined_subtitle <-
htmltools::tagList(
htmltools::HTML(info_label),
htmltools::tags$div(
style = htmltools::css(
height = "25px",
`margin-top` = "10px"
),
htmltools::HTML(paste0(table_type_html, table_dims))
)
) %>% as.character()
time_end <- Sys.time()
# Generate table execution start/end time (and duration)
# as a table source note
# TODO: Add outer div with top and bottom margins set (3px and 5px), then,
# the `#pb_information .gt_sourcenote` CSS can be removed
table_time <-
create_table_time_html(
time_start = time_start,
time_end = time_end,
size = size,
locale = locale
)
# Generate the report title with the `title` option
title_text <-
process_title_text(
title = title,
tbl_name = tbl_name,
report_type = "informant",
lang = lang
)
# Generate a gt table
gt_informant_report <-
gt::gt(
tbl,
groupname_col = "group",
id = "pb_information"
) %>%
gt::tab_header(
title = title_text,
subtitle = gt::md(combined_subtitle)
) %>%
gt::tab_source_note(source_note = gt::md(table_time)) %>%
gt::fmt_markdown(columns = "item") %>%
gt::tab_options(
column_labels.hidden = TRUE
) %>%
gt::tab_style(
style = gt::cell_text(
size = gt::px(28),
weight = 500,
align = "left",
color = "#444444"
),
locations = gt::cells_title("title")
) %>%
gt::tab_style(
style = gt::cell_text(
size = gt::px(12),
align = "left"
),
locations = gt::cells_title("subtitle")
) %>%
gt::tab_style(
style = list(
gt::cell_text(
color = "#444444",
weight = 500,
transform = "uppercase"
),
gt::cell_fill(color = "#FCFCFC"),
gt::cell_borders(
sides = "bottom",
color = "#EFEFEF",
weight = 1
)
),
locations = gt::cells_row_groups(groups = TRUE)
) %>%
gt::tab_style(
style = list(
gt::cell_text(
color = "#666666",
size = "smaller"
),
gt::cell_borders(
sides = "top",
style = "solid",
color = "#EFEFEF",
weight = 1
)
),
locations = gt::cells_body(columns = gt::everything())
)
if (size == "small") {
gt_informant_report <-
gt_informant_report %>%
gt::cols_width(gt::everything() ~ gt::px(575))
}
if (size != "small") {
if (size == "standard") {
width_px <- 650
} else {
width_px <- size
}
gt_informant_report <-
gt_informant_report %>%
gt::tab_options(
table.width = width_px,
table.font.size = gt::pct(130)
) %>%
gt::opt_table_font(font = gt::google_font("IBM Plex Sans")) %>%
gt::opt_css(
css = "
#pb_information {
-webkit-font-smoothing: antialiased;
letter-spacing: .15px;
}
#pb_information a {
color: #375F84;
text-decoration: none;
}
#pb_information a:hover {
color: #375F84;
text-decoration: underline;
}
#pb_information p {
overflow: visible;
margin-top: 2px;
margin-left: 0;
margin-right: 0;
margin-bottom: 5px;
}
#pb_information ul {
list-style-type: square;
padding-left: 25px;
margin-top: -4px;
margin-bottom: 6px;
}
#pb_information li {
text-indent: -1px;
}
#pb_information h4 {
font-weight: 500;
color: #444444;
}
#pb_information code {
font-family: 'IBM Plex Mono', monospace, courier;
font-size: 90%;
font-weight: 500;
color: #666666;
background-color: transparent;
padding: 0;
}
#pb_information .pb_date {
text-decoration-style: solid;
text-decoration-color: #9933CC;
text-decoration-line: underline;
text-underline-position: under;
font-variant-numeric: tabular-nums;
margin-right: 4px;
}
#pb_information .pb_label {
border: solid 1px;
border-color: inherit;
padding: 0px 3px 0px 3px;
}
#pb_information .pb_label_rounded {
border: solid 1px;
border-color: inherit;
border-radius: 8px;
padding: 0px 8px 0px 8px;
}
#pb_information .pb_sub_label {
font-size: smaller;
color: #777777;
}
#pb_information .pb_col_type {
font-size: 75%;
}
#pb_information .gt_sourcenote {
height: 35px;
font-size: 60%;
padding: 0;
}
#pb_information .gt_group_heading {
text-indent: -3px;
}
"
)
}
class(gt_informant_report) <-
c("ptblank_informant_report", class(gt_informant_report))
# nocov end
gt_informant_report
}
add_to_tbl <- function(tbl, item, group) {
dplyr::bind_rows(tbl, dplyr::tibble(group = group, item = item))
}
# Process titles and text
title_text_md <- function(
item,
use_title = TRUE,
title_level = 4,
title_code = FALSE,
elements = "vertical"
) {
title <- names(item)
item <- unname(unlist(item))
# Process item with text transformers
for (i in seq_along(item)) {
# Dates are automatically set in the `pb_date` class if they can
# be parsed as ISO-8601 dates, and, if the date is enclosed in
# parentheses
if (grepl("\\([1-2][0-9][0-9][0-9]-[0-1][0-9]-[0-3][0-9]\\)", item[i])) {
for (j in 1:10) {
item[i] <-
gsub(
"(.*)\\(([1-2][0-9][0-9][0-9]-[0-1][0-9]-[0-3][0-9])\\)(.*)",
"\\1<span class=\"pb_date\">\\2</span>\\3",
item[i]
)
}
}
# Rounded labels are generated when there is text surrounded by `((( )))`
if (grepl("\\(\\(\\(.*?\\)\\)\\)", item[i])) {
for (j in 1:10) {
item[i] <-
gsub(
"(.*)\\(\\(\\((.*?)\\)\\)\\)(.*)",
"\\1<span class=\"pb_label_rounded\">\\2</span>\\3",
item[i]
)
}
}
# Square labels are generated when there is text surrounded by `(( ))`
if (grepl("\\(\\(.*?\\)\\)", item[i])) {
for (j in 1:10) {
item[i] <-
gsub(
"(.*)\\(\\((.*?)\\)\\)(.*)",
"\\1<span class=\"pb_label\">\\2</span>\\3",
item[i]
)
}
}
# Constructions with style and class declarations when there is
# text in this form: `[[ text ]]<< classes, styles >>`
if (grepl("\\[\\[.*?\\]\\](\\n?)<<.*?>>", item[i])) {
# Strip any `\n` characters
item[i] <- item[i] %>% gsub("\\n", "", .)
for (j in 1:10) {
text_content <-
item[i] %>%
gsub("(.*)(\\[\\[.*?\\]\\]<<.*?>>)(.*)", "\\2", .) %>%
gsub("\\[\\[(.*?)\\]\\]<<(.*?)>>", "\\1", .)
replace_within_anchor_chars <- function(x, left, right, what, repl) {
re <-
paste0(
"(?:\\G(?!^)|", left, ")[^",
right, "]*?\\K", what, "(?=[^",
right, "]*", right, ")"
)
gsub(re, repl, x, perl = TRUE)
}
tag_content <-
item[i] %>%
gsub("(.*)(\\[\\[.*?\\]\\]<<.*?>>)(.*)", "\\2", .) %>%
gsub("\\[\\[(.*?)\\]\\]<<(.*?)>>", "\\2", .) %>%
gsub(":\\s+?", ":", .) %>%
gsub(";\\s+?", ";", .) %>%
replace_within_anchor_chars(
left = ":", right = ";", what = "\\s+", repl = " ") %>%
strsplit(" ")
id_values <-
vapply(
tag_content,
USE.NAMES = FALSE,
FUN.VALUE = character(1),
FUN = function(x) {
if (all(!grepl("^\\#", x))) {
return("")
}
paste0(
"id=\"",
paste(x[grepl("^\\#", x)], collapse = " "),
"\""
)
}
)
class_values <-
vapply(
tag_content,
USE.NAMES = FALSE,
FUN.VALUE = character(1),
FUN = function(x) {
if (all(!grepl("^\\.", x))) {
return("")
}
paste0(
"class=\"",
paste(x[grepl("^\\.", x)], collapse = " "),
"\""
)
}
)
style_values <-
vapply(
tag_content,
USE.NAMES = FALSE,
FUN.VALUE = character(1),
FUN = function(x) {
if (all(!(grepl(":", x) & grepl(";$", x)))) {
return("")
}
styles_idx <- which(grepl(":", x) & grepl(";$", x))
paste0(
"style=\"",
paste(gsub(" ", " ", x[styles_idx]), collapse = " "),
"\""
)
}
)
item[i] <-
gsub(
"(.*)(\\[\\[.*?\\]\\]<<.*?>>)(.*)",
paste0(
"\\1<",
paste(
"span", id_values, class_values, style_values, collapse = " "
),
">", text_content, "</span>\\3"
),
item[i]
)
}
}
}
if (elements == "vertical") {
item <- paste(item, collapse = "\n\n")
if (use_title) {
if (!title_code) {
title <- gsub("_", " ", toupper(title))
}
item <-
paste0(
"<",
ifelse(title_code, "code", "h"),
ifelse(title_code, "", as.character(title_level)), " ",
"style=\"margin-bottom:5px;",
ifelse(
title_code,
paste0(
"color:#555555;font-weight:500;line-height:2em;",
"border:solid 1px #499FFE;",
"padding:2px 8px 3px 8px;background-color:#FAFAFA;"
),
""
),
"\">",
title, "</", ifelse(title_code, "code", "h"),
ifelse(title_code, "", as.character(title_level)), ">\n\n",
item
)
}
} else if (elements == "horizontal") {
item <- paste(item, collapse = " — ")
if (use_title) {
if (!title_code) {
title <- gsub("_", " ", toupper(title))
}
item <-
paste0(
"<span style=\"font-size:1.17em;font-weight:bold;\">",
ifelse(
title_code,
"<code style=\"font-weight:bold;margin-bottom:2px;\">",
""
),
title,
ifelse(title_code, "</code>", ""),
"</span> ",
item
)
}
}
item
}
make_info_label_html <- function(info_label) {
htmltools::tags$span(
info_label,
style = htmltools::css(
`text-decoration-style` = "solid",
`text-decoration-color` = "#ADD8E6",
`text-decoration-line` = "underline",
`text-underline-position` = "under",
color = "#333333",
`font-variant-numeric` = "tabular-nums",
`padding-left` = "4px",
`margin-right` = "5px",
`padding-right` = "2px"
)
) %>% as.character()
}
make_table_dims_html <- function(
columns = NULL,
rows = NULL,
lang = NULL,
locale = NULL
) {
if (is.null(columns) && is.null(rows)) {
return("")
}
columns <- columns %||% "—"
if (is.null(columns)) {
columns <- "—"
} else {
columns <- pb_fmt_number(columns, decimals = 0, locale = locale)
}
if (is.null(rows)) {
rows <- "—"
} else {
rows <- pb_fmt_number(rows, decimals = 0, locale = locale)
}
as.character(
htmltools::tagList(
htmltools::tags$span(
style = htmltools::css(
`background-color` = "#eecbff",
color = "#333333",
padding = "0.5em 0.5em",
position = "inherit",
`text-transform` = "uppercase",
margin = "5px 0px 5px 5px",
`font-weight` = "bold",
border = paste0("solid 1px #eecbff"),
padding = "2px 15px 2px 15px",
`font-size` = "smaller"
),
get_lsv("table_scan/tbl_lab_rows")[[lang]]
),
htmltools::tags$span(
style = htmltools::css(
`background-color` = "none",
color = "#333333",
padding = "0.5em 0.5em",
position = "inherit",
margin = "5px 0px 5px -4px",
`font-weight` = "bold",
border = paste0("solid 1px #eecbff"),
padding = "2px 15px 2px 15px",
`font-size` = "smaller"
),
htmltools::HTML(rows)
),
htmltools::tags$span(
style = htmltools::css(
`background-color` = "#BDE7B4",
color = "#333333",
padding = "0.5em 0.5em",
position = "inherit",
`text-transform` = "uppercase",
margin = "5px 0px 5px 1px",
`font-weight` = "bold",
border = paste0("solid 1px #BDE7B4"),
padding = "2px 15px 2px 15px",
`font-size` = "smaller"
),
get_lsv("table_scan/tbl_lab_columns")[[lang]]
),
htmltools::tags$span(
style = htmltools::css(
`background-color` = "none",
color = "#333333",
padding = "0.5em 0.5em",
position = "inherit",
margin = "5px 0px 5px -4px",
`font-weight` = "bold",
border = paste0("solid 1px #BDE7B4"),
padding = "2px 15px 2px 15px",
`font-size` = "smaller"
),
htmltools::HTML(columns)
)
)
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.