Incorporate the use of a units notation for inserting measurement units

.Rbuildignore

@@ -88,5 +88,6 @@ tests/testthat/test-text_transform.R
 tests/testthat/test-util_functions.R
 tests/testthat/test-utils_formatters.R
 tests/testthat/test-utils_render_html.R
+tests/testthat/test-utils_units.R
 tests/testthat/test-utils.R
 tests/testthat/test-vec_fmt.R

DESCRIPTION

@@ -137,6 +137,7 @@ Collate:
     'utils_render_latex.R'
     'utils_render_rtf.R'
     'utils_render_xml.R'
+    'utils_units.R'
     'z_utils_render_footnotes.R'
     'zzz.R'
 Config/testthat/edition: 3

NAMESPACE

@@ -40,12 +40,14 @@ export(cols_move)
 export(cols_move_to_end)
 export(cols_move_to_start)
 export(cols_unhide)
+export(cols_units)
 export(cols_width)
 export(contains)
 export(css)
 export(currency)
 export(data_color)
 export(default_fonts)
+export(define_units)
 export(ends_with)
 export(escape_latex)
 export(everything)
@@ -75,6 +77,7 @@ export(fmt_roman)
 export(fmt_scientific)
 export(fmt_spelled_num)
 export(fmt_time)
+export(fmt_units)
 export(fmt_url)
 export(ggplot_image)
 export(google_font)

R/data_color.R

@@ -675,7 +675,7 @@
 #'
 #' @family data formatting functions
 #' @section Function ID:
-#' 3-30
+#' 3-31
 #'
 #' @section Function Introduced:
 #' `v0.2.0.5` (March 31, 2020)

R/datasets.R

@@ -565,6 +565,146 @@
 #'
 "metro"
 
