From d2122238285c0ddbee4d8b3ec1d90932670ba79a Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 09:21:15 +0200 Subject: [PATCH 01/21] MAINT: Remove deprecated context() from tests --- tests/testthat/test-comparison.R | 2 -- tests/testthat/test-conversion.R | 2 -- 2 files changed, 4 deletions(-) diff --git a/tests/testthat/test-comparison.R b/tests/testthat/test-comparison.R index 5094a83..bc62ffd 100644 --- a/tests/testthat/test-comparison.R +++ b/tests/testthat/test-comparison.R @@ -1,5 +1,3 @@ -context("comparison") - spectrum <- unname(t(col2rgb(rainbow(10)))) spectrum2 <- unname(t(col2rgb(heat.colors(5)))) reconvert <- function(data, space) { diff --git a/tests/testthat/test-conversion.R b/tests/testthat/test-conversion.R index a960cf6..4d952a3 100644 --- a/tests/testthat/test-conversion.R +++ b/tests/testthat/test-conversion.R @@ -1,5 +1,3 @@ -context("conversion") - spectrum <- unname(t(col2rgb(rainbow(10)))) reconvert <- function(data, space) { unname(round(convert_colour(convert_colour(data, 'rgb', space), space, 'rgb'))) From 52a1dc9d0773c67dab575a62fda790eb5298de36 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 09:22:29 +0200 Subject: [PATCH 02/21] REFACTOR: Encode colour input --- src/encode.cpp | 101 ++++++++++++++++++++++++++++--------------------- 1 file changed, 57 insertions(+), 44 deletions(-) diff --git a/src/encode.cpp b/src/encode.cpp index 2f52486..c7a9460 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -49,16 +49,51 @@ inline std::string prepare_code(const char* col) { return code; } +struct colour_channels { + int n; + int *colour_i1; + int *colour_i2; + int *colour_i3; + int *colour_i4; + double *colour_d1; + double *colour_d2; + double *colour_d3; + double *colour_d4; + bool colour_is_int; +}; + +static void get_input_channels(struct colour_channels *cc, SEXP colour, int n_channels) { + if (Rf_isMatrix(colour)) { + cc->colour_is_int = Rf_isInteger(colour); + if (Rf_ncols(colour) < n_channels) { + Rf_errorcall(R_NilValue, "Colour in this format must contain at least %i columns", n_channels); + } + cc->n = Rf_nrows(colour); + if (cc->colour_is_int) { + cc->colour_i1 = INTEGER(colour); + cc->colour_i2 = cc->colour_i1 + cc->n; + cc->colour_i3 = cc->colour_i1 + 2*cc->n; + cc->colour_i4 = cc->colour_i1 + 3*cc->n; + } else { + cc->colour_d1 = REAL(colour); + cc->colour_d2 = cc->colour_d1 + cc->n; + cc->colour_d3 = cc->colour_d1 + 2*cc->n; + cc->colour_d4 = cc->colour_d1 + 3*cc->n; + } + } else { + Rf_error("invalid input format, expected a matrix"); + } + return; +} + template SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { - int n_channels = dimension(); - if (Rf_ncols(colour) < n_channels) { - Rf_errorcall(R_NilValue, "Colour in this format must contain at least %i columns", n_channels); - } static ColorSpace::Rgb rgb; + struct colour_channels cc; + int n_channels = dimension(); + get_input_channels(&cc, colour, n_channels); ColorSpace::XyzConverter::SetWhiteReference(REAL(white)[0], REAL(white)[1], REAL(white)[2]); - int n = Rf_nrows(colour); - SEXP codes = PROTECT(Rf_allocVector(STRSXP, n)); + SEXP codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); bool has_alpha = !Rf_isNull(alpha); char alpha1 = '\0'; char alpha2 = '\0'; @@ -90,25 +125,13 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { } else { buf = buffer; } - int offset1 = 0; - int offset2 = offset1 + n; - int offset3 = offset2 + n; - int offset4 = offset3 + n; - int* colour_i = NULL; - double* colour_d = NULL; - bool colour_is_int = Rf_isInteger(colour); int num; - if (colour_is_int) { - colour_i = INTEGER(colour); - } else { - colour_d = REAL(colour); - } - for (int i = 0; i < n; ++i) { - if (colour_is_int) { - fill_rgb(&rgb, colour_i[offset1 + i], colour_i[offset2 + i], colour_i[offset3 + i], n_channels == 4 ? colour_i[offset4 + i] : 0); + for (int i = 0; i < cc.n; ++i) { + if (cc.colour_is_int) { + fill_rgb(&rgb, cc.colour_i1[i], cc.colour_i2[i], cc.colour_i3[i], n_channels == 4 ? cc.colour_i4[i]: 0); } else { - fill_rgb(&rgb, colour_d[offset1 + i], colour_d[offset2 + i], colour_d[offset3 + i], n_channels == 4 ? colour_d[offset4 + i] : 0.0); + fill_rgb(&rgb, cc.colour_d1[i], cc.colour_d2[i], cc.colour_d3[i], n_channels == 4 ? cc.colour_d4[i] : 0.0); } if (!rgb.valid) { SET_STRING_ELT(codes, i, R_NaString); @@ -160,11 +183,9 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { template<> SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { - if (Rf_ncols(colour) < 3) { - Rf_errorcall(R_NilValue, "Colour in RGB format must contain at least 3 columns"); - } - int n = Rf_nrows(colour); - SEXP codes = PROTECT(Rf_allocVector(STRSXP, n)); + struct colour_channels cc; + get_input_channels(&cc, colour, 3); + SEXP codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); bool has_alpha = !Rf_isNull(alpha); char alpha1 = '\0'; char alpha2 = '\0'; @@ -196,21 +217,14 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { } else { buf = buffer; } - int offset1 = 0; - int offset2 = offset1 + n; - int offset3 = offset2 + n; - int* colour_i = NULL; - double* colour_d = NULL; - bool colour_is_int = Rf_isInteger(colour); int num; - if (colour_is_int) { + if (cc.colour_is_int) { int r, g, b; - colour_i = INTEGER(colour); - for (int i = 0; i < n; ++i) { - r = colour_i[offset1 + i]; - g = colour_i[offset2 + i]; - b = colour_i[offset3 + i]; + for (int i = 0; i < cc.n; ++i) { + r = cc.colour_i1[i]; + g = cc.colour_i2[i]; + b = cc.colour_i3[i]; if (r == R_NaInt || g == R_NaInt || b == R_NaInt) { SET_STRING_ELT(codes, i, R_NaString); continue; @@ -251,11 +265,10 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { } } else { double r, g, b; - colour_d = REAL(colour); - for (int i = 0; i < n; ++i) { - r = colour_d[offset1 + i]; - g = colour_d[offset2 + i]; - b = colour_d[offset3 + i]; + for (int i = 0; i < cc.n; ++i) { + r = cc.colour_d1[i]; + g = cc.colour_d2[i]; + b = cc.colour_d3[i]; if (!(R_finite(r) && R_finite(g) && R_finite(b))) { SET_STRING_ELT(codes, i, R_NaString); continue; From 8e87454abad8a3d53f953ecf4a61f1717f625020 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 09:40:06 +0200 Subject: [PATCH 03/21] FEAT: encode colour accepts a list/data.frame of channels besides a matrix --- R/encode.R | 28 +++++++++++++++--- src/encode.cpp | 77 ++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 96 insertions(+), 9 deletions(-) diff --git a/R/encode.R b/R/encode.R index 8299379..c5e514a 100644 --- a/R/encode.R +++ b/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"`, @@ -47,18 +51,34 @@ encode_colour <- function(colour, alpha = NULL, from = 'rgb', white = 'D65') { } encode_c <- function(colour, alpha, from, white) { - if (nrow(colour) == 0) { + # 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) + .Call(`farver_encode_c`, colour, alpha, as.integer(from), white) } diff --git a/src/encode.cpp b/src/encode.cpp index c7a9460..42544fe 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -63,7 +63,63 @@ struct colour_channels { }; static void get_input_channels(struct colour_channels *cc, SEXP colour, int n_channels) { - if (Rf_isMatrix(colour)) { + if (TYPEOF(colour) == VECSXP) { + int input_n_channels = Rf_length(colour); + if (input_n_channels < n_channels) { + Rf_errorcall(R_NilValue, "Colour, if given as a list, must contain at least %i elements (channels)", n_channels); + } + input_n_channels = n_channels; + SEXP a_channel = VECTOR_ELT(colour, 0); + cc->colour_is_int = Rf_isInteger(a_channel); + if (!(cc->colour_is_int)) { + if (TYPEOF(a_channel) != REALSXP) { + Rf_error("All channels must be either integers or reals"); + } + cc->colour_d1 = REAL(a_channel); + } else { + cc->colour_i1 = INTEGER(a_channel); + } + cc->n = Rf_length(a_channel); + for (int i=1; icolour_is_int) { + if (TYPEOF(a_channel) != INTSXP) { + Rf_error("The first channel was integer, channel %d is not. All channels should be of the same type", i+1); + } + } else { + if (TYPEOF(a_channel) != REALSXP) { + Rf_error("The first channel was real, channel %d is not. All channels should be of the same type", i+1); + } + } + int n_thisch = Rf_length(a_channel); + if (n_thisch != cc->n) { + Rf_error("The first channel was of length %d. Channel %d is of length %d. All channels should be of the same length", cc->n, i+1, n_thisch); + } + switch(i) { + case 1: + if (cc->colour_is_int) { + cc->colour_i2 = INTEGER(a_channel); + } else { + cc->colour_d2 = REAL(a_channel); + } + break; + case 2: + if (cc->colour_is_int) { + cc->colour_i3 = INTEGER(a_channel); + } else { + cc->colour_d3 = REAL(a_channel); + } + break; + case 3: + if (cc->colour_is_int) { + cc->colour_i4 = INTEGER(a_channel); + } else { + cc->colour_d4 = REAL(a_channel); + } + break; + } + } + } else if (Rf_isMatrix(colour)) { cc->colour_is_int = Rf_isInteger(colour); if (Rf_ncols(colour) < n_channels) { Rf_errorcall(R_NilValue, "Colour in this format must contain at least %i columns", n_channels); @@ -81,7 +137,7 @@ static void get_input_channels(struct colour_channels *cc, SEXP colour, int n_ch cc->colour_d4 = cc->colour_d1 + 3*cc->n; } } else { - Rf_error("invalid input format, expected a matrix"); + Rf_error("invalid input format, expected a matrix or a list of vectors"); } return; } @@ -175,8 +231,17 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } - - copy_names(colour, codes); + + if (Rf_isMatrix(colour)) { + copy_names(colour, codes); + } else if (Rf_inherits(colour, "data.frame")) { + SEXP names = PROTECT(Rf_getAttrib(colour, Rf_install("dimnames"))); + if (!Rf_isNull(names)) { + names = VECTOR_ELT(names, 0); + } + Rf_namesgets(codes, names); + UNPROTECT(1); + } UNPROTECT(1); return codes; } @@ -309,7 +374,9 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { } } - copy_names(colour, codes); + if (Rf_isMatrix(colour)) { + copy_names(colour, codes); + } UNPROTECT(1); return codes; } From 99a9c9a4bbfae8b413bb1f18a186e0cc5908620f Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 09:41:36 +0200 Subject: [PATCH 04/21] TEST: Add unit test for encode_colour with list or data frame --- tests/testthat/test-encoding.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-encoding.R b/tests/testthat/test-encoding.R index a0fcc81..c891164 100644 --- a/tests/testthat/test-encoding.R +++ b/tests/testthat/test-encoding.R @@ -21,4 +21,13 @@ test_that("colours can be encoded", { test_that("alpha gets encoded correctly", { alpha_col <- encode_colour(cols_dec[1:6,], alpha = seq(0, 1, length.out = 6)) expect_equal(substr(alpha_col, 8, 9), c("00", "33", "66", "99", "CC", "")) -}) \ No newline at end of file +}) + +test_that("colours can be encoded from a list of channels", { + cols_cmy <- convert_colour(cols_dec, 'rgb', 'cmy') + expect_equal(encode_colour(list(cols_dec[,1], cols_dec[,2], cols_dec[,3])), cols) + expect_equal(encode_colour(data.frame(cols_dec[,1], cols_dec[,2], cols_dec[,3])), cols) + expect_equal(encode_colour(list(cols_cmy[,1], cols_cmy[,2], cols_cmy[,3]), from = 'cmy'), cols) + expect_equal(encode_colour(data.frame(cols_cmy[,1], cols_cmy[,2], cols_cmy[,3]), from = 'cmy'), cols) +}) + From 52149d2ed3f52166c8f53b1a9c8c2d014e5613e7 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 09:42:52 +0200 Subject: [PATCH 05/21] NEWS: Add entry for list of channels feature --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/NEWS.md b/NEWS.md index dedab61..7463d3c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # 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). + # farver 2.1.1 * Added input checking to a range of functions to guard against segfaults with From 69b2b7b662cd23f37c3434a29f130698b46c7897 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 21:48:43 +0200 Subject: [PATCH 06/21] DOCUMENT: devtools::document() --- DESCRIPTION | 2 +- man/encode_colour.Rd | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f1d41cc..de50e3a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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 diff --git a/man/encode_colour.Rd b/man/encode_colour.Rd index 7113f90..39c49b4 100644 --- a/man/encode_colour.Rd +++ b/man/encode_colour.Rd @@ -10,7 +10,8 @@ encode_colour(colour, alpha = NULL, from = "rgb", white = "D65") \item{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 \code{'cmyk'} this will mean a matrix with three columns - -for \code{'cmyk'} it means four columns.} +for \code{'cmyk'} it means four columns. Alternatively, \code{colour} may be a list of +length three (or four for \code{'cmyk'}) numeric vectors of the same length.} \item{alpha}{A numeric vector between 0 and 1. Will be recycled to the number of rows in \code{colour}. If \code{NULL} or a single \code{NA} it will be ignored.} From 90cd2930757f92dd7cf73fd39b28908dce395fec Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 23:15:36 +0200 Subject: [PATCH 07/21] PERF: encode_native does not go through a character vector representation --- R/encode.R | 10 +- R/native.R | 19 +-- src/encode.cpp | 351 +++++++++++++++++++++++++++++++------------------ src/encode.h | 4 +- src/init.cpp | 4 +- 5 files changed, 246 insertions(+), 142 deletions(-) diff --git a/R/encode.R b/R/encode.R index c5e514a..f5b53af 100644 --- a/R/encode.R +++ b/R/encode.R @@ -47,10 +47,10 @@ encode_colour <- function(colour, alpha = NULL, from = 'rgb', white = 'D65') { 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) } -encode_c <- function(colour, alpha, from, white) { +encode_c <- function(colour, alpha, from, white, out_format = 1L) { # colour has zero colours: if ((is.matrix(colour) || is.data.frame(colour)) && nrow(colour) == 0) { return(character()) @@ -80,5 +80,9 @@ encode_c <- function(colour, alpha, from, white) { alpha <- NULL } } - .Call(`farver_encode_c`, 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)") + } + .Call(`farver_encode_c`, colour, alpha, as.integer(from), white, out_format) } diff --git a/R/native.R b/R/native.R index 80f371c..e5cfc69 100644 --- a/R/native.R +++ b/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,12 +32,16 @@ #' # 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') { + if (is.character(colour)) { + return(encode_native_c(colour)) } - encode_native_c(colour) + if (from != 'rgb') { + white <- as_white_ref(white) + } + encode_c(colour, alpha, colourspace_match(from), white, out_format = 2L) } + #' @rdname native_encoding #' @export decode_native <- function(colour) { @@ -50,4 +53,4 @@ encode_native_c <- function(colour) { } decode_native_c <- function(colour) { .Call(`farver_decode_native_c`, as.integer(colour)) -} \ No newline at end of file +} diff --git a/src/encode.cpp b/src/encode.cpp index 42544fe..83d4b8a 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -143,13 +143,24 @@ static void get_input_channels(struct colour_channels *cc, SEXP colour, int n_ch } template -SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { +SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { static ColorSpace::Rgb rgb; struct colour_channels cc; + int out_fmt = INTEGER(s_out_fmt)[0]; // 1 is character vector, 2 is native format + if (out_fmt != 1 && out_fmt != 2) { + Rf_error("invalid output format."); + } int n_channels = dimension(); get_input_channels(&cc, colour, n_channels); ColorSpace::XyzConverter::SetWhiteReference(REAL(white)[0], REAL(white)[1], REAL(white)[2]); - SEXP codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); + SEXP codes; + int *codes_int; + if (out_fmt == 1) { + codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); + } else { + codes = PROTECT(Rf_allocVector(INTSXP, cc.n)); + codes_int = INTEGER(codes); + } bool has_alpha = !Rf_isNull(alpha); char alpha1 = '\0'; char alpha2 = '\0'; @@ -158,11 +169,11 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { char* buf = NULL; int* alpha_i = NULL; double* alpha_d = NULL; + int first_alpha; if (has_alpha) { buf = buffera; alpha_is_int = Rf_isInteger(alpha); one_alpha = Rf_length(alpha) == 1; - int first_alpha; if (alpha_is_int) { alpha_i = INTEGER(alpha); first_alpha = alpha_i[0]; @@ -175,82 +186,113 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { first_alpha = double2int(alpha_d[0]); } } - first_alpha = cap0255(first_alpha) * 2; - alpha1 = hex8[first_alpha]; - alpha2 = hex8[first_alpha + 1]; + first_alpha = cap0255(first_alpha); + alpha1 = hex8[2*first_alpha]; + alpha2 = hex8[2*first_alpha + 1]; } else { buf = buffer; } - - int num; + for (int i = 0; i < cc.n; ++i) { if (cc.colour_is_int) { - fill_rgb(&rgb, cc.colour_i1[i], cc.colour_i2[i], cc.colour_i3[i], n_channels == 4 ? cc.colour_i4[i]: 0); + fill_rgb(&rgb, cc.colour_i1[i], cc.colour_i2[i], cc.colour_i3[i], n_channels == 4 ? cc.colour_i4[i] : 0); } else { fill_rgb(&rgb, cc.colour_d1[i], cc.colour_d2[i], cc.colour_d3[i], n_channels == 4 ? cc.colour_d4[i] : 0.0); } if (!rgb.valid) { - SET_STRING_ELT(codes, i, R_NaString); + if (out_fmt == 1) { + SET_STRING_ELT(codes, i, R_NaString); + } else { + codes_int[i] = R_NaInt; + } continue; } - num = double2int(rgb.r); - num = cap0255(num) * 2; - buf[1] = hex8[num]; - buf[2] = hex8[num + 1]; - - num = double2int(rgb.g); - num = cap0255(num) * 2; - buf[3] = hex8[num]; - buf[4] = hex8[num + 1]; - - num = double2int(rgb.b); - num = cap0255(num) * 2; - buf[5] = hex8[num]; - buf[6] = hex8[num + 1]; - - if (has_alpha) { - if (one_alpha) { - buf[7] = alpha1; - buf[8] = alpha2; - } else { - if (alpha_is_int) { - num = alpha_i[i]; + + if (out_fmt == 2) { /* native output */ + int alpha; + if (has_alpha) { + if (one_alpha) { + alpha = first_alpha; } else { - num = double2int(alpha_d[i]); + if (alpha_is_int) { + alpha = alpha_i[i]; + alpha = alpha == R_NaInt ? 255 : cap0255(alpha); + } else { + alpha = !R_finite(alpha_d[i]) ? 255 : cap0255(double2int(alpha_d[i])); + } } - num = cap0255(num) * 2; - if (num == 510) { // opaque - buf[7] = '\0'; + } else { + alpha = 255; + } + codes_int[i] = ( + cap0255(double2int(rgb.r)) + + (cap0255(double2int(rgb.g)) << 8) + + (cap0255(double2int(rgb.b)) << 16) + + (alpha << 24) + ); + } else { /* character output */ + int num; + num = double2int(rgb.r); + num = cap0255(num) * 2; + buf[1] = hex8[num]; + buf[2] = hex8[num + 1]; + + num = double2int(rgb.g); + num = cap0255(num) * 2; + buf[3] = hex8[num]; + buf[4] = hex8[num + 1]; + + num = double2int(rgb.b); + num = cap0255(num) * 2; + buf[5] = hex8[num]; + buf[6] = hex8[num + 1]; + + if (has_alpha) { + if (one_alpha) { + buf[7] = alpha1; + buf[8] = alpha2; } else { - buf[7] = hex8[num]; - buf[8] = hex8[num + 1]; + if (alpha_is_int) { + num = alpha_i[i]; + } else { + num = double2int(alpha_d[i]); + } + num = cap0255(num) * 2; + if (num == 510) { // opaque + buf[7] = '\0'; + } else { + buf[7] = hex8[num]; + buf[8] = hex8[num + 1]; + } } } + SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } - - - SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } if (Rf_isMatrix(colour)) { copy_names(colour, codes); - } else if (Rf_inherits(colour, "data.frame")) { - SEXP names = PROTECT(Rf_getAttrib(colour, Rf_install("dimnames"))); - if (!Rf_isNull(names)) { - names = VECTOR_ELT(names, 0); - } - Rf_namesgets(codes, names); - UNPROTECT(1); } UNPROTECT(1); return codes; } template<> -SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { +SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { struct colour_channels cc; + int out_fmt = INTEGER(s_out_fmt)[0]; // 1 is character vector, 2 is native format + if (out_fmt != 1 && out_fmt != 2) { + Rf_error("invalid output format."); + } get_input_channels(&cc, colour, 3); - SEXP codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); + SEXP codes; + int *codes_int; + if (out_fmt == 1) { + codes = PROTECT(Rf_allocVector(STRSXP, cc.n)); + } else { + codes = PROTECT(Rf_allocVector(INTSXP, cc.n)); + codes_int = INTEGER(codes); + } bool has_alpha = !Rf_isNull(alpha); char alpha1 = '\0'; char alpha2 = '\0'; @@ -259,11 +301,11 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { char* buf = NULL; int* alpha_i = NULL; double* alpha_d = NULL; + int first_alpha; if (has_alpha) { buf = buffera; alpha_is_int = Rf_isInteger(alpha); one_alpha = Rf_length(alpha) == 1; - int first_alpha; if (alpha_is_int) { alpha_i = INTEGER(alpha); first_alpha = alpha_i[0]; @@ -276,14 +318,13 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { first_alpha = double2int(alpha_d[0]); } } - first_alpha = cap0255(first_alpha) * 2; - alpha1 = hex8[first_alpha]; - alpha2 = hex8[first_alpha + 1]; + first_alpha = cap0255(first_alpha); + alpha1 = hex8[2*first_alpha]; + alpha2 = hex8[2*first_alpha + 1]; } else { buf = buffer; } - int num; if (cc.colour_is_int) { int r, g, b; for (int i = 0; i < cc.n; ++i) { @@ -291,42 +332,70 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { g = cc.colour_i2[i]; b = cc.colour_i3[i]; if (r == R_NaInt || g == R_NaInt || b == R_NaInt) { - SET_STRING_ELT(codes, i, R_NaString); + if (out_fmt == 1) { + SET_STRING_ELT(codes, i, R_NaString); + } else { + codes_int[i] = R_NaInt; + } continue; } - num = cap0255(r) * 2; - buf[1] = hex8[num]; - buf[2] = hex8[num + 1]; - - num = cap0255(g) * 2; - buf[3] = hex8[num]; - buf[4] = hex8[num + 1]; - - num = cap0255(b) * 2; - buf[5] = hex8[num]; - buf[6] = hex8[num + 1]; - - if (has_alpha) { - if (one_alpha) { - buf[7] = alpha1; - buf[8] = alpha2; - } else { - if (alpha_is_int) { - num = alpha_i[i]; + if (out_fmt == 2) { + int alpha; + if (has_alpha) { + if (one_alpha) { + alpha = first_alpha; } else { - num = double2int(alpha_d[i]); + if (alpha_is_int) { + alpha = alpha_i[i]; + alpha = alpha == R_NaInt ? 255 : cap0255(alpha); + } else { + alpha = !R_finite(alpha_d[i]) ? 255 : cap0255(double2int(alpha_d[i])); + } } - num = cap0255(num) * 2; - if (num == 510) { // opaque - buf[7] = '\0'; + } else { + alpha = 255; + } + codes_int[i] = ( + cap0255(r) + + (cap0255(g) << 8) + + (cap0255(b) << 16) + + (alpha << 24) + ); + } else { + int num; + num = cap0255(r) * 2; + buf[1] = hex8[num]; + buf[2] = hex8[num + 1]; + + num = cap0255(g) * 2; + buf[3] = hex8[num]; + buf[4] = hex8[num + 1]; + + num = cap0255(b) * 2; + buf[5] = hex8[num]; + buf[6] = hex8[num + 1]; + + if (has_alpha) { + if (one_alpha) { + buf[7] = alpha1; + buf[8] = alpha2; } else { - buf[7] = hex8[num]; - buf[8] = hex8[num + 1]; + if (alpha_is_int) { + num = alpha_i[i]; + num = num == R_NaInt ? 255 : cap0255(num); + } else { + num = !R_finite(alpha_d[i]) ? 255 : cap0255(double2int(alpha_d[i])); + } + if (num == 255) { // opaque + buf[7] = '\0'; + } else { + buf[7] = hex8[2*num]; + buf[8] = hex8[2*num + 1]; + } } } + SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } - - SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } } else { double r, g, b; @@ -335,42 +404,70 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { g = cc.colour_d2[i]; b = cc.colour_d3[i]; if (!(R_finite(r) && R_finite(g) && R_finite(b))) { - SET_STRING_ELT(codes, i, R_NaString); + if (out_fmt == 1) { + SET_STRING_ELT(codes, i, R_NaString); + } else { + codes_int[i] = R_NaInt; + } continue; } - num = cap0255(double2int(r)) * 2; - buf[1] = hex8[num]; - buf[2] = hex8[num + 1]; - - num = cap0255(double2int(g)) * 2; - buf[3] = hex8[num]; - buf[4] = hex8[num + 1]; - - num = cap0255(double2int(b)) * 2; - buf[5] = hex8[num]; - buf[6] = hex8[num + 1]; - - if (has_alpha) { - if (one_alpha) { - buf[7] = alpha1; - buf[8] = alpha2; - } else { - if (alpha_is_int) { - num = alpha_i[i]; + if (out_fmt == 2) { + int alpha; + if (has_alpha) { + if (one_alpha) { + alpha = first_alpha; } else { - num = double2int(alpha_d[i]); + if (alpha_is_int) { + alpha = alpha_i[i]; + alpha = alpha == R_NaInt ? 255 : cap0255(alpha); + } else { + alpha = !R_finite(alpha_d[i]) ? 255 : cap0255(double2int(alpha_d[i])); + } } - num = cap0255(num) * 2; - if (num == 510) { // opaque - buf[7] = '\0'; + } else { + alpha = 255; + } + codes_int[i] = ( + cap0255(double2int(r)) + + (cap0255(double2int(g)) << 8) + + (cap0255(double2int(b)) << 16) + + (alpha << 24) + ); + } else { + int num; + num = cap0255(double2int(r)) * 2; + buf[1] = hex8[num]; + buf[2] = hex8[num + 1]; + + num = cap0255(double2int(g)) * 2; + buf[3] = hex8[num]; + buf[4] = hex8[num + 1]; + + num = cap0255(double2int(b)) * 2; + buf[5] = hex8[num]; + buf[6] = hex8[num + 1]; + + if (has_alpha) { + if (one_alpha) { + buf[7] = alpha1; + buf[8] = alpha2; } else { - buf[7] = hex8[num]; - buf[8] = hex8[num + 1]; + if (alpha_is_int) { + num = alpha_i[i]; + num = num == R_NaInt ? 255 : cap0255(num); + } else { + num = !R_finite(alpha_d[i]) ? 255 : cap0255(double2int(alpha_d[i])); + } + if (num == 255) { // opaque + buf[7] = '\0'; + } else { + buf[7] = hex8[2*num]; + buf[8] = hex8[2*num + 1]; + } } } + SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } - - SET_STRING_ELT(codes, i, Rf_mkChar(buf)); } } @@ -381,23 +478,23 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white) { return codes; } -SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white) { +SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt) { switch (INTEGER(from)[0]) { - case CMY: return encode_impl(colour, alpha, white); - case CMYK: return encode_impl(colour, alpha, white); - case HSL: return encode_impl(colour, alpha, white); - case HSB: return encode_impl(colour, alpha, white); - case HSV: return encode_impl(colour, alpha, white); - case LAB: return encode_impl(colour, alpha, white); - case HUNTERLAB: return encode_impl(colour, alpha, white); - case LCH: return encode_impl(colour, alpha, white); - case LUV: return encode_impl(colour, alpha, white); - case RGB: return encode_impl(colour, alpha, white); - case XYZ: return encode_impl(colour, alpha, white); - case YXY: return encode_impl(colour, alpha, white); - case HCL: return encode_impl(colour, alpha, white); - case OKLAB: return encode_impl(colour, alpha, white); - case OKLCH: return encode_impl(colour, alpha, white); + case CMY: return encode_impl(colour, alpha, white, out_fmt); + case CMYK: return encode_impl(colour, alpha, white, out_fmt); + case HSL: return encode_impl(colour, alpha, white, out_fmt); + case HSB: return encode_impl(colour, alpha, white, out_fmt); + case HSV: return encode_impl(colour, alpha, white, out_fmt); + case LAB: return encode_impl(colour, alpha, white, out_fmt); + case HUNTERLAB: return encode_impl(colour, alpha, white, out_fmt); + case LCH: return encode_impl(colour, alpha, white, out_fmt); + case LUV: return encode_impl(colour, alpha, white, out_fmt); + case RGB: return encode_impl(colour, alpha, white, out_fmt); + case XYZ: return encode_impl(colour, alpha, white, out_fmt); + case YXY: return encode_impl(colour, alpha, white, out_fmt); + case HCL: return encode_impl(colour, alpha, white, out_fmt); + case OKLAB: return encode_impl(colour, alpha, white, out_fmt); + case OKLCH: return encode_impl(colour, alpha, white, out_fmt); } // never happens diff --git a/src/encode.h b/src/encode.h index 9704577..6e56ea4 100644 --- a/src/encode.h +++ b/src/encode.h @@ -36,7 +36,7 @@ typedef std::unordered_map ColourMap; // Defined in init.cpp ColourMap& get_named_colours(); -SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white); +SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt); SEXP decode_c(SEXP codes, SEXP alpha, SEXP to, SEXP white, SEXP na); SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na); SEXP decode_channel_c(SEXP codes, SEXP channel, SEXP space, SEXP white, SEXP na); @@ -430,4 +430,4 @@ inline double grab_channel(ColorSpace::OkLch& color, int chan return 0.0; } -#endif \ No newline at end of file +#endif diff --git a/src/init.cpp b/src/init.cpp index 448b524..d7d1b82 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -15,7 +15,7 @@ ColourMap& get_named_colours() { static const R_CallMethodDef CallEntries[] = { {"farver_convert_c", (DL_FUNC) &convert_c, 5}, {"farver_compare_c", (DL_FUNC) &compare_c, 8}, - {"farver_encode_c", (DL_FUNC) &encode_c, 4}, + {"farver_encode_c", (DL_FUNC) &encode_c, 5}, {"farver_decode_c", (DL_FUNC) &decode_c, 5}, {"farver_encode_channel_c", (DL_FUNC) &encode_channel_c, 7}, {"farver_decode_channel_c", (DL_FUNC) &decode_channel_c, 5}, @@ -34,4 +34,4 @@ extern "C" void R_init_farver(DllInfo *dll) { extern "C" void R_unload_farver(DllInfo *dll) { delete named_colours; -} \ No newline at end of file +} From d69d32b6ee2e5a4edfffaa7ab269c99ef31bb6ac Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 23:16:06 +0200 Subject: [PATCH 08/21] DOC: devtools::document() --- man/native_encoding.Rd | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/man/native_encoding.Rd b/man/native_encoding.Rd index d41a0a3..089ed18 100644 --- a/man/native_encoding.Rd +++ b/man/native_encoding.Rd @@ -6,18 +6,28 @@ \alias{decode_native} \title{Convert to and from the R native colour representation} \usage{ -encode_native(colour, ...) +encode_native(colour, alpha = NULL, from = "rgb", white = "D65") decode_native(colour) } \arguments{ \item{colour}{For \code{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 \code{\link[=encode_colour]{encode_colour()}} first. For \code{decode_native} it is a vector of +colour spaces. For \code{decode_native} it is a vector of integers.} -\item{...}{Arguments passed on to \code{\link[=encode_colour]{encode_colour()}}} +\item{alpha}{A numeric vector between 0 and 1. Will be recycled to the number +of rows in \code{colour}. If \code{NULL} or a single \code{NA} it will be ignored.} + +\item{from}{The input colour space. Allowed values are: \code{"cmy"}, +\code{"cmyk"}, \code{"hsl"}, \code{"hsb"}, \code{"hsv"}, \code{"lab"} (CIE L*ab), \code{"hunterlab"} +(Hunter Lab), \code{"oklab"}, \code{"lch"} (CIE Lch(ab) / polarLAB), \code{"luv"}, +\code{"rgb"} (sRGB), \code{"xyz"}, \code{"yxy"} (CIE xyY), \code{"hcl"} (CIE Lch(uv) / polarLuv), +or \code{"oklch"} (Polar form of oklab)} + +\item{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 +\code{\link[=as_white_ref]{as_white_ref()}} allowed.} } \value{ \code{encode_native()} returns an integer vector and \code{decode_native()} From 4d2459bd85c10d8f9f5f9c795276db3791bf3cd2 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 23:16:26 +0200 Subject: [PATCH 09/21] Test native encoding --- tests/testthat/test-encoding.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/testthat/test-encoding.R b/tests/testthat/test-encoding.R index c891164..6207c3b 100644 --- a/tests/testthat/test-encoding.R +++ b/tests/testthat/test-encoding.R @@ -1,6 +1,7 @@ cols <- c("#404040", "#8FBC8F", "#FFFFE0", "#7AC5CD", "#66CDAA", "#1E90FF", "#CDC0B0", "#CD0000", "#7A67EE", "#FFFACD") cols_dec <- decode_colour(cols) +native_cols <- encode_native(cols) test_that("colours can be encoded", { expect_equal(encode_colour(cols_dec), cols) @@ -23,6 +24,25 @@ test_that("alpha gets encoded correctly", { expect_equal(substr(alpha_col, 8, 9), c("00", "33", "66", "99", "CC", "")) }) + + +test_that("colours can be encoded to native", { + expect_equal(encode_native(cols_dec), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'cmy'), from = 'cmy'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'cmyk'), from = 'cmyk'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'hsl'), from = 'hsl'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'hsb'), from = 'hsb'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'hsv'), from = 'hsv'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'lab'), from = 'lab'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'hunterlab'), from = 'hunterlab'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'lch'), from = 'lch'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'luv'), from = 'luv'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'xyz'), from = 'xyz'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'yxy'), from = 'yxy'), native_cols) + expect_equal(encode_native(convert_colour(cols_dec, 'rgb', 'hcl'), from = 'hcl'), native_cols) +}) + + test_that("colours can be encoded from a list of channels", { cols_cmy <- convert_colour(cols_dec, 'rgb', 'cmy') expect_equal(encode_colour(list(cols_dec[,1], cols_dec[,2], cols_dec[,3])), cols) From 796297d79bcbf7d2400eda9e7182a4ead16a4fcb Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Sun, 18 Sep 2022 23:16:56 +0200 Subject: [PATCH 10/21] NEWS: Faster encode_native() --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index 7463d3c..c96e62b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,9 @@ 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 (#375, @zeehio). + # farver 2.1.1 * Added input checking to a range of functions to guard against segfaults with From 3f632b183186026d067c5cf41d7da80ab5976114 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 08:04:06 +0200 Subject: [PATCH 11/21] FEAT: encode_colour() and encode_native() accept a na_value --- R/encode.R | 21 ++++++++-- R/native.R | 17 +++++--- src/encode.cpp | 104 +++++++++++++++++++++++++++++++++++-------------- src/encode.h | 4 +- src/init.cpp | 4 +- 5 files changed, 108 insertions(+), 42 deletions(-) diff --git a/R/encode.R b/R/encode.R index f5b53af..2c7b22c 100644 --- a/R/encode.R +++ b/R/encode.R @@ -21,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)` #' @@ -43,14 +47,14 @@ #' 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, out_format = 1L) + encode_c(colour, alpha, colourspace_match(from), white, out_format = 1L, na_value) } -encode_c <- function(colour, alpha, from, white, out_format = 1L) { +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()) @@ -84,5 +88,14 @@ encode_c <- function(colour, alpha, from, white, out_format = 1L) { if (out_format != 1L && out_format != 2L) { stop("out_format must be 1L (for character) or 2L (for native)") } - .Call(`farver_encode_c`, colour, alpha, as.integer(from), white, out_format) + 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) } + diff --git a/R/native.R b/R/native.R index e5cfc69..28dc287 100644 --- a/R/native.R +++ b/R/native.R @@ -32,14 +32,14 @@ #' # Convert back #' decode_native(native_col) #' -encode_native <- function(colour, alpha = NULL, from = 'rgb', white = 'D65') { +encode_native <- function(colour, alpha = NULL, from = 'rgb', white = 'D65', na_value = NA) { if (is.character(colour)) { - return(encode_native_c(colour)) + return(encode_native_c(colour, na_value = na_value)) } if (from != 'rgb') { white <- as_white_ref(white) } - encode_c(colour, alpha, colourspace_match(from), white, out_format = 2L) + encode_c(colour, alpha, colourspace_match(from), white, out_format = 2L, na_value = na_value) } #' @rdname native_encoding @@ -48,8 +48,15 @@ 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)) diff --git a/src/encode.cpp b/src/encode.cpp index 83d4b8a..189d521 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -142,14 +142,39 @@ static void get_input_channels(struct colour_channels *cc, SEXP colour, int n_ch return; } +static SEXP get_na_value(SEXP s_na_value, int *na_value_int) { + SEXP na_value_sexp; + const char *na_txt; + if (TYPEOF(s_na_value) == STRSXP) { + na_value_sexp = STRING_ELT(s_na_value, 0); + } else if (TYPEOF(s_na_value) == CHARSXP) { + na_value_sexp = s_na_value; + } else { + Rf_error("Expected na_value to be a string"); + } + na_txt = CHAR(na_value_sexp); + + if (na_value_sexp == R_NaString || strcmp("NA", na_txt) == 0) { + na_value_sexp = R_NaString; + *na_value_int = R_NaInt; + } else { + SEXP tmp = encode_native_c(na_value_sexp, R_NaString); + *na_value_int = INTEGER(tmp)[0]; + } + return(na_value_sexp); +} + + template -SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { +SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt, SEXP s_na_value) { static ColorSpace::Rgb rgb; struct colour_channels cc; int out_fmt = INTEGER(s_out_fmt)[0]; // 1 is character vector, 2 is native format if (out_fmt != 1 && out_fmt != 2) { Rf_error("invalid output format."); } + int na_value_int; + SEXP na_value_sexp = get_na_value(s_na_value, &na_value_int); int n_channels = dimension(); get_input_channels(&cc, colour, n_channels); ColorSpace::XyzConverter::SetWhiteReference(REAL(white)[0], REAL(white)[1], REAL(white)[2]); @@ -201,9 +226,9 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { } if (!rgb.valid) { if (out_fmt == 1) { - SET_STRING_ELT(codes, i, R_NaString); + SET_STRING_ELT(codes, i, na_value_sexp); } else { - codes_int[i] = R_NaInt; + codes_int[i] = na_value_int; } continue; } @@ -278,13 +303,15 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { } template<> -SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt) { +SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_out_fmt, SEXP s_na_value) { struct colour_channels cc; int out_fmt = INTEGER(s_out_fmt)[0]; // 1 is character vector, 2 is native format if (out_fmt != 1 && out_fmt != 2) { Rf_error("invalid output format."); } get_input_channels(&cc, colour, 3); + int na_value_int; + SEXP na_value_sexp = get_na_value(s_na_value, &na_value_int); SEXP codes; int *codes_int; if (out_fmt == 1) { @@ -333,9 +360,9 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_ou b = cc.colour_i3[i]; if (r == R_NaInt || g == R_NaInt || b == R_NaInt) { if (out_fmt == 1) { - SET_STRING_ELT(codes, i, R_NaString); + SET_STRING_ELT(codes, i, na_value_sexp); } else { - codes_int[i] = R_NaInt; + codes_int[i] = na_value_int; } continue; } @@ -405,9 +432,9 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_ou b = cc.colour_d3[i]; if (!(R_finite(r) && R_finite(g) && R_finite(b))) { if (out_fmt == 1) { - SET_STRING_ELT(codes, i, R_NaString); + SET_STRING_ELT(codes, i, na_value_sexp); } else { - codes_int[i] = R_NaInt; + codes_int[i] = na_value_int; } continue; } @@ -478,23 +505,23 @@ SEXP encode_impl(SEXP colour, SEXP alpha, SEXP white, SEXP s_ou return codes; } -SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt) { +SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt, SEXP na_value) { switch (INTEGER(from)[0]) { - case CMY: return encode_impl(colour, alpha, white, out_fmt); - case CMYK: return encode_impl(colour, alpha, white, out_fmt); - case HSL: return encode_impl(colour, alpha, white, out_fmt); - case HSB: return encode_impl(colour, alpha, white, out_fmt); - case HSV: return encode_impl(colour, alpha, white, out_fmt); - case LAB: return encode_impl(colour, alpha, white, out_fmt); - case HUNTERLAB: return encode_impl(colour, alpha, white, out_fmt); - case LCH: return encode_impl(colour, alpha, white, out_fmt); - case LUV: return encode_impl(colour, alpha, white, out_fmt); - case RGB: return encode_impl(colour, alpha, white, out_fmt); - case XYZ: return encode_impl(colour, alpha, white, out_fmt); - case YXY: return encode_impl(colour, alpha, white, out_fmt); - case HCL: return encode_impl(colour, alpha, white, out_fmt); - case OKLAB: return encode_impl(colour, alpha, white, out_fmt); - case OKLCH: return encode_impl(colour, alpha, white, out_fmt); + case CMY: return encode_impl(colour, alpha, white, out_fmt, na_value); + case CMYK: return encode_impl(colour, alpha, white, out_fmt, na_value); + case HSL: return encode_impl(colour, alpha, white, out_fmt, na_value); + case HSB: return encode_impl(colour, alpha, white, out_fmt, na_value); + case HSV: return encode_impl(colour, alpha, white, out_fmt, na_value); + case LAB: return encode_impl(colour, alpha, white, out_fmt, na_value); + case HUNTERLAB: return encode_impl(colour, alpha, white, out_fmt, na_value); + case LCH: return encode_impl(colour, alpha, white, out_fmt, na_value); + case LUV: return encode_impl(colour, alpha, white, out_fmt, na_value); + case RGB: return encode_impl(colour, alpha, white, out_fmt, na_value); + case XYZ: return encode_impl(colour, alpha, white, out_fmt, na_value); + case YXY: return encode_impl(colour, alpha, white, out_fmt, na_value); + case HCL: return encode_impl(colour, alpha, white, out_fmt, na_value); + case OKLAB: return encode_impl(colour, alpha, white, out_fmt, na_value); + case OKLCH: return encode_impl(colour, alpha, white, out_fmt, na_value); } // never happens @@ -1251,8 +1278,20 @@ SEXP decode_channel_c(SEXP codes, SEXP channel, SEXP space, SEXP white, SEXP na) return R_NilValue; } -SEXP encode_native_c(SEXP color) { +SEXP encode_native_c(SEXP color, SEXP na_value) { int n = Rf_length(color); + switch(TYPEOF(color)) { + case STRSXP: + n = Rf_length(color); + break; + case CHARSXP: + n = 1; + break; + default: + Rf_error("color should be a character vector"); + } + int na_value_int; + get_na_value(na_value, &na_value_int); ColourMap& named_colours = get_named_colours(); SEXP natives = PROTECT(Rf_allocVector(INTSXP, n)); int* natives_p = INTEGER(natives); @@ -1260,9 +1299,14 @@ SEXP encode_native_c(SEXP color) { int nchar; bool has_alpha; for (int i = 0; i < n; ++i) { - SEXP code = STRING_ELT(color, i); + SEXP code; + if (TYPEOF(color) == STRSXP) { + code = STRING_ELT(color, i); + } else { + code = color; + } if (code == R_NaString || strcmp("NA", CHAR(code)) == 0) { - natives_p[i] = NA_INTEGER; + natives_p[i] = na_value_int; } const char* col = Rf_translateCharUTF8(code); if (col[0] == '#') { @@ -1281,14 +1325,16 @@ SEXP encode_native_c(SEXP color) { ColourMap::iterator it = named_colours.find(prepare_code(col)); if (it == named_colours.end()) { Rf_errorcall(R_NilValue, "Unknown colour name: %s", col); - natives_p[i] = NA_INTEGER; + natives_p[i] = na_value_int; } else { natives_p[i] = R_RGB(it->second.r, it->second.g, it->second.b); } } } - copy_names(color, natives); + if (TYPEOF(color) == STRSXP) { + copy_names(color, natives); + } UNPROTECT(1); return natives; } diff --git a/src/encode.h b/src/encode.h index 6e56ea4..bbde9d2 100644 --- a/src/encode.h +++ b/src/encode.h @@ -36,12 +36,12 @@ typedef std::unordered_map ColourMap; // Defined in init.cpp ColourMap& get_named_colours(); -SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt); +SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt, SEXP na_value); SEXP decode_c(SEXP codes, SEXP alpha, SEXP to, SEXP white, SEXP na); SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na); SEXP decode_channel_c(SEXP codes, SEXP channel, SEXP space, SEXP white, SEXP na); SEXP load_colour_names_c(SEXP name, SEXP value); -SEXP encode_native_c(SEXP color); +SEXP encode_native_c(SEXP color, SEXP na_value); SEXP decode_native_c(SEXP native); template diff --git a/src/init.cpp b/src/init.cpp index d7d1b82..f911767 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -15,12 +15,12 @@ ColourMap& get_named_colours() { static const R_CallMethodDef CallEntries[] = { {"farver_convert_c", (DL_FUNC) &convert_c, 5}, {"farver_compare_c", (DL_FUNC) &compare_c, 8}, - {"farver_encode_c", (DL_FUNC) &encode_c, 5}, + {"farver_encode_c", (DL_FUNC) &encode_c, 6}, {"farver_decode_c", (DL_FUNC) &decode_c, 5}, {"farver_encode_channel_c", (DL_FUNC) &encode_channel_c, 7}, {"farver_decode_channel_c", (DL_FUNC) &decode_channel_c, 5}, {"farver_load_colour_names_c", (DL_FUNC) &load_colour_names_c, 2}, - {"farver_encode_native_c", (DL_FUNC) &encode_native_c, 1}, + {"farver_encode_native_c", (DL_FUNC) &encode_native_c, 2}, {"farver_decode_native_c", (DL_FUNC) &decode_native_c, 1}, {NULL, NULL, 0} }; From 8eb78b68739858968119394a35bce9d48f6f9870 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 08:04:31 +0200 Subject: [PATCH 12/21] TEST: Add tests for na_value in encode_*() functions --- tests/testthat/test-encoding.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-encoding.R b/tests/testthat/test-encoding.R index 6207c3b..ab0e547 100644 --- a/tests/testthat/test-encoding.R +++ b/tests/testthat/test-encoding.R @@ -51,3 +51,22 @@ test_that("colours can be encoded from a list of channels", { expect_equal(encode_colour(data.frame(cols_cmy[,1], cols_cmy[,2], cols_cmy[,3]), from = 'cmy'), cols) }) + +test_that("can provide a colour to be used when NA are found", { + na_value <- "red" + cols_dec_na <- cols_dec + cols_dec_na[2,3] <- NA + cols_na <- cols + cols_na[2] <- NA + + expect_equal(encode_colour(cols_dec_na), cols_na) + cols_na[2] <- na_value + expect_equal(encode_colour(cols_dec_na, na_value = na_value), cols_na) + + native_cols_na <- native_cols + native_cols_na[2] <- NA + expect_equal(encode_native(cols_dec_na), native_cols_na) + native_cols_na[2] <- farver::encode_native(na_value) + expect_equal(encode_native(cols_dec_na, na_value = na_value), native_cols_na) +}) + From 67aa7bbfe84e7f71a9649f921ae86ec73bd2e148 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 08:04:45 +0200 Subject: [PATCH 13/21] DOC: devtools::document() --- man/encode_colour.Rd | 13 ++++++++++++- man/native_encoding.Rd | 7 ++++++- 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/man/encode_colour.Rd b/man/encode_colour.Rd index 39c49b4..1fb9200 100644 --- a/man/encode_colour.Rd +++ b/man/encode_colour.Rd @@ -4,7 +4,13 @@ \alias{encode_colour} \title{Encode colours into RGB hex-strings} \usage{ -encode_colour(colour, alpha = NULL, from = "rgb", white = "D65") +encode_colour( + colour, + alpha = NULL, + from = "rgb", + white = "D65", + na_value = NA_character_ +) } \arguments{ \item{colour}{A numeric matrix (or an object coercible to one) with colours @@ -25,6 +31,11 @@ or \code{"oklch"} (Polar form of oklab)} \item{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 \code{\link[=as_white_ref]{as_white_ref()}} allowed.} + +\item{na_value}{A valid colour string or \code{NA} to use when \code{colour} contains +\code{NA} elements or is invalid in the RGB space. The general approach in farver +is to carry \code{NA} values over, but if you want to mimick \code{\link[=col2rgb]{col2rgb()}} you should +set \code{na_value = 'transparent'}, i.e. treat \code{NA} as transparent white.} } \value{ A character vector with colours encoded as \verb{#RRGGBB(AA)} diff --git a/man/native_encoding.Rd b/man/native_encoding.Rd index 089ed18..ec1e37d 100644 --- a/man/native_encoding.Rd +++ b/man/native_encoding.Rd @@ -6,7 +6,7 @@ \alias{decode_native} \title{Convert to and from the R native colour representation} \usage{ -encode_native(colour, alpha = NULL, from = "rgb", white = "D65") +encode_native(colour, alpha = NULL, from = "rgb", white = "D65", na_value = NA) decode_native(colour) } @@ -28,6 +28,11 @@ or \code{"oklch"} (Polar form of oklab)} \item{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 \code{\link[=as_white_ref]{as_white_ref()}} allowed.} + +\item{na_value}{A valid colour string or \code{NA} to use when \code{colour} contains +\code{NA} elements or is invalid in the RGB space. The general approach in farver +is to carry \code{NA} values over, but if you want to mimick \code{\link[=col2rgb]{col2rgb()}} you should +set \code{na_value = 'transparent'}, i.e. treat \code{NA} as transparent white.} } \value{ \code{encode_native()} returns an integer vector and \code{decode_native()} From b855431ba55d3ba05f72d01ca63a500b55590902 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 08:05:08 +0200 Subject: [PATCH 14/21] NEWS: Add entry for na_value support --- NEWS.md | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index c96e62b..4bf931d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,7 +5,12 @@ 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 (#375, @zeehio). + 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 From 736863d37430f4df0d4909744ef2a9d471516e13 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 18:09:52 +0200 Subject: [PATCH 15/21] FEAT: Provide modify channel functions for native colour encoding --- R/modify.R | 8 +- R/modify_native.R | 68 +++++++++++++ src/encode.cpp | 249 ++++++++++++++++++++++++++++++++++++++++++++++ src/encode.h | 1 + src/init.cpp | 1 + 5 files changed, 324 insertions(+), 3 deletions(-) create mode 100644 R/modify_native.R diff --git a/R/modify.R b/R/modify.R index 84ea223..8ac10d3 100644 --- a/R/modify.R +++ b/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 diff --git a/R/modify_native.R b/R/modify_native.R new file mode 100644 index 0000000..881e4d6 --- /dev/null +++ b/R/modify_native.R @@ -0,0 +1,68 @@ +#' @rdname manip_channel +#' @export +set_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { + if (space != 'rgb') { + white <- as_white_ref(white) + } + encode_channel_native_c(colour, channel, value, space, 1L, white, na_value) +} + +#' @rdname manip_channel +#' @export +add_to_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { + if (space != 'rgb') { + white <- as_white_ref(white) + } + encode_channel_native_c(colour, channel, value, space, 2L, white, na_value) +} + +#' @rdname manip_channel +#' @export +multiply_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { + if (space != 'rgb') { + white <- as_white_ref(white) + } + encode_channel_native_c(colour, channel, value, space, 3L, white, na_value) +} + +#' @rdname manip_channel +#' @export +raise_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { + if (space != 'rgb') { + white <- as_white_ref(white) + } + encode_channel_native_c(colour, channel, value, space, 4L, white, na_value) +} + +#' @rdname manip_channel +#' @export +cap_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { + if (space != 'rgb') { + white <- as_white_ref(white) + } + encode_channel_native_c(colour, channel, value, space, 5L, white, na_value) +} + +encode_channel_native_c <- function(colour, channel, value, space, op, white, na_value) { + 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) + } + + .Call(`farver_encode_channel_native_c`, colour, as.integer(channel), value, as.integer(space), as.integer(op), white, as.character(na_value)) +} diff --git a/src/encode.cpp b/src/encode.cpp index 189d521..8144f45 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -1076,6 +1076,255 @@ SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, return R_NilValue; } + +template +SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { + int chan = INTEGER(channel)[0]; + int operation = INTEGER(op)[0]; + int n = Rf_length(codes); + + bool one_value = Rf_length(value) == 1; + int first_value_i = 0; + double first_value_d = 0.0; + int* value_i = NULL; + double* value_d = NULL; + bool value_is_int = Rf_isInteger(value); + if (value_is_int) { + value_i = INTEGER(value); + first_value_i = value_i[0]; + } else { + value_d = REAL(value); + first_value_d = value_d[0]; + } + + SEXP na_code = STRING_ELT(na, 0); + int na_int = R_NaInt; + get_na_value(na, &na_int); + bool na_is_na = na_int == R_NaInt; + + if (TYPEOF(codes) != INTSXP) { + Rf_error("Expected an integer vector"); + } + int *codes_int = INTEGER(codes); + SEXP ret = PROTECT(Rf_allocVector(INTSXP, n)); + int *ret_int = INTEGER(ret); + + ColorSpace::Rgb rgb; + ColorSpace::XyzConverter::SetWhiteReference(REAL(white)[0], REAL(white)[1], REAL(white)[2]); + Space colour; + int num, alpha; + ColourMap& named_colours = get_named_colours(); + + for (int i = 0; i < n; ++i) { + int code = codes_int[i]; + if (code == R_NaInt) { + if (na_is_na) { + ret_int[i] = R_NaInt; + continue; + } + code = na_int; + } + + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + ret_int[i] = R_NaInt; + continue; + } + rgb.r = code & 0xFF; + rgb.g = (code >> 8) & 0xFF; + rgb.b = (code >> 16) & 0xFF; + alpha = (code >> 24) & 0xFF; + + ColorSpace::IConverter::ToColorSpace(&rgb, &colour); + if (value_is_int) { + modify_channel(colour, one_value ? first_value_i : value_i[i], chan, operation); + } else { + modify_channel(colour, one_value ? first_value_d : value_d[i], chan, operation); + } + colour.Cap(); + colour.ToRgb(&rgb); + + if (!(R_finite(rgb.r) && R_finite(rgb.g) && R_finite(rgb.b))) { + ret_int[i] = R_NaInt; + continue; + } + ret_int[i] = ( + cap0255(double2int(rgb.r)) + + (cap0255(double2int(rgb.g)) << 8) + + (cap0255(double2int(rgb.b)) << 16) + + (alpha << 24) + ); + } + + copy_names(codes, ret); + UNPROTECT(1); + return ret; +} + +template <> +SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { + int chan = INTEGER(channel)[0]; + int operation = INTEGER(op)[0]; + int n = Rf_length(codes); + + bool one_value = Rf_length(value) == 1; + int first_value_i = 0; + double first_value_d = 0.0; + int* value_i = NULL; + double* value_d = NULL; + bool value_is_int = Rf_isInteger(value); + if (value_is_int) { + value_i = INTEGER(value); + first_value_i = value_i[0]; + } else { + value_d = REAL(value); + first_value_d = value_d[0]; + } + + SEXP na_code = STRING_ELT(na, 0); + int na_int = R_NaInt; + get_na_value(na, &na_int); + bool na_is_na = na_int == R_NaInt; + + if (TYPEOF(codes) != INTSXP) { + Rf_error("Expected an integer vector"); + } + int *codes_int = INTEGER(codes); + SEXP ret = PROTECT(Rf_allocVector(INTSXP, n)); + int *ret_int = INTEGER(ret); + + int num, nchar; + int r, g, b, alpha; + double new_val; + ColourMap& named_colours = get_named_colours(); + + for (int i = 0; i < n; ++i) { + int code = codes_int[i]; + if (code == R_NaInt) { + if (na_is_na) { + ret_int[i] = R_NaInt; + continue; + } + code = na_int; + } + + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + ret_int[i] = R_NaInt; + continue; + } + r = code & 0xFF; + g = (code >> 8) & 0xFF; + b = (code >> 16) & 0xFF; + alpha = (code >> 24) & 0xFF; + + switch (chan) { + case 1: + r = mod_val(r, value_is_int ? (one_value ? first_value_i : value_i[i]) : (one_value ? first_value_d : value_d[i]), operation); // Sometimes I really hate myself + break; + case 2: + g = mod_val(g, value_is_int ? (one_value ? first_value_i : value_i[i]) : (one_value ? first_value_d : value_d[i]), operation); + break; + case 3: + b = mod_val(b, value_is_int ? (one_value ? first_value_i : value_i[i]) : (one_value ? first_value_d : value_d[i]), operation); + break; + } + ret_int[i] = ( + cap0255(r) + + (cap0255(g) << 8) + + (cap0255(b) << 16) + + (alpha << 24) + ); + } + + copy_names(codes, ret); + UNPROTECT(1); + return ret; +} + + +SEXP encode_alpha_native_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { + int operation = INTEGER(op)[0]; + int n = Rf_length(codes); + + bool one_value = Rf_length(value) == 1; + int first_value_i = 0; + double first_value_d = 0.0; + int* value_i = NULL; + double* value_d = NULL; + bool value_is_int = Rf_isInteger(value); + if (value_is_int) { + value_i = INTEGER(value); + first_value_i = value_i[0]; + } else { + value_d = REAL(value); + first_value_d = value_d[0]; + } + + int na_int = R_NaInt; + get_na_value(na, &na_int); + + if (TYPEOF(codes) != INTSXP) { + Rf_error("Expected an integer vector"); + } + int *codes_int = INTEGER(codes); + SEXP ret = PROTECT(Rf_allocVector(INTSXP, n)); + int *ret_int = INTEGER(ret); + int alpha; + + for (int i = 0; i < n; ++i) { + int code = codes_int[i]; + if (code == R_NaInt) { + if (na_int == R_NaInt) { + ret_int[i] = na_int; + continue; + } + code = na_int; + } + + alpha = (code >> 24) & 0xFF; + + if (value_is_int) { + alpha = double2int(mod_val(alpha / 255.0, one_value ? first_value_i : value_i[i], operation) * 255.0); + } else { + alpha = double2int(mod_val(alpha / 255.0, one_value ? first_value_d : value_d[i], operation) * 255.0); + } + alpha = cap0255(alpha); + ret_int[i] = (alpha << 24) | ( code & 0x00FFFFFF); + } + + copy_names(codes, ret); + UNPROTECT(1); + return ret; +} + + +SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na) { + if (INTEGER(channel)[0] == 0) { + return encode_alpha_native_impl(codes, value, op, na); + } + switch (INTEGER(space)[0]) { + case CMY: return encode_channel_native_impl(codes, channel, value, op, white, na); + case CMYK: return encode_channel_native_impl(codes, channel, value, op, white, na); + case HSL: return encode_channel_native_impl(codes, channel, value, op, white, na); + case HSB: return encode_channel_native_impl(codes, channel, value, op, white, na); + case HSV: return encode_channel_native_impl(codes, channel, value, op, white, na); + case LAB: return encode_channel_native_impl(codes, channel, value, op, white, na); + case HUNTERLAB: return encode_channel_native_impl(codes, channel, value, op, white, na); + case LCH: return encode_channel_native_impl(codes, channel, value, op, white, na); + case LUV: return encode_channel_native_impl(codes, channel, value, op, white, na); + case RGB: return encode_channel_native_impl(codes, channel, value, op, white, na); + case XYZ: return encode_channel_native_impl(codes, channel, value, op, white, na); + case YXY: return encode_channel_native_impl(codes, channel, value, op, white, na); + case HCL: return encode_channel_native_impl(codes, channel, value, op, white, na); + case OKLAB: return encode_channel_native_impl(codes, channel, value, op, white, na); + case OKLCH: return encode_channel_native_impl(codes, channel, value, op, white, na); + } + + // never happens + return R_NilValue; +} + template SEXP decode_channel_impl(SEXP codes, SEXP channel, SEXP white, SEXP na) { int chan = INTEGER(channel)[0]; diff --git a/src/encode.h b/src/encode.h index bbde9d2..8ef2011 100644 --- a/src/encode.h +++ b/src/encode.h @@ -43,6 +43,7 @@ SEXP decode_channel_c(SEXP codes, SEXP channel, SEXP space, SEXP white, SEXP na) SEXP load_colour_names_c(SEXP name, SEXP value); SEXP encode_native_c(SEXP color, SEXP na_value); SEXP decode_native_c(SEXP native); +SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na); template inline void modify_channel(Space&, double value, int channel, int op); diff --git a/src/init.cpp b/src/init.cpp index f911767..f3505a2 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -22,6 +22,7 @@ static const R_CallMethodDef CallEntries[] = { {"farver_load_colour_names_c", (DL_FUNC) &load_colour_names_c, 2}, {"farver_encode_native_c", (DL_FUNC) &encode_native_c, 2}, {"farver_decode_native_c", (DL_FUNC) &decode_native_c, 1}, + {"farver_encode_channel_native_c", (DL_FUNC) &encode_channel_native_c, 7}, {NULL, NULL, 0} }; From 0a1dd209af8fd764a768b38f787cb8a4c4d042fb Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 18:10:47 +0200 Subject: [PATCH 16/21] TEST: Add tests for modify channels in native encoding --- tests/testthat/test-manip.R | 58 +++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) diff --git a/tests/testthat/test-manip.R b/tests/testthat/test-manip.R index 147bc07..f83f632 100644 --- a/tests/testthat/test-manip.R +++ b/tests/testthat/test-manip.R @@ -10,6 +10,10 @@ cols_mod <- cols cols_lch <- convert_colour(cols, 'rgb' ,'lch') cols_lch_mod <- cols_lch +codes_native <- encode_native(codes) +codes_native_alpha <- encode_native(codes_alpha) + + test_that("setting channel works", { cols_mod[, 'g'] <- 1:10 expect_equal(set_channel(codes, 'g', 1:10), encode_colour(cols_mod)) @@ -60,3 +64,57 @@ test_that("capping channel works", { expect_equal(cap_channel(codes_alpha, 'alpha', 0.5), encode_colour(cols, alpha = ifelse(alpha > 0.5, 0.5, alpha))) }) + +## Native variants: + +test_that("setting channel native works", { + cols_mod[, 'g'] <- 1:10 + expect_equal(set_channel_native(codes_native, 'g', 1:10), encode_native(cols_mod)) + + cols_lch_mod[, 'l'] <- 1:10 + expect_equal(set_channel_native(codes_native, 'l', 1:10, 'lch'), encode_native(cols_lch_mod, from = 'lch')) + + expect_equal(set_channel_native(codes_native, 'alpha', (1:10)/10), encode_native(cols, alpha = (1:10)/10)) +}) + +test_that("adding channel works", { + cols_mod[, 'r'] <- cols_mod[, 'r'] + 1:10 + expect_equal(add_to_channel_native(codes_native, 'r', 1:10), encode_native(cols_mod)) + + cols_lch_mod[, 'c'] <- cols_lch_mod[, 'c'] + 1:10 + expect_equal(add_to_channel_native(codes_native, 'c', 1:10, 'lch'), encode_native(cols_lch_mod, from = 'lch')) + + skip_on_os('linux') # Rounding difference on someones aarch64/ppc64le processor + expect_equal(add_to_channel_native(codes_native_alpha, 'alpha', (1:10)/10), encode_native(cols, alpha = alpha + (1:10)/10)) +}) + + +test_that("multiply channel works", { + cols_mod[, 'b'] <- cols_mod[, 'b'] * 1:10 + expect_equal(multiply_channel_native(codes_native, 'b', 1:10), encode_native(cols_mod)) + + cols_lch_mod[, 'h'] <- cols_lch_mod[, 'h'] * 1:10 + expect_equal(multiply_channel_native(codes_native, 'h', 1:10, 'lch'), encode_native(cols_lch_mod, from = 'lch')) + + expect_equal(multiply_channel_native(codes_native_alpha, 'alpha', 1:10), encode_native(cols, alpha = alpha * 1:10)) +}) + +test_that("raising channel works", { + cols_mod[, 'g'] <- ifelse(cols_mod[, 'g'] < 200, 200, cols_mod[, 'g']) + expect_equal(raise_channel_native(codes_native, 'g', 200), encode_native(cols_mod)) + + cols_lch_mod[, 'l'] <- ifelse(cols_lch_mod[, 'l'] < 50, 50, cols_lch_mod[, 'l']) + expect_equal(raise_channel_native(codes_native, 'l', 50, 'lch'), encode_native(cols_lch_mod, from = 'lch')) + + expect_equal(raise_channel_native(codes_native_alpha, 'alpha', 0.5), encode_native(cols, alpha = ifelse(alpha < 0.5, 0.5, alpha))) +}) + +test_that("capping channel works", { + cols_mod[, 'g'] <- ifelse(cols_mod[, 'g'] > 200, 200, cols_mod[, 'g']) + expect_equal(cap_channel_native(codes_native, 'g', 200), encode_native(cols_mod)) + + cols_lch_mod[, 'l'] <- ifelse(cols_lch_mod[, 'l'] > 50, 50, cols_lch_mod[, 'l']) + expect_equal(cap_channel_native(codes_native, 'l', 50, 'lch'), encode_native(cols_lch_mod, from = 'lch')) + + expect_equal(cap_channel_native(codes_native_alpha, 'alpha', 0.5), encode_native(cols, alpha = ifelse(alpha > 0.5, 0.5, alpha))) +}) From b6418df9ed64cc7b00b68408bfdefd74cd7ed63c Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Mon, 19 Sep 2022 18:10:58 +0200 Subject: [PATCH 17/21] DOCUMENT: devtools::document() --- NAMESPACE | 5 ++++ man/manip_channel.Rd | 60 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 61 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ff87945..c845dee 100644 --- a/NAMESPACE +++ b/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) diff --git a/man/manip_channel.Rd b/man/manip_channel.Rd index 4b5bf15..c67e4c2 100644 --- a/man/manip_channel.Rd +++ b/man/manip_channel.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/modify.R +% Please edit documentation in R/modify.R, R/modify_native.R \name{manip_channel} \alias{manip_channel} \alias{set_channel} @@ -8,6 +8,11 @@ \alias{raise_channel} \alias{cap_channel} \alias{get_channel} +\alias{set_channel_native} +\alias{add_to_channel_native} +\alias{multiply_channel_native} +\alias{raise_channel_native} +\alias{cap_channel_native} \title{Modify colour space channels in hex-encoded colour strings} \usage{ set_channel( @@ -56,10 +61,56 @@ cap_channel( ) get_channel(colour, channel, space = "rgb", white = "D65", na_value = NA) + +set_channel_native( + colour, + channel, + value, + space = "rgb", + white = "D65", + na_value = NA +) + +add_to_channel_native( + colour, + channel, + value, + space = "rgb", + white = "D65", + na_value = NA +) + +multiply_channel_native( + colour, + channel, + value, + space = "rgb", + white = "D65", + na_value = NA +) + +raise_channel_native( + colour, + channel, + value, + space = "rgb", + white = "D65", + na_value = NA +) + +cap_channel_native( + colour, + channel, + value, + space = "rgb", + white = "D65", + na_value = NA +) } \arguments{ \item{colour}{A character string giving colours, either as hexadecimal -strings or accepted colour names.} +strings or accepted colour names. The \verb{_native} functions expect an integer +vector, describing colours in \link{native-encoding} format.} \item{channel}{The channel to modify or extract as a single letter, or \code{'alpha'} for the alpha channel.} @@ -87,8 +138,9 @@ vector in the case of \code{get_channel()}) } \description{ 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 \verb{_native} functions provide +the same feature on \link{native-encoding} colours. } \examples{ spectrum <- rainbow(10) From d5a458a4b25fc7e59ddec1eb065173dba19f0a5c Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Tue, 20 Sep 2022 07:30:14 +0200 Subject: [PATCH 18/21] Feat: Specify behaviour for modifying functions when value is NA When a replacement value is `NA`, two behaviours may be expected: - Set the colour to `NA` - Ignore the modification and leave the colour as it was Here we introduce skip_na_values. If `FALSE` (the default), when the replacement value is NA we set the colour to NA. If `TRUE`, when the replacement value is NA we leave the colour unmodified. --- R/modify.R | 41 +++++++---- R/modify_native.R | 25 +++---- src/encode.cpp | 174 +++++++++++++++++++++++++++++----------------- src/encode.h | 4 +- src/init.cpp | 4 +- 5 files changed, 155 insertions(+), 93 deletions(-) diff --git a/R/modify.R b/R/modify.R index 8ac10d3..acc6b94 100644 --- a/R/modify.R +++ b/R/modify.R @@ -23,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()`) @@ -40,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') @@ -60,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 @@ -112,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 @@ -128,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) { diff --git a/R/modify_native.R b/R/modify_native.R index 881e4d6..51f03ba 100644 --- a/R/modify_native.R +++ b/R/modify_native.R @@ -1,49 +1,49 @@ #' @rdname manip_channel #' @export -set_channel_native <- function(colour, channel, value, space = 'rgb', white = 'D65', na_value = NA) { +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) + 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) { +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) + 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) { +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) + 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) { +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) + 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) { +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) + 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) { +encode_channel_native_c <- function(colour, channel, value, space, op, white, na_value, skip_na_values) { if (length(colour) == 0) { return(colour) } @@ -63,6 +63,7 @@ encode_channel_native_c <- function(colour, channel, value, space, op, white, na 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)) + .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) } diff --git a/src/encode.cpp b/src/encode.cpp index 8144f45..b67c2a7 100644 --- a/src/encode.cpp +++ b/src/encode.cpp @@ -753,11 +753,13 @@ SEXP decode_c(SEXP codes, SEXP alpha, SEXP to, SEXP white, SEXP na) { } template -SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { int chan = INTEGER(channel)[0]; int operation = INTEGER(op)[0]; int n = Rf_length(codes); + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; + bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -784,6 +786,15 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP whi for (int i = 0; i < n; ++i) { SEXP code = STRING_ELT(codes, i); + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + SET_STRING_ELT(ret, i, code); + } else { + SET_STRING_ELT(ret, i, R_NaString); + } + continue; + } if (code == R_NaString || strcmp("NA", CHAR(code)) == 0) { if (na_is_na) { SET_STRING_ELT(ret, i, R_NaString); @@ -791,11 +802,6 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP whi } code = na_code; } - if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || - (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { - SET_STRING_ELT(ret, i, R_NaString); - continue; - } const char* col = CHAR(code); if (col[0] == '#') { nchar = strlen(col); @@ -855,11 +861,13 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP whi } template <> -SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { int chan = INTEGER(channel)[0]; int operation = INTEGER(op)[0]; int n = Rf_length(codes); + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; + bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -884,6 +892,15 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, for (int i = 0; i < n; ++i) { SEXP code = STRING_ELT(codes, i); + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + SET_STRING_ELT(ret, i, code); + } else { + SET_STRING_ELT(ret, i, R_NaString); + } + continue; + } if (code == R_NaString || strcmp("NA", CHAR(code)) == 0) { if (na_is_na) { SET_STRING_ELT(ret, i, R_NaString); @@ -891,11 +908,6 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, } code = na_code; } - if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || - (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { - SET_STRING_ELT(ret, i, R_NaString); - continue; - } const char* col = CHAR(code); if (col[0] == '#') { nchar = strlen(col); @@ -960,10 +972,10 @@ SEXP encode_channel_impl(SEXP codes, SEXP channel, SEXP value, return ret; } -SEXP encode_alpha_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { +SEXP encode_alpha_impl(SEXP codes, SEXP value, SEXP op, SEXP na, SEXP skip_na_values) { int operation = INTEGER(op)[0]; int n = Rf_length(codes); - + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -987,6 +999,15 @@ SEXP encode_alpha_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { for (int i = 0; i < n; ++i) { SEXP code = STRING_ELT(codes, i); + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + SET_STRING_ELT(ret, i, code); + } else { + SET_STRING_ELT(ret, i, R_NaString); + } + continue; + } if (code == R_NaString || strcmp("NA", CHAR(code)) == 0) { if (na_is_na) { SET_STRING_ELT(ret, i, R_NaString); @@ -1050,26 +1071,26 @@ SEXP encode_alpha_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { return ret; } -SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { if (INTEGER(channel)[0] == 0) { - return encode_alpha_impl(codes, value, op, na); + return encode_alpha_impl(codes, value, op, na, skip_na_values); } switch (INTEGER(space)[0]) { - case CMY: return encode_channel_impl(codes, channel, value, op, white, na); - case CMYK: return encode_channel_impl(codes, channel, value, op, white, na); - case HSL: return encode_channel_impl(codes, channel, value, op, white, na); - case HSB: return encode_channel_impl(codes, channel, value, op, white, na); - case HSV: return encode_channel_impl(codes, channel, value, op, white, na); - case LAB: return encode_channel_impl(codes, channel, value, op, white, na); - case HUNTERLAB: return encode_channel_impl(codes, channel, value, op, white, na); - case LCH: return encode_channel_impl(codes, channel, value, op, white, na); - case LUV: return encode_channel_impl(codes, channel, value, op, white, na); - case RGB: return encode_channel_impl(codes, channel, value, op, white, na); - case XYZ: return encode_channel_impl(codes, channel, value, op, white, na); - case YXY: return encode_channel_impl(codes, channel, value, op, white, na); - case HCL: return encode_channel_impl(codes, channel, value, op, white, na); - case OKLAB: return encode_channel_impl(codes, channel, value, op, white, na); - case OKLCH: return encode_channel_impl(codes, channel, value, op, white, na); + case CMY: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case CMYK: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case HSL: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case HSB: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case HSV: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case LAB: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case HUNTERLAB: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case LCH: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case LUV: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case RGB: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case XYZ: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case YXY: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case HCL: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case OKLAB: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); + case OKLCH: return encode_channel_impl(codes, channel, value, op, white, na, skip_na_values); } // never happens @@ -1078,11 +1099,13 @@ SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, template -SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { int chan = INTEGER(channel)[0]; int operation = INTEGER(op)[0]; int n = Rf_length(codes); + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; + bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -1117,6 +1140,16 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, S for (int i = 0; i < n; ++i) { int code = codes_int[i]; + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + ret_int[i] = code; + } else { + ret_int[i] = R_NaInt; + } + continue; + } + if (code == R_NaInt) { if (na_is_na) { ret_int[i] = R_NaInt; @@ -1125,11 +1158,6 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, S code = na_int; } - if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || - (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { - ret_int[i] = R_NaInt; - continue; - } rgb.r = code & 0xFF; rgb.g = (code >> 8) & 0xFF; rgb.b = (code >> 16) & 0xFF; @@ -1162,11 +1190,13 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, S } template <> -SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP value, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { int chan = INTEGER(channel)[0]; int operation = INTEGER(op)[0]; int n = Rf_length(codes); - + + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; + bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -1200,6 +1230,15 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP for (int i = 0; i < n; ++i) { int code = codes_int[i]; + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + ret_int[i] = code; + } else { + ret_int[i] = R_NaInt; + } + continue; + } if (code == R_NaInt) { if (na_is_na) { ret_int[i] = R_NaInt; @@ -1207,12 +1246,7 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP } code = na_int; } - - if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || - (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { - ret_int[i] = R_NaInt; - continue; - } + r = code & 0xFF; g = (code >> 8) & 0xFF; b = (code >> 16) & 0xFF; @@ -1243,10 +1277,12 @@ SEXP encode_channel_native_impl(SEXP codes, SEXP channel, SEXP } -SEXP encode_alpha_native_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { +SEXP encode_alpha_native_impl(SEXP codes, SEXP value, SEXP op, SEXP na, SEXP skip_na_values) { int operation = INTEGER(op)[0]; int n = Rf_length(codes); - + + bool skip_na_values_lgl = INTEGER(skip_na_values)[0]; + bool one_value = Rf_length(value) == 1; int first_value_i = 0; double first_value_d = 0.0; @@ -1274,6 +1310,16 @@ SEXP encode_alpha_native_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { for (int i = 0; i < n; ++i) { int code = codes_int[i]; + if ((value_is_int && (one_value ? first_value_i : value_i[i]) == R_NaInt) || + (!value_is_int && !R_finite(one_value ? first_value_d : value_d[i]))) { + if (skip_na_values_lgl) { + ret_int[i] = code; + } else { + ret_int[i] = R_NaInt; + } + continue; + } + if (code == R_NaInt) { if (na_int == R_NaInt) { ret_int[i] = na_int; @@ -1299,26 +1345,26 @@ SEXP encode_alpha_native_impl(SEXP codes, SEXP value, SEXP op, SEXP na) { } -SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na) { +SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na, SEXP skip_na_values) { if (INTEGER(channel)[0] == 0) { - return encode_alpha_native_impl(codes, value, op, na); + return encode_alpha_native_impl(codes, value, op, na, skip_na_values); } switch (INTEGER(space)[0]) { - case CMY: return encode_channel_native_impl(codes, channel, value, op, white, na); - case CMYK: return encode_channel_native_impl(codes, channel, value, op, white, na); - case HSL: return encode_channel_native_impl(codes, channel, value, op, white, na); - case HSB: return encode_channel_native_impl(codes, channel, value, op, white, na); - case HSV: return encode_channel_native_impl(codes, channel, value, op, white, na); - case LAB: return encode_channel_native_impl(codes, channel, value, op, white, na); - case HUNTERLAB: return encode_channel_native_impl(codes, channel, value, op, white, na); - case LCH: return encode_channel_native_impl(codes, channel, value, op, white, na); - case LUV: return encode_channel_native_impl(codes, channel, value, op, white, na); - case RGB: return encode_channel_native_impl(codes, channel, value, op, white, na); - case XYZ: return encode_channel_native_impl(codes, channel, value, op, white, na); - case YXY: return encode_channel_native_impl(codes, channel, value, op, white, na); - case HCL: return encode_channel_native_impl(codes, channel, value, op, white, na); - case OKLAB: return encode_channel_native_impl(codes, channel, value, op, white, na); - case OKLCH: return encode_channel_native_impl(codes, channel, value, op, white, na); + case CMY: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case CMYK: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case HSL: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case HSB: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case HSV: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case LAB: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case HUNTERLAB: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case LCH: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case LUV: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case RGB: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case XYZ: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case YXY: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case HCL: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case OKLAB: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); + case OKLCH: return encode_channel_native_impl(codes, channel, value, op, white, na, skip_na_values); } // never happens diff --git a/src/encode.h b/src/encode.h index 8ef2011..64a21ba 100644 --- a/src/encode.h +++ b/src/encode.h @@ -38,12 +38,12 @@ ColourMap& get_named_colours(); SEXP encode_c(SEXP colour, SEXP alpha, SEXP from, SEXP white, SEXP out_fmt, SEXP na_value); SEXP decode_c(SEXP codes, SEXP alpha, SEXP to, SEXP white, SEXP na); -SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na); +SEXP encode_channel_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na, SEXP skip_na_values); SEXP decode_channel_c(SEXP codes, SEXP channel, SEXP space, SEXP white, SEXP na); SEXP load_colour_names_c(SEXP name, SEXP value); SEXP encode_native_c(SEXP color, SEXP na_value); SEXP decode_native_c(SEXP native); -SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na); +SEXP encode_channel_native_c(SEXP codes, SEXP channel, SEXP value, SEXP space, SEXP op, SEXP white, SEXP na, SEXP skip_na_values); template inline void modify_channel(Space&, double value, int channel, int op); diff --git a/src/init.cpp b/src/init.cpp index f3505a2..5933519 100644 --- a/src/init.cpp +++ b/src/init.cpp @@ -17,12 +17,12 @@ static const R_CallMethodDef CallEntries[] = { {"farver_compare_c", (DL_FUNC) &compare_c, 8}, {"farver_encode_c", (DL_FUNC) &encode_c, 6}, {"farver_decode_c", (DL_FUNC) &decode_c, 5}, - {"farver_encode_channel_c", (DL_FUNC) &encode_channel_c, 7}, + {"farver_encode_channel_c", (DL_FUNC) &encode_channel_c, 8}, {"farver_decode_channel_c", (DL_FUNC) &decode_channel_c, 5}, {"farver_load_colour_names_c", (DL_FUNC) &load_colour_names_c, 2}, {"farver_encode_native_c", (DL_FUNC) &encode_native_c, 2}, {"farver_decode_native_c", (DL_FUNC) &decode_native_c, 1}, - {"farver_encode_channel_native_c", (DL_FUNC) &encode_channel_native_c, 7}, + {"farver_encode_channel_native_c", (DL_FUNC) &encode_channel_native_c, 8}, {NULL, NULL, 0} }; From 9ca6d1c0c578bcbc5c50598b552607776b15e13f Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Tue, 20 Sep 2022 07:34:36 +0200 Subject: [PATCH 19/21] Test: Handle missing values in modifications --- tests/testthat/test-manip.R | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/tests/testthat/test-manip.R b/tests/testthat/test-manip.R index f83f632..a123705 100644 --- a/tests/testthat/test-manip.R +++ b/tests/testthat/test-manip.R @@ -14,6 +14,21 @@ codes_native <- encode_native(codes) codes_native_alpha <- encode_native(codes_alpha) +test_that("setting channel sets colour to NA if modification value is NA", { + cols_mod[, 'g'] <- 1:10 + expected <- encode_colour(cols_mod) + expected[2] <- NA + expect_equal(set_channel(codes, 'g', c(1L, NA, 3:10)), expected) +}) + +test_that("setting channel leaves colour as it was if modification value is NA and skip_na_values is TRUE", { + cols_mod[, 'g'] <- 1:10 + expected <- encode_colour(cols_mod) + expected[2] <- codes[2] + expect_equal(set_channel(codes, 'g', c(1L, NA, 3:10), skip_na_values = TRUE), expected) +}) + + test_that("setting channel works", { cols_mod[, 'g'] <- 1:10 expect_equal(set_channel(codes, 'g', 1:10), encode_colour(cols_mod)) @@ -77,6 +92,22 @@ test_that("setting channel native works", { expect_equal(set_channel_native(codes_native, 'alpha', (1:10)/10), encode_native(cols, alpha = (1:10)/10)) }) + +test_that("setting channel native sets colour to NA if modification value is NA", { + cols_mod[, 'g'] <- 1:10 + expected <- encode_native(cols_mod) + expected[2] <- NA + expect_equal(set_channel_native(codes_native, 'g', c(1L, NA, 3:10)), expected) +}) + +test_that("setting channel native leaves colour as it was if modification value is NA and skip_na_values is TRUE", { + cols_mod[, 'g'] <- 1:10 + expected <- encode_native(cols_mod) + expected[2] <- codes_native[2] + expect_equal(set_channel_native(codes_native, 'g', c(1L, NA, 3:10), skip_na_values = TRUE), expected) +}) + + test_that("adding channel works", { cols_mod[, 'r'] <- cols_mod[, 'r'] + 1:10 expect_equal(add_to_channel_native(codes_native, 'r', 1:10), encode_native(cols_mod)) From 81435e3a263543f33d17257025f75076e092d18a Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Tue, 20 Sep 2022 07:34:52 +0200 Subject: [PATCH 20/21] Doc: devtools::document() --- man/manip_channel.Rd | 39 +++++++++++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 10 deletions(-) diff --git a/man/manip_channel.Rd b/man/manip_channel.Rd index c67e4c2..dd91fde 100644 --- a/man/manip_channel.Rd +++ b/man/manip_channel.Rd @@ -21,7 +21,8 @@ set_channel( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) add_to_channel( @@ -30,7 +31,8 @@ add_to_channel( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) multiply_channel( @@ -39,7 +41,8 @@ multiply_channel( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) raise_channel( @@ -48,7 +51,8 @@ raise_channel( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) cap_channel( @@ -57,7 +61,8 @@ cap_channel( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) get_channel(colour, channel, space = "rgb", white = "D65", na_value = NA) @@ -68,7 +73,8 @@ set_channel_native( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) add_to_channel_native( @@ -77,7 +83,8 @@ add_to_channel_native( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) multiply_channel_native( @@ -86,7 +93,8 @@ multiply_channel_native( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) raise_channel_native( @@ -95,7 +103,8 @@ raise_channel_native( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) cap_channel_native( @@ -104,7 +113,8 @@ cap_channel_native( value, space = "rgb", white = "D65", - na_value = NA + na_value = NA, + skip_na_values = FALSE ) } \arguments{ @@ -131,6 +141,10 @@ by \code{\link[=as_white_ref]{as_white_ref()}} allowed.} \code{NA} elements. The general approach in farver is to carry \code{NA} values over, but if you want to mimick \code{\link[=col2rgb]{col2rgb()}} you should set \code{na_value = 'transparent'}, i.e. treat \code{NA} as transparent white.} + +\item{skip_na_values}{By default (\code{skip_na_values = FALSE}), if \code{value} is \code{NA} the colour +will be set to \code{NA}. If \code{skip_na_values} is \code{TRUE} and the \code{value} to modify with +is \code{NA}, the colour won't be modified.} } \value{ A character vector of the same length as \code{colour} (or a numeric @@ -150,6 +164,11 @@ set_channel(spectrum, 'r', c(10, 50)) 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') From 8624c8ccfa5d0fad6c5dd1e6d520c5f82f40f441 Mon Sep 17 00:00:00 2001 From: Sergio Oller Date: Fri, 23 Sep 2022 03:05:17 +0200 Subject: [PATCH 21/21] Bump development version So I can depend on these patches on my Remotes: --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index de50e3a..e265482 100644 --- a/DESCRIPTION +++ b/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")),