diff --git a/models/sipnet/NEWS.md b/models/sipnet/NEWS.md index cf1107c46f..ef8991bf63 100644 --- a/models/sipnet/NEWS.md +++ b/models/sipnet/NEWS.md @@ -1,5 +1,6 @@ # PEcAn.SIPNET 1.10.0.9000 +* `write_segmented_configs.SIPNET` now merges consecutive segments with the same PFT to avoid unnecessary SIPNET restarts (#4129). * `write.config.SIPNET` converted `stem_respiration_rate` and `root_respiration_rate` to per day rates, but SIPNET reads `baseVegResp` and `baseFineRootResp` as per year and divides by 365 itself, so both were diff --git a/models/sipnet/R/write_segmented_configs.R b/models/sipnet/R/write_segmented_configs.R index d431bc7a51..3939dd4b5a 100644 --- a/models/sipnet/R/write_segmented_configs.R +++ b/models/sipnet/R/write_segmented_configs.R @@ -176,7 +176,24 @@ segment_dataframe <- function(run_settings) { dplyr::arrange(.data$start_date) |> dplyr::mutate(segment_id = sprintf("%03d", dplyr::row_number())) } +drop_same_pft_segments <- function(segments) { + if (nrow(segments) <= 1) { + return(segments) + } + segments |> + dplyr::mutate(pft_group = dplyr::consecutive_id(.data$pft)) |> + dplyr::summarise( + start_date = min(.data$start_date), + end_date = max(.data$end_date), + crop_code = paste(.data$crop_code, collapse = " "), + pft = dplyr::first(.data$pft), + .by = "pft_group" + ) |> + dplyr::mutate( + segment_id = sprintf("%03d", dplyr::row_number()) + ) +} write_segment_configs <- function( settings, run_row, @@ -210,9 +227,14 @@ write_segment_configs <- function( # Adds an all-NA pft column if needed w/o clobbering one that exists already dplyr::bind_rows(tibble::tibble(pft = character())) |> dplyr::mutate( - pft = dplyr::coalesce(.data$pft, crop2pft(.data$crop_code)), - segment_dir = file.path(segment_rootdir, - sprintf("segment_%s", .data$segment_id)) + pft = dplyr::coalesce(.data$pft, crop2pft(.data$crop_code)) + ) |> + drop_same_pft_segments() |> + dplyr::mutate( + segment_dir = file.path( + segment_rootdir, + paste0("segment_", .data$segment_id) + ) ) utils::write.csv( segments, diff --git a/models/sipnet/tests/testthat/test-write_segmented_configs.R b/models/sipnet/tests/testthat/test-write_segmented_configs.R index 76b539bdca..14cab9c37f 100644 --- a/models/sipnet/tests/testthat/test-write_segmented_configs.R +++ b/models/sipnet/tests/testthat/test-write_segmented_configs.R @@ -10,7 +10,7 @@ test_that("write_segmented_configs", { event_lines |> writeLines(con = event_src_path) - c("date,crop_code", "2025-01-02,D12", "2025-01-05,G6") |> + c("date,crop_code", "2025-01-02,D12", "2025-01-04,D13", "2025-01-05,G6") |> writeLines(crp_chg_path) c("run_id,site_id", "ENS-00001-a,a") |> writeLines(file.path(pth, "runs_manifest.csv")) @@ -269,3 +269,44 @@ test_that("write_segment_configs returns unaltered job.sh when no segments remai expect_false(file.exists(file.path(run_path, "job_segmented.sh"))) expect_false(dir.exists(file.path(run_path, "segments"))) }) + +test_that("drop_same_pft_segments merges consecutive segments with the same PFT", { + segments <- data.frame( + start_date = as.Date(c( + "2025-01-01", "2025-01-02", "2025-01-04", "2025-01-05" + )), + end_date = as.Date(c( + "2025-01-01", "2025-01-03", "2025-01-04", "2025-01-10" + )), + crop_code = c(NA_character_, "D12", "D13", "G6"), + pft = c("pft1", "pft2", "pft2", "pft3") + ) + + result <- PEcAn.SIPNET:::drop_same_pft_segments(segments) + + expect_equal(nrow(result), 3) + + expect_equal( + result$start_date, + as.Date(c("2025-01-01", "2025-01-02", "2025-01-05")) + ) + + expect_equal( + result$end_date, + as.Date(c("2025-01-01", "2025-01-04", "2025-01-10")) + ) + + expect_identical( + result$crop_code, + c("NA", "D12 D13", "G6") + ) + expect_identical( + result$pft, + c("pft1", "pft2", "pft3") + ) + + expect_identical( + result$segment_id, + c("001", "002", "003") + ) +})