Merge branch 'dev'

Claudius-Appel · Apr 24, 2024 · 3b49556 · 3b49556
2 parents 4665c85 + 7a43ff7
commit 3b49556
Show file tree

Hide file tree

Showing 5 changed files with 90 additions and 1 deletion.
diff --git 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"))

diff --git 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])

diff --git 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)))
 })
+
diff --git a/tests/testthat/test-plot_array_as_image_sRGB.R 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
@@ -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)
+})