+#' The fundamental physical constants
+#'
+#' @description
+#'
+#' This dataset contains values for over 300 basic fundamental constants in
+#' nature. The values originate from the 2018 adjustment which is based on the
+#' latest relevant precision measurements and improvements of theoretical
+#' calculations. Such work has been carried out under the authority of the
+#' *Task Group on Fundamental Constants* (TGFC) of the
+#' *Committee on Data of the International Science Council* (CODATA). These
+#' updated values became available on May 20, 2019. They are published at
+#' <http://physics.nist.gov/constants>, a website of the
+#' *Fundamental Constants Data Center* of the
+#' *National Institute of Standards and Technology* (NIST), Gaithersburg,
+#' Maryland, USA.
+#'
+#' @format A tibble with 354 rows and 4 variables:
+#' \describe{
+#' \item{name}{The name of the constant.}
+#' \item{value}{The value of the constant.}
+#' \item{uncert}{The uncertainty associated with the value. If `NA` then the
+#' value is seen as an 'exact' value (e.g., an electron volt has the exact value
+#' of 1.602 176 634 e-19 J).}
+#' \item{units}{The units associated with the constant.}
+#' }
+#'
+#' @section Examples:
+#'
+#' Here is a glimpse at the data available in `constants`.
+#'
+#' ```{r}
+#' dplyr::glimpse(constants)
+#' ```
+#'
+#' @family datasets
+#' @section Dataset ID and Badge:
+#' DATA-9
+#'
+#' \if{html}{\out{
+#' `r data_get_image_tag(file = "dataset_constants.png")`
+#' }}
+#'
+#' @section Dataset Introduced:
+#' *In Development*
+#'
+"constants"
+
+#' Lab tests for one suffering from an illness
+#'
+#' @description
+#'
+#' A dataset with artificial daily lab data for a patient with Yellow Fever
+#' (YF). The table comprises laboratory findings for the patient from day 3 of
+#' illness onset until day 9 (after which the patient died). YF viral DNA was
+#' found in serum samples from day 3, where the viral load reached 14,000 copies
+#' per mL. Several medical interventions were taken to help the patient,
+#' including the administration of fresh frozen plasma, platelets, red cells,
+#' and coagulation factor VIII. The patient also received advanced support
+#' treatment in the form of mechanical ventilation and plasmapheresis. Though
+#' the patient's temperature remained stable during their illness,
+#' unfortunately, the patient's condition did not improve. On days 7 and 8, the
+#' patient's health declined further, with symptoms such as nosebleeds,
+#' gastrointestinal bleeding, and hematoma.
+#'
+#' @details
+#'
+#' The various tests are identified in the `test` column. The following listing
+#' provides full names for any of the abbreviations seen in that column.
+#'
+#' \itemize{
+#' \item `"WBC"`: white blood cells.
+#' \item `"RBC"`: red blood cells.
+#' \item `"Hb"`: hemoglobin.
+#' \item `"PLT"`: platelets.
+#' \item `"ALT"`: alanine aminotransferase.
+#' \item `"AST"`: aspartate aminotransferase.
+#' \item `"TBIL"`: total bilirubin.
+#' \item `"DBIL"`: direct bilirubin.
+#' \item `"NH3"`: hydrogen nitride.
+#' \item `"PT"`: prothrombin time.
+#' \item `"APTT"`: activated partial thromboplastin time.
+#' \item `"PTA"`: prothrombin time activity.
+#' \item `"DD"`: D-dimer.
+#' \item `"FDP"`: fibrinogen degradation products.
+#' \item `"LDH"`: lactate dehydrogenase.
+#' \item `"HBDH"`: hydroxybutyrate dehydrogenase.
+#' \item `"CK"`: creatine kinase.
+#' \item `"CKMB"`: the MB fraction of creatine kinase.
+#' \item `"BNP"`: B-type natriuetic peptide.
+#' \item `"MYO"`: myohemoglobin.
+#' \item `"TnI"`: troponin inhibitory.
+#' \item `"CREA"`: creatinine.
+#' \item `"BUN"`: blood urea nitrogen.
+#' \item `"AMY"`: amylase.
+#' \item `"LPS"`: lipase.
+#' \item `"K"`: kalium.
+#' \item `"Na"`: sodium.
+#' \item `"Cl"`: chlorine.
+#' \item `"Ca"`: calcium.
+#' \item `"P"`: phosphorus.
+#' \item `"Lac"`: lactate, blood.
+#' \item `"CRP"`: c-reactive protein.
+#' \item `"PCT"`: procalcitonin.
+#' \item `"IL-6"`: interleukin-6.
+#' \item `"CD3+CD4+"`: CD4+T lymphocytes.
+#' \item `"CD3+CD8+"`: CD8+T lymphocytes.
+#' }
+#'
+#' @format A tibble with 39 rows and 11 variables:
+#' \describe{
+#' \item{test}{The name of the test.}
+#' \item{units}{The measurement units for the test.}
+#' \item{day_3,day_4,day_5,day_6,day_7,day_8,day_9}{Measurement values
+#' associated with each test administered. If `NA` then the test either could
+#' not be performed properly.)}
+#' \item{norm_l,norm_u}{Lower and upper bounds for the normal range associated
+#' with the test.}
+#' }
+#'
+#' @section Examples:
+#'
+#' Here is a glimpse at the data available in `illness`.
+#'
+#' ```{r}
+#' dplyr::glimpse(illness)
+#' ```
+#'
+#' @family datasets
+#' @section Dataset ID and Badge:
+#' DATA-10
+#'
+#' \if{html}{\out{
+#' `r data_get_image_tag(file = "dataset_illness.png")`
+#' }}
+#'
+#' @section Dataset Introduced:
+#' *In Development*
+#'
+"illness"
+
 #' An ADSL-flavored clinical trial toy dataset
 #'
 #' @description
@@ -624,7 +764,7 @@
 #'
 #' @family datasets
 #' @section Dataset ID and Badge:
-#' DATA-9
+#' DATA-11
 #'
 #' \if{html}{\out{
 #' `r data_get_image_tag(file = "dataset_rx_adsl.png")`
@@ -697,7 +837,7 @@
 #'
 #' @family datasets
 #' @section Dataset ID and Badge:
-#' DATA-10
+#' DATA-12
 #'
 #' \if{html}{\out{
 #' `r data_get_image_tag(file = "dataset_rx_addv.png")`

R/dt_boxhead.R

