add temporal stratification

inbo · Jan 6, 2025 · d8600e4 · d8600e4
1 parent f0edb64
commit d8600e4
Show file tree

Hide file tree

Showing 3 changed files with 89 additions and 46 deletions.
diff --git 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
@@ -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
@@ -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