diff --git a/source/pipelines/R/flea_functions.R b/source/pipelines/R/flea_functions.R index 9da400c..f1897d0 100644 --- 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 index cdcbf73..4c030fc 100644 --- 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 index 0d537fd..bb6f546 100644 --- 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