@@ -55,22 +55,21 @@ dt_boxhead_init <- function(data) {
       # - `default` appears as a column with values below
       # - `stub` appears as part of a table stub, set to the left
       #   and styled differently
-      # - `row_group` uses values as categoricals and groups rows
+      # - `row_group` uses categorical values and groups rows
       #   under row group headings
       # - `hidden` hides this column from the final table render
       #   but retains values to use in expressions
       # - `hidden_at_px` similar to hidden but takes a list of
       #   screen widths (in px) whereby the column would be hidden
       type = "default",
-      # # The shared spanner label between columns, where column names
-      # # act as the keys
-      # spanner_label = empty_list,
-      # # The label for row groups, which is maintained as a list of
-      # # labels by render context (e.g., HTML, LaTeX, etc.)
-      # row_group_label = lapply(seq_along(names(data)), function(x) NULL),
       # The presentation label, which is a list of labels by
       # render context (e.g., HTML, LaTeX, etc.)
       column_label = as.list(column_labels),
+      # Units for the column label, written in a shorthand notation
+      column_units = NA_character_,
+      # A pattern to use when arranging the `column_label` and the
+      # `column_units`
+      column_pattern = NA_character_,
       # The alignment of the column ("left", "right", "center")
       column_align = "center",
       # The width of the column in `px`
@@ -113,6 +112,8 @@ dt_boxhead_add_var <- function(
     var,
     type,
     column_label = list(var),
+    column_units = NA_character_,
+    column_pattern = NA_character_,
     column_align = "left",
     column_width = list(NULL),
     hidden_px = list(NULL),
@@ -126,6 +127,8 @@ dt_boxhead_add_var <- function(
       var = var,
       type = type,
       column_label = column_label,
+      column_units = column_units,
+      column_pattern = column_pattern,
       column_align = column_align,
       column_width = column_width,
       hidden_px = hidden_px
@@ -189,6 +192,24 @@ dt_boxhead_edit_column_label <- function(data, var, column_label) {
   )
 }
 
+dt_boxhead_edit_column_units <- function(data, var, column_units) {
+
+  dt_boxhead_edit(
+    data = data,
+    var = var,
+    column_units = column_units
+  )
+}
+
+dt_boxhead_edit_column_pattern <- function(data, var, column_pattern) {
+
+  dt_boxhead_edit(
+    data = data,
+    var = var,
+    column_pattern = column_pattern
+  )
+}
+
 dt_boxhead_get_vars <- function(data) {
   dt_boxhead_get(data = data)$var
 }
@@ -263,7 +284,8 @@ dt_boxhead_get_alignment_by_var <- function(data, var) {
 check_names_dt_boxhead_expr <- function(expr) {
 
   if (!all(names(expr) %in% c(
-    "type", "column_label", "column_align", "column_width", "hidden_px"
+    "type", "column_label", "column_units", "column_pattern",
+    "column_align", "column_width", "hidden_px"
   ))) {
     cli::cli_abort("Expressions must use names available in `dt_boxhead`.")
   }
@@ -283,6 +305,54 @@ dt_boxhead_build <- function(data, context) {
   boxh$column_label <-
     lapply(boxh$column_label, function(label) process_text(label, context))
 
+  # Merge column units into column labels
+  if (!all(is.na(boxh$column_units))) {
+
+    for (i in seq_along(boxh$column_label)) {
+
+      if (is.na(boxh[["column_units"]][i])) next
+
+      column_label <- unlist(boxh[["column_label"]][i])
+
+      units <- boxh[["column_units"]][i]
+      column_pattern <- boxh[["column_pattern"]][i]
+
+      units_built <-
+        render_units(
+          define_units(units_notation = units),
+          context = context
+        )
+
+      if (column_pattern == "" && grepl(units, column_label, fixed = TRUE)) {
+
+        # With `column_pattern` equal to `""`, we can surmise that this was
+        # set automatically by `cols_label()`; the mechanism now is to replace
+        # the units text in the label with the 'built' units text
+
+        column_label <- gsub(units, units_built, column_label, fixed = TRUE)
+
+      } else {
+
+        if (is.na(column_pattern)) {
+
+          # Obtain the default `column_pattern` (which that is settable in the
+          # `column_labels.units_pattern` option of `tab_options()`
+          column_pattern <-
+            dt_options_get_value(
+              data = data,
+              option = "column_labels_units_pattern"
+            )
+        }
+
+        column_pattern <- gsub("{1}", column_label, column_pattern, fixed = TRUE)
+        column_pattern <- gsub("{2}", units_built, column_pattern, fixed = TRUE)
+        column_label <- column_pattern
+      }
+
+      boxh$column_label[i] <- list(column_label)
+    }
+  }
+
   dt_boxhead_set(data = data, boxh = boxh)
 }
 

R/dt_options.R

@@ -122,6 +122,7 @@ dt_options_tbl <-
     "column_labels_border_lr_width",      TRUE,  "column_labels",    "px",      "1px",
     "column_labels_border_lr_color",      TRUE,  "column_labels",    "value",   "#D3D3D3",
     "column_labels_hidden",              FALSE,  "column_labels",    "logical", FALSE,
+    "column_labels_units_pattern",       FALSE,  "column_labels",    "value",   "{1}, {2}",
     "row_group_background_color",         TRUE,  "row_group",        "value",   NA_character_,
     "row_group_font_size",                TRUE,  "row_group",        "px",      "100%",
     "row_group_font_weight",              TRUE,  "row_group",        "value",   "initial",