From d8600e4bbd0329fee322cff4cd658246e10b9ba1 Mon Sep 17 00:00:00 2001 From: hansvancalster Date: Mon, 6 Jan 2025 18:15:46 +0100 Subject: [PATCH] add temporal stratification --- source/pipelines/R/process_rasters.R | 99 ++++++++++++--------- source/pipelines/run_pipeline.R | 23 ++++- source/pipelines/script_validation_sample.R | 13 ++- 3 files changed, 89 insertions(+), 46 deletions(-) diff --git a/source/pipelines/R/process_rasters.R b/source/pipelines/R/process_rasters.R index 6764cc9..c31f2f7 100644 --- a/source/pipelines/R/process_rasters.R +++ b/source/pipelines/R/process_rasters.R @@ -67,14 +67,22 @@ get_grts <- function(path) { } -binary_change <- function(data, lg) { - binary <- vector("list", length = length(lg)) - binary <- setNames(binary, lg) - for (i in lg) { - binary[[i]] <- paste0( - stringr::str_detect(data$lg2013_label, i) %>% as.numeric(), - stringr::str_detect(data$lg2016_label, i) %>% as.numeric(), - stringr::str_detect(data$lg2019_label, i) %>% as.numeric() +binary_change <- function(data, lg_values, mapnames) { + binary <- vector("list", length = length(lg_values)) + bc_colnames <- paste0("bc_", lg_values) + binary <- setNames(binary, bc_colnames) + colselect <- paste0("value_", mapnames) + for (i in seq_along(lg_values)) { + binary[[bc_colnames[i]]] <- + purrr::map(colselect, ~{ + stringr::str_detect( + data[[.x]], + paste0("^", lg_values[i], "$") + ) %>% as.numeric() + }) %>% + purrr::list_transpose() %>% + purrr::map_chr( + .f = \(x) paste(x, collapse = "") ) } bind_cols(data, binary) @@ -137,67 +145,74 @@ create_temporal_maps <- function(input_maps) { return(temporal_stratification) } -add_changecats_tempstrat <- function(tempstrat, cats) { +add_changecats_tempstrat <- function(tempstrat, cats, mapnames) { - lg <- gsub(pattern = "^\\d\\s-\\s", replacement = "", x = cats$label) + lg_values <- as.character(cats$value) additional_levels <- freq(tempstrat) %>% as_tibble() %>% tidyr::separate( value, - into = c("lg2013", "lg2016", "lg2019"), + into = mapnames, sep = "_", remove = FALSE ) %>% + tidyr::pivot_longer( + cols = all_of(mapnames), + names_to = "mapname", + values_to = "year_value" + ) + + additional_levels <- additional_levels %>% left_join( cats %>% mutate( value = as.character(value), - lg2013_label = label, - .keep = "none" - ), - by = join_by(lg2013 == value) - ) %>% - left_join( - cats %>% - mutate( - value = as.character(value), - lg2016_label = label, - .keep = "none" - ), - by = join_by(lg2016 == value) - ) %>% - left_join( - catstable %>% - mutate( - value = as.character(value), - lg2019_label = label, + year_label = label, .keep = "none" ), - by = join_by(lg2019 == value) - ) %>% - binary_change(lg = lg) %>% + by = join_by( + year_value == value + ) + ) + + additional_levels <- additional_levels %>% + tidyr::pivot_wider( + id_cols = c(layer, value, count), + names_from = mapname, + values_from = c(year_value, year_label), + names_sort = TRUE, + names_glue = "{gsub('year_','',.value)}_{mapname}" + ) + + bc_colnames <- paste0("bc_", lg_values) + + additional_levels <- additional_levels %>% + binary_change(lg_values = lg_values, mapnames = mapnames) %>% rowwise() %>% - mutate(stable = ifelse( - all(lg2013 == lg2016, lg2016 == lg2019), - "stable", "changed" - ) %>% - as.factor()) %>% + mutate(stable = all( + c_across(starts_with("value_")) == first(c_across(starts_with("value_"))) + ) %>% + if_else("stable", "changed") %>% + as.factor() + ) %>% ungroup() %>% mutate( across( - all_of(lg), + all_of(bc_colnames), \(x) categorize_land_use_change(x), .names = "{.col}_changecat" ) ) join_levels <- cats(tempstrat)[[1]] %>% - mutate(across(starts_with("lg"), as.character)) %>% + mutate(across(all_of(mapnames), as.character)) %>% + as_tibble() %>% inner_join( additional_levels, - by = join_by(lg2013, lg2016, lg2019, label == value) - ) + by = join_by(label == value) + ) %>% + select(-starts_with("value_")) levels(tempstrat) <- join_levels coltab(tempstrat) <- NULL diff --git a/source/pipelines/run_pipeline.R b/source/pipelines/run_pipeline.R index 5e4c4ea..6fd9b07 100644 --- a/source/pipelines/run_pipeline.R +++ b/source/pipelines/run_pipeline.R @@ -50,8 +50,25 @@ tm <- targets::tar_read(temporal_map) tm terra::plot(tm) +tms <- targets::tar_read(temporal_map_strata) +tms +terra::plot(tms) +terra::activeCat(tms) <- "stable" +terra::plot(tms) + + # develop targets::tar_load_globals() -tar_load(names = c(mapnames, catstable, maps)) -debug(create_temporal_maps) -test <- create_temporal_maps(input_maps = maps) +tar_load(names = c(mapnames, catstable, temporal_map)) +debug(add_changecats_tempstrat) +test <- add_changecats_tempstrat( + tempstrat = temporal_map, cats = catstable, mapnames = mapnames +) + +targets::tar_load_globals() +targets::tar_workspace("temporal_map_strata") +debugonce(binary_change) +test <- add_changecats_tempstrat( + tempstrat = temporal_map, cats = catstable, mapnames = mapnames +) + diff --git a/source/pipelines/script_validation_sample.R b/source/pipelines/script_validation_sample.R index 9f56e1d..8698faa 100644 --- a/source/pipelines/script_validation_sample.R +++ b/source/pipelines/script_validation_sample.R @@ -24,7 +24,7 @@ if (tar_active()) { tar_option_set( - packages = c("tibble", "geotargets", "assertthat", "terra"), + packages = c("tibble", "geotargets", "assertthat", "terra", "dplyr"), format = "qs", error = "null", memory = "transient", @@ -106,8 +106,19 @@ list( input_maps = maps ), preserve_metadata = "zip" + ), + # add change categories to temporal map + tar_terra_rast( + name = temporal_map_strata, + command = add_changecats_tempstrat( + tempstrat = temporal_map, + cats = catstable, + mapnames = mapnames + ), + preserve_metadata = "zip" ) + # apply majority filter, use 3 by 3 block # create table containing all occuring transitions for each land-use