adjust allocation strategy

inbo · Jan 8, 2025 · 3ba5f1f · 3ba5f1f
1 parent 270cdeb
commit 3ba5f1f
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 15 deletions.
diff --git a/source/pipelines/R/flea_functions.R b/source/pipelines/R/flea_functions.R
@@ -143,11 +143,6 @@ separate_grts_strata <- function(
   return(fleagrts_ts2)
 }
 
-get_changecats <- function(separate_grts) {
-  changecats <- names(separate_grts)
-  return(changecats)
-}
-
 
 #' Extract stratified sample from the cropped set of GRTS
 #' (Generalized Random Tessellation Stratified) rankings
@@ -159,6 +154,7 @@ get_changecats <- function(separate_grts) {
 #'
 extract_sample <- function(
     separate_grts,
+    stratum_name,
     ntot,
     nmin,
     min_stratum_size) {
@@ -172,7 +168,8 @@ extract_sample <- function(
 
   # determine stratum population sizes
   popsize <- global(separate_grts, fun = "notNA") |>
-    as_tibble(rownames = "layername")
+    as_tibble(rownames = "layername") |>
+    rename(count = notNA)
 
   # check for strata that are too small
   remove_me <- popsize$layername[popsize$count < min_stratum_size]
@@ -188,11 +185,25 @@ extract_sample <- function(
   # determine sample size allocation
   # first distribute nmin to each stratum,
   # remaining allocate proportional to stratum size
+  # give more weight to changes than to stable?
+  ntot <- ntot * nrow(popsize) / 4 # reduce ntot in case less than 4 changeclass
+
   allocation <- popsize |>
     mutate(
-      n_h = nmin + round((ntot - nmin * n()) * (count / sum(count))) # nolint
+      stable = layername == "Stable presence",
+      n_changeclasses = n(),
+      ntot_stable = round(ntot * 1 / n_changeclasses),
+      ntot_changed = ntot - ntot_stable,
+      n_h = ifelse(
+        stable,
+        ntot_stable,
+        nmin +
+          round((ntot_changed - nmin * (n() - 1)) *
+                  (count / sum(count[!stable]))) # nolint
+      )
     )
 
+
   sample_ts2 <- vector(mode = "list", length = nlyr(separate_grts))
   sample_ts2 <- setNames(sample_ts2, names(separate_grts))
   for (i in names(sample_ts2)) {
@@ -204,6 +215,7 @@ extract_sample <- function(
   }
 
   sample_ts2 <- vect(sample_ts2)
+  sample_ts2$stratum_name <- stratum_name
 
   return(sample_ts2)
 }

diff --git a/source/pipelines/run_pipeline.R b/source/pipelines/run_pipeline.R
@@ -68,7 +68,10 @@ targets::tar_read(lu_changecats)
 sg <- targets::tar_read(separate_grts)
 all(purrr::map(sg, ~inherits(.x, "SpatRaster")) |> unlist())
 
-cc <- targets::tar_read(changecats)
+vs <- targets::tar_read(validation_sample)
+terra::vect(vs) |> sf::st_as_sf(crs = 31370) |>
+  sf::st_drop_geometry() |>
+  dplyr::count(grts_rank) |> dplyr::count(n)
 
 # develop
 targets::tar_load_globals()
@@ -77,12 +80,14 @@ debugonce(get_changecats)
 get_changecats(separate_grts)
 
 targets::tar_load_globals()
-targets::tar_workspace("separate_grts_03c5fe21ea8598b0")
-debugonce(separate_grts_strata)
-test <- separate_grts_strata(
-    stratum_raster = temporal_map_strata,
-    fleagrts = fleagrts,
-    stratum_name = lu_changecats)
+targets::tar_workspace("validation_sample_8ed063f6bf68fd26")
+debugonce(extract_sample)
+test <- extract_sample(
+  separate_grts = separate_grts,
+  ntot = 40 * 4 * 4,
+  nmin = 40,
+  min_stratum_size = 1000 # 10 ha
+)
 
 
 

diff --git a/source/pipelines/script_validation_sample.R b/source/pipelines/script_validation_sample.R
@@ -139,11 +139,12 @@ list(
     name = validation_sample,
     command = extract_sample(
       separate_grts = separate_grts,
+      stratum_name = lu_changecats,
       ntot = 40 * 4 * 4,
       nmin = 40,
       min_stratum_size = 1000 # 10 ha
     ),
-    pattern = map(separate_grts),
+    pattern = map(separate_grts, lu_changecats),
     deployment = "main",
     memory = "transient",
     garbage_collection = TRUE