Merge branch 'feat/simplify-applyhsv-col-func' into dev

NAMESPACE

@@ -4,7 +4,7 @@ export(HSVtoRGB)
 export(RGBtoHSV)
 export(RGBtosRGB)
 export(adjacency)
-export(change_pixel_color_HSV)
+export(apply_HSV_color_by_mask)
 export(convert_pixels_to_area)
 export(diagonal_adjacency)
 export(extract_pixels_HSV)

R/change_pixel_color_HSV.R → R/apply_HSV_color_by_mask.R

@@ -1,4 +1,11 @@
-#' handles color-translation from character-name to hsv and returns results of `duflor::apply_hsv_color_to_image_subset()`
+#' apply color to pixel.array by mask.
+#'
+#' If `target.color` is a character-string (e.g. `"red1"`) are members of `colors()`,
+#' it will be translated into its HSV-representation.
+#' If `target.color` is a vector of RGB-values, it gets translated into its
+#' HSV-representation.
+#' The resulting HSV-color will be applied to all elements of `pixel.array`
+#' which are members of `pixel.idx` are translated to their HSV-representation.
 #'
 #' Values for `target.color` which lie outside the RGB-range of `[0-255,0-255,0-255]` will be
 #' constricted to limits of the range `[0,255]`
@@ -9,7 +16,7 @@
 #' @importFrom grDevices colors
 #' @export
 #'
-change_pixel_color_HSV <- function(pixel.array, pixel.idx, target.color, mask_extreme) {
+apply_HSV_color_by_mask <- function(pixel.array, pixel.idx, target.color, mask_extreme) {
 
     if (is.character(target.color)) {
         if (sum(is.element(colors(),target.color))==0) { # color is not part of the available color set from grDevices, thus error out descriptively
@@ -36,5 +43,17 @@ change_pixel_color_HSV <- function(pixel.array, pixel.idx, target.color, mask_ex
         target.color.hsv <- rgb2hsv(target.color[1], target.color[2], target.color[3])
     }
     ## colors are in HSV format here
-    return(apply_hsv_color_to_image_subset(pixel.array, pixel.idx, target.color.hsv, mask_extreme))
+    # it seems that converting the cImg to a normal arr speeds up the following operation
+    pa_t <- as.array(pixel.array)
+    for (i in 1:nrow(pixel.idx)) {
+        pa_t[pixel.idx[i, "x"], pixel.idx[i, "y"],1,1] <- target.color.hsv[1]
+        pa_t[pixel.idx[i, "x"], pixel.idx[i, "y"],1,2] <- target.color.hsv[2]
+    }
+    if (isTRUE(as.logical(mask_extreme))) {
+        for (i in 1:nrow(pixel.idx)) {
+            pa_t[pixel.idx[i, "x"], pixel.idx[i, "y"],1,3] <- target.color.hsv[3]
+        }
+    }
+    pixel.array <- as.cimg(pa_t)
+    return(pixel.array)
 }

R/get_indicator_image.R

@@ -1,15 +1,15 @@
-#' wrapper around `change_pixel_color_HVS()` for the intention of clarity.
-#'
-#' @inheritParams change_pixel_color_HSV
-#'
-#' @return `pixel.array` with hsv-values of pixels at positions `pixel.idx` modified.
-#' @export
-#'
-get_indicator_image <- function(pixel.array, pixel.idx, target.color, mask_extreme = F) {
-    return(change_pixel_color_HSV(
-        pixel.array = pixel.array,
-        pixel.idx = pixel.idx,
-        target.color = target.color,
-        mask_extreme = mask_extreme
-    ))
-}
+#' wrapper around `change_pixel_color_HVS()` for the intention of clarity.
+#'
+#' @inheritParams apply_HSV_color_by_mask
+#'
+#' @return `pixel.array` with hsv-values of pixels at positions `pixel.idx` modified.
+#' @export
+#'
+get_indicator_image <- function(pixel.array, pixel.idx, target.color, mask_extreme = F) {
+    return(apply_HSV_color_by_mask(
+        pixel.array = pixel.array,
+        pixel.idx = pixel.idx,
+        target.color = target.color,
+        mask_extreme = mask_extreme
+    ))
+}

R/retrieve_adjacency_coords.R

@@ -1,28 +1,28 @@
-#' return coordinates by cluster_id from `pixel.idx`
-#'
-#' @inheritParams .main_args
-#' @param cluster_id index of the to-be-retrieved cluster
-#'
-#' @return `pixel.idx` with added 3rd column `clus` mapping to a cluster
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' pixels <- extract_pixels_HSV(...) # extract pixels of a certain color-range
-#' adjacency <- adjacency(pixels$identifier$pixel.idx) # assign clusters
-#' coords <- retrieve_adjacency_coords(adjacency,1) # retrieve coordinates of first cluster
-#'
-#' plot_array_as_image_sRGB( # display result
-#'     HSVtoRGB(
-#'         change_pixel_color_HSV(
-#'             pixel.array,
-#'             coords,
-#'             target.color = "white",
-#'             mask_extreme = T
-#'             )
-#'         )
-#'     )
-#' }
-retrieve_adjacency_coords <- function(pixel.idx,cluster_id) {
-    pixel.idx[pixel.idx[,"clus"]==cluster_id,]
-}
+#' return coordinates by cluster_id from `pixel.idx`
+#'
+#' @inheritParams .main_args
+#' @param cluster_id index of the to-be-retrieved cluster
+#'
+#' @return `pixel.idx` with added 3rd column `clus` mapping to a cluster
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' pixels <- extract_pixels_HSV(...) # extract pixels of a certain color-range
+#' adjacency <- adjacency(pixels$identifier$pixel.idx) # assign clusters
+#' coords <- retrieve_adjacency_coords(adjacency,1) # retrieve coordinates of first cluster
+#'
+#' plot_array_as_image_sRGB( # display result
+#'     HSVtoRGB(
+#'         apply_HSV_color_by_mask(
+#'             pixel.array,
+#'             coords,
+#'             target.color = "white",
+#'             mask_extreme = T
+#'             )
+#'         )
+#'     )
+#' }
+retrieve_adjacency_coords <- function(pixel.idx,cluster_id) {
+    pixel.idx[pixel.idx[,"clus"]==cluster_id,]
+}

_pkgdown.yml

@@ -14,7 +14,7 @@ reference:
   - title: Conversion & Modification
     desc: modification or conversion of objects
     contents:
-      - '`change_pixel_color_HSV`'
+      - '`apply_HSV_color_by_mask`'
       - '`RGBtoHSV`'
       - '`sRGBtoRGB`'
       - '`HSVtoRGB`'
@@ -36,7 +36,6 @@ reference:
   - title: Internals
     desc: Internal functions and helpers
     contents:
-      - '`apply_hsv_color_to_image_subset`'
       - '`norm_to_range_01`'
       - '`limit_to_range`'
       - '`get_unique_list_elements`'

tests/testthat/test-change_pixel_color_HSV.R → tests/testthat/test-apply_HSV_color_by_mask.R

@@ -9,13 +9,21 @@ test_that("target.color must be a valid name", {
         )
 
     expect_error(
-        change_pixel_color_HSV(
+        apply_HSV_color_by_mask(
             pixel.array = test_arr,
             pixel.idx = ret$bex_identifier_dot$pixel.idx,
             target.color = "red99",
             mask_extreme = F
             )
         )
+    expect_no_error(
+        apply_HSV_color_by_mask(
+            pixel.array = test_arr,
+            pixel.idx = ret$bex_identifier_dot$pixel.idx,
+            target.color = "red1",
+            mask_extreme = F
+            )
+        )
 })
 test_that("target.color must be a valid vector", {
     test_path <- load_extdata("duflor-icon.png")
@@ -27,7 +35,7 @@ test_that("target.color must be a valid vector", {
         upper_bound = spectrums$upper_bound
         )
   expect_error(
-        change_pixel_color_HSV(
+        apply_HSV_color_by_mask(
             pixel.array = test_arr,
             pixel.idx = ret$bex_identifier_dot$pixel.idx,
             target.color = c(255,0,0,1),
@@ -44,14 +52,31 @@ test_that("target.color must be a length-3-vector of numerics in range [0,255]",
         lower_bound = spectrums$lower_bound,
         upper_bound = spectrums$upper_bound
         )
-  expect_no_error(change_pixel_color_HSV(
+  expect_no_error(apply_HSV_color_by_mask(
             pixel.array = test_arr,
             pixel.idx = ret$bex_identifier_dot$pixel.idx,
             target.color = c(255,255,255),
             mask_extreme = F
             )
         )
 })
+test_that("mask_extreme also changes the `V`-component of the pixel", {
+    test_path <- load_extdata("duflor-icon.png")
+    spectrums <- getOption("duflor.default_hsv_spectrums")
+    test_arr <- load_image(test_path)
+    ret <- extract_pixels_HSV(
+        pixel.array = test_arr,
+        lower_bound = spectrums$lower_bound,
+        upper_bound = spectrums$upper_bound
+        )
+  expect_no_error(apply_HSV_color_by_mask(
+            pixel.array = test_arr,
+            pixel.idx = ret$bex_identifier_dot$pixel.idx,
+            target.color = c(255,255,255),
+            mask_extreme = T
+            )
+        )
+})
 test_that("elements of target.color outside of range [0,255] get set to respective boundaries", {
     test_path <- load_extdata("duflor-icon.png")
     spectrums <- getOption("duflor.default_hsv_spectrums")
@@ -62,15 +87,15 @@ test_that("elements of target.color outside of range [0,255] get set to respecti
         upper_bound = spectrums$upper_bound
         )
   expect_warning(
-        change_pixel_color_HSV(
+        apply_HSV_color_by_mask(
             pixel.array = test_arr,
             pixel.idx = ret$bex_identifier_dot$pixel.idx,
             target.color = c(256,255,255),
             mask_extreme = F
             )
         )
   expect_warning(
-        change_pixel_color_HSV(
+        apply_HSV_color_by_mask(
             pixel.array = test_arr,
             pixel.idx = ret$bex_identifier_dot$pixel.idx,
             target.color = c(-50,255,256),