Feature: set_channel() sets or skips NA values

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: farver
 Title: High Performance Colour Space Manipulation
-Version: 2.1.1.9000
+Version: 2.1.1.9001
 Authors@R: c(
     person("Thomas Lin", "Pedersen", , "thomasp85@gmail.com", role = c("cre", "aut"),
            comment = c(ORCID = "0000-0002-5147-4711")),
@@ -27,6 +27,6 @@ Suggests:
     testthat (>= 3.0.0)
 Encoding: UTF-8
 Roxygen: list(markdown=TRUE)
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.1
 SystemRequirements: C++11
 Config/testthat/edition: 3

NAMESPACE

@@ -1,8 +1,10 @@
 # Generated by roxygen2: do not edit by hand
 
 export(add_to_channel)
+export(add_to_channel_native)
 export(as_white_ref)
 export(cap_channel)
+export(cap_channel_native)
 export(compare_colour)
 export(convert_colour)
 export(decode_colour)
@@ -11,6 +13,9 @@ export(encode_colour)
 export(encode_native)
 export(get_channel)
 export(multiply_channel)
+export(multiply_channel_native)
 export(raise_channel)
+export(raise_channel_native)
 export(set_channel)
+export(set_channel_native)
 useDynLib(farver, .registration = TRUE)

NEWS.md

@@ -1,5 +1,17 @@
 # farver (development version)
 
+* `encode_colour()` and `encode_native()` also accept a list of channel vectors.
+  If you compute your channels independently you don't need to `cbind()` them into
+  a contiguous matrix anymore, but rather you can `list()` them (#36, @zeehio).
+
+* `encode_native()` is faster now. It avoids going through an intermediate character
+  vector representation (#37, @zeehio).
+
+* `encode_colour()` and `encode_native()` accept a `na_value` argument to specify
+  a color that can be used as a fallback if the color to convert contains `NA`s
+  or it can not be represented in the RGB space. (#38, @zeehio)
+
+
 # farver 2.1.1
 
 * Added input checking to a range of functions to guard against segfaults with 

R/encode.R

@@ -6,7 +6,11 @@
 #' 
 #' @inheritSection convert_colour Handling of non-finite and out of bounds values
 #' 
-#' @inheritParams convert_colour
+#' @param colour A numeric matrix (or an object coercible to one) with colours 
+#' encoded in the rows and the different colour space values in the columns. For 
+#' all colourspaces except `'cmyk'` this will mean a matrix with three columns - 
+#' for `'cmyk'` it means four columns. Alternatively, `colour` may be a list of
+#' length three (or four for `'cmyk'`) numeric vectors of the same length.
 #' @param alpha A numeric vector between 0 and 1. Will be recycled to the number
 #' of rows in `colour`. If `NULL` or a single `NA` it will be ignored.
 #' @param from The input colour space. Allowed values are: `"cmy"`, 
@@ -17,6 +21,10 @@
 #' @param white The white reference of the input colour space. Will only have an 
 #' effect for relative colour spaces such as Lab and luv. Any value accepted by 
 #' [as_white_ref()] allowed.
+#' @param na_value A valid colour string or `NA` to use when `colour` contains
+#' `NA` elements or is invalid in the RGB space. The general approach in farver
+#' is to carry `NA` values over, but if you want to mimick [col2rgb()] you should
+#' set `na_value = 'transparent'`, i.e. treat `NA` as transparent white.
 #' 
 #' @return A character vector with colours encoded as `#RRGGBB(AA)`
 #' 
@@ -39,26 +47,55 @@
 #' spectrum_hcl <- convert_colour(spectrum, 'rgb', 'hcl')
 #' encode_colour(spectrum_hcl, from = 'hcl')
 #' 
-encode_colour <- function(colour, alpha = NULL, from = 'rgb', white = 'D65') {
+encode_colour <- function(colour, alpha = NULL, from = 'rgb', white = 'D65', na_value = NA_character_) {
   if (from != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_c(colour, alpha, colourspace_match(from), white)
+  encode_c(colour, alpha, colourspace_match(from), white, out_format = 1L, na_value)
 }
 
-encode_c <- function(colour, alpha, from, white) {
-  if (nrow(colour) == 0) {
+encode_c <- function(colour, alpha, from, white, out_format = 1L, na_value) {
+  # colour has zero colours:
+  if ((is.matrix(colour) || is.data.frame(colour)) && nrow(colour) == 0) {
     return(character())
   }
+  # Colour has zero colours (given as a list of channels)
+  if (is.list(colour) && (length(colour) == 0 || length(colour[[1]]) == 0)) {
+    return(character())
+  }
+  # Colour is neither a list or a matrix, so let's coerce it
+  if (!is.matrix(colour) && !is.list(colour)) {
+    colour <- as.matrix(colour)
+  }
+  # How many colours do we have?
+  if (is.matrix(colour)) {
+    num_colours <- nrow(colour)
+  } else {
+    num_colours <- length(colour[[1]])
+  }
+
   if (!is.null(alpha)) {
     alpha <- alpha * 255
     if (length(alpha) == 0) {
       alpha <- NULL
     } else if (length(alpha) != 1) {
-      alpha <- rep_len(alpha, nrow(colour))
+      alpha <- rep_len(alpha, num_colours)
     } else if (is.na(alpha) || alpha == 1) {
       alpha <- NULL
     }
   }
-  .Call(`farver_encode_c`, as.matrix(colour), alpha, as.integer(from), white)
+  out_format <- as.integer(out_format)
+  if (out_format != 1L && out_format != 2L) {
+    stop("out_format must be 1L (for character) or 2L (for native)")
+  }
+  if (length(na_value) == 0) {
+    na_value <- NA_character_
+  }
+  if (length(na_value) > 1) {
+    stop("na_value must be a string")
+  }
+  na_value <- as.character(na_value)
+
+  .Call(`farver_encode_c`, colour, alpha, as.integer(from), white, out_format, na_value)
 }
+

R/modify.R

@@ -1,11 +1,13 @@
 #' Modify colour space channels in hex-encoded colour strings
 #' 
 #' This set of functions allows you to modify colours as given by strings, 
-#' whithout first decoding them. For large vectors of colour values this should
-#' provide a considerable speedup.
+#' without first decoding them. For large vectors of colour values this should
+#' provide a considerable speedup. The corresponding `_native` functions provide
+#' the same feature on [native-encoding] colours.
 #' 
 #' @param colour A character string giving colours, either as hexadecimal 
-#' strings or accepted colour names. 
+#' strings or accepted colour names. The `_native` functions expect an integer
+#' vector, describing colours in [native-encoding] format.
 #' @param channel The channel to modify or extract as a single letter, or 
 #' `'alpha'` for the alpha channel.
 #' @param value The value to modify with
@@ -21,6 +23,10 @@
 #' `NA` elements. The general approach in farver is to carry `NA` values over,
 #' but if you want to mimick [col2rgb()] you should set 
 #' `na_value = 'transparent'`, i.e. treat `NA` as transparent white.
+#' @param skip_na_values By default (`skip_na_values = FALSE`), if `value` is `NA` the colour
+#' will be set to `NA`. If `skip_na_values` is `TRUE` and the `value` to modify with
+#' is `NA`, the colour won't be modified.
+#' 
 #' 
 #' @return A character vector of the same length as `colour` (or a numeric 
 #' vector in the case of `get_channel()`)
@@ -38,6 +44,11 @@
 #' set_channel(spectrum, 'l', 50, space = 'lab')
 #' set_channel(spectrum, 'alpha', c(0.5, 1))
 #' 
+#' # This returns NA, because the replacement value is NA
+#' set_channel("#FF0000", "r", NA)
+#' # This returns "red", because we skip modifications on NA values:
+#' set_channel("red", "r", NA, skip_na_values = TRUE)
+#' 
 #' # Add value to channel
 #' add_to_channel(spectrum, 'r', c(10, 50))
 #' add_to_channel(spectrum, 'l', 50, space = 'lab')
@@ -58,47 +69,47 @@ NULL
 
 #' @rdname manip_channel
 #' @export
-set_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) {
+set_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
   if (space != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_channel_c(colour, channel, value, space, 1L, white, na_value)
+  encode_channel_c(colour, channel, value, space, 1L, white, na_value, skip_na_values)
 }
 
 #' @rdname manip_channel
 #' @export
-add_to_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) {
+add_to_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
   if (space != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_channel_c(colour, channel, value, space, 2L, white, na_value)
+  encode_channel_c(colour, channel, value, space, 2L, white, na_value, skip_na_values)
 }
 
 #' @rdname manip_channel
 #' @export
-multiply_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) {
+multiply_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
   if (space != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_channel_c(colour, channel, value, space, 3L, white, na_value)
+  encode_channel_c(colour, channel, value, space, 3L, white, na_value, skip_na_values)
 }
 
 #' @rdname manip_channel
 #' @export
-raise_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) {
+raise_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
   if (space != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_channel_c(colour, channel, value, space, 4L, white, na_value)
+  encode_channel_c(colour, channel, value, space, 4L, white, na_value, skip_na_values)
 }
 
 #' @rdname manip_channel
 #' @export
-cap_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) {
+cap_channel <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
   if (space != 'rgb') {
     white <- as_white_ref(white)
   }
-  encode_channel_c(colour, channel, value, space, 5L, white, na_value)
+  encode_channel_c(colour, channel, value, space, 5L, white, na_value, skip_na_values)
 }
 
 #' @rdname manip_channel
@@ -110,13 +121,19 @@ get_channel <- function(colour, channel, space = 'rgb', white = 'D65', na_value
   decode_channel_c(colour, channel, space, white, na_value)
 }
 
-encode_channel_c <- function(colour, channel, value, space, op, white, na_value) {
+encode_channel_c <- function(colour, channel, value, space, op, white, na_value, skip_na_values) {
   if (length(colour) == 0) {
     return(colour)
   }
   if (length(value) == 0) {
     stop("`value` must not be empty", call. = FALSE)
   }
+  if (is.logical(value)) {
+    if (!all(is.na(value))) {
+      stop("`value` must be a numeric", call. = FALSE)
+    }
+    value <- NA_integer_
+  }
   if (length(value) != 1) value <- rep_len(value, length(colour))
   if (channel == 'alpha') {
     channel <- 0L
@@ -126,8 +143,8 @@ encode_channel_c <- function(colour, channel, value, space, op, white, na_value)
     channel <- colour_channel_index[[space]][channel]
     if (is.na(channel)) stop('Invalid channel for this colourspace', call. = FALSE)
   }
-
-  .Call(`farver_encode_channel_c`, as_colour_code(colour), as.integer(channel), value, as.integer(space), as.integer(op), white, as.character(na_value))
+  skip_na_values <- isTRUE(skip_na_values)
+  .Call(`farver_encode_channel_c`, as_colour_code(colour), as.integer(channel), value, as.integer(space), as.integer(op), white, as.character(na_value), skip_na_values)
 }
 
 decode_channel_c <- function(colour, channel, space, white, na_value) {

R/modify_native.R

@@ -0,0 +1,69 @@
+#' @rdname manip_channel
+#' @export
+set_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
+  if (space != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_channel_native_c(colour, channel, value, space, 1L, white, na_value, skip_na_values)
+}
+
+#' @rdname manip_channel
+#' @export
+add_to_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
+  if (space != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_channel_native_c(colour, channel, value, space, 2L, white, na_value, skip_na_values)
+}
+
+#' @rdname manip_channel
+#' @export
+multiply_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
+  if (space != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_channel_native_c(colour, channel, value, space, 3L, white, na_value, skip_na_values)
+}
+
+#' @rdname manip_channel
+#' @export
+raise_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
+  if (space != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_channel_native_c(colour, channel, value, space, 4L, white, na_value, skip_na_values)
+}
+
+#' @rdname manip_channel
+#' @export
+cap_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA, skip_na_values = FALSE) {
+  if (space != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_channel_native_c(colour, channel, value, space, 5L, white, na_value, skip_na_values)
+}
+
+encode_channel_native_c <- function(colour, channel, value, space, op, white, na_value, skip_na_values) {
+  if (length(colour) == 0) {
+    return(colour)
+  }
+  if (length(value) == 0) {
+    stop("`value` must not be empty", call. = FALSE)
+  }
+  if (length(value) != 1) value <- rep_len(value, length(colour))
+  if (channel == 'alpha') {
+    channel <- 0L
+    space <- 0L
+  } else {
+    space <- colourspace_match(space)
+    channel <- colour_channel_index[[space]][channel]
+    if (is.na(channel)) stop('Invalid channel for this colourspace', call. = FALSE)
+  }
+
+  if (!is.integer(colour)) {
+    stop('colour must be an integer vector (nativeRaster format)', call. = FALSE)
+  }
+  skip_na_values <- isTRUE(skip_na_values)
+
+  .Call(`farver_encode_channel_native_c`, colour, as.integer(channel), value, as.integer(space), as.integer(op), white, as.character(na_value), skip_na_values)
+}

R/native.R

@@ -12,10 +12,9 @@
 #' 
 #' @param colour For `encode_native` either a vector of hex-encoded 
 #' colours/colour names or a matrix encoding colours in any of the supported 
-#' colour spaces. If the  latter, the colours will be encoded to a hex string 
-#' using [encode_colour()] first. For `decode_native` it is a vector of 
+#' colour spaces. For `decode_native` it is a vector of 
 #' integers.
-#' @param ... Arguments passed on to [encode_colour()]
+#' @inheritParams encode_colour
 #' 
 #' @return `encode_native()` returns an integer vector and `decode_native()`
 #' returns a character vector, both matching the length of the input.
@@ -33,21 +32,32 @@
 #' # Convert back
 #' decode_native(native_col)
 #' 
-encode_native <- function(colour, ...) {
-  if (!is.character(colour)) {
-    colour <- encode_colour(colour, ...)
+encode_native <- function(colour, alpha = NULL, from = 'rgb', white = 'D65', na_value = NA) {
+  if (is.character(colour)) {
+    return(encode_native_c(colour, na_value = na_value))
   }
-  encode_native_c(colour)
+  if (from != 'rgb') {
+    white <- as_white_ref(white)
+  }
+  encode_c(colour, alpha, colourspace_match(from), white, out_format = 2L, na_value = na_value)
 }
+
 #' @rdname native_encoding
 #' @export
 decode_native <- function(colour) {
   decode_native_c(colour)
 } 
 
-encode_native_c <- function(colour) {
-  .Call(`farver_encode_native_c`, colour)
+encode_native_c <- function(colour, na_value = NA_character_) {
+  if (length(na_value) == 0) {
+    na_value <- NA_character_
+  }
+  if (length(na_value) > 1) {
+    stop("na_value must be a string")
+  }
+  na_value <- as.character(na_value)
+  .Call(`farver_encode_native_c`, colour, na_value)
 }
 decode_native_c <- function(colour) {
   .Call(`farver_decode_native_c`, as.integer(colour))
-}
+}