refactor default colour selection

R/core.R

@@ -179,7 +179,7 @@ as.character.emphatic <- function(x, ..., mode = 'ansi') {
   # Build full options by combining global and local options
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   opt <- attr(x, 'options', exact = TRUE) %||% list()
-  opt <- modifyList(hl_opts(), opt)
+  opt <- modify_list(hl_opts(), opt)
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # format the data as character matrix
@@ -567,7 +567,6 @@ calc_contrasting_text <- function(fill, text_contrast, dark_mode) {
   # i.e. this will use the default console colouring
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   if (text_contrast == 1) {
-    # retain original colours
     contrast_colour[fill_not_set] <- ''
   }
 

R/hl-diff.R

@@ -1,6 +1,4 @@
 
-
-
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 #' Colour the differences between character representations of objects
 #'
@@ -13,13 +11,15 @@
 #'
 #' @param x,y each argument is a single string. vectors of strings not currently
 #'        supported.
-#' @param bg,fg named list of colours for substitutions, insertions and
+#' @param fill named list of colours for substitutions, insertions and
 #'        deletions with names 'sub', 'ins' and 'del'.  If set to NULL (the
-#'        default) then colours will be chosen automatically depending on the
-#'        \code{dark_mode} argument
+#'        default) then default colours will be used.
+#' @param text named list of colours for the text for 'sub', 'ins' and 'del'
+#'        operations. If \code{NULL}, then colours which contrast with \code{fill} will
+#'        be chosen automatically
 #' @param ... further arguments passed to \code{adist()}
 #' @inheritParams coerce_to_string
-#' @param sep what to output on the line separating the two objects. Default: NULL
+#' @param sep character string of the  line separating the two objects. Default: \code{NULL}
 #'        for no separation. Use the empty string to insert an empty line.
 #' @inheritParams hl_grep
 #'
@@ -32,43 +32,51 @@
 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 hl_diff <- function(x, y,
                     coerce = "default",
-                    bg = NULL, fg = NULL,
-                    opts = hl_opts(),
-                    sep = NULL,
+                    fill   = NULL,
+                    text   = NULL,
+                    opts   = hl_opts(),
+                    sep   = NULL,
                     ...) {
 
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Default colours
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  fill_default_dark  <- list(sub = 'dodgerblue' , ins = 'darkgreen', del = 'firebrick' )
+  fill_default_light <- list(sub = 'dodgerblue1', ins = 'darkgreen', del = 'firebrick3')
 
-  if (is.null(bg)) {
-    if (opts$dark_mode) {
-      bg <- list(sub = 'dodgerblue', ins = 'darkgreen', del = 'firebrick')
-    } else {
-      bg <- list(sub = 'dodgerblue1', ins = 'darkgreen', del = 'firebrick3')
-    }
+  text_default_dark  <- list(sub = 'white', ins = 'white', del = 'white')
+  text_default_light <- list(sub = 'black', ins = 'black', del = 'black')
+
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Work hard to ensure we have a full complement of colours for both
+  # 'fill' and 'text'.  and 'text' colours are chosen as contrasting if
+  # they are not specified
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  if (opts$dark_mode) {
+    fill <- modify_list(fill_default_dark, fill)
+  } else {
+    fill <- modify_list(fill_default_light, fill)
   }
-  if (is.null(fg)) {
-    if (opts$dark_mode) {
-      fg <- list(sub = 'white', ins = 'white', del = 'white')
-    } else {
-      fg <- list(sub = 'black', ins = 'black', del = 'black')
-    }
+
+  if (is.null(text)) {
+    text <- list(
+      sub = calc_contrasting_text(fill$sub, text_contrast = opts$text_contrast, dark_mode = opts$dark_mode),
+      ins = calc_contrasting_text(fill$ins, text_contrast = opts$text_contrast, dark_mode = opts$dark_mode),
+      del = calc_contrasting_text(fill$del, text_contrast = opts$text_contrast, dark_mode = opts$dark_mode)
+    )
+  }
+
+  if (opts$dark_mode) {
+    text <- modify_list(text_default_dark, text)
+  } else {
+    text <- modify_list(text_default_light, text)
   }
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Coerce
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  # if (!is.character(x)) {
-    x <- coerce_to_string(x, coerce)
-  # } else {
-  #   x <- capture.output(x)
-  #   x <- paste(x, collapse = "\n")
-  # }
-
-  # if (!is.character(y)) {
-    y <- coerce_to_string(y, coerce)
-  # } else {
-  #   y <- capture.output(y)
-  #   y <- paste(y, collapse = "\n")
-  # }
+  x <- coerce_to_string(x, coerce)
+  y <- coerce_to_string(y, coerce)
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Sanity check
@@ -90,7 +98,6 @@ hl_diff <- function(x, y,
   lev <- attr(lev, 'trafos')[1]
   lev <- strsplit(lev, '')[[1]]
 
-
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Adjust input strings to account for deletions and insertions
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -134,25 +141,35 @@ hl_diff <- function(x, y,
   ybits <- ifelse(xcr2, paste0(ybits, "\n"), ybits)
 
 
-
-  rl <- base::rle(lev)
-  N  <- length(rl$values)
-  end <- cumsum(rl$lengths)
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Find the beginning and end of each run of the same edit
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  rl    <- base::rle(lev)
+  N     <- length(rl$values)
+  end   <- cumsum(rl$lengths)
   begin <- c(0, head(end, -1) + 1)
 
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Break apart string into these "same edit operation" chunks
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   xv <- character(N)
   yv <- character(N)
   for (i in seq(N)) {
     xv[i] <- paste(xbits[begin[i]:end[i]], collapse = "")
     yv[i] <- paste(ybits[begin[i]:end[i]], collapse = "")
   }
 
-  xtext <- c(S = fg$sub, I = fg$ins, D = fg$del, M = NA)[rl$values]
-  xfill <- c(S = bg$sub, I = bg$ins, D = bg$del, M = NA)[rl$values]
-  ytext <- c(S = fg$sub, I = fg$ins, D = fg$del, M = NA)[rl$values]
-  yfill <- c(S = bg$sub, I = bg$ins, D = bg$del, M = NA)[rl$values]
-
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Construct a vector of colours for each chunk
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  xtext <- c(S = text$sub, I = text$ins, D = text$del, M = NA)[rl$values]
+  xfill <- c(S = fill$sub, I = fill$ins, D = fill$del, M = NA)[rl$values]
+  ytext <- c(S = text$sub, I = text$ins, D = text$del, M = NA)[rl$values]
+  yfill <- c(S = fill$sub, I = fill$ins, D = fill$del, M = NA)[rl$values]
 
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Create the 'emphatic' object
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   if (is.null(sep)) {
     structure(
       list(
@@ -176,26 +193,3 @@ hl_diff <- function(x, y,
 
 }
 
-
-if (FALSE) {
-  x <- "abcdx"
-  y <- "abcd\nef"
-  lev <- utils::adist(x, y, counts = TRUE)
-  hl_diff(x, y)
-
-  coerce = "default"
-  bg = NULL
-  fg = NULL
-  opts = hl_opts()
-
-  hl_diff(head(mtcars, 2), head(mtcars, 3), sep = " ")
-
-
-  x <- "hi\nhi aa"
-  y <- "hi\nhi bb"
-  lev <- utils::adist(x, y, counts = TRUE)
-  hl_diff(x, y, sep = "----------------")
-}
-
-
-

R/hl-grep.R

@@ -12,6 +12,10 @@
 #'
 #' @param x character string
 #' @param pattern regular expression string. Note: don't get too fancy here
+#' @param fill solid colour for background.  If \code{NULL} (the default),
+#'        then a colour will be selected based upon \code{opts$dark_mode}
+#' @param text text colour. If \code{NULL} (the default), then a colour
+#'        will be seleted which contrasts with the \code{fill} colour.
 #' @param ... extra args passed to \code{gsub}
 #' @param perl logical. use perl style regex. default: TRUE
 #' @inheritParams coerce_to_string
@@ -25,36 +29,50 @@ hl_grep <- function(x,
                     pattern,
                     coerce = "default",
                     opts = hl_opts(),
-                    fg = NULL,
-                    bg = NULL,
+                    fill = NULL,
+                    text = NULL,
                     ..., perl = TRUE) {
 
-  x <- coerce_to_string(x, coerce)
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Choose colours
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  if (is.null(fill)) {
+    fill <- ifelse(opts$dark_mode, "#f0e60f", "#0F19F0")
+  }
+  if (is.null(text)) {
+    text <- calc_contrasting_text(
+      fill,
+      text_contrast = opts$text_contrast,
+      dark_mode = opts$dark_mode
+    )
+  }
 
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Coerge to string
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  x <- coerce_to_string(x, coerce)
   if (length(x) > 1) {
     x <- deparse(x)
   }
 
-  if (is.null(fg)) {
-    fg <- ifelse(opts$dark_mode, "black", "yellow")
-  }
-  if (is.null(bg)) {
-    bg <- ifelse(opts$dark_mode, "yellow", "black")
-  }
-
-
-  # matches <- gregexpr(pattern, x)[[1]]
-  matches <- gregexpr(pattern, x, ..., perl = perl)[[1]]
-  matches
-
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Where are the matches? Where do they start and finish?
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  matches      <- gregexpr(pattern, x, ..., perl = perl)[[1]]
   match_starts <- matches; attributes(match_starts) <- NULL
   match_ends   <- match_starts + attr(matches, "match.length") - 1
 
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # Early exit if there are no matches for this string
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   if (match_starts[1] == -1) {
     return(x) # no matches found
   }
 
-  # add some fake matches outside the string.
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  # add some dummy matches outside the string to make the logic for
+  # colouring easier
+  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   match_starts <- c(-Inf, match_starts, nchar(x) + 1)
   match_ends   <- c(   0, match_ends  , Inf)
 
@@ -71,8 +89,8 @@ hl_grep <- function(x,
   }
 
   # Drop the first segment which is known to be out of bounds
-  starts <- starts[-1] # tail(starts, -1)
-  ends   <- ends  [-1] # tail(ends  , -1)
+  starts <- starts[-1]
+  ends   <- ends  [-1]
 
   # Drop any redundant segments
   keep   <- ends >= starts
@@ -92,16 +110,16 @@ hl_grep <- function(x,
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Determine text colour and fill for each segment
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  text <- ifelse(is_match, fg, NA_character_)
-  fill <- ifelse(is_match, bg, NA_character_)
+  text_grep <- ifelse(is_match, text, NA_character_)
+  fill_grep <- ifelse(is_match, fill, NA_character_)
 
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   # Build emphatic structure:  raw vector + text + fill
   #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   res <- structure(
     bits,
     class = c('emphatic', 'compact'),
-    text = t(as.matrix(text)), fill = t(as.matrix(fill))
+    text = t(as.matrix(text_grep)), fill = t(as.matrix(fill_grep))
   )
 
   attr(res, 'options') <- opts

R/utils.R

@@ -99,6 +99,23 @@ coerce_to_string <- function(x, coerce) {
 }
 
 
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#' Update a list
+#'
+#' @param current,new current list and new list. 'new' may be NULL
+#'
+#' @return updated list
+#' @noRd
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+modify_list <- function (current, new) {
+
+  for (i in names(new)) {
+    current[[i]] <- new[[i]]
+  }
+
+  current
+}
+
 
 if (FALSE) {
   chunked_indices(4, 6)