tidy and docs

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: emphatic
 Type: Package
 Title: Highlight R Output
-Version: 0.1.6.9013
+Version: 0.1.6.9014
 Author: mikefc
 Maintainer: mikefc <[email protected]>
 Description: User-defined colour highlighting of data.frames and other R output. 
@@ -19,6 +19,7 @@ Suggests:
     dplyr,
     ggplot2,
     tidyr,
+    purrr,
     testthat,
     openxlsx
 VignetteBuilder: knitr

NEWS.md

@@ -1,5 +1,5 @@
 
-# emphatic 0.1.6.9013  2024-05-05
+# emphatic 0.1.6.9014  2024-05-26
 
 * Removed `hl_mat()` and associated vignettes.
     * function is not exported for now as the selection process is too 

R/core-html.R

@@ -168,10 +168,13 @@ as_html <- function(x, ..., font_size = NULL, style = list(), complete = FALSE,
 #' @return None
 #' @export
 #' @examples
-#' # Will try and spawn a viewer for content
+#' \dontrun{
+#' # This example will try and spawn an external viewer for HTML content
+#' # and is thus marked as 'dontrun' so it does not get executed on CRAN
 #' hl_grep(mode, "switch") |>
 #'   as_html() |>
 #'   show_html()
+#' }
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 show_html <- function(x, viewer = getOption("viewer", utils::browseURL)) {
 

R/core-svg.R

@@ -49,7 +49,6 @@ as_svg <- function(x, width = 1200, height = 900, ..., font_size = NULL,
 
 
 
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Wrap an emphatic object to part of an SVG
 #'
@@ -81,7 +80,6 @@ as_svg_group <- function(x, width = 1200, height = 900, font_size = NULL,
 
 
   svg_text <- paste(
-    "",
     ifelse(visible, '<g visibility="visible">', '<g visibility="hidden">'),
     '<foreignObject width=\"100%\" height=\"100%\">',
     '<div xmlns=\"http://www.w3.org/1999/xhtml\">',
@@ -90,7 +88,6 @@ as_svg_group <- function(x, width = 1200, height = 900, font_size = NULL,
     "</foreignObject>",
     extra,
     "</g>",
-    "",
     sep = "\n"
   )
 
@@ -102,6 +99,7 @@ as_svg_group <- function(x, width = 1200, height = 900, font_size = NULL,
 }
 
 
+
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 # This helper function creates a \code{<set>} tag to do frame flipping
 # animation within an SVG
@@ -127,6 +125,7 @@ make_animate_tag <- function(i, n, dur = 1, playback, svg_id) {
 }
 
 
+
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Wrap multiple emphatic object into an SVG animation
 #'
@@ -226,97 +225,4 @@ as_svg_anim <- function(x, width = 1200, height = 900, duration = 1, playback =
   class(svg_text) <- union(c('knit_asis', 'html', 'character'), class(svg_text))
 
   svg_text
-}
-
-
-
-
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# Examples
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-if (FALSE) {
-  library(dplyr)
-  library(tidyr)
-  m <- matrix(0.1, 10, 10)
-
-  w <- 16
-  h <- 50
-
-  create_sinus <- function(xoff, yoff) {
-    expand.grid(x=1:w, y=1:h) |>
-      as.data.frame() |>
-      mutate(val = cos((x - w/2)/w + xoff) + sin((y - h/3)/h + yoff) ) |>
-      mutate(val = round(val, 3)) |>
-      spread(x, val) |>
-      select(-y) |>
-      setNames(sprintf("% 7i", seq(w))) |>
-      hl(ggplot2::scale_color_gradient2(), cols = all())
-  }
-
-
-  groups <- purrr::map2(
-    cos(seq(0, 2*pi , length.out = 60)),
-    sin(seq(-2*pi, 2*pi, length.out = 60)),
-    ~create_sinus(.x, .y)
-  )
-
-
-  as_svg_anim(groups, duration = 0.1, playback = 'click') |>
-    writeLines("~/Desktop/demo2.svg")
-
-  create_sinus(0.3, -1.2)
-
-  as_svg_anim(groups, duration = 0.1, playback = 'infinite', browsable = TRUE)
-
-
-  # write_xlsx(create_sinus(0.3, -0.7), "working/sinus.xlsx", opts = hl_opts(text_mode = 'contrast'))
-
-
-
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  # Consolel print output
-  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  library(emphatic)
-  library(dplyr)
-  library(tidyr)
-
-  w <- 16
-  h <- 50
-
-  create_sinus <- function(xoff, yoff) {
-    expand.grid(x=1:w, y=1:h) |>
-      as.data.frame() |>
-      mutate(val = cos((x - w/2)/w + xoff) + sin((y - h/3)/h + yoff) ) |>
-      mutate(val = round(val, 3)) |>
-      spread(x, val) |>
-      select(-y) |>
-      setNames(sprintf("% 7i", seq(w))) |>
-      hl(ggplot2::scale_color_gradient2(), cols = all())
-  }
-  groups <- purrr::map2(
-    cos(seq(0, 2*pi , length.out = 60)),
-    sin(seq(-2*pi, 2*pi, length.out = 60)),
-    function(x, y) {
-      # cat("\014")
-      create_sinus(x, y) |>
-        hl_adjust(full_colour = TRUE, text_mode = 'asis') |>
-        as.character() |>
-        cat()
-      Sys.sleep(0.1)
-    }
-  )
-
-
-
-
-
-
-
-
-
-
-
-
-
-
 }

R/core-xlsx.R

@@ -2,6 +2,8 @@
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Write an emphatic data.frame to an Excel workbook
 #'
+#' Requires \code{openxlsx} package
+#'
 #' @param x emphatic data.frame object
 #' @param xlsx_filename xlsx filename
 #' @param colNames Display column names? logical. Default: TRUE

R/core.R

@@ -17,7 +17,7 @@ escape <- list(
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 collapse = list(
   ansi  = "\n",
-  html  = "<br/>\n",
+  html  = "<br/>",
   latex = "\\\\\n",
   typst = "\\\n"
 )
@@ -342,7 +342,6 @@ as.character.emphatic <- function(x, ..., mode = 'ansi') {
 
 
 
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Private function for converting an emphatic data.frame or matrix to a string
 #'
@@ -589,7 +588,6 @@ as_character_inner <- function(m,
 
 
 
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Calculate a contrasting text colours for vector of fill colours
 #'
@@ -696,11 +694,3 @@ interp_colour <- function(colour1, colour2, frac) {
 
   rgb(m[,1], m[,2], m[,3])
 }
-
-
-
-
-
-
-
-

R/data-sets.R

@@ -8,8 +8,6 @@
 #'
 #' Sourced from a table in Tufte's "Visual and Statistical Thinking"
 #'
-#' @source \url{http://williamwolff.org/wp-content/uploads/2013/01/tufte-challenger-1997.pdf}
-#'
 #' @format A data.frame
 #' \describe{
 #'   \item{flight}{Flight number}
@@ -19,13 +17,6 @@
 #'   \item{damage}{Damage severity index}
 #'   \item{date}{Date of launch}
 #' }
-#'
-#' Other references:
-#'
-#' \itemize{
-#' \item{\url{http://williamwolff.org/wp-content/uploads/2013/01/tufte-challenger-1997.pdf}}
-#' \item{\url{https://archive.ics.uci.edu/dataset/92/challenger+usa+space+shuttle+o+ring}}
-#' }
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 "challenger"
 
@@ -36,7 +27,16 @@
 #' From the 'National Snow and Ice Data Center' \url{https://nsidc.org/data/g02135}
 #'
 #' @format Matrix of sea ice area, monthly from 1978 to 2020.
-#'
-#' @source  \url{ftp://sidads.colorado.edu/DATASETS/NOAA/G02135/south/monthly/data/}
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 "sea_ice_area"
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Monthly total rainfall in Centennial Park, Sydney, Australia
+#'
+#' From the Australian Bureau of Meteorology
+#'
+#' @format data.frame with each row representing a year, and each column
+#'         representing a month of that year
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+"sydney_rain"

R/hl-dataframe.R

@@ -310,17 +310,3 @@ hl <- function(.data, palette,
 
   .data
 }
-
-
-if (FALSE) {
-  mtcars |>
-    hl(ggplot2::scale_color_continuous(), cols = hp, show_legend = TRUE) |>
-    hl(ggplot2::scale_color_continuous(type = 'viridis'), cols = am, show_legend = TRUE) |>
-    hl(ggplot2::scale_color_gradient(low = 'hotpink', high = 'yellow'), cols = mpg, show_legend = TRUE)
-}
-
-
-
-
-
-

R/hl-grep.R

@@ -1,5 +1,4 @@
 
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Colour highlighting a regular expression search
 #'
@@ -124,10 +123,5 @@ hl_grep <- function(x,
   )
 
   attr(res, 'options') <- opts
-
-
   res
 }
-
-
-

R/hl-mat.R

@@ -1,6 +1,4 @@
 
-
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Highlight elements of a matrix or atomic vector
 #'
@@ -139,4 +137,3 @@ hl_mat <- function(.data, colour, selection = NULL, elem = 'fill',
 
   .data
 }
-

R/legend.R

@@ -1,7 +1,4 @@
 
-
-
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Create a single line legend
 #'
@@ -118,29 +115,3 @@ create_legend_string <- function(
 
   paste(ansi_vec, collapse = '')
 }
-
-
-if (FALSE) {
-
-  suppressPackageStartupMessages({
-    library(ggplot2)
-  })
-
-  scale <- scale_colour_viridis_c()
-  values <- runif(20)
-  scale$reset()
-  scale$train(values)
-
-  cat(create_legend_string(scale, values, label = "hello"), "\n")
-
-
-  scale  <- scale_colour_viridis_d()
-  values <- sample(c('alpha', 'beta', 'gam', 'epsilon'), 20, T)
-  scale$reset()
-  scale$train(values)
-
-  cat(create_legend_string(scale, values, label = 'cyl'), "\n")
-
-
-
-}

R/options.R

@@ -1,5 +1,4 @@
 
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Set options for printing on the emphatic matrix or data.frame
 #'
@@ -113,16 +112,10 @@ hl_opts <- function(na               = getOption("HL_NA", "NA"),
     text_contrast <= 1
   })
 
-
-
   list(
     na               = na,
     full_colour      = full_colour,
     text_mode        = text_mode,
     text_contrast    = text_contrast
   )
-
 }
-
-
-

R/utils-index-lookup.R

@@ -177,8 +177,5 @@ loc_expr_to_ids <- function(.data, expr, axis) {
     stop(axis, " specification must not contain NAs:", deparse(ids))
   }
 
-
   ids
 }
-
-