add latex support. first draft

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: emphatic
 Type: Package
 Title: Exploration of Data.Frames, Matrices using ANSI Colouring
-Version: 0.1.6.9002
+Version: 0.1.6.9003
 Author: mikefc
 Maintainer: mikefc <[email protected]>
 Description: Colour data.frame, matrix and vector output in the console.

NAMESPACE

@@ -4,6 +4,7 @@ S3method(as.character,emphatic)
 S3method(print,emphatic)
 export(as_emphatic)
 export(as_html)
+export(as_latex)
 export(as_svg)
 export(hl)
 export(hl_adjust)

NEWS.md

@@ -1,12 +1,14 @@
 
-# emphatic 0.1.6.9002  2024-04-28
+# emphatic 0.1.6.9003  2024-04-28
 
 * Removed `hl_mat()` and associated vignettes.
     * function is not exported for now as the selection process is too 
       difficult to describe well. Needs a rethink
 * Refactored colour handling for `hl_grep()` and `hl_diff()`
 * Settled on `text`/`fill` nomenclature
 * Refactored arguments to `hl()` for more clarity
+* Added latex output so Quarto/Rmd will show emphatic objects when 
+  rendered to PDF
 
 # emphatic 0.1.6  2024-04-27
 

R/core-latex.R

@@ -0,0 +1,75 @@
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Convert R colours to hex colours
+#'
+#' @param colours Character vector of R colours
+#'
+#' @return Character vector of 6-char hex colours
+#'
+#' @noRd
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+col2hex_latex <- function(colours) {
+
+  colours <- grDevices::col2rgb(colours)
+  colours <- structure(sprintf("%02X", colours), dim = dim(colours))
+  colours <- apply(colours, 2, paste0, collapse = '')
+
+  colours
+}
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Convert a vector of colours to opening latex code for background colour
+#'
+#' @param colours Chcaracter vector of R colours
+#'
+#' @return Character vector of latex opening span tags
+#'
+#' @noRd
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+col2fill_latex <- function(colours) {
+  no_colour <- is.na(colours) | colours == ''
+  colours[no_colour] <- NA
+  colours <- col2hex_latex(colours)
+
+  ifelse(
+    no_colour,
+    "{",
+    paste0("\\colorbox[HTML]{", colours, "}{")
+  )
+
+}
+
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Convert a vector of colours to opening latex code for text colour
+#'
+#' @param colours Chcaracter vector of R colours
+#'
+#' @return Character vector of latex opening span tags
+#'
+#' @noRd
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+col2text_latex <- function(colours) {
+  no_colour <- is.na(colours) | colours == ''
+  colours[no_colour] <- NA
+  colours <- col2hex_latex(colours)
+
+  ifelse(
+    no_colour,
+    "{",
+    paste0("\\textcolor[HTML]{", colours, "}{")
+  )
+
+}
+
+reset_latex         <- "\\vrule height 3mm depth 1.25mm width 0mm}}"
+underline_on_latex  <- r"(\underline{)"
+underline_off_latex <- "}"
+
+# res <- r"(\texttt{
+# \colorbox{BurntOrange}{\textcolor[HTML]{AFFE90}{hello  }}\colorbox[HTML]{AFFE90}{\textcolor{blue}{there}}
+# })"
+
+

R/core.R

@@ -150,13 +150,15 @@ as.character.emphatic <- function(x, ..., mode = 'ansi') {
     strs <- vapply(x, as.character, character(1), ..., mode = mode)
     if (mode == 'ansi') {
       return (paste(strs, collapse = "\n"))
-    } else {
+    } else if (mode == 'html') {
       return (paste(strs, collapse = "<br/>"))
+    } else if (mode == 'latex') {
+      return (paste(strs, collapse = "\\\\\n"))
     }
   }
 
 
-  stopifnot(mode %in% c('ansi', 'html'))
+  stopifnot(mode %in% c('ansi', 'html', 'latex'))
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Remove the 'emphatic' class here, so that if any subsequent operations
@@ -292,7 +294,10 @@ as_character_inner <- function(m,
   stopifnot(is.character(m))
   stopifnot((is_atomic(m) && length(m) == length(text)) || identical(dim(m), dim(text)))
   stopifnot((is_atomic(m) && length(m) == length(fill)) || identical(dim(m), dim(fill)))
-  stopifnot(mode %in% c('ansi', 'html'))
+  stopifnot(mode %in% c('ansi', 'html', 'latex'))
+
+  collapser <- "\n"
+  if (mode == 'latex') collapser <- '\\\\\n'
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Automatic contrasting text for foreground?
@@ -315,9 +320,11 @@ as_character_inner <- function(m,
   # text and fill attributes to the terminal default
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   if (mode == 'ansi') {
-    end <- matrix(reset_ansi, nrow = nrow(m), ncol = ncol(m))
+    end <- matrix(reset_ansi , nrow = nrow(m), ncol = ncol(m))
   } else if (mode == 'html') {
-    end <- matrix(reset_html, nrow = nrow(m), ncol = ncol(m))
+    end <- matrix(reset_html , nrow = nrow(m), ncol = ncol(m))
+  } else if (mode == 'latex') {
+    end <- matrix(reset_latex, nrow = nrow(m), ncol = ncol(m))
   }
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -334,6 +341,9 @@ as_character_inner <- function(m,
   } else if (mode == 'html') {
     text[] <- col2text_html(text)
     fill[] <- col2fill_html(fill)
+  } else if (mode == 'latex') {
+    text[] <- col2text_latex(text)
+    fill[] <- col2fill_latex(fill)
   }
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -360,6 +370,7 @@ as_character_inner <- function(m,
   if (has_col_names) {
     for (i in seq_along(col_widths)) {
       width <- col_widths[i]
+      # if (mode == 'latex') width <- width - 1
       fmt   <- sprintf(" %%%is", width)
       m[,i] <- sprintf(fmt, m[,i])
       fmt   <- sprintf("%%%is", width)
@@ -374,6 +385,10 @@ as_character_inner <- function(m,
     att <- attributes(m)
     m <- escape_html(m)
     attributes(m) <- att
+  } else if (mode == 'latex') {
+    att <- attributes(m)
+    m <- escape_latex(m)
+    attributes(m) <- att
   }
 
   ansi_mat <- paste0(text, fill, m, end)
@@ -440,28 +455,31 @@ as_character_inner <- function(m,
     }
 
     if (!compact) {
-      res <- paste(res, collapse = "\n")
+      res <- paste(res, collapse = collapser)
     } else {
       res <- paste0(res, collapse = '')
     }
   } else {
 
-
     if (!is.null(rownames(m)) && !is.null(colnames(m))) {
       this_rownames <- rownames(m)
       max_nchar     <- max(nchar(this_rownames))
       fmt           <- paste0("%-", max_nchar + 1, "s ")
+      this_rownames <- sprintf(fmt, this_rownames)
       if (mode == 'html') {
         this_rownames <- escape_html(this_rownames)
+      } else if (mode == 'latex') {
+        this_rownames <- escape_latex(this_rownames)
       }
-      this_rownames <- sprintf(fmt, this_rownames)
       ansi_mat      <- cbind(this_rownames, ansi_mat)
       col_names     <- c(sprintf(fmt, ''), col_names)
     } else {
+      if (mode == 'latex') {
+        rownames(m) <- escape_latex(rownames(m))
+      }
       col_names <- c('', col_names)
     }
 
-
     #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     # Assemble single text string
     #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -475,13 +493,16 @@ as_character_inner <- function(m,
         } else if (mode == 'html') {
           header <- escape_html(header)
           header <- paste0(underline_on_html, header, underline_off_html)
+        } else if (mode == 'latex') {
+          header <- escape_latex(header)
+          header <- paste0(underline_on_latex, header, underline_off_latex)
         }
       }
     }
 
     body   <- apply(ansi_mat, 1, paste, collapse = '')
-    res    <- paste(c(header, body), collapse = "\n")
-    res    <- paste0(res, "\n")
+    res    <- paste(c(header, body), collapse = collapser)
+    res    <- paste0(res, collapser)
   }
 
 
@@ -507,7 +528,7 @@ as_character_inner <- function(m,
       legend_texts <- c('', legend_texts)
     }
 
-    res <- paste(c(res, legend_texts), collapse = "\n")
+    res <- paste(c(res, legend_texts), collapse = collapser)
   }
 
 

R/knitr.R

@@ -34,6 +34,29 @@ as_html <- function(x, style = NULL, ..., complete = FALSE) {
 }
 
 
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Render an emphatic object to Latex
+#'
+#' @param x emphatic object
+#' @param ... other arguments passed to \code{as.character.emphatic}
+#'
+#' @export
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+as_latex <- function(x, ...) {
+
+  res <- paste0(
+    "\\setlength{\\fboxsep}{0pt}\n",
+    "\\texttt{",
+    as.character(x, ..., mode = 'latex'),
+    "}"
+  )
+
+  class(res) <- unique(c('knit_asis', class(res)))
+
+  res
+}
+
+
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Automatically output emphatic objects to HTML knitted documents.
 #'
@@ -42,7 +65,13 @@ as_html <- function(x, style = NULL, ..., complete = FALSE) {
 #' @export
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 knit_print.emphatic <- function(x, style = NULL, ...) {
-  as_html(x, style = style, ...)
+
+  if (requireNamespace('knitr', quietly = TRUE) && knitr::is_latex_output()) {
+    as_latex(x, ...)
+  } else {
+    as_html(x, style = style, ...)
+  }
+
 }
 
 

R/utils.R

@@ -138,3 +138,20 @@ escape_html <- function(x) {
   Encoding(x) <- 'UTF-8'
   x
 }
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+# Escape latex
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+escape_latex <- function (x, newlines = FALSE, spaces = TRUE) {
+  x = gsub("\\\\", "\\\\textbackslash", x)
+  x = gsub("([#$%&_{}])", "\\\\\\1", x)
+  x = gsub("\\\\textbackslash", "\\\\textbackslash{}", x)
+  x = gsub("~", "\\\\textasciitilde{}", x)
+  x = gsub("\\^", "\\\\textasciicircum{}", x)
+  if (newlines)
+    x = gsub("(?<!\n)\n(?!\n)", "\\\\\\\\", x, perl = TRUE)
+  if (spaces)
+    x = gsub("(?<= ) ", "\\\\ ", x, perl = TRUE)
+  x
+}

R/zzz.R

@@ -7,9 +7,9 @@
 # without having knitr as a dependency for this package
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 register_s3_method <- function(pkg, generic, class, fun = NULL) {
-  stopifnot(is.character(pkg), length(pkg) == 1)
+  stopifnot(is.character(pkg)    , length(pkg) == 1)
   stopifnot(is.character(generic), length(generic) == 1)
-  stopifnot(is.character(class), length(class) == 1)
+  stopifnot(is.character(class)  , length(class) == 1)
 
   if (is.null(fun)) {
     fun <- get(paste0(generic, ".", class), envir = parent.frame())

README.Rmd

@@ -129,7 +129,7 @@ highlighting you need step by step
 
 ```{r eval = FALSE}
 mtcars |>
-  head(15) %>%
+  head(15) |>
   hl(
     palette     = ggplot2::scale_colour_viridis_c(),
     cols        = mpg,      # Where the colour scale is calculated
@@ -142,7 +142,7 @@ mtcars |>
 
 ```{r echo = FALSE}
 mtcars |>
-  head(15) %>%
+  head(15) |>
   hl(
     palette     = ggplot2::scale_colour_viridis_c(),
     cols        = mpg,      # Where the colour scale is calculated

README.md

@@ -68,7 +68,7 @@ highlighting you need step by step
 
 ``` r
 mtcars |>
-  head(15) %>%
+  head(15) |>
   hl(
     palette     = ggplot2::scale_colour_viridis_c(),
     cols        = mpg,      # Where the colour scale is calculated