From 8e5907c1f2088ab7dcfb18e68b146e262b844ece Mon Sep 17 00:00:00 2001 From: Claudius Appel <151634114+Claudius-Appel@users.noreply.github.com> Date: Wed, 24 Apr 2024 12:02:24 +0200 Subject: [PATCH 1/4] `plot_array_as_image_sRGB()`: add comments in code --- R/plot_array_as_image_sRGB.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/plot_array_as_image_sRGB.R b/R/plot_array_as_image_sRGB.R index 7e8b246..e33d5c4 100644 --- a/R/plot_array_as_image_sRGB.R +++ b/R/plot_array_as_image_sRGB.R @@ -22,6 +22,7 @@ plot_array_as_image_sRGB <- function(rgb.array, main = "title") { # plot rgb data as raster # HSV>sRGB-data + # coerce to array to remove the 'depth'-dimension of the cImg rgb.array <- rgb.array[1:dim(rgb.array)[1], 1:dim(rgb.array)[2], , 1:3] rgb.array <- aperm(rgb.array, c(2, 1, 3)) rgb.array[, , 1] <- norm_to_range_01(rgb.array[, , 1]) From 109a7de567e47604a5fac2620a40225002336930 Mon Sep 17 00:00:00 2001 From: Claudius Appel <151634114+Claudius-Appel@users.noreply.github.com> Date: Wed, 24 Apr 2024 12:07:57 +0200 Subject: [PATCH 2/4] add tests for `plot_array_as_image_sRGB()` & `validate_mask_edges()`, closes #30 --- .../testthat/test-plot_array_as_image_sRGB.R | 41 ++++++++++++++++++ tests/testthat/test-validate_mask_edges.R | 43 +++++++++++++++++++ 2 files changed, 84 insertions(+) create mode 100644 tests/testthat/test-plot_array_as_image_sRGB.R create mode 100644 tests/testthat/test-validate_mask_edges.R diff --git a/tests/testthat/test-plot_array_as_image_sRGB.R b/tests/testthat/test-plot_array_as_image_sRGB.R new file mode 100644 index 0000000..9c52bcb --- /dev/null +++ b/tests/testthat/test-plot_array_as_image_sRGB.R @@ -0,0 +1,41 @@ +load_extdata <- function(path = NULL) { + if (is.null(path)) { + dir(system.file("extdata", package = "duflor"),full.names = T) + } else { + system.file("extdata", path, package = "duflor", mustWork = TRUE) + } +} +test_that("valid array gets plotted properly", { + file_path <- load_extdata("duflor-icon.png") + pixel.array <- load_image(file_path,subset_only = F,return_hsv = T) + spectrums <- getOption("duflor.default_hsv_spectrums") + spectrums$lower_bound <- duflor:::remove_key_from_list(spectrums$lower_bound,c("bex_root_HSV","bex_green_HSV","bex_drought_HSV")) + spectrums$upper_bound <- duflor:::remove_key_from_list(spectrums$upper_bound,c("bex_root_HSV","bex_green_HSV","bex_drought_HSV")) + ## convert spectrums to matrix + nlb <- do.call(rbind,spectrums$lower_bound) + nub <- do.call(rbind,spectrums$upper_bound) + ## strip dimnames-attributes + dimnames(nlb) <- c() + dimnames(nub) <- c() + result <- extract_pixels_HSV(pixel.array = pixel.array, + lower_bound = spectrums$lower_bound, + upper_bound = spectrums$upper_bound, + fast_eval = T, + bundle_pixelarray = F, + check_value = T, + use_single_iteration_cpp = T + ) + expect_no_error( + plot_array_as_image_sRGB( + HSVtoRGB( + apply_HSV_color_by_mask( + pixel.array = pixel.array, + pixel.idx = result$bex_complete_HSV$pixel.idx, + target.color = "red", + mask_extreme = F + ) + ) + ) + ) + # I really don't know what else there is to test here. +}) diff --git a/tests/testthat/test-validate_mask_edges.R b/tests/testthat/test-validate_mask_edges.R new file mode 100644 index 0000000..72e4d3d --- /dev/null +++ b/tests/testthat/test-validate_mask_edges.R @@ -0,0 +1,43 @@ +load_extdata <- function(path = NULL) { + if (is.null(path)) { + dir(system.file("extdata", package = "duflor"),full.names = T) + } else { + system.file("extdata", path, package = "duflor", mustWork = TRUE) + } +} +test_that("masks touching the edge get reported", { + file_path <- load_extdata("duflor-icon.png") + pixel.array <- load_image(file_path,subset_only = F,return_hsv = T) + spectrums <- getOption("duflor.default_hsv_spectrums") + spectrums$lower_bound <- duflor:::remove_key_from_list(spectrums$lower_bound,c("bex_root_HSV","bex_green_HSV","bex_drought_HSV")) + spectrums$upper_bound <- duflor:::remove_key_from_list(spectrums$upper_bound,c("bex_root_HSV","bex_green_HSV","bex_drought_HSV")) + ## convert spectrums to matrix + nlb <- do.call(rbind,spectrums$lower_bound) + nub <- do.call(rbind,spectrums$upper_bound) + ## strip dimnames-attributes + dimnames(nlb) <- c() + dimnames(nub) <- c() + result <- extract_pixels_HSV(pixel.array = pixel.array, + lower_bound = spectrums$lower_bound, + upper_bound = spectrums$upper_bound, + fast_eval = T, + bundle_pixelarray = F, + check_value = T, + use_single_iteration_cpp = T + ) + edge_checks <- list() + for (mask in names(result)) { + suppressWarnings( + + edge_checks[[mask]] <- duflor:::validate_mask_edges(result[[mask]]$pixel.idx,mask, dim(pixel.array)[1:2],file_path) + ) + } + expect_true(edge_checks$bex_complete_HSV$left) + expect_true(edge_checks$bex_complete_HSV$right) + expect_false(edge_checks$bex_complete_HSV$top) + expect_true(edge_checks$bex_complete_HSV$bottom) + expect_false(edge_checks$bex_identifier_dot$left) + expect_false(edge_checks$bex_identifier_dot$right) + expect_false(edge_checks$bex_identifier_dot$top) + expect_false(edge_checks$bex_identifier_dot$bottom) +}) From 12345f87ef1274cacbbf9ca9b1280ac0fbf33dde Mon Sep 17 00:00:00 2001 From: Claudius Appel <151634114+Claudius-Appel@users.noreply.github.com> Date: Wed, 24 Apr 2024 12:09:43 +0200 Subject: [PATCH 3/4] update tests for `limit_to_range()` --- tests/testthat/test-limit_to_range.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/testthat/test-limit_to_range.R b/tests/testthat/test-limit_to_range.R index 16a342e..f2901c0 100644 --- a/tests/testthat/test-limit_to_range.R +++ b/tests/testthat/test-limit_to_range.R @@ -18,4 +18,8 @@ test_that("non-numeric inputs error", { expect_error(limit_to_range(x = vector,replace_lower = 255,replace_upper = c("1","A",NULL))) expect_error(limit_to_range(x = vector,replace_lower = 255,replace_upper = c(NULL))) expect_error(limit_to_range(x = vector,replace_lower = 255,replace_upper = c(NA))) + expect_error(limit_to_range(x = c("1","A",NULL),replace_lower = 255,replace_upper = c("1","A",NULL))) + expect_error(limit_to_range(x = c(NULL),replace_lower = 255,replace_upper = c(NULL))) + expect_error(limit_to_range(x = c(NA),replace_lower = 255,replace_upper = c(NA))) }) + From dcd2a2f56e82e90972ed1d20f9ca9177ef833e47 Mon Sep 17 00:00:00 2001 From: Claudius Appel <151634114+Claudius-Appel@users.noreply.github.com> Date: Wed, 24 Apr 2024 12:10:48 +0200 Subject: [PATCH 4/4] version bump to 0.0.1.9026 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 97ac26d..6218d76 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: duflor Title: Plant Image Analysis For Determination of Leaf- and Root-Area -Version: 0.0.1.9025 +Version: 0.0.1.9026 Author: Claudius Appel Authors@R: c( person("Claudius", "Appel", email = "claudius.appel@freenet.de" , role = c("aut", "cre"))