From ac69f9bf40eeb63c2ac458d9896a6a7d8fbd821d Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 3 Jun 2026 12:28:46 +0000 Subject: [PATCH 01/34] Wien/BadAussee: ET0 mm/d->mm/h fix + per-run thinning to cut RAM ET0 fix: both full workflows now divide the daily ET0 by its interval in hours (period_et = 24) before writing //Kurven/ET0, mirroring the rain conversion. The kernel reads the ET0 curve as a mm/h rate, so unconverted daily values were integrated 24x too high. RAM: run_one() now thins each run to its single optimisation row immediately (get_simulation_results_optim(lean = TRUE) + add_overflow_events_and_waterbalance) and returns it; run_scenarios() collects the one-row tibbles and the analyse chunk just binds them. This removes the get_simulation_results_optim_parallel() pass that loaded every run's full time series into memory at once. New 'lean' arg on get_simulation_results_optim() reads only the fields the optimisation summary needs (element rates + both water balances), nulling states/meta/ connected-area rates; its intro message is gated behind debug. --- NEWS.md | 21 ++++++++++++-- R/get_simulation_results_optim.R | 32 +++++++++++++------- vignettes/workflow_badaussee.Rmd | 50 +++++++++++++++++++++----------- vignettes/workflow_wien.Rmd | 50 +++++++++++++++++++++----------- 4 files changed, 105 insertions(+), 48 deletions(-) diff --git a/NEWS.md b/NEWS.md index 3038ce8..d6aaace 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,15 +2,30 @@ ## Bug fixes -* `vignettes/example_wien_minimal.Rmd` now converts ET0 from mm/day to mm/h +* `vignettes/example_wien_minimal.Rmd`, `vignettes/workflow_wien.Rmd` and + `vignettes/workflow_badaussee.Rmd` now convert ET0 from mm/day to mm/h (`value / period_et`) before writing `//Kurven/ET0`, mirroring the existing rain conversion. The engine reads the ET0 curve as a mm/h rate, so the unconverted daily values were integrated 24× too high — the cause of the - implausibly large modelled ET share. The timeseries-info summary now labels - ET0 as mm/h and recovers its total via `value * period_h`. + implausibly large modelled ET share. The minimal vignette's timeseries-info + summary now labels ET0 as mm/h and recovers its total via `value * period_h`. ## New features +* The Wien and Bad Aussee workflows now thin each run to its optimisation row + **inside** `run_one()` (via `get_simulation_results_optim(..., lean = TRUE)` + + `add_overflow_events_and_waterbalance()`) and `run_scenarios()` returns + those one-row tibbles for a final `dplyr::bind_rows()`. This replaces the + previous "run everything, then read every run's full results into memory at + once" pass (`get_simulation_results_optim_parallel()`), drastically cutting + peak RAM for large parameter grids. + +* `get_simulation_results_optim()` gains a `lean` argument. When `TRUE` it + reads only the fields consumed downstream (`element$rates`, + `element$water_balance`, `connected_area$water_balance`) and leaves the + unused `meta`/`states` and `connected_area$rates` as `NULL`, minimising + per-run memory and I/O. Its intro message is now gated behind `debug`. + * `inst/scripts/prepare_eisenstadt_swmm_timeseries.R` extracts the rain (`/Kurven/Regen`) and ET0 (`/Kurven/ET0`) curves from an engine HDF5 and writes SWMM-5 external time-series files. It converts **out** of the diff --git a/R/get_simulation_results_optim.R b/R/get_simulation_results_optim.R index 0540e13..e4d48b0 100644 --- a/R/get_simulation_results_optim.R +++ b/R/get_simulation_results_optim.R @@ -26,6 +26,13 @@ #' @param simulation_names Character vector of simulation run identifiers #' (e.g. \code{c("s00001", "s00002")}). #' @param debug print debug messages (default: TRUE) +#' @param lean Logical. If \code{TRUE}, read only the fields consumed by +#' \code{\link{add_overflow_events_and_waterbalance}} -- \code{element$rates}, +#' \code{element$water_balance} and \code{connected_area$water_balance} -- and +#' leave \code{meta}/\code{states} (both sides) and \code{connected_area$rates} +#' as \code{NULL}. This keeps per-run memory and I/O minimal when each run is +#' thinned to its optimisation row immediately instead of collecting every +#' run's full results first. Defaults to \code{FALSE} (read everything). #' @return A named list with one entry per \code{simulation_names}. Each entry is #' either \code{NULL} (element HDF5 missing) or a nested list: #' \describe{ @@ -53,13 +60,16 @@ #' @importFrom stats setNames #' @importFrom hdf5r H5File get_simulation_results_optim <- function(paths, - path_list, + path_list, simulation_names, - debug = TRUE) { - - message(sprintf("Reading results files ('%s') for %d model runs", - paste0(c(paths$file_results_hdf5_element, paths$file_results_hdf5_flaeche), collapse = "|"), - length(simulation_names))) + debug = TRUE, + lean = FALSE) { + + if (isTRUE(debug)) { + message(sprintf("Reading results files ('%s') for %d model runs", + paste0(c(paths$file_results_hdf5_element, paths$file_results_hdf5_flaeche), collapse = "|"), + length(simulation_names))) + } stats::setNames(lapply(simulation_names, function(s_name) { paths <- kwb.utils::resolve(path_list, dir_target = s_name) @@ -109,20 +119,20 @@ get_simulation_results_optim <- function(paths, paths$dir_target_output), expr = { element <- list( - meta = kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Metainfo"]], + meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Metainfo"]], numeric_only = FALSE), rates = kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Raten"]]), water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Wasserbilanz"]]), - states = kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Zustandsvariablen"]]) + states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Zustandsvariablen"]]) ) connected_area <- if (!is.null(res_hdf5_flaeche)) { list( - meta = kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Metainfo"]], + meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Metainfo"]], numeric_only = FALSE), - rates = kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Raten"]]), + rates = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Raten"]]), water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Wasserbilanz"]]), - states = kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Zustandsvariablen"]]) + states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Zustandsvariablen"]]) ) } else { NULL diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index 69b87ef..d1ead79 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -260,6 +260,12 @@ message(txt) period <- c(diff(timeseries_rain$time), mean(diff(timeseries_rain$time))) timeseries_rain$value <- timeseries_rain$value / period +### Convert ET0 from mm/day to mm/h (the engine reads //Kurven/ET0 as a mm/h +### rate, exactly like rain; daily values must be divided by their interval in +### hours = 24, otherwise ET0 is integrated 24x too high) +period_et <- c(diff(timeseries_et$time), mean(diff(timeseries_et$time))) +timeseries_et$value <- timeseries_et$value / period_et + #openxlsx::write.xlsx(list(regen = timeseries_rain, et = timeseries_et), "timeseries.xlsx") @@ -332,13 +338,33 @@ run_one <- function(i, path_input = paths$path_target_input, debug = debug) - invisible(NULL) + # Thin immediately: read only this run's results (lean = water balance + + # overflow rates, no states/meta/connected-area rates) and reduce to the + # single optimisation row. This way we never hold all scenarios' full + # time series in memory at once; the full result HDF5 stays on disk for + # ad-hoc inspection. + sim_one <- kwb.raindrop::get_simulation_results_optim( + paths = paths, + path_list = path_list, + simulation_names = param_grid_tmp$scenario_name, + debug = debug, + lean = TRUE + ) + + kwb.raindrop::add_overflow_events_and_waterbalance( + simulation_results = sim_one, + event_separation_hours = 4, + canonical_variables = kwb.raindrop::default_canonical_wb_variables() + ) } n_cores <- parallel::detectCores() +# run_one() now returns the thinned per-run optimisation row, so run_scenarios() +# yields a list of one-row tibbles we simply bind below. +scenario_rows <- NULL system.time(expr = { -kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), +scenario_rows <- kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), run_one_scenario = run_one, timestep_hours = 0.1, debug = FALSE, @@ -368,21 +394,11 @@ x$Fehlerbeschreibung ### Analyse Results ```{r analyse_results, eval = data_available && is_windows && !is_ghactions} -system.time( -simulation_results <- kwb.raindrop::get_simulation_results_optim_parallel( - paths = paths, - path_list = path_list, - simulation_names = param_grid$scenario_name, - debug = FALSE) -) - -system.time( -simulation_results_optimisation <- kwb.raindrop::add_overflow_events_and_waterbalance( - simulation_results = simulation_results, - event_separation_hours = 4, - canonical_variables = kwb.raindrop::default_canonical_wb_variables() - ) -) +# Each run was already thinned to its optimisation row inside run_one(), so we +# just bind the per-run rows here instead of re-reading every run's full +# results into memory. (The previous get_simulation_results_optim_parallel() + +# add_overflow_events_and_waterbalance() pass loaded all runs at once.) +simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) simulation_results_optimisation <- param_grid %>% dplyr::left_join(simulation_results_optimisation, diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index e9971ef..426da47 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -260,6 +260,12 @@ message(txt) period <- c(diff(timeseries_rain$time), mean(diff(timeseries_rain$time))) timeseries_rain$value <- timeseries_rain$value / period +### Convert ET0 from mm/day to mm/h (the engine reads //Kurven/ET0 as a mm/h +### rate, exactly like rain; daily values must be divided by their interval in +### hours = 24, otherwise ET0 is integrated 24x too high) +period_et <- c(diff(timeseries_et$time), mean(diff(timeseries_et$time))) +timeseries_et$value <- timeseries_et$value / period_et + #openxlsx::write.xlsx(list(regen = timeseries_rain, et = timeseries_et), "timeseries.xlsx") ``` @@ -329,13 +335,33 @@ run_one <- function(i, path_input = paths$path_target_input, debug = debug) - invisible(NULL) + # Thin immediately: read only this run's results (lean = water balance + + # overflow rates, no states/meta/connected-area rates) and reduce to the + # single optimisation row. This way we never hold all scenarios' full + # time series in memory at once; the full result HDF5 stays on disk for + # ad-hoc inspection. + sim_one <- kwb.raindrop::get_simulation_results_optim( + paths = paths, + path_list = path_list, + simulation_names = param_grid_tmp$scenario_name, + debug = debug, + lean = TRUE + ) + + kwb.raindrop::add_overflow_events_and_waterbalance( + simulation_results = sim_one, + event_separation_hours = 4, + canonical_variables = kwb.raindrop::default_canonical_wb_variables() + ) } n_cores <- parallel::detectCores() +# run_one() now returns the thinned per-run optimisation row, so run_scenarios() +# yields a list of one-row tibbles we simply bind below. +scenario_rows <- NULL system.time(expr = { -kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), +scenario_rows <- kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), run_one_scenario = run_one, timestep_hours = 0.1, debug = FALSE, @@ -364,21 +390,11 @@ x$Fehlerbeschreibung ### Analyse Results ```{r analyse_results, eval = data_available && is_windows && !is_ghactions} -system.time( -simulation_results <- kwb.raindrop::get_simulation_results_optim_parallel( - paths = paths, - path_list = path_list, - simulation_names = param_grid$scenario_name, - debug = FALSE) -) - -system.time( -simulation_results_optimisation <- kwb.raindrop::add_overflow_events_and_waterbalance( - simulation_results = simulation_results, - event_separation_hours = 4, - canonical_variables = kwb.raindrop::default_canonical_wb_variables() - ) -) +# Each run was already thinned to its optimisation row inside run_one(), so we +# just bind the per-run rows here instead of re-reading every run's full +# results into memory. (The previous get_simulation_results_optim_parallel() + +# add_overflow_events_and_waterbalance() pass loaded all runs at once.) +simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) simulation_results_optimisation <- param_grid %>% dplyr::left_join(simulation_results_optimisation, From 5ddd90e8291369cdde7f4f2c3c6bcc858677d880 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 3 Jun 2026 12:35:01 +0000 Subject: [PATCH 02/34] Eisenstadt 2005 workflows: per-run thinning to cut RAM Apply the same memory fix as Wien/BadAussee: run_one() now thins each run to its optimisation row immediately (get_simulation_results_optim(lean = TRUE) + add_overflow_events_and_waterbalance) and returns it; run_scenarios() collects the rows and the analyse chunk binds them, replacing the get_simulation_results_optim_parallel() pass that held every run's full time series at once. No ET0 unit change here: the Eisenstadt workflows use the base.h5 constant ET0 placeholder (0.2 mm/h) and the template rain (already mm/h), so there is no mm/d daily series to convert. --- vignettes/workflow_eisenstadt-2005.Rmd | 44 +++++++++++++--------- vignettes/workflow_eisenstadt-2005_neu.Rmd | 44 +++++++++++++--------- 2 files changed, 54 insertions(+), 34 deletions(-) diff --git a/vignettes/workflow_eisenstadt-2005.Rmd b/vignettes/workflow_eisenstadt-2005.Rmd index 818fc01..474da95 100644 --- a/vignettes/workflow_eisenstadt-2005.Rmd +++ b/vignettes/workflow_eisenstadt-2005.Rmd @@ -228,13 +228,33 @@ if (is.data.frame(vals[["//Kurven/Regen"]])) { path_input = paths$path_target_input, debug = debug) - invisible(NULL) + # Thin immediately: read only this run's results (lean = water balance + + # overflow rates, no states/meta/connected-area rates) and reduce to the + # single optimisation row. This way we never hold all scenarios' full + # time series in memory at once; the full result HDF5 stays on disk for + # ad-hoc inspection. + sim_one <- kwb.raindrop::get_simulation_results_optim( + paths = paths, + path_list = path_list, + simulation_names = param_grid_tmp$scenario_name, + debug = debug, + lean = TRUE + ) + + kwb.raindrop::add_overflow_events_and_waterbalance( + simulation_results = sim_one, + event_separation_hours = 4, + canonical_variables = kwb.raindrop::default_canonical_wb_variables() + ) } n_cores <- parallel::detectCores() +# run_one() now returns the thinned per-run optimisation row, so run_scenarios() +# yields a list of one-row tibbles we simply bind below. +scenario_rows <- NULL system.time(expr = { -kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), +scenario_rows <- kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), run_one_scenario = run_one, timestep_hours = 0.1, debug = FALSE, @@ -264,21 +284,11 @@ x$Fehlerbeschreibung ### Analyse Results ```{r analyse_results, eval = data_available && is_windows && !is_ghactions} -system.time( -simulation_results <- kwb.raindrop::get_simulation_results_optim_parallel( - paths = paths, - path_list = path_list, - simulation_names = param_grid$scenario_name, - debug = FALSE) -) - -system.time( -simulation_results_optimisation <- kwb.raindrop::add_overflow_events_and_waterbalance( - simulation_results = simulation_results, - event_separation_hours = 4, - canonical_variables = kwb.raindrop::default_canonical_wb_variables() - ) -) +# Each run was already thinned to its optimisation row inside run_one(), so we +# just bind the per-run rows here instead of re-reading every run's full +# results into memory. (The previous get_simulation_results_optim_parallel() + +# add_overflow_events_and_waterbalance() pass loaded all runs at once.) +simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) simulation_results_optimisation <- param_grid %>% dplyr::left_join(simulation_results_optimisation, diff --git a/vignettes/workflow_eisenstadt-2005_neu.Rmd b/vignettes/workflow_eisenstadt-2005_neu.Rmd index 5c74100..c95f8a8 100644 --- a/vignettes/workflow_eisenstadt-2005_neu.Rmd +++ b/vignettes/workflow_eisenstadt-2005_neu.Rmd @@ -228,13 +228,33 @@ run_one <- function(i, path_input = paths$path_target_input, debug = debug) - invisible(NULL) + # Thin immediately: read only this run's results (lean = water balance + + # overflow rates, no states/meta/connected-area rates) and reduce to the + # single optimisation row. This way we never hold all scenarios' full + # time series in memory at once; the full result HDF5 stays on disk for + # ad-hoc inspection. + sim_one <- kwb.raindrop::get_simulation_results_optim( + paths = paths, + path_list = path_list, + simulation_names = param_grid_tmp$scenario_name, + debug = debug, + lean = TRUE + ) + + kwb.raindrop::add_overflow_events_and_waterbalance( + simulation_results = sim_one, + event_separation_hours = 4, + canonical_variables = kwb.raindrop::default_canonical_wb_variables() + ) } n_cores <- parallel::detectCores() +# run_one() now returns the thinned per-run optimisation row, so run_scenarios() +# yields a list of one-row tibbles we simply bind below. +scenario_rows <- NULL system.time(expr = { -kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), +scenario_rows <- kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), run_one_scenario = run_one, timestep_hours = 0.1, debug = FALSE, @@ -266,21 +286,11 @@ x$Fehlerbeschreibung ### Analyse Results ```{r analyse_results, eval = data_available && is_windows && !is_ghactions} -system.time( -simulation_results <- kwb.raindrop::get_simulation_results_optim_parallel( - paths = paths, - path_list = path_list, - simulation_names = param_grid$scenario_name, - debug = FALSE) -) - -system.time( -simulation_results_optimisation <- kwb.raindrop::add_overflow_events_and_waterbalance( - simulation_results = simulation_results, - event_separation_hours = 4, - canonical_variables = kwb.raindrop::default_canonical_wb_variables() - ) -) +# Each run was already thinned to its optimisation row inside run_one(), so we +# just bind the per-run rows here instead of re-reading every run's full +# results into memory. (The previous get_simulation_results_optim_parallel() + +# add_overflow_events_and_waterbalance() pass loaded all runs at once.) +simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) simulation_results_optimisation <- param_grid %>% dplyr::left_join(simulation_results_optimisation, From 971dcdd75162201e89218b0b8dd3a66da3d0388d Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 3 Jun 2026 12:35:01 +0000 Subject: [PATCH 03/34] Add results landing page vignettes/index.Rmd (excluded from R CMD check) Summary page linking the per-site brute-force outputs (workflow html, result tables, CSVs, interactive plots). Added to .Rbuildignore so R CMD check does not build/execute it; render it manually into the assembled results directory. Result-file links match each workflow's paths$modelname (Wien, BadAussee, Eisenstadt_2005). --- .Rbuildignore | 1 + vignettes/index.Rmd | 150 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 151 insertions(+) create mode 100644 vignettes/index.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index 906e453..5ae8bc9 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ ^codecov\.yml$ ^index\.md$ ^README\.md$ +^vignettes/index\.Rmd$ diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd new file mode 100644 index 0000000..5439b48 --- /dev/null +++ b/vignettes/index.Rmd @@ -0,0 +1,150 @@ +--- +title: "RainDrop Optimierung – Brute Force" +author: "Michael Rustler" +date: "2026-02-25" +output: + html_document: + toc: true + toc_depth: 3 + number_sections: true +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) + +sites <- c("Eisenstadt_2005", "Wien", "BadAussee") + +# index.html liegt im gleichen Verzeichnis wie der Ordner "brute-force" +base_dir <- "." + +design_spaces <- paste0( + "mulde-area_vs_", + c("filter_hydraulicconductivity", "mulde_height", "storage_height") +) + +rel <- function(...) file.path(..., fsep = "/") + +md_link_line <- function(label, href) sprintf("- [%s](%s)", label, href) + +md_list <- function(lines) knitr::asis_output(paste(lines, collapse = "\n")) +``` + +# Hintergrund + +xxx + +# Methodik + +Die Modellierung erfolgte in R mit dem R Paket [kwb.raindrop](https://github.com/kwb-r/kwb.raindrop). +Das genaue Vorgehen ist für jede Fallstudie im folgenden im R Markdown reproduzierbar +dokumentiert. + +```{r brute_force_rmarkdown, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/workflow_%s.html)\n", + site, + base_dir, + site + )) +} +``` + +# Ergebnisse + +Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die +beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in +unten stehenden Links: + +## Tabellen + +```{r brute_force_tabelle, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s.html)\n", + site, + base_dir, + site + )) +} + +``` + +## CSV + +Die in den [obenstehenden Tabellen](#tabellen) dargestellten Ergebnisse können auch als `.csv` Datei +heruntergeladen werden. + +```{r brute_force_csv, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s.csv)\n", + site, + base_dir, + site + )) +} +``` + +## Interaktive Visualisierungen + +### Sensitive Modellparameter + +```{r brute_force_plots_main, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_main-effects.html)\n", + site, + base_dir, + site + )) +} +``` + +### Design Spaces + +In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit +**einem weiteren Parameter** (y-Achse) dargestellt. Diese sind im folgenden: + +- ***Muldenhöhe*** + +- ***Speicherhöhe*** + +- ***hydraulische Leitfähigkeit*** des Bodenfilters + +```{r brute_force_plots_design-spaches, echo = FALSE, results='asis'} +cat("| Design Space |", paste(sites, collapse = " | "), "|\n") +cat("|---|", paste(rep("---", length(sites)), collapse = "|"), "|\n") + +for (ds in design_spaces) { + + ds_label <- sub("^mulde-area_vs_", "", ds) + + row_links <- sapply(sites, function(site) { + sprintf( + "[%s](%s/simulation_results_optimisation_%s_design-space_%s.html)", + ds_label, + base_dir, + site, + ds + ) + }) + + cat("|", ds_label, "|", paste(row_links, collapse = " | "), "|\n") +} +``` + +### Wasserbilanz + +```{r brute_force_plots_water-balance, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_water-balance.html)\n", + site, + base_dir, + site + )) +} +``` + + From 5302a4dd3ada087f196d0fe65f6c78b6ae4ce677 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 3 Jun 2026 13:31:09 +0000 Subject: [PATCH 04/34] Tolerate unreadable result HDF5 in get_simulation_results_optim() Since the workflows now thin per run inside run_one(), reading happens inside the future_lapply batch. A result file that exists but cannot be opened/read (engine crashed mid-write for a scenario, or a transient lock) previously threw H5File.open() 'unable to open file' and aborted the whole render at the run_model chunk. Wrap the open+read in an inner function (own on.exit for handle cleanup) plus tryCatch: such a file is now treated like a missing one -- warn, name the scenario, return NULL -- so add_overflow_events_and_waterbalance() emits an NA row and the batch completes. --- NEWS.md | 9 +++ R/get_simulation_results_optim.R | 102 ++++++++++++++++++------------- 2 files changed, 67 insertions(+), 44 deletions(-) diff --git a/NEWS.md b/NEWS.md index d6aaace..d997a05 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,15 @@ ## Bug fixes +* `get_simulation_results_optim()` now treats a result HDF5 that exists but + cannot be opened/read (e.g. the engine crashed mid-write for a scenario, or a + file briefly locked just after the run) like a missing file: it `warning()`s, + names the scenario, and returns `NULL` instead of throwing. Because the Wien / + Bad Aussee / Eisenstadt workflows now read results per run inside `run_one()`, + a single unreadable file used to abort the entire `future_lapply` batch (seen + as an `H5File.open()` "unable to open file" error mid-render); the run now + completes with NA rows for the affected scenarios. + * `vignettes/example_wien_minimal.Rmd`, `vignettes/workflow_wien.Rmd` and `vignettes/workflow_badaussee.Rmd` now convert ET0 from mm/day to mm/h (`value / period_et`) before writing `//Kurven/ET0`, mirroring the existing diff --git a/R/get_simulation_results_optim.R b/R/get_simulation_results_optim.R index e4d48b0..311315e 100644 --- a/R/get_simulation_results_optim.R +++ b/R/get_simulation_results_optim.R @@ -92,56 +92,70 @@ get_simulation_results_optim <- function(paths, return(NULL) } - # Open H5 handles outside catAndRun so on.exit binds to *this* lambda's - # frame, not catAndRun's internal frame. Handles are guaranteed to close - # whichever way the iteration unwinds. - res_hdf5_element <- hdf5r::H5File$new(paths$path_results_hdf5_element, mode = "r") - on.exit(try(res_hdf5_element$close_all(), silent = TRUE), add = TRUE) + # Open + read in an inner function so its on.exit() handle-closing binds to + # *its own* frame and always fires (even on error) before we decide what to + # return. The surrounding tryCatch makes a result file that exists but is + # unreadable -- e.g. the engine crashed mid-write for that scenario -- + # behave like a missing file (NULL + warning) instead of aborting the whole + # (possibly parallel) batch. Downstream add_overflow_events_and_waterbalance() + # then emits an NA row for the scenario. + read_result <- function() { + res_hdf5_element <- hdf5r::H5File$new(paths$path_results_hdf5_element, mode = "r") + on.exit(try(res_hdf5_element$close_all(), silent = TRUE), add = TRUE) - res_hdf5_flaeche <- if (has_flaeche) { - h <- hdf5r::H5File$new(paths$path_results_hdf5_flaeche, mode = "r") - on.exit(try(h$close_all(), silent = TRUE), add = TRUE) - h - } else { - if (isTRUE(debug)) { - message(sprintf( - "No connected_area H5 for %s ('%s') -> connected_area = NULL", - s_name, paths$path_results_hdf5_flaeche - )) + res_hdf5_flaeche <- if (has_flaeche) { + h <- hdf5r::H5File$new(paths$path_results_hdf5_flaeche, mode = "r") + on.exit(try(h$close_all(), silent = TRUE), add = TRUE) + h + } else { + if (isTRUE(debug)) { + message(sprintf( + "No connected_area H5 for %s ('%s') -> connected_area = NULL", + s_name, paths$path_results_hdf5_flaeche + )) + } + NULL } - NULL - } - kwb.utils::catAndRun( - messageText = sprintf("(%d/%d)) Reading results files for model run %s", - which(simulation_names == s_name), - length(simulation_names), - paths$dir_target_output), - expr = { - element <- list( - meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Metainfo"]], - numeric_only = FALSE), - rates = kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Raten"]]), - water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Wasserbilanz"]]), - states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Zustandsvariablen"]]) - ) - - connected_area <- if (!is.null(res_hdf5_flaeche)) { - list( - meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Metainfo"]], + kwb.utils::catAndRun( + messageText = sprintf("(%d/%d)) Reading results files for model run %s", + which(simulation_names == s_name), + length(simulation_names), + paths$dir_target_output), + expr = { + element <- list( + meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Metainfo"]], numeric_only = FALSE), - rates = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Raten"]]), - water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Wasserbilanz"]]), - states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Zustandsvariablen"]]) + rates = kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Raten"]]), + water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_element[["Wasserbilanz"]]), + states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_element[["Zustandsvariablen"]]) ) - } else { - NULL - } - list(element = element, connected_area = connected_area) - }, - dbg = debug - ) + connected_area <- if (!is.null(res_hdf5_flaeche)) { + list( + meta = if (lean) NULL else kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Metainfo"]], + numeric_only = FALSE), + rates = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Raten"]]), + water_balance = kwb.raindrop::read_hdf5_scalars(res_hdf5_flaeche[["Wasserbilanz"]]), + states = if (lean) NULL else kwb.raindrop::read_hdf5_timeseries(res_hdf5_flaeche[["Zustandsvariablen"]]) + ) + } else { + NULL + } + + list(element = element, connected_area = connected_area) + }, + dbg = debug + ) + } + + tryCatch(read_result(), error = function(e) { + warning(sprintf( + "Scenario '%s': result HDF5 unreadable ('%s'): %s -- treating as missing (NULL).", + s_name, paths$path_results_hdf5_element, conditionMessage(e) + ), call. = FALSE) + NULL + }) }), nm = simulation_names) } From a8b4e0d97531e6efac62984531a6b8e0129e1aba Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 3 Jun 2026 14:39:14 +0000 Subject: [PATCH 05/34] Sync get_simulation_results_optim.Rd with new lean argument R CMD check failed with a codoc WARNING because the .Rd still documented the old signature (no 'lean'). Regenerate the usage block and add the \item{lean} documentation to match R/get_simulation_results_optim.R (devtools::document() equivalent), clearing the only WARNING (the 3 NOTEs are pre-existing). --- man/get_simulation_results_optim.Rd | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/man/get_simulation_results_optim.Rd b/man/get_simulation_results_optim.Rd index 1c7d586..1a1c68b 100644 --- a/man/get_simulation_results_optim.Rd +++ b/man/get_simulation_results_optim.Rd @@ -4,7 +4,13 @@ \alias{get_simulation_results_optim} \title{Read Raindrop optimisation simulation results from HDF5} \usage{ -get_simulation_results_optim(paths, path_list, simulation_names, debug = TRUE) +get_simulation_results_optim( + paths, + path_list, + simulation_names, + debug = TRUE, + lean = FALSE +) } \arguments{ \item{paths}{A list of path definitions. Used for messaging and expected to @@ -20,6 +26,14 @@ run-specific paths (must yield \code{path_results_hdf5_element}, (e.g. \code{c("s00001", "s00002")}).} \item{debug}{print debug messages (default: TRUE)} + +\item{lean}{Logical. If \code{TRUE}, read only the fields consumed by +\code{\link{add_overflow_events_and_waterbalance}} -- \code{element$rates}, +\code{element$water_balance} and \code{connected_area$water_balance} -- and +leave \code{meta}/\code{states} (both sides) and \code{connected_area$rates} +as \code{NULL}. This keeps per-run memory and I/O minimal when each run is +thinned to its optimisation row immediately instead of collecting every +run's full results first. Defaults to \code{FALSE} (read everything).} } \value{ A named list with one entry per \code{simulation_names}. Each entry is From f08073e036d72df1c020a52cf14043486c62db99 Mon Sep 17 00:00:00 2001 From: mrustl Date: Thu, 2 Jul 2026 08:42:01 +0200 Subject: [PATCH 06/34] Only use LAI 3.9 for mulde-rigole (Wien/BadAussee) to do: adapt Eisenstadt to the same parameter --- R/plot_main_effects.R | 3 +-- man/add_overflow_events_and_waterbalance.Rd | 18 ++++++++++-------- man/download_engine.Rd | 14 +++++++------- man/read_hdf5_connections.Rd | 2 +- man/read_hdf5_scalars.Rd | 2 +- man/read_hdf5_timeseries.Rd | 4 ++-- man/run_model.Rd | 4 ++-- vignettes/workflow_badaussee.Rmd | 3 ++- vignettes/workflow_wien.Rmd | 3 ++- 9 files changed, 28 insertions(+), 25 deletions(-) diff --git a/R/plot_main_effects.R b/R/plot_main_effects.R index 5e98e8c..289d8f0 100644 --- a/R/plot_main_effects.R +++ b/R/plot_main_effects.R @@ -29,8 +29,7 @@ #' @export #' @importFrom dplyr %>% select all_of group_by summarise left_join mutate n_distinct #' @importFrom tidyr pivot_longer -#' @importFrom ggplot2 ggplot aes geom_violin geom_boxplot geom_jitter facet_wrap -#' theme_bw theme labs element_text coord_cartesian +#' @importFrom ggplot2 ggplot aes geom_violin geom_boxplot geom_jitter facet_wrap theme_bw theme labs element_text coord_cartesian #' @importFrom forcats fct_reorder #' @importFrom stats median #' @importFrom rlang .data diff --git a/man/add_overflow_events_and_waterbalance.Rd b/man/add_overflow_events_and_waterbalance.Rd index d7af72d..d74b486 100644 --- a/man/add_overflow_events_and_waterbalance.Rd +++ b/man/add_overflow_events_and_waterbalance.Rd @@ -24,14 +24,16 @@ to contain: \item{canonical_variables}{Optional \code{character()} vector of water-balance variable names (without the \code{element.} / \code{connectedarea.} prefix and -without the trailing \verb{_}), e.g. -\code{c("WB_Regen", "WB_Evapotranspiration", "WB_InfiltrationNetto", "WB_Oberflaechenablauf_Ueberlauf", "WB_Oberflaechenablauf_Verschaltungen")}. -When \strong{every} scenario in \code{simulation_results} is \code{NULL} (or otherwise -provides no water-balance data), the function would normally return only -the four headline columns. Pass \code{canonical_variables} to attach -\verb{element._} and \verb{connectedarea._} \code{NA}-filled stub columns to -such rows so the rendered datatable still exposes the expected column -structure. Defaults to \code{NULL} (no canonical fallback).} +without the trailing \verb{_}), e.g. \code{default_canonical_wb_variables()}. +This is a \strong{per-scenario} fallback: for any scenario whose +\code{wb_element} and \code{wb_connectedarea} are both empty after the regular +pivot / mirror logic (including scenarios that are entirely \code{NULL}), +the function attaches \verb{element._} and \verb{connectedarea._} +\code{NA}-filled stub columns built from this list. This guarantees the +output tibble keeps the expected water-balance column structure even +when no scenario contributes real data — \code{dplyr::bind_rows()} would +otherwise drop columns that no row supplies. Defaults to \code{NULL} (no +canonical fallback).} } \value{ A tibble with one row per scenario containing: diff --git a/man/download_engine.Rd b/man/download_engine.Rd index d4969d5..d131caa 100644 --- a/man/download_engine.Rd +++ b/man/download_engine.Rd @@ -12,14 +12,14 @@ download_engine( } \arguments{ \item{version}{\code{character(1)} -Engine release version, matching the part after \code{engine-} in the -\code{KWB-R/kwb.raindrop.binaries} Release tag. Defaults to the -package's pinned version.} +Engine release version, matching the part after \verb{engine-} in the +\code{KWB-R/kwb.raindrop.binaries} Release tag. Defaults to the package's +pinned version.} \item{cache_dir}{\code{character(1)} Directory where engine binaries are cached. A sub-directory named after \code{version} is used so multiple versions can coexist. Defaults to -\code{\link[tools:R_user_dir]{tools::R_user_dir}}\code{("kwb.raindrop", "cache")}.} +\code{\link[tools:R_user_dir]{tools::R_user_dir}}\verb{("kwb.raindrop", "cache")}.} \item{force}{\code{logical(1)} If \code{TRUE}, re-download even if the executable already exists in the @@ -36,9 +36,9 @@ are no-ops once the file is present. } \details{ Releases in \code{KWB-R/kwb.raindrop.binaries} follow the tag scheme -\code{engine-} and contain a single asset named -\code{Regenwasserbewirtschaftung.exe} (the version is encoded in the -tag, not in the filename, so multiple engine versions can coexist +\verb{engine-} and contain a single asset named +\code{Regenwasserbewirtschaftung.exe} (the version is encoded in the tag, +not in the filename, so multiple engine versions can coexist side-by-side in the cache). The executable is a Windows binary; on non-Windows platforms the file is diff --git a/man/read_hdf5_connections.Rd b/man/read_hdf5_connections.Rd index 200f92a..08a7794 100644 --- a/man/read_hdf5_connections.Rd +++ b/man/read_hdf5_connections.Rd @@ -7,7 +7,7 @@ read_hdf5_connections(file) } \arguments{ -\item{file}{An \code{\link[hdf5r:H5File-class]{hdf5r::H5File}} object pointing to a \verb{*_Verschaltungen.h5} file, +\item{file}{An \code{\link[hdf5r:H5File]{hdf5r::H5File}} object pointing to a \verb{*_Verschaltungen.h5} file, already opened in read mode.} } \value{ diff --git a/man/read_hdf5_scalars.Rd b/man/read_hdf5_scalars.Rd index 4eb7a1f..15c6aac 100644 --- a/man/read_hdf5_scalars.Rd +++ b/man/read_hdf5_scalars.Rd @@ -7,7 +7,7 @@ read_hdf5_scalars(group, numeric_only = TRUE) } \arguments{ -\item{group}{An \code{\link[hdf5r:H5Group-class]{hdf5r::H5Group}} object. Direct children of this group are expected +\item{group}{An \code{\link[hdf5r:H5Group]{hdf5r::H5Group}} object. Direct children of this group are expected to be scalar datasets (i.e. \code{dataset.dims == 0}).} \item{numeric_only}{Logical (default: \code{TRUE}). If \code{TRUE}, only numeric / integer scalars are diff --git a/man/read_hdf5_timeseries.Rd b/man/read_hdf5_timeseries.Rd index 30d5f05..3b7e21d 100644 --- a/man/read_hdf5_timeseries.Rd +++ b/man/read_hdf5_timeseries.Rd @@ -24,8 +24,8 @@ columns: variable, time, value. \details{ Supported dataset layouts: \itemize{ -\item k x N (rows): \code{[1, ]} = time, \code{[2..k, ]} = values (series) -\item N x k (cols): \code{[, 1]} = time, \code{[, 2..k]} = values (series) +\item k x N (rows): \verb{[1, ]} = time, \verb{[2..k, ]} = values (series) +\item N x k (cols): \verb{[, 1]} = time, \verb{[, 2..k]} = values (series) } Special handling for names containing "deeperLayers"/"deeper_layers": diff --git a/man/run_model.Rd b/man/run_model.Rd index 6e8c74e..2a349ee 100644 --- a/man/run_model.Rd +++ b/man/run_model.Rd @@ -39,7 +39,7 @@ command output are wrapped with \code{\link[kwb.utils:catAndRun]{kwb.utils::catA } \details{ Both \code{path_exe} and \code{path_input} are converted to absolute, normalised -paths via \code{\link[fs:path_math]{fs::path_abs()}} and \code{\link[base:normalizePath]{base::normalizePath()}}. The command is +paths via \code{\link[fs:path_abs]{fs::path_abs()}} and \code{\link[base:normalizePath]{base::normalizePath()}}. The command is executed with \code{\link[base:shell]{base::shell()}}, which on Windows invokes the system shell. On non-Windows platforms, prefer \code{\link[base:system]{base::system()}} if you need full POSIX semantics. } @@ -64,5 +64,5 @@ status <- run_model(exe, input, print_output = TRUE) } \seealso{ -\code{\link[base:shell]{base::shell()}}, \code{\link[fs:path_math]{fs::path_abs()}}, \code{\link[kwb.utils:catAndRun]{kwb.utils::catAndRun()}} +\code{\link[base:shell]{base::shell()}}, \code{\link[fs:path_abs]{fs::path_abs()}}, \code{\link[kwb.utils:catAndRun]{kwb.utils::catAndRun()}} } diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index d1ead79..71b297c 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -115,7 +115,8 @@ bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). # 8.5 = status-quo H5 default; 3.9 = grass per Hörnschemeyer et al., # Water 2023, 15, 2840, Tab. 6, plant type 5 (grasses/herbs). -lai <- c(3.9, 8.5) +#lai <- c(3.9, 8.5) +lai <- 3.9 # Alle Kombinationen erzeugen diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index 426da47..4e0e684 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -115,7 +115,8 @@ bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). # 8.5 = status-quo H5 default; 3.9 = grass per Hörnschemeyer et al., # Water 2023, 15, 2840, Tab. 6, plant type 5 (grasses/herbs). -lai <- c(3.9, 8.5) +#lai <- c(3.9, 8.5) +lai <- 3.9 # Alle Kombinationen erzeugen From c61fb8c6c9deb7db9d9456d35d3691b584986de1 Mon Sep 17 00:00:00 2001 From: Claude Date: Tue, 7 Jul 2026 07:41:22 +0000 Subject: [PATCH 07/34] Add cost-vs-overflow-volume plot and pin Eisenstadt LAI to 3.9 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Consistency: - workflow_eisenstadt-2005.Rmd and workflow_eisenstadt-2005_neu.Rmd now unconditionally set //Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex = 3.9 (Hoernschemeyer grass value, Water 2023, 15, 2840, Tab. 6, plant type 5). Wien already sweeps LAI over c(3.9, 8.5); Bad Aussee uses the same sweep grid as Wien; Eisenstadt was the outlier still running on the base.h5 default 8.5. New feature: - plot_cost_vs_overflow_volume() -- new exported ggplot helper mirroring plot_wb_tradeoff_overflows() for cost-aware optimisation. x = cost_total (EUR), y = overflow volume in m3 (computed from sum_overflows [mm] * mulde_area [m2] / 1000), points coloured discretely by n_overflows using the same 0..x / ">x" palette and top legend. Plotly tooltip carries the cost breakdown (cost_excavation / _profiling / _filter / _storage / _total) plus the varying param_grid entries. - Each of the four case-study workflow vignettes (workflow_wien, workflow_badaussee, workflow_eisenstadt-2005, workflow_eisenstadt-2005_neu) now renders the plot as simulation_results_optimisation__cost-vs-overflow-volume.html right after the existing water-balance render, matching its PDF / saveWidget pattern exactly. - vignettes/index.Rmd gains a new "Kosten vs. Überlaufvolumen" section under "Interaktive Visualisierungen" that links to the three top-level sites (Eisenstadt 2005, Wien, Bad Aussee). https://claude.ai/code/session_014QrjF51tg7cMVmsgjmfPNG --- NAMESPACE | 1 + NEWS.md | 23 ++ R/plot_cost_vs_overflow_volume.R | 296 +++++++++++++++++++++ man/plot_cost_vs_overflow_volume.Rd | 83 ++++++ vignettes/index.Rmd | 20 ++ vignettes/workflow_badaussee.Rmd | 27 +- vignettes/workflow_eisenstadt-2005.Rmd | 34 ++- vignettes/workflow_eisenstadt-2005_neu.Rmd | 30 ++- vignettes/workflow_wien.Rmd | 30 ++- 9 files changed, 538 insertions(+), 6 deletions(-) create mode 100644 R/plot_cost_vs_overflow_volume.R create mode 100644 man/plot_cost_vs_overflow_volume.Rd diff --git a/NAMESPACE b/NAMESPACE index 6df2600..5fbbafb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ export(h5_read_values) export(h5_validate_write) export(h5_write_values) export(list_h5_datasets) +export(plot_cost_vs_overflow_volume) export(plot_hpond_vs_ref) export(plot_main_effects) export(plot_valid_design_space) diff --git a/NEWS.md b/NEWS.md index d997a05..f5ad5de 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,28 @@ # kwb.raindrop (development version) +## New features + +* New exported plot `plot_cost_vs_overflow_volume()` — companion to + `plot_wb_tradeoff_overflows()` for cost-aware optimisation. + Scatters `cost_total` (EUR) against overflow volume (m³, computed + from `sum_overflows` [mm] and `mulde_area` [m²]), points coloured + discretely by `n_overflows` with the same `0..x / ">x"` palette + and top legend as the water-balance plot. The plotly tooltip + carries the full cost breakdown (excavation, profiling, filter, + storage, total) plus the varying `param_grid` entries. Rendered + as HTML (`*_cost-vs-overflow-volume.html`) in the four case-study + vignettes and linked from `vignettes/index.Rmd` under a new + "Kosten vs. Überlaufvolumen" section. + +## Consistency + +* Eisenstadt 2005 (`workflow_eisenstadt-2005.Rmd` and + `workflow_eisenstadt-2005_neu.Rmd`) now pins + `//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex = 3.9` + (Hörnschemeyer grass value) so all four case-study vignettes + operate on the same LAI baseline. Wien uses it as one of the + sweep levels (`c(3.9, 8.5)`), Bad Aussee identical to Wien. + ## Bug fixes * `get_simulation_results_optim()` now treats a result HDF5 that exists but diff --git a/R/plot_cost_vs_overflow_volume.R b/R/plot_cost_vs_overflow_volume.R new file mode 100644 index 0000000..ecfa43c --- /dev/null +++ b/R/plot_cost_vs_overflow_volume.R @@ -0,0 +1,296 @@ +#' Cost vs. overflow-volume scatter with n_overflows-coloured points +#' +#' Companion to \code{\link{plot_wb_tradeoff_overflows}} for cost-aware +#' optimisation. Plots the per-scenario **total construction cost** (EUR) on +#' the x-axis against the **overflow volume** (m3) on the y-axis, with the +#' points coloured discretely by the **number** of overflow events (same +#' 0..x / >x palette used by `plot_wb_tradeoff_overflows`, legend at the top). +#' +#' Overflow volume is computed from `sum_overflows` (in mm on the swale +#' surface, as returned by [`add_overflow_events_and_waterbalance()`]) +#' multiplied by `mulde_area` (m2) and converted to m3: +#' `overflow_volume_m3 = sum_overflows * mulde_area / 1000`. +#' +#' The tooltip carries the cost breakdown (`cost_excavation`, +#' `cost_profiling`, `cost_filter`, `cost_storage`, `cost_total`) plus the +#' varying parameters from `param_grid` (excluding `scenario_name`), so the +#' user can hover over a scatter point and see exactly why it landed where +#' it did. +#' +#' The plot language can be switched via `lang = "de"` or `lang = "en"`. +#' Titles / axis labels / legend / tooltip labels follow the choice unless +#' explicit overrides are supplied. +#' +#' @param simulation_results_optimisation Data frame with the columns +#' `scenario_name`, `n_overflows`, `sum_overflows`, `mulde_area`, +#' `cost_excavation`, `cost_profiling`, `cost_filter`, `cost_storage`, +#' `cost_total`. Typically the joined output of +#' [`add_overflow_events_and_waterbalance()`] and +#' [`compute_costs()`]. +#' @param param_grid Data frame with parameter grid. Must contain +#' `scenario_name`. +#' @param x Numeric threshold for the overflow-count colour bucket. Values +#' greater than `x` are pushed into the red `">x"` category. +#' @param filter_n_gtx Logical. If `TRUE`, scenarios with `n_overflows > x` +#' are dropped before plotting. +#' @param use_jitter,jitter_width,jitter_height,jitter_seed As in +#' [`plot_wb_tradeoff_overflows()`]. +#' @param digits Integer. Rounding for numeric values in the tooltip. +#' @param digits_params Integer. Rounding for parameter values in the +#' tooltip. +#' @param lang Character. Plot language: `"de"` or `"en"`. +#' @param title,lab_x,lab_y Optional character overrides for the default +#' language-specific title / axis labels. +#' @param legend_position Character. Legend position, default `"top"`. +#' +#' @return A `ggplot` object. Convert to interactive via +#' `plotly::ggplotly(p, tooltip = "text")`. +#' +#' @export +#' +#' @importFrom dplyr %>% select summarise across everything n_distinct filter pull mutate group_by left_join case_when all_of +#' @importFrom tidyr pivot_longer +#' @importFrom purrr map_chr +#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual labs theme_bw position_jitter theme guides guide_legend +#' @importFrom grDevices colorRampPalette +#' @importFrom rlang .data +plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, + param_grid, + x = 1, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.15, + jitter_height = 0.15, + jitter_seed = 1L, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + title = NULL, + lab_x = NULL, + lab_y = NULL, + legend_position = "top") { + + lang <- match.arg(lang) + + txt <- switch( + lang, + de = list( + title = paste0( + "Kosten vs. Überlaufvolumen (Anzahl Überläufe ≤ ", x, ")" + ), + x = "Gesamtkosten [€]", + y = "Überlaufvolumen [m³]", + legend = "Anzahl Überlaufereignisse", + tt_scenario = "Szenario", + tt_n_overflows = "Anzahl Überlaufereignisse", + tt_sum_overflows_mm = "Summe Überläufe [mm]", + tt_overflow_volume = "Überlaufvolumen [m³]", + tt_cost_total = "Gesamtkosten", + tt_cost_excavation = "Aushub", + tt_cost_profiling = "Profilierung + Begrünung", + tt_cost_filter = "Bodenfilter", + tt_cost_storage = "Speicherschicht", + tt_costs_header = "Kostenaufteilung [€]", + tt_params = "Variierende Parameter" + ), + en = list( + title = paste0( + "Cost vs. overflow volume (overflow events ≤ ", x, ")" + ), + x = "Total cost [€]", + y = "Overflow volume [m³]", + legend = "Number of overflow events", + tt_scenario = "Scenario", + tt_n_overflows = "Number of overflow events", + tt_sum_overflows_mm = "Sum of overflows [mm]", + tt_overflow_volume = "Overflow volume [m³]", + tt_cost_total = "Total cost", + tt_cost_excavation = "Excavation", + tt_cost_profiling = "Profiling + greening", + tt_cost_filter = "Soil filter", + tt_cost_storage = "Storage layer", + tt_costs_header = "Cost breakdown [€]", + tt_params = "Varying parameters" + ) + ) + + if (is.null(title)) title <- txt$title + if (is.null(lab_x)) lab_x <- txt$x + if (is.null(lab_y)) lab_y <- txt$y + + req_grid <- c("scenario_name") + req_res <- c( + "scenario_name", "n_overflows", "sum_overflows", "mulde_area", + "cost_excavation", "cost_profiling", "cost_filter", + "cost_storage", "cost_total" + ) + + miss_grid <- setdiff(req_grid, names(param_grid)) + miss_res <- setdiff(req_res, names(simulation_results_optimisation)) + + if (length(miss_grid) > 0) { + stop("param_grid is missing column(s): ", paste(miss_grid, collapse = ", ")) + } + if (length(miss_res) > 0) { + stop( + "simulation_results_optimisation is missing column(s): ", + paste(miss_res, collapse = ", ") + ) + } + if (!is.numeric(x) || length(x) != 1 || is.na(x) || x < 0) { + stop("x must be a single non-negative numeric value.") + } + + x_int <- as.integer(round(x)) + if (!isTRUE(all.equal(x, x_int))) { + warning("x is not an integer; using x_int = ", x_int, + " for discrete palette/legend.") + } + + varying_params <- param_grid %>% + dplyr::select(-"scenario_name") %>% + dplyr::summarise(dplyr::across(dplyr::everything(), + ~ dplyr::n_distinct(.) > 1)) %>% + tidyr::pivot_longer(dplyr::everything(), + names_to = "param", + values_to = "vary") %>% + dplyr::filter(.data$vary) %>% + dplyr::pull("param") + + if (length(varying_params) == 0) { + param_tooltip <- param_grid %>% + dplyr::select("scenario_name") %>% + dplyr::mutate(params_html = "") + } else { + param_tooltip <- param_grid %>% + dplyr::select("scenario_name", dplyr::all_of(varying_params)) %>% + tidyr::pivot_longer(-"scenario_name", + names_to = "param", + values_to = "val") %>% + dplyr::mutate( + val_chr = purrr::map_chr(.data$val, ~ paste(.x, collapse = ",")), + val_num = suppressWarnings(as.numeric(.data$val_chr)), + val_fmt = ifelse( + is.na(.data$val_num), + .data$val_chr, + format(round(.data$val_num, digits_params), trim = TRUE) + ), + kv = paste0(.data$param, "=", .data$val_fmt) + ) %>% + dplyr::group_by(.data$scenario_name) %>% + dplyr::summarise(params_html = paste(.data$kv, collapse = "
"), + .groups = "drop") + } + + df <- simulation_results_optimisation %>% + dplyr::left_join(param_tooltip, by = "scenario_name") %>% + dplyr::filter(!isTRUE(filter_n_gtx) | + is.na(.data$n_overflows) | + .data$n_overflows <= x_int) %>% + dplyr::mutate( + overflow_volume_m3 = .data$sum_overflows * .data$mulde_area / 1000 + ) + + hi_lab <- paste0(">", x_int) + df <- df %>% + dplyr::mutate( + overflow_cat = dplyr::case_when( + is.na(.data$n_overflows) ~ NA_character_, + .data$n_overflows > x_int ~ hi_lab, + TRUE ~ as.character(.data$n_overflows) + ) + ) + + base_levels <- as.character(0:x_int) + levs <- c(base_levels, hi_lab) + + df <- df %>% + dplyr::mutate( + overflow_cat = factor(.data$overflow_cat, levels = levs) + ) + + if (x_int == 0L) { + pal <- c("0" = "orange", ">0" = "red") + } else if (x_int == 1L) { + pal <- c("0" = "darkgreen", "1" = "orange", ">1" = "red") + } else { + pal_green <- grDevices::colorRampPalette(c("darkgreen", "yellowgreen"))(x_int) + pal_vals <- c(pal_green, "orange", "red") + pal_names <- c(base_levels, hi_lab) + pal <- stats::setNames(pal_vals, pal_names) + } + + legend_breaks <- levs + + pos <- if (isTRUE(use_jitter)) { + ggplot2::position_jitter( + width = jitter_width, + height = jitter_height, + seed = jitter_seed + ) + } else { + "identity" + } + + legend_direction <- if (legend_position %in% c("top", "bottom")) { + "horizontal" + } else { + "vertical" + } + + legend_nrow <- if (legend_direction == "horizontal") 1 else NULL + legend_ncol <- if (legend_direction == "vertical") 1 else NULL + + p <- ggplot2::ggplot(df, ggplot2::aes( + x = .data$cost_total, + y = .data$overflow_volume_m3, + color = .data$overflow_cat, + text = paste0( + txt$tt_scenario, ": ", .data$scenario_name, + "
", txt$tt_n_overflows, ": ", .data$n_overflows, + "
", txt$tt_sum_overflows_mm, ": ", round(.data$sum_overflows, digits), + "
", txt$tt_overflow_volume, ": ", + round(.data$overflow_volume_m3, digits), + "

", txt$tt_costs_header, "", + "
", txt$tt_cost_excavation, ": ", + format(round(.data$cost_excavation, 0), big.mark = " ", trim = TRUE), + "
", txt$tt_cost_profiling, ": ", + format(round(.data$cost_profiling, 0), big.mark = " ", trim = TRUE), + "
", txt$tt_cost_filter, ": ", + format(round(.data$cost_filter, 0), big.mark = " ", trim = TRUE), + "
", txt$tt_cost_storage, ": ", + format(round(.data$cost_storage, 0), big.mark = " ", trim = TRUE), + "
", txt$tt_cost_total, ": ", + format(round(.data$cost_total, 0), big.mark = " ", trim = TRUE), "", + "

", txt$tt_params, "
", .data$params_html + ) + )) + + ggplot2::geom_point(alpha = 0.7, position = pos) + + ggplot2::scale_color_manual( + values = pal, + breaks = legend_breaks, + limits = levs, + drop = FALSE, + name = txt$legend + ) + + ggplot2::guides( + colour = ggplot2::guide_legend( + direction = legend_direction, + nrow = legend_nrow, + ncol = legend_ncol, + byrow = TRUE + ) + ) + + ggplot2::labs( + title = title, + x = lab_x, + y = lab_y + ) + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = legend_position, + legend.direction = legend_direction + ) + + p +} diff --git a/man/plot_cost_vs_overflow_volume.Rd b/man/plot_cost_vs_overflow_volume.Rd new file mode 100644 index 0000000..fed1392 --- /dev/null +++ b/man/plot_cost_vs_overflow_volume.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_cost_vs_overflow_volume.R +\name{plot_cost_vs_overflow_volume} +\alias{plot_cost_vs_overflow_volume} +\title{Cost vs. overflow-volume scatter with n_overflows-coloured points} +\usage{ +plot_cost_vs_overflow_volume( + simulation_results_optimisation, + param_grid, + x = 1, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.15, + jitter_height = 0.15, + jitter_seed = 1L, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + title = NULL, + lab_x = NULL, + lab_y = NULL, + legend_position = "top" +) +} +\arguments{ +\item{simulation_results_optimisation}{Data frame with the columns +\code{scenario_name}, \code{n_overflows}, \code{sum_overflows}, \code{mulde_area}, +\code{cost_excavation}, \code{cost_profiling}, \code{cost_filter}, +\code{cost_storage}, \code{cost_total}. Typically the joined output of +\code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and +\code{\link[=compute_costs]{compute_costs()}}.} + +\item{param_grid}{Data frame with parameter grid. Must contain +\code{scenario_name}.} + +\item{x}{Numeric threshold for the overflow-count colour bucket. Values +greater than \code{x} are pushed into the red \code{">x"} category.} + +\item{filter_n_gtx}{Logical. If \code{TRUE}, scenarios with \code{n_overflows > x} +are dropped before plotting.} + +\item{use_jitter, jitter_width, jitter_height, jitter_seed}{As in +\code{\link[=plot_wb_tradeoff_overflows]{plot_wb_tradeoff_overflows()}}.} + +\item{digits}{Integer. Rounding for numeric values in the tooltip.} + +\item{digits_params}{Integer. Rounding for parameter values in the +tooltip.} + +\item{lang}{Character. Plot language: \code{"de"} or \code{"en"}.} + +\item{title, lab_x, lab_y}{Optional character overrides for the default +language-specific title / axis labels.} + +\item{legend_position}{Character. Legend position, default \code{"top"}.} +} +\value{ +A \code{ggplot} object. Convert to interactive via +\code{plotly::ggplotly(p, tooltip = "text")}. +} +\description{ +Companion to \code{\link{plot_wb_tradeoff_overflows}} for cost-aware +optimisation. Plots the per-scenario \strong{total construction cost} (EUR) on +the x-axis against the \strong{overflow volume} (m3) on the y-axis, with the +points coloured discretely by the \strong{number} of overflow events (same +0..x / >x palette used by \code{plot_wb_tradeoff_overflows}, legend at the top). +} +\details{ +Overflow volume is computed from \code{sum_overflows} (in mm on the swale +surface, as returned by \code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}}) +multiplied by \code{mulde_area} (m2) and converted to m3: +\code{overflow_volume_m3 = sum_overflows * mulde_area / 1000}. + +The tooltip carries the cost breakdown (\code{cost_excavation}, +\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}) plus the +varying parameters from \code{param_grid} (excluding \code{scenario_name}), so the +user can hover over a scatter point and see exactly why it landed where +it did. + +The plot language can be switched via \code{lang = "de"} or \code{lang = "en"}. +Titles / axis labels / legend / tooltip labels follow the choice unless +explicit overrides are supplied. +} diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index 5439b48..42f2053 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -147,4 +147,24 @@ for (site in sites) { } ``` +### Kosten vs. Überlaufvolumen + +Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten +[€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und +`mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, +`>5` = rot, Legende oben). Mouseover zeigt die vollständige +Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, +Gesamt) plus die variierenden Design-Parameter des Szenarios. + +```{r brute_force_plots_cost-overflow, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-vs-overflow-volume.html)\n", + site, + base_dir, + site + )) +} +``` + diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index 71b297c..18ef075 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -561,6 +561,31 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( ) # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) + suppressWarnings(print(p)) +dev.off() + +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_overflow_volume( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE +) + +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. overflow volume", + paths$modelname) +) + +suppressWarnings(print(p)) dev.off() ``` \ No newline at end of file diff --git a/vignettes/workflow_eisenstadt-2005.Rmd b/vignettes/workflow_eisenstadt-2005.Rmd index 474da95..7a1c6b4 100644 --- a/vignettes/workflow_eisenstadt-2005.Rmd +++ b/vignettes/workflow_eisenstadt-2005.Rmd @@ -210,7 +210,12 @@ run_one <- function(i, vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, param_grid_tmp$storage_height) vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity - + # Pin LAI to the grass value from Hoernschemeyer et al. (Water 2023, + # 15, 2840, Tab. 6, plant type 5 = grasses/herbs); base.h5 ships 8.5. + # Wien and Bad Aussee already use 3.9 (Wien as one of the sweep + # levels); this line keeps Eisenstadt 2005 consistent. + vals$`//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` <- 3.9 + vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- psi_s_mm(param_grid_tmp$filter_hydraulicconductivity) @@ -447,8 +452,33 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( ) # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) + suppressWarnings(print(p)) dev.off() #kwb.utils::finishAndShowPdf(pdff) +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_overflow_volume( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE +) + +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. overflow volume", + paths$modelname) +) + +suppressWarnings(print(p)) +dev.off() + ``` \ No newline at end of file diff --git a/vignettes/workflow_eisenstadt-2005_neu.Rmd b/vignettes/workflow_eisenstadt-2005_neu.Rmd index c95f8a8..9a6e49e 100644 --- a/vignettes/workflow_eisenstadt-2005_neu.Rmd +++ b/vignettes/workflow_eisenstadt-2005_neu.Rmd @@ -215,7 +215,10 @@ run_one <- function(i, vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, param_grid_tmp$storage_height) vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity - + # Pin LAI to the grass value from Hoernschemeyer et al. (Water 2023, + # 15, 2840, Tab. 6, plant type 5 = grasses/herbs); base.h5 ships 8.5. + vals$`//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` <- 3.9 + vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- psi_s_mm(param_grid_tmp$filter_hydraulicconductivity) @@ -411,8 +414,31 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( ) # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) + suppressWarnings(print(p)) dev.off() #kwb.utils::finishAndShowPdf(pdff) +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_overflow_volume( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + filter_n_gtx = FALSE, + use_jitter = TRUE +) + +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", + paths$modelname), + selfcontained = TRUE, + title = "Cost vs. overflow volume" +) + +suppressWarnings(print(p)) +dev.off() + ``` diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index 4e0e684..3d0b38e 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -557,7 +557,35 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( ) # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) + suppressWarnings(print(p)) +dev.off() +#kwb.utils::finishAndShowPdf(pdff) + +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_overflow_volume( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE +) + +# interaktiv als HTML +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. overflow volume", + paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) dev.off() #kwb.utils::finishAndShowPdf(pdff) From 7166211cf38ecf54d26f423dc4d5eb567f1555b6 Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 7 Jul 2026 08:55:18 +0100 Subject: [PATCH 08/34] Update docu + delete unneeded vignette --- .Rbuildignore | 2 + .gitignore | 1 + DESCRIPTION | 2 +- man/plot_cost_vs_overflow_volume.Rd | 4 +- vignettes/workflow_eisenstadt-2005_neu.Rmd | 444 --------------------- 5 files changed, 6 insertions(+), 447 deletions(-) delete mode 100644 vignettes/workflow_eisenstadt-2005_neu.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index 5ae8bc9..aaee986 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -9,3 +9,5 @@ ^index\.md$ ^README\.md$ ^vignettes/index\.Rmd$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index 0d7f03b..5c9c9ee 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ .Ruserdata docs inst/doc +.positai diff --git a/DESCRIPTION b/DESCRIPTION index 9482d3b..56be511 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -49,4 +49,4 @@ Remotes: github::kwb-r/kwb.utils Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +Config/roxygen2/version: 8.0.0 diff --git a/man/plot_cost_vs_overflow_volume.Rd b/man/plot_cost_vs_overflow_volume.Rd index fed1392..f0f8c9f 100644 --- a/man/plot_cost_vs_overflow_volume.Rd +++ b/man/plot_cost_vs_overflow_volume.Rd @@ -25,8 +25,8 @@ plot_cost_vs_overflow_volume( \arguments{ \item{simulation_results_optimisation}{Data frame with the columns \code{scenario_name}, \code{n_overflows}, \code{sum_overflows}, \code{mulde_area}, -\code{cost_excavation}, \code{cost_profiling}, \code{cost_filter}, -\code{cost_storage}, \code{cost_total}. Typically the joined output of +\code{cost_excavation}, \code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, +\code{cost_total}. Typically the joined output of \code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and \code{\link[=compute_costs]{compute_costs()}}.} diff --git a/vignettes/workflow_eisenstadt-2005_neu.Rmd b/vignettes/workflow_eisenstadt-2005_neu.Rmd deleted file mode 100644 index 9a6e49e..0000000 --- a/vignettes/workflow_eisenstadt-2005_neu.Rmd +++ /dev/null @@ -1,444 +0,0 @@ ---- -title: "Workflow Eisenstadt (2005, neuer Rechenkern 2026-01-22)" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Workflow Eisenstadt (2005, neuer Rechenkern 2026-01-22)} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- - -```{r, include = FALSE, eval=TRUE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>" -) -is_ghactions <- tolower(Sys.getenv("GITHUB_ACTIONS")) == "true" || - tolower(Sys.getenv("CI")) %in% c("true", "1", "yes") - -# base.h5 ships in inst/extdata/models/eisenstadt-2005/. The vignette only -# renders if that file is present; the engine .exe is fetched from the -# kwb.raindrop.binaries Release on demand and only runs on Windows. -# This vignette pins engine 2026-01-22 — that release must exist in the -# binaries repo for the run_model chunk to succeed locally on Windows. -# On CI the engine is never downloaded (preparation builds path_exe via -# the is_windows && !is_ghactions guard, and run_model itself is gated -# off with !is_ghactions). -path_base <- system.file("extdata/models/eisenstadt-2005/base.h5", package = "kwb.raindrop") -data_available <- nzchar(path_base) && file.exists(path_base) -is_windows <- Sys.info()[["sysname"]] == "Windows" -engine_version <- "2026-01-22" -``` - -### Input data - -The HDF5 model template (`base.h5`) ships with the package under -`inst/extdata/models/eisenstadt-2005/` and is produced with the -Tandler "Regenwasserbewirtschaftung" calculation engine. This vignette -pins engine version `2026-01-22` (newer Rechenkern); the engine is -downloaded from the `KWB-R/kwb.raindrop.binaries` GitHub Release on -demand via `kwb.raindrop::download_engine("2026-01-22")`. - -### Define Paths and Scenarios - -```{r preparation, eval = data_available} -library(kwb.raindrop) - -path_list <- list( - modelname = "Eisenstadt_2005", - root_path = file.path(tempdir(), "raindrop_eisenstadt_2005_neu"), - dir_input = "/models//input", - dir_output = "/models//output", - dir_target_output = "/", - file_errors_hdf5 = "Fehlerprotokoll.h5", - file_results_hdf5_element = "Mulde_Rigole.h5", - file_results_hdf5_flaeche = "Dach.h5", - file_results_hdf5_verschaltungen = "_Verschaltungen.h5", - file_results_txt = "Mulde_Rigole_RAINDROP.txt", - file_results_txt_multilayer = "Mulde_Rigole_RAINDROP_multi_layer.txt", - file_target = ".h5", - path_base = system.file("extdata/models/eisenstadt-2005/base.h5", package = "kwb.raindrop"), - path_exe = if (is_windows && !is_ghactions) kwb.raindrop::download_engine(engine_version) else NA_character_, - path_errors_hdf5 = "/", - path_results_hdf5_element = "/", - path_results_hdf5_flaeche = "/", - path_results_hdf5_verschaltungen = "/", - path_results_txt = "/", - path_results_txt_multilayer = "/", - path_target_input = "/" -) - - -parameters <- tibble::tibble( - para_nama_short = c( - "connected_area", - "mulde_area", - "mulde_height", - "filter_hydraulicconductivity", - # "filter_height", - "storage_height"#, - # "bottom_hydraulicconductivity" - ), - para_name_long = c( - "/Massnahmenelemente/Dach/Allgemein/Flaeche", - "/Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche", - "/Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe", - "Bodenarten/Bodenfilter/Ks_HydraulicConductivity", - #"/Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken", - "/Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken"#, - # "/Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate" - ), - index = c(1L, - 1L, - 1L, - 1L, - 2) -) - -DT::datatable(parameters, - filter = "top", - options = list(pageLength = 25, - autoWidth = TRUE)) - - -connected_area <- 1000 -mulde_area <- c(25, 50, 75, 100, 125, 150, 175, 200) -mulde_height <- c(100, 200, 300) -filter_hydraulicconductivity <- c(36, 180, 360) -filter_height <- 300 -storage_height <- c(100, 500, 1000) -rain_factor <- 1 -bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) - - -# Alle Kombinationen erzeugen -param_grid_all_combinations <- expand.grid( - connected_area = connected_area, - mulde_area = mulde_area, - mulde_height = mulde_height, - filter_hydraulicconductivity = filter_hydraulicconductivity, - filter_height = filter_height, - storage_height = storage_height, - bottom_hydraulicconductivity = bottom_hydraulicconductivity, - rain_factor = rain_factor -) - -param_grid_all_combinations <- param_grid_all_combinations %>% - dplyr::bind_cols(tibble::tibble(scenario_name = sprintf("s%05d", - seq_len(nrow(param_grid_all_combinations))))) - -ref_scenario <- param_grid_all_combinations %>% - dplyr::filter(connected_area == min(unique(param_grid_all_combinations$connected_area)), - mulde_area == min(unique(param_grid_all_combinations$mulde_area)), - filter_height == min(filter_height), - filter_hydraulicconductivity == min(param_grid_all_combinations$filter_hydraulicconductivity), - bottom_hydraulicconductivity == min(unique(param_grid_all_combinations$bottom_hydraulicconductivity)), - mulde_height == min(param_grid_all_combinations$mulde_height), - storage_height == min(param_grid_all_combinations$storage_height)) %>% - dplyr::pull(scenario_name) - -stopifnot(length(ref_scenario)==1) - -scenarios_with_single_parameter_variation <- kwb.raindrop::find_single_param_variations( - data = param_grid_all_combinations, - ref_scenario = ref_scenario - ) %>% - dplyr::pull(scenario_name) %>% unique() - -param_grid <- param_grid_all_combinations %>% - dplyr::filter(scenario_name %in% scenarios_with_single_parameter_variation) -param_grid <- param_grid_all_combinations - -DT::datatable(param_grid, - filter = "top", - options = list(pageLength = 25, - autoWidth = TRUE)) - -htmlwidgets::saveWidget(DT::datatable(parameters, - filter = "top", - options = list(pageLength = 25, - autoWidth = TRUE)), "parameters.html") -htmlwidgets::saveWidget(DT::datatable(param_grid, - filter = "top", - options = list(pageLength = 25, - autoWidth = TRUE)), "param_grid.html") - - -psi_s_mm <- function(kf_mmh) (3.237 * (kf_mmh/25.4)^(-0.328)) * 25.4 - -paths <- kwb.utils::resolve(path_list) -``` - -### Run Model - -```{r run_model, eval = data_available && is_windows && !is_ghactions} -run_one <- function(i, - timestep_hours, - debug = FALSE, - ...) { - - param_grid_tmp <- param_grid[i, ] - - paths <- kwb.utils::resolve(path_list, - dir_target = param_grid_tmp$scenario_name) - - fs::dir_create(paths$dir_input, recurse = TRUE) - fs::dir_create(paths$dir_output, recurse = TRUE) - fs::dir_create(paths$dir_target_output, recurse = TRUE) - - fs::file_copy(path = paths$path_base, - new_path = paths$path_target_input, - overwrite = TRUE) - - h5 <- hdf5r::H5File$new(paths$path_target_input, mode = "a") - - new_path <- stringr::str_c(normalizePath(fs::path_abs(paths$dir_target_output)), - "\\") - - vals <- kwb.raindrop::h5_read_values(h5) - - vals$`//Berechnungsparameter/Ergebnispfad` <- new_path - vals$`//Berechnungsparameter/Zeitschritt_Infiltration` <- timestep_hours - vals$`//Berechnungsparameter/Zeitschritt_ET` <- timestep_hours - vals$`//Berechnungsparameter/Zeitschritt_Verschaltungen` <- timestep_hours - vals$`//Berechnungsparameter/R-Plots` <- 0 - vals$`//Berechnungsparameter/Ausgabemodus` <- "Optimierung" - vals$`//Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - - vals$`//Massnahmenelemente/Dach/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - vals$`//Massnahmenelemente/Dach/Allgemein/Flaeche` <- param_grid_tmp$connected_area - - vals$`//Massnahmenelemente/Mulde_Rigole/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- param_grid_tmp$mulde_area - vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- param_grid_tmp$mulde_height - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, 0) - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, - param_grid_tmp$storage_height) - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity - # Pin LAI to the grass value from Hoernschemeyer et al. (Water 2023, - # 15, 2840, Tab. 6, plant type 5 = grasses/herbs); base.h5 ships 8.5. - vals$`//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` <- 3.9 - - vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity - vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- psi_s_mm(param_grid_tmp$filter_hydraulicconductivity) - - kwb.raindrop::h5_write_values(h5, vals, resize = TRUE, - scalar_strategy = "error", - verbose = FALSE) - h5$close_all() - - kwb.raindrop::run_model(path_exe = paths$path_exe, - path_input = paths$path_target_input, - debug = debug) - - # Thin immediately: read only this run's results (lean = water balance + - # overflow rates, no states/meta/connected-area rates) and reduce to the - # single optimisation row. This way we never hold all scenarios' full - # time series in memory at once; the full result HDF5 stays on disk for - # ad-hoc inspection. - sim_one <- kwb.raindrop::get_simulation_results_optim( - paths = paths, - path_list = path_list, - simulation_names = param_grid_tmp$scenario_name, - debug = debug, - lean = TRUE - ) - - kwb.raindrop::add_overflow_events_and_waterbalance( - simulation_results = sim_one, - event_separation_hours = 4, - canonical_variables = kwb.raindrop::default_canonical_wb_variables() - ) -} - -n_cores <- parallel::detectCores() - -# run_one() now returns the thinned per-run optimisation row, so run_scenarios() -# yields a list of one-row tibbles we simply bind below. -scenario_rows <- NULL -system.time(expr = { -scenario_rows <- kwb.raindrop::run_scenarios(indices = seq_len(nrow(param_grid)), - run_one_scenario = run_one, - timestep_hours = 0.1, - debug = FALSE, - parallel = TRUE, - workers = n_cores, - show_progress = TRUE - ) -} -) - -### Read results for first run -if(FALSE) { -paths <- kwb.utils::resolve(path_list, - dir_target = sprintf("s%05d", i = 1)) - -#simulation_names <- basename(fs::dir_ls(paths$dir_output)) -simulation_names <- scenarios_with_single_parameter_variation -simulation_names <- param_grid$scenario_nam -simulation_names <- simulation_names[1:8] - -debug <- TRUEn_cores -errors_df <- kwb.raindrop::read_raindrop_errors(simulation_names, path_list) -x <- tidyr::unnest(errors_df, errors) -x$Fehlerbeschreibung -} - -``` - -### Analyse Results - -```{r analyse_results, eval = data_available && is_windows && !is_ghactions} -# Each run was already thinned to its optimisation row inside run_one(), so we -# just bind the per-run rows here instead of re-reading every run's full -# results into memory. (The previous get_simulation_results_optim_parallel() + -# add_overflow_events_and_waterbalance() pass loaded all runs at once.) -simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) - -simulation_results_optimisation <- param_grid %>% - dplyr::left_join(simulation_results_optimisation, - by = c("scenario_name" = "s_name")) %>% - dplyr::relocate(scenario_name, .before = connected_area) - -readr::write_csv(simulation_results_optimisation, - file = sprintf("simulation_results_optimisation_%s.csv", - paths$modelname) - ) - -htmlwidgets::saveWidget(DT::datatable(simulation_results_optimisation, - filter = "top", - options = list(pageLength = 25, - autoWidth = TRUE)), - file = sprintf("simulation_results_optimisation_%s.html", - paths$modelname), - title = "RAINDROP - Solution Space") - -### Plot results - - -params <- c( - #"connected_area", - "mulde_area", - "mulde_height", - "filter_hydraulicconductivity", - #"filter_height", - "storage_height"#, - #"bottom_hydraulicconductivity", - #"rain_factor" -) - -pdff <- sprintf("simulation_results_optimisation_%s_main-effects.pdf", - paths$modelname) - -gg <- kwb.raindrop::plot_main_effects( - df = simulation_results_optimisation, - y = "n_overflows", - params = params -) - -# --- 1) Statisch ins PDF: kein Plotly dazwischen! -kwb.utils::preparePdf(pdfFile = pdff) -print(gg) -dev.off() -#kwb.utils::finishAndShowPdf(pdff) - -# --- 2) Interaktiv als HTML: nach dem PDF -plotly_gg <- plotly::ggplotly(gg) - -htmlwidgets::saveWidget( - widget = plotly_gg, - file = sprintf("simulation_results_optimisation_%s_main-effects.html", - paths$modelname), - selfcontained = TRUE, - title = "RAINDROP - Main Effects" -) - - - -pdff <- sprintf("simulation_results_optimisation_%s_design-space_mulde-area_vs_parameters.pdf", - paths$modelname) -kwb.utils::preparePdf(pdfFile = pdff) - -for (y in c("mulde_height", "filter_hydraulicconductivity", "storage_height")) { - - p <- kwb.raindrop::plot_valid_design_space( - param_grid = param_grid, - sim_results = simulation_results_optimisation, - x = "mulde_area", - y = y, - valid_max = 1, - jitter = TRUE, - alpha_mode = "duplicates", - alpha_min = 0.25, - alpha_max = 1, - drop_overflow_gt_valid_max = TRUE, - keep_param_grid_limits = TRUE - ) - - # interaktiv als HTML - plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) - htmlwidgets::saveWidget( - widget = plotly_p, - file = sprintf("simulation_results_optimisation_%s_design-space_mulde-area_vs_%s.html", - paths$modelname, - y), - selfcontained = TRUE, - title = sprintf("Design Space: mulde_area vs. %s", y) - ) - - # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) -} -dev.off() -#kwb.utils::finishAndShowPdf(pdff) - -pdff <- sprintf("simulation_results_optimisation_%s_water-balance.pdf", - paths$modelname) -kwb.utils::preparePdf(pdfFile = pdff) - -p <- kwb.raindrop::plot_wb_tradeoff_overflows( - simulation_results_optimisation = simulation_results_optimisation, - param_grid = param_grid, - filter_n_gt1 = TRUE, - use_jitter = TRUE - ) - - # interaktiv als HTML - plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) - htmlwidgets::saveWidget( - widget = plotly_p, - file = sprintf("simulation_results_optimisation_%s_water-balance.html", - paths$modelname), - selfcontained = TRUE, - title = "Water balance vs overflows" - ) - - # statisch ins PDF (WICHTIG!) - suppressWarnings(print(p)) -dev.off() -#kwb.utils::finishAndShowPdf(pdff) - -pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.pdf", - paths$modelname) -kwb.utils::preparePdf(pdfFile = pdff) - -p <- kwb.raindrop::plot_cost_vs_overflow_volume( - simulation_results_optimisation = simulation_results_optimisation, - param_grid = param_grid, - filter_n_gtx = FALSE, - use_jitter = TRUE -) - -plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) -htmlwidgets::saveWidget( - widget = plotly_p, - file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", - paths$modelname), - selfcontained = TRUE, - title = "Cost vs. overflow volume" -) - -suppressWarnings(print(p)) -dev.off() - -``` From 6c4575193a2fa787227a4550d66a3bcb9aebc621 Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 7 Jul 2026 14:39:25 +0100 Subject: [PATCH 09/34] Add cost-overflow boxplots, enrich tooltips, fix Eisenstadt costs Builds on the cost-vs-overflow-volume plot (PR #15) with a new cost-by-overflow-count boxplot (three best-selection variants), richer tooltips and i18n parameter labels, and fixes the Eisenstadt cost pipeline the PR review flagged. Bug fix (PR #15 review blocker): - vignettes/workflow_eisenstadt-2005.Rmd now pipes the joined optimisation results through kwb.raindrop::compute_costs(), like the Wien and Bad Aussee workflows already did. Without it the vignette's plot_cost_vs_overflow_volume() call aborted with "missing column(s): cost_excavation, ..." on Windows, so the cost PDF/HTML was never produced and the exported CSV lacked the cost columns. New plot -- plot_cost_overflow_boxplot() (exported): - Boxplot of total construction cost (EUR, y) per number of overflow events (x). Counts 0..x each get their own box (x = max_n_overflows, as in the sibling plots); higher counts collapse into a single ">x" catch-all box (furthest right, red), keeping the axis readable for the long-tailed 15-year runs (Wien / Bad Aussee reach several hundred overflow events). The ">x" box highlights the scenario with the fewest overflow events above x (closest to valid), best_by breaking ties. - Individual scenarios are overlaid as jittered points whose size scales with a chosen variable (size_by): the overflow volume (m3, default) or the element evapotranspiration share (%). The size scale is calibrated to the valid region (0..x) and capped, with a minimum size, so the many-overflow outliers of the ">x" box do not shrink the valid-region points to invisible dots. - One best scenario per box is highlighted with a black-outlined diamond in that box's group colour (so its tooltip inherits the group colour) and the best of all boxes are joined by a frontier line (mark_best / connect_best). best_by picks the objective, cost as tie-breaker -- "min_cost" (cheapest), "min_overflow" (smallest overflow volume) or "max_evapotranspiration" (highest evapotranspiration) -- so the three variants trace three different frontier lines; label_best annotates the marker ("NN m3 / NN %" or "NN %"). - Each case-study vignette loops the three variants into *_cost-by-overflows-boxplot-{cheapest,min-overflow,max-evap}.html, all linked from vignettes/index.Rmd, which now groups the cost plots under one "Kosten" heading with sub-points (toc_depth 4). Tooltip enrichment (shared helpers in R/cost_tooltip.R): - The plotly tooltip of plot_cost_vs_overflow_volume() now carries the element water balance (evapotranspiration / infiltration / overflow, all in %) in addition to the cost breakdown, and names the chosen storage type on its own bold line, bilingually ("Sickerbox / Infiltration box" or "Schotterrigol / Gravel trench"). - The "varying parameters" block is translated via the new exported default_param_labels() helper -- a hovered point shows e.g. "Muldenflaeche [m2]=125" (de) / "Swale area [m2]=125" (en) instead of the raw "mulde_area=125"; override with param_labels =. - cost_tooltip_labels() / cost_tooltip_text() / build_varying_param_html() are shared so both cost plots emit byte-identical tooltips. Code hygiene: - All non-ASCII characters in R code (string literals in the plot functions and in the vignette code chunks) are unicode-escaped (\uXXXX); the few non-ASCII code comments were rewritten in plain ASCII ("Hoernschemeyer", "2xN"). Markdown prose keeps UTF-8. New exports: plot_cost_overflow_boxplot(), default_param_labels(). --- NAMESPACE | 10 + NEWS.md | 58 +++- R/cost_tooltip.R | 222 ++++++++++++++++ R/plot_cost_overflow_boxplot.R | 349 +++++++++++++++++++++++++ R/plot_cost_vs_overflow_volume.R | 133 +++------- man/default_param_labels.Rd | 32 +++ man/plot_cost_overflow_boxplot.Rd | 146 +++++++++++ man/plot_cost_vs_overflow_volume.Rd | 29 +- vignettes/example_wien_minimal.Rmd | 4 +- vignettes/index.Rmd | 73 +++++- vignettes/workflow_badaussee.Rmd | 55 +++- vignettes/workflow_eisenstadt-2005.Rmd | 58 +++- vignettes/workflow_wien.Rmd | 52 +++- 13 files changed, 1098 insertions(+), 123 deletions(-) create mode 100644 R/cost_tooltip.R create mode 100644 R/plot_cost_overflow_boxplot.R create mode 100644 man/default_param_labels.Rd create mode 100644 man/plot_cost_overflow_boxplot.Rd diff --git a/NAMESPACE b/NAMESPACE index 5fbbafb..395fbb6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ export(add_overflow_events_and_waterbalance) export(compute_costs) export(default_canonical_wb_variables) export(default_cost_rates) +export(default_param_labels) export(download_engine) export(find_single_param_variations) export(get_simulation_results_all) @@ -16,6 +17,7 @@ export(h5_read_values) export(h5_validate_write) export(h5_write_values) export(list_h5_datasets) +export(plot_cost_overflow_boxplot) export(plot_cost_vs_overflow_volume) export(plot_hpond_vs_ref) export(plot_main_effects) @@ -34,6 +36,8 @@ importFrom(dplyr,arrange) importFrom(dplyr,bind_cols) importFrom(dplyr,bind_rows) importFrom(dplyr,case_when) +importFrom(dplyr,coalesce) +importFrom(dplyr,desc) importFrom(dplyr,everything) importFrom(dplyr,filter) importFrom(dplyr,group_by) @@ -45,6 +49,7 @@ importFrom(dplyr,n_distinct) importFrom(dplyr,pull) importFrom(dplyr,relocate) importFrom(dplyr,select) +importFrom(dplyr,slice) importFrom(dplyr,summarise) importFrom(dplyr,transmute) importFrom(dplyr,ungroup) @@ -63,7 +68,9 @@ importFrom(ggplot2,element_text) importFrom(ggplot2,facet_wrap) importFrom(ggplot2,geom_boxplot) importFrom(ggplot2,geom_jitter) +importFrom(ggplot2,geom_line) importFrom(ggplot2,geom_point) +importFrom(ggplot2,geom_text) importFrom(ggplot2,geom_violin) importFrom(ggplot2,ggplot) importFrom(ggplot2,guide_legend) @@ -71,9 +78,12 @@ importFrom(ggplot2,guides) importFrom(ggplot2,labs) importFrom(ggplot2,position_identity) importFrom(ggplot2,position_jitter) +importFrom(ggplot2,position_nudge) importFrom(ggplot2,scale_alpha_identity) importFrom(ggplot2,scale_color_manual) importFrom(ggplot2,scale_colour_manual) +importFrom(ggplot2,scale_fill_manual) +importFrom(ggplot2,scale_size) importFrom(ggplot2,scale_x_continuous) importFrom(ggplot2,scale_x_discrete) importFrom(ggplot2,scale_y_continuous) diff --git a/NEWS.md b/NEWS.md index f5ad5de..d7434fc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -8,14 +8,59 @@ from `sum_overflows` [mm] and `mulde_area` [m²]), points coloured discretely by `n_overflows` with the same `0..x / ">x"` palette and top legend as the water-balance plot. The plotly tooltip - carries the full cost breakdown (excavation, profiling, filter, - storage, total) plus the varying `param_grid` entries. Rendered - as HTML (`*_cost-vs-overflow-volume.html`) in the four case-study + carries the element water balance (evapotranspiration, infiltration, + overflow — all in %), the chosen storage type on its own bold line + (bilingual, `Sickerbox / Infiltration box` or + `Schotterrigol / Gravel trench`), the full cost breakdown (excavation, + profiling, filter, storage, total) plus the varying `param_grid` + entries (translated via `default_param_labels()`). Rendered + as HTML (`*_cost-vs-overflow-volume.html`) in the three case-study vignettes and linked from `vignettes/index.Rmd` under a new "Kosten vs. Überlaufvolumen" section. +* New exported plot `plot_cost_overflow_boxplot()` — boxplot of the + total construction cost (EUR, y) per number of overflow events (x), + with the individual scenarios overlaid as jittered points whose + **size scales with the overflow volume** (m³; the size scale is + calibrated to the valid region so the many-overflow outliers do not + shrink the valid-region points away, and a minimum size keeps every + point visible). Counts up to the + threshold `x` (= `max_n_overflows`, as in the sibling plots) each get + their own box; higher counts collapse into a single `">x"` catch-all + box (furthest right, red), keeping the axis readable for the long-tailed + 15-year runs (Wien / Bad Aussee reach several hundred overflow events); + the `">x"` box highlights the scenario with the fewest overflow events + above `x`. One best scenario per box is highlighted with a black-outlined + diamond + in that box's group colour (so its tooltip inherits the group colour), + and the best scenarios of **all** boxes are joined by a frontier line + (`mark_best` / `connect_best`). The point tooltip is identical to + `plot_cost_vs_overflow_volume()`. `best_by` picks the objective (cost + as tie-breaker) — `"min_cost"` (cheapest), `"min_overflow"` (smallest + overflow volume) or `"max_evapotranspiration"` (highest + evapotranspiration) — so the three variants trace three different + frontier lines; `label_best` annotates the marker (overflow volume + + share `"NN m³ / NN %"`, or evapotranspiration `"NN %"`); + `size_by` scales the points by overflow volume (default) or + evapotranspiration. The three case-study vignettes render all three + variants (`*_cost-by-overflows-boxplot-cheapest.html`, + `*-min-overflow.html`, `*-max-evap.html`), each linked from + `vignettes/index.Rmd` under the grouped "Kosten" section. + +* New exported helper `default_param_labels()` — German / English, + unit-carrying labels for the parameter-grid columns. The + "varying parameters" block of both cost-plot tooltips now shows e.g. + `Muldenfläche [m²]=125` instead of the raw `mulde_area=125`; pass + `param_labels =` to the plot functions to override. + ## Consistency +* Non-ASCII characters in R code are now unicode-escaped: all string literals + in `plot_cost_vs_overflow_volume()` and in the vignette code chunks use + `\uxxxx` escapes (rendered labels unchanged), and the few non-ASCII code + comments were rewritten in plain ASCII. Markdown prose keeps UTF-8 (escapes + are not interpreted there). + * Eisenstadt 2005 (`workflow_eisenstadt-2005.Rmd` and `workflow_eisenstadt-2005_neu.Rmd`) now pins `//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex = 3.9` @@ -25,6 +70,13 @@ ## Bug fixes +* `vignettes/workflow_eisenstadt-2005.Rmd` now pipes the joined optimisation + results through `kwb.raindrop::compute_costs()` like the Wien and Bad Aussee + workflows already did. Without it the vignette's + `plot_cost_vs_overflow_volume()` call aborted with "missing column(s): + cost_excavation, ..." — the cost-vs-overflow-volume PDF/HTML was never + produced and the exported CSV lacked the cost columns. + * `get_simulation_results_optim()` now treats a result HDF5 that exists but cannot be opened/read (e.g. the engine crashed mid-write for a scenario, or a file briefly locked just after the run) like a missing file: it `warning()`s, diff --git a/R/cost_tooltip.R b/R/cost_tooltip.R new file mode 100644 index 0000000..f30c03e --- /dev/null +++ b/R/cost_tooltip.R @@ -0,0 +1,222 @@ +#' German / English labels for optimisation parameter-grid columns +#' +#' Maps the raw `param_grid` column names produced by the case-study workflows +#' to human-readable, unit-carrying labels. Used to translate the +#' "varying parameters" block in the interactive tooltips of +#' [plot_cost_vs_overflow_volume()] and [plot_cost_overflow_boxplot()], so a +#' hovered point shows e.g. `Muldenflaeche [m2]=125` instead of the raw +#' `mulde_area=125`. +#' +#' Unknown columns fall back to their raw name, so a grid gaining a new column +#' still renders (just untranslated). Override individual entries or pass your +#' own named vector via the `param_labels` argument of the plot functions. +#' +#' @param lang Character. `"de"` or `"en"`. +#' +#' @return A named `character` vector: names are `param_grid` column names, +#' values are the display labels. +#' +#' @export +#' +#' @examples +#' default_param_labels("de")[["mulde_area"]] +#' default_param_labels("en")[["storage_height"]] +default_param_labels <- function(lang = c("de", "en")) { + lang <- match.arg(lang) + switch( + lang, + de = c( + connected_area = "Angeschlossene Fl\u00e4che [m\u00b2]", + mulde_area = "Muldenfl\u00e4che [m\u00b2]", + mulde_height = "Muldenh\u00f6he [mm]", + filter_hydraulicconductivity = "Filter-Leitf\u00e4higkeit kf [mm/h]", + filter_height = "Filterh\u00f6he [mm]", + storage_height = "Speicherh\u00f6he [mm]", + bottom_hydraulicconductivity = "Sohl-Leitf\u00e4higkeit kf [mm/h]", + rain_factor = "Regenfaktor [-]", + lai = "Blattfl\u00e4chenindex LAI [-]", + storage_type = "Speichertyp" + ), + en = c( + connected_area = "Connected area [m\u00b2]", + mulde_area = "Swale area [m\u00b2]", + mulde_height = "Swale depth [mm]", + filter_hydraulicconductivity = "Filter conductivity kf [mm/h]", + filter_height = "Filter thickness [mm]", + storage_height = "Storage thickness [mm]", + bottom_hydraulicconductivity = "Subsoil conductivity kf [mm/h]", + rain_factor = "Rain factor [-]", + lai = "Leaf area index LAI [-]", + storage_type = "Storage type" + ) + ) +} + +#' Per-scenario HTML of the varying parameter-grid entries (translated) +#' +#' Detects the `param_grid` columns that vary across scenarios (excluding +#' `scenario_name`), formats their values, translates the parameter names via +#' `param_labels`, and collapses them into one `
`-separated HTML string per +#' scenario for use in a plotly tooltip. +#' +#' @param param_grid Data frame with a `scenario_name` column. +#' @param lang Character. `"de"` or `"en"`. +#' @param param_labels Named character vector mapping columns to labels, or +#' `NULL` to use [default_param_labels()]. +#' @param digits_params Integer. Rounding for numeric parameter values. +#' +#' @return A tibble with columns `scenario_name` and `params_html`. +#' +#' @importFrom dplyr %>% select summarise across everything n_distinct filter +#' @importFrom dplyr pull mutate group_by all_of coalesce +#' @importFrom tidyr pivot_longer +#' @importFrom purrr map_chr +#' @importFrom rlang .data +#' @noRd +build_varying_param_html <- function(param_grid, lang = c("de", "en"), + param_labels = NULL, digits_params = 4L) { + lang <- match.arg(lang) + if (is.null(param_labels)) param_labels <- default_param_labels(lang) + + varying_params <- param_grid %>% + dplyr::select(-"scenario_name") %>% + dplyr::summarise(dplyr::across(dplyr::everything(), + ~ dplyr::n_distinct(.) > 1)) %>% + tidyr::pivot_longer(dplyr::everything(), + names_to = "param", + values_to = "vary") %>% + dplyr::filter(.data$vary) %>% + dplyr::pull("param") + + if (length(varying_params) == 0) { + return( + param_grid %>% + dplyr::select("scenario_name") %>% + dplyr::mutate(params_html = "") + ) + } + + param_grid %>% + dplyr::select("scenario_name", dplyr::all_of(varying_params)) %>% + tidyr::pivot_longer(-"scenario_name", + names_to = "param", + values_to = "val") %>% + dplyr::mutate( + val_chr = purrr::map_chr(.data$val, ~ paste(.x, collapse = ",")), + val_num = suppressWarnings(as.numeric(.data$val_chr)), + val_fmt = ifelse( + is.na(.data$val_num), + .data$val_chr, + format(round(.data$val_num, digits_params), trim = TRUE) + ), + param_label = dplyr::coalesce(unname(param_labels[.data$param]), + .data$param), + kv = paste0(.data$param_label, "=", .data$val_fmt) + ) %>% + dplyr::group_by(.data$scenario_name) %>% + dplyr::summarise(params_html = paste(.data$kv, collapse = "
"), + .groups = "drop") +} + +#' Shared tooltip labels for the cost plots +#' +#' The `tt_*` label set used to assemble the (identical) plotly tooltip of +#' [plot_cost_vs_overflow_volume()] and [plot_cost_overflow_boxplot()]. +#' +#' @param lang Character. `"de"` or `"en"`. +#' @return Named list of label strings. +#' @noRd +cost_tooltip_labels <- function(lang = c("de", "en")) { + lang <- match.arg(lang) + switch( + lang, + de = list( + tt_scenario = "Szenario", + tt_n_overflows = "Anzahl \u00dcberlaufereignisse", + tt_sum_overflows_mm = "Summe \u00dcberl\u00e4ufe [mm]", + tt_overflow_volume = "\u00dcberlaufvolumen [m\u00b3]", + tt_wb_header = "Wasserhaushalt [%]", + tt_wb_evap = "Verdunstung", + tt_wb_infil = "Versickerung", + tt_wb_overflow = "\u00dcberlauf", + tt_cost_total = "Gesamtkosten", + tt_cost_excavation = "Aushub", + tt_cost_profiling = "Profilierung + Begr\u00fcnung", + tt_cost_filter = "Bodenfilter", + tt_cost_storage = "Speicherschicht", + tt_storage_type = "Speichertyp", + st_infiltration_box = "Sickerbox / Infiltration box", + st_gravel_trench = "Schotterrigol / Gravel trench", + tt_costs_header = "Kostenaufteilung [\u20ac]", + tt_params = "Variierende Parameter" + ), + en = list( + tt_scenario = "Scenario", + tt_n_overflows = "Number of overflow events", + tt_sum_overflows_mm = "Sum of overflows [mm]", + tt_overflow_volume = "Overflow volume [m\u00b3]", + tt_wb_header = "Water balance [%]", + tt_wb_evap = "Evapotranspiration", + tt_wb_infil = "Infiltration", + tt_wb_overflow = "Overflow", + tt_cost_total = "Total cost", + tt_cost_excavation = "Excavation", + tt_cost_profiling = "Profiling + greening", + tt_cost_filter = "Soil filter", + tt_cost_storage = "Storage layer", + tt_storage_type = "Storage type", + st_infiltration_box = "Infiltration box / Sickerbox", + st_gravel_trench = "Gravel trench / Schotterrigol", + tt_costs_header = "Cost breakdown [\u20ac]", + tt_params = "Varying parameters" + ) + ) +} + +#' Assemble the shared cost-plot tooltip HTML for each row of `df` +#' +#' `df` must carry `scenario_name`, `n_overflows`, `sum_overflows`, +#' `overflow_volume_m3`, the three `element.WB_*` shares, the five `cost_*` +#' columns, `storage_type` and `params_html`. Returns one HTML string per row. +#' Both cost plots call this so their tooltips are byte-identical. +#' +#' @param df Data frame with the columns listed above. +#' @param tt Label list from `cost_tooltip_labels()`. +#' @param digits Integer. Rounding for the numeric tooltip values. +#' @return Character vector, length `nrow(df)`. +#' @noRd +cost_tooltip_text <- function(df, tt, digits = 2L) { + st_raw <- if ("storage_type" %in% names(df)) { + as.character(df$storage_type) + } else { + rep(NA_character_, nrow(df)) + } + st_disp <- ifelse(!is.na(st_raw) & st_raw == "gravel_trench", + tt$st_gravel_trench, tt$st_infiltration_box) + paste0( + tt$tt_scenario, ": ", df$scenario_name, + "
", tt$tt_n_overflows, ": ", df$n_overflows, + "
", tt$tt_sum_overflows_mm, ": ", round(df$sum_overflows, digits), + "
", tt$tt_overflow_volume, ": ", round(df$overflow_volume_m3, digits), + "

", tt$tt_wb_header, "", + "
", tt$tt_wb_evap, ": ", + round(df[["element.WB_Evapotranspiration_"]], digits), + "
", tt$tt_wb_infil, ": ", + round(df[["element.WB_InfiltrationNetto_"]], digits), + "
", tt$tt_wb_overflow, ": ", + round(df[["element.WB_Oberflaechenablauf_Ueberlauf_"]], digits), + "

", tt$tt_storage_type, ": ", st_disp, "", + "

", tt$tt_costs_header, "", + "
", tt$tt_cost_excavation, ": ", + format(round(df$cost_excavation, 0), big.mark = " ", trim = TRUE), + "
", tt$tt_cost_profiling, ": ", + format(round(df$cost_profiling, 0), big.mark = " ", trim = TRUE), + "
", tt$tt_cost_filter, ": ", + format(round(df$cost_filter, 0), big.mark = " ", trim = TRUE), + "
", tt$tt_cost_storage, ": ", + format(round(df$cost_storage, 0), big.mark = " ", trim = TRUE), + "
", tt$tt_cost_total, ": ", + format(round(df$cost_total, 0), big.mark = " ", trim = TRUE), "", + "

", tt$tt_params, "
", df$params_html + ) +} diff --git a/R/plot_cost_overflow_boxplot.R b/R/plot_cost_overflow_boxplot.R new file mode 100644 index 0000000..7b08d1e --- /dev/null +++ b/R/plot_cost_overflow_boxplot.R @@ -0,0 +1,349 @@ +#' Cost boxplot per overflow-event count, points sized by overflow volume +#' +#' Companion to [plot_cost_vs_overflow_volume()]. For every number of overflow +#' events (x-axis) it draws a boxplot of the total construction cost (y-axis, +#' EUR) across all scenarios with that count, overlaid with the individual +#' scenarios as jittered points whose **size scales with `size_by`** -- +#' the overflow volume (`m3`, `sum_overflows` (`mm`) * `mulde_area` (`m2`) / +#' 1000; the default) or the element evapotranspiration share (%). One best +#' scenario per box is highlighted; `best_by` selects its objective -- cheapest, +#' smallest overflow volume, or highest evapotranspiration (cost as +#' tie-breaker) -- so the three variants trace three different frontier lines. +#' `label_best` annotates the marker. +#' +#' Overflow counts greater than `x` are collapsed into a single `">x"` +#' catch-all box (furthest right, coloured red), keeping the axis readable for +#' the long-tailed 15-year runs (Wien / Bad Aussee reach several hundred +#' overflow events). Its highlighted scenario is the one with the **fewest** +#' overflow events above `x` (closest to the valid region). Set `x` high to +#' resolve more counts individually, or to `max(n_overflows)` to give every +#' count its own box. +#' +#' The point tooltip is **identical** to [plot_cost_vs_overflow_volume()]: +#' scenario, overflow count / sum (`mm`) / volume (`m3`), the element water +#' balance (evapotranspiration / infiltration / overflow, %), the cost breakdown +#' (EUR) +#' and the varying `param_grid` parameters translated via `param_labels`. +#' Points and boxes are coloured with the same green (low counts) to red +#' (`">x"`) palette as the sibling plots; because the colour merely echoes the +#' x-axis it carries no separate legend -- only the point-size legend is shown. +#' +#' The point-size scale is calibrated to the valid region (`0..x`): the extreme +#' overflow volumes of the `">x"` catch-all are capped and a minimum size keeps +#' even zero-volume points (the `0`-overflow box) visible, so the many-overflow +#' outliers no longer shrink every valid-region point to an invisible dot. +#' +#' @inheritParams plot_cost_vs_overflow_volume +#' @param x Numeric threshold. Counts `0..x` each get their own box; counts +#' `> x` collapse into a single `">x"` box. +#' @param filter_n_gtx Logical. If `TRUE`, scenarios with `n_overflows > x` +#' are dropped (removing the `">x"` box) before plotting. +#' @param use_jitter Logical. If `TRUE`, points are horizontally jittered. +#' @param jitter_width Numeric. Horizontal jitter half-width. +#' @param jitter_seed Integer. Seed for reproducible jitter. +#' @param max_point_size Numeric. Point size for the largest (valid-region) +#' `size_by` value; the smallest maps to a fixed minimum so no point vanishes. +#' @param box_alpha,point_alpha Numeric in `[0, 1]`. Box-fill / point opacity. +#' @param lab_size Optional character override for the size-legend title. +#' @param size_by Character. Which variable drives the point area (and its +#' legend): `"overflow_volume"` (default, m3) or `"evapotranspiration"` (the +#' element evapotranspiration share in %, from `element.WB_Evapotranspiration_` +#' -- larger points then mean *more* evapotranspiration, which is desirable). +#' @param best_by Character. Objective for the highlighted best scenario per +#' box, with cost as the tie-breaker: `"min_cost"` (default; cheapest, ties +#' broken by `scenario_name`), `"min_overflow"` (smallest overflow volume) or +#' `"max_evapotranspiration"` (highest evapotranspiration). In the `">x"` box +#' the fewest-overflow scenario is picked first, `best_by` then breaking ties. +#' @param label_best Logical. If `TRUE`, the best scenario per box is annotated +#' next to it: overflow volume plus overflow share (`"NN m3 / NN %"`) for +#' `min_overflow`, the evapotranspiration share (`"NN %"`) for +#' `max_evapotranspiration`, or the total cost for `min_cost`. Default +#' `FALSE`. +#' @param mark_best Logical. If `TRUE` (default), the best scenario per box +#' (see `best_by`) is highlighted with a black-outlined diamond filled in +#' that box's group colour, so its plotly tooltip inherits the group colour. +#' @param connect_best Logical. If `TRUE` (default), the highlighted best +#' scenarios of **all** boxes (overflow counts `0..x` plus the `">x"` +#' catch-all) are connected by a line -- the best-per-overflow-level frontier. +#' +#' @return A `ggplot` object. Convert to interactive via +#' `plotly::ggplotly(p, tooltip = "text")`. +#' +#' @seealso [plot_cost_vs_overflow_volume()] +#' +#' @export +#' +#' @importFrom dplyr %>% filter mutate left_join case_when group_by arrange desc slice ungroup +#' @importFrom ggplot2 ggplot aes geom_boxplot geom_jitter geom_line geom_point geom_text position_jitter position_nudge scale_size scale_color_manual scale_fill_manual scale_x_discrete labs theme_bw theme element_text +#' @importFrom grDevices colorRampPalette +#' @importFrom rlang .data +plot_cost_overflow_boxplot <- function(simulation_results_optimisation, + param_grid, + x = 5, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.2, + jitter_seed = 1L, + max_point_size = 6, + box_alpha = 0.35, + point_alpha = 0.6, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + param_labels = NULL, + size_by = c("overflow_volume", + "evapotranspiration"), + best_by = c("min_cost", + "min_overflow", + "max_evapotranspiration"), + label_best = FALSE, + title = NULL, + lab_x = NULL, + lab_y = NULL, + lab_size = NULL, + mark_best = TRUE, + connect_best = TRUE, + legend_position = "right") { + + lang <- match.arg(lang) + size_by <- match.arg(size_by) + best_by <- match.arg(best_by) + if (is.null(param_labels)) param_labels <- default_param_labels(lang) + + size_col <- if (size_by == "evapotranspiration") { + "element.WB_Evapotranspiration_" + } else { + "overflow_volume_m3" + } + + txt <- switch( + lang, + de = list( + x = "Anzahl \u00dcberlaufereignisse", + y = "Gesamtkosten [\u20ac]", + title_cheapest = "Kosten je \u00dcberlaufanzahl \u2014 g\u00fcnstigste je Kategorie", + title_min_overflow = "Kosten je \u00dcberlaufanzahl \u2014 geringstes \u00dcberlaufvolumen je Kategorie", + title_max_evap = "Kosten je \u00dcberlaufanzahl \u2014 h\u00f6chste Verdunstung je Kategorie", + size_volume = "\u00dcberlaufvolumen [m\u00b3]", + size_evap = "Verdunstung [%]", + best_cheapest = "G\u00fcnstigste L\u00f6sung", + best_min_overflow = "Geringstes \u00dcberlaufvolumen", + best_max_evap = "H\u00f6chste Verdunstung" + ), + en = list( + x = "Number of overflow events", + y = "Total cost [\u20ac]", + title_cheapest = "Cost by overflow count \u2014 cheapest per class", + title_min_overflow = "Cost by overflow count \u2014 lowest overflow volume per class", + title_max_evap = "Cost by overflow count \u2014 highest evapotranspiration per class", + size_volume = "Overflow volume [m\u00b3]", + size_evap = "Evapotranspiration [%]", + best_cheapest = "Cheapest solution", + best_min_overflow = "Lowest overflow volume", + best_max_evap = "Highest evapotranspiration" + ) + ) + txt <- c(txt, cost_tooltip_labels(lang)) + + def_title <- switch(best_by, + min_cost = txt$title_cheapest, + min_overflow = txt$title_min_overflow, + max_evapotranspiration = txt$title_max_evap) + def_size <- if (size_by == "evapotranspiration") txt$size_evap else txt$size_volume + best_lab <- switch(best_by, + min_cost = txt$best_cheapest, + min_overflow = txt$best_min_overflow, + max_evapotranspiration = txt$best_max_evap) + + if (is.null(title)) title <- def_title + if (is.null(lab_x)) lab_x <- txt$x + if (is.null(lab_y)) lab_y <- txt$y + if (is.null(lab_size)) lab_size <- def_size + + req_grid <- c("scenario_name") + req_res <- c( + "scenario_name", "n_overflows", "sum_overflows", "mulde_area", + "element.WB_Evapotranspiration_", "element.WB_InfiltrationNetto_", + "element.WB_Oberflaechenablauf_Ueberlauf_", + "cost_excavation", "cost_profiling", "cost_filter", + "cost_storage", "cost_total", "storage_type" + ) + + miss_grid <- setdiff(req_grid, names(param_grid)) + miss_res <- setdiff(req_res, names(simulation_results_optimisation)) + + if (length(miss_grid) > 0) { + stop("param_grid is missing column(s): ", paste(miss_grid, collapse = ", ")) + } + if (length(miss_res) > 0) { + stop("simulation_results_optimisation is missing column(s): ", + paste(miss_res, collapse = ", ")) + } + if (!is.numeric(x) || length(x) != 1 || is.na(x) || x < 0) { + stop("x must be a single non-negative numeric value.") + } + + x_int <- as.integer(round(x)) + if (!isTRUE(all.equal(x, x_int))) { + warning("x is not an integer; using x_int = ", x_int, + " for discrete axis/palette.") + } + + param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, + digits_params) + + # Counts greater than x collapse into a single ">x" catch-all box, shown + # furthest right and coloured red. Its highlighted scenario is the one with + # the fewest overflow events (closest to the valid region); see the best + # selection below. + hi_lab <- paste0(">", x_int) + base_levels <- as.character(0:x_int) + levs <- c(base_levels, hi_lab) + + df <- simulation_results_optimisation %>% + dplyr::left_join(param_tooltip, by = "scenario_name") %>% + dplyr::filter(!isTRUE(filter_n_gtx) | + is.na(.data$n_overflows) | + .data$n_overflows <= x_int) %>% + dplyr::mutate( + overflow_volume_m3 = .data$sum_overflows * .data$mulde_area / 1000, + overflow_cat = dplyr::case_when( + is.na(.data$n_overflows) ~ NA_character_, + .data$n_overflows > x_int ~ hi_lab, + TRUE ~ as.character(.data$n_overflows) + ), + overflow_cat = factor(.data$overflow_cat, levels = levs) + ) + + df$tooltip_html <- cost_tooltip_text(df, txt, digits) + + # Point size: calibrate the scale to the valid region (0..x) and cap the + # extreme ">x" values, otherwise the many-overflow outliers (overflow + # volumes of several thousand m3) shrink every valid-region point to an + # invisible dot. pmin() caps; scale_size() below adds a minimum size so even + # zero-volume points (the 0-overflow box) stay visible. + valid_size <- df[[size_col]][!is.na(df$n_overflows) & df$n_overflows <= x_int] + size_cap <- suppressWarnings(max(valid_size[is.finite(valid_size)])) + if (!is.finite(size_cap) || size_cap <= 0) { + size_cap <- suppressWarnings(max(df[[size_col]], na.rm = TRUE)) + } + if (!is.finite(size_cap) || size_cap <= 0) size_cap <- 1 + df$size_plot <- pmin(df[[size_col]], size_cap) + + # Best scenario per box. n_overflows is the first sort key, so the ">x" + # catch-all box highlights the scenario with the fewest overflow events + # (closest to the valid region); the objective (best_by) then breaks ties, + # with cost as the final tie-breaker: + # min_cost -> cheapest + # min_overflow -> smallest overflow volume + # max_evapotranspiration -> highest evapotranspiration + # For the single-count boxes 0..x, n_overflows is constant, so only the + # objective matters there. The frontier line runs through the best of every + # box, so the three objectives yield three different lines. + best_grp <- df %>% + dplyr::filter(!is.na(.data$overflow_cat), !is.na(.data$cost_total)) %>% + dplyr::group_by(.data$overflow_cat) + best <- switch(best_by, + max_evapotranspiration = best_grp %>% + dplyr::arrange(.data$n_overflows, + dplyr::desc(.data[["element.WB_Evapotranspiration_"]]), + .data$cost_total, .data$scenario_name, .by_group = TRUE), + min_overflow = best_grp %>% + dplyr::arrange(.data$n_overflows, .data$overflow_volume_m3, + .data$cost_total, .data$scenario_name, .by_group = TRUE), + min_cost = best_grp %>% + dplyr::arrange(.data$n_overflows, .data$cost_total, + .data$scenario_name, .by_group = TRUE) + ) + best <- best %>% dplyr::slice(1L) %>% dplyr::ungroup() + best$tooltip_best <- paste0("", best_lab, "
", best$tooltip_html) + if (isTRUE(label_best)) { + best$label_text <- switch(best_by, + min_overflow = paste0( + format(round(best$overflow_volume_m3, 1), trim = TRUE), " m\u00b3 / ", + format(round(best[["element.WB_Oberflaechenablauf_Ueberlauf_"]], 1), + trim = TRUE), " %"), + max_evapotranspiration = paste0( + format(round(best[["element.WB_Evapotranspiration_"]], 1), + trim = TRUE), " %"), + min_cost = paste0( + format(round(best$cost_total, 0), big.mark = " ", trim = TRUE), " \u20ac") + ) + } + + if (x_int == 0L) { + pal <- stats::setNames(c("orange", "red"), c("0", hi_lab)) + } else if (x_int == 1L) { + pal <- stats::setNames(c("darkgreen", "orange", "red"), + c("0", "1", hi_lab)) + } else { + pal_green <- grDevices::colorRampPalette(c("darkgreen", "yellowgreen"))(x_int) + pal <- stats::setNames(c(pal_green, "orange", "red"), + c(base_levels, hi_lab)) + } + + pos <- if (isTRUE(use_jitter)) { + ggplot2::position_jitter(width = jitter_width, height = 0, + seed = jitter_seed) + } else { + "identity" + } + + p <- ggplot2::ggplot(df, ggplot2::aes(x = .data$overflow_cat, + y = .data$cost_total)) + + ggplot2::geom_boxplot( + ggplot2::aes(fill = .data$overflow_cat), + alpha = box_alpha, outlier.shape = NA, colour = "grey40" + ) + + ggplot2::geom_jitter( + ggplot2::aes(size = .data$size_plot, + colour = .data$overflow_cat, + text = .data$tooltip_html), + position = pos, alpha = point_alpha + ) + + ggplot2::scale_size(range = c(1.5, max_point_size), name = lab_size) + + ggplot2::scale_fill_manual(values = pal, limits = levs, drop = FALSE, + guide = "none") + + ggplot2::scale_color_manual(values = pal, limits = levs, drop = FALSE, + guide = "none") + + ggplot2::scale_x_discrete(drop = FALSE) + + ggplot2::labs(title = title, x = lab_x, y = lab_y) + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = legend_position, + plot.title = ggplot2::element_text(size = 11) + ) + + # Frontier line across the best of every box (all classes), then the + # group-coloured best-marker on top of everything. + if (isTRUE(connect_best) && nrow(best) > 1L) { + p <- p + ggplot2::geom_line( + data = best, + ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, group = 1L), + colour = "black", linewidth = 0.7, na.rm = TRUE + ) + } + if (isTRUE(mark_best) && nrow(best) > 0L) { + p <- p + ggplot2::geom_point( + data = best, + ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, + fill = .data$overflow_cat, + text = .data$tooltip_best), + shape = 23, size = 3.2, colour = "black", stroke = 1.2, na.rm = TRUE + ) + } + if (isTRUE(label_best) && "label_text" %in% names(best) && nrow(best) > 0L) { + # place the label just above the marker (centred), so long labels such as + # "3515 m3 / 35 %" never run off the right edge of the last box. + lab_nudge_y <- 0.045 * diff(range(df$cost_total, na.rm = TRUE)) + p <- p + ggplot2::geom_text( + data = best, + ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, + label = .data$label_text), + position = ggplot2::position_nudge(y = lab_nudge_y), + hjust = 0.5, vjust = 0, size = 2.8, colour = "black", na.rm = TRUE + ) + } + + p +} diff --git a/R/plot_cost_vs_overflow_volume.R b/R/plot_cost_vs_overflow_volume.R index ecfa43c..f95e137 100644 --- a/R/plot_cost_vs_overflow_volume.R +++ b/R/plot_cost_vs_overflow_volume.R @@ -11,11 +11,13 @@ #' multiplied by `mulde_area` (m2) and converted to m3: #' `overflow_volume_m3 = sum_overflows * mulde_area / 1000`. #' -#' The tooltip carries the cost breakdown (`cost_excavation`, -#' `cost_profiling`, `cost_filter`, `cost_storage`, `cost_total`) plus the -#' varying parameters from `param_grid` (excluding `scenario_name`), so the -#' user can hover over a scatter point and see exactly why it landed where -#' it did. +#' The tooltip carries the element water balance +#' (`element.WB_Evapotranspiration_`, `element.WB_InfiltrationNetto_`, +#' `element.WB_Oberflaechenablauf_Ueberlauf_`, all as % of the total water +#' input) and the cost breakdown (`cost_excavation`, `cost_profiling`, +#' `cost_filter`, `cost_storage`, `cost_total`) plus the varying parameters +#' from `param_grid` (excluding `scenario_name`), so the user can hover over a +#' scatter point and see exactly why it landed where it did. #' #' The plot language can be switched via `lang = "de"` or `lang = "en"`. #' Titles / axis labels / legend / tooltip labels follow the choice unless @@ -23,10 +25,11 @@ #' #' @param simulation_results_optimisation Data frame with the columns #' `scenario_name`, `n_overflows`, `sum_overflows`, `mulde_area`, -#' `cost_excavation`, `cost_profiling`, `cost_filter`, `cost_storage`, -#' `cost_total`. Typically the joined output of -#' [`add_overflow_events_and_waterbalance()`] and -#' [`compute_costs()`]. +#' `element.WB_Evapotranspiration_`, `element.WB_InfiltrationNetto_`, +#' `element.WB_Oberflaechenablauf_Ueberlauf_`, `cost_excavation`, +#' `cost_profiling`, `cost_filter`, `cost_storage`, `cost_total`, +#' `storage_type`. Typically the joined output of +#' [`add_overflow_events_and_waterbalance()`] and [`compute_costs()`]. #' @param param_grid Data frame with parameter grid. Must contain #' `scenario_name`. #' @param x Numeric threshold for the overflow-count colour bucket. Values @@ -39,6 +42,8 @@ #' @param digits_params Integer. Rounding for parameter values in the #' tooltip. #' @param lang Character. Plot language: `"de"` or `"en"`. +#' @param param_labels Named character vector translating `param_grid` columns +#' to tooltip labels, or `NULL` to use [default_param_labels()] for `lang`. #' @param title,lab_x,lab_y Optional character overrides for the default #' language-specific title / axis labels. #' @param legend_position Character. Legend position, default `"top"`. @@ -46,11 +51,12 @@ #' @return A `ggplot` object. Convert to interactive via #' `plotly::ggplotly(p, tooltip = "text")`. #' +#' @seealso [plot_cost_overflow_boxplot()] for the same data / tooltip shown as +#' a cost-by-overflow-count boxplot. +#' #' @export #' -#' @importFrom dplyr %>% select summarise across everything n_distinct filter pull mutate group_by left_join case_when all_of -#' @importFrom tidyr pivot_longer -#' @importFrom purrr map_chr +#' @importFrom dplyr %>% filter mutate left_join case_when #' @importFrom ggplot2 ggplot aes geom_point scale_color_manual labs theme_bw position_jitter theme guides guide_legend #' @importFrom grDevices colorRampPalette #' @importFrom rlang .data @@ -65,54 +71,35 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, digits = 2L, digits_params = 4L, lang = c("de", "en"), + param_labels = NULL, title = NULL, lab_x = NULL, lab_y = NULL, legend_position = "top") { lang <- match.arg(lang) + if (is.null(param_labels)) param_labels <- default_param_labels(lang) txt <- switch( lang, de = list( title = paste0( - "Kosten vs. Überlaufvolumen (Anzahl Überläufe ≤ ", x, ")" + "Kosten vs. \u00dcberlaufvolumen (Anzahl \u00dcberl\u00e4ufe \u2264 ", x, ")" ), - x = "Gesamtkosten [€]", - y = "Überlaufvolumen [m³]", - legend = "Anzahl Überlaufereignisse", - tt_scenario = "Szenario", - tt_n_overflows = "Anzahl Überlaufereignisse", - tt_sum_overflows_mm = "Summe Überläufe [mm]", - tt_overflow_volume = "Überlaufvolumen [m³]", - tt_cost_total = "Gesamtkosten", - tt_cost_excavation = "Aushub", - tt_cost_profiling = "Profilierung + Begrünung", - tt_cost_filter = "Bodenfilter", - tt_cost_storage = "Speicherschicht", - tt_costs_header = "Kostenaufteilung [€]", - tt_params = "Variierende Parameter" + x = "Gesamtkosten [\u20ac]", + y = "\u00dcberlaufvolumen [m\u00b3]", + legend = "Anzahl \u00dcberlaufereignisse" ), en = list( title = paste0( - "Cost vs. overflow volume (overflow events ≤ ", x, ")" + "Cost vs. overflow volume (overflow events \u2264 ", x, ")" ), - x = "Total cost [€]", - y = "Overflow volume [m³]", - legend = "Number of overflow events", - tt_scenario = "Scenario", - tt_n_overflows = "Number of overflow events", - tt_sum_overflows_mm = "Sum of overflows [mm]", - tt_overflow_volume = "Overflow volume [m³]", - tt_cost_total = "Total cost", - tt_cost_excavation = "Excavation", - tt_cost_profiling = "Profiling + greening", - tt_cost_filter = "Soil filter", - tt_cost_storage = "Storage layer", - tt_costs_header = "Cost breakdown [€]", - tt_params = "Varying parameters" + x = "Total cost [\u20ac]", + y = "Overflow volume [m\u00b3]", + legend = "Number of overflow events" ) ) + txt <- c(txt, cost_tooltip_labels(lang)) if (is.null(title)) title <- txt$title if (is.null(lab_x)) lab_x <- txt$x @@ -121,8 +108,10 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, req_grid <- c("scenario_name") req_res <- c( "scenario_name", "n_overflows", "sum_overflows", "mulde_area", + "element.WB_Evapotranspiration_", "element.WB_InfiltrationNetto_", + "element.WB_Oberflaechenablauf_Ueberlauf_", "cost_excavation", "cost_profiling", "cost_filter", - "cost_storage", "cost_total" + "cost_storage", "cost_total", "storage_type" ) miss_grid <- setdiff(req_grid, names(param_grid)) @@ -147,40 +136,8 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, " for discrete palette/legend.") } - varying_params <- param_grid %>% - dplyr::select(-"scenario_name") %>% - dplyr::summarise(dplyr::across(dplyr::everything(), - ~ dplyr::n_distinct(.) > 1)) %>% - tidyr::pivot_longer(dplyr::everything(), - names_to = "param", - values_to = "vary") %>% - dplyr::filter(.data$vary) %>% - dplyr::pull("param") - - if (length(varying_params) == 0) { - param_tooltip <- param_grid %>% - dplyr::select("scenario_name") %>% - dplyr::mutate(params_html = "") - } else { - param_tooltip <- param_grid %>% - dplyr::select("scenario_name", dplyr::all_of(varying_params)) %>% - tidyr::pivot_longer(-"scenario_name", - names_to = "param", - values_to = "val") %>% - dplyr::mutate( - val_chr = purrr::map_chr(.data$val, ~ paste(.x, collapse = ",")), - val_num = suppressWarnings(as.numeric(.data$val_chr)), - val_fmt = ifelse( - is.na(.data$val_num), - .data$val_chr, - format(round(.data$val_num, digits_params), trim = TRUE) - ), - kv = paste0(.data$param, "=", .data$val_fmt) - ) %>% - dplyr::group_by(.data$scenario_name) %>% - dplyr::summarise(params_html = paste(.data$kv, collapse = "
"), - .groups = "drop") - } + param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, + digits_params) df <- simulation_results_optimisation %>% dplyr::left_join(param_tooltip, by = "scenario_name") %>% @@ -209,6 +166,8 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, overflow_cat = factor(.data$overflow_cat, levels = levs) ) + df$tooltip_html <- cost_tooltip_text(df, txt, digits) + if (x_int == 0L) { pal <- c("0" = "orange", ">0" = "red") } else if (x_int == 1L) { @@ -245,25 +204,7 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, x = .data$cost_total, y = .data$overflow_volume_m3, color = .data$overflow_cat, - text = paste0( - txt$tt_scenario, ": ", .data$scenario_name, - "
", txt$tt_n_overflows, ": ", .data$n_overflows, - "
", txt$tt_sum_overflows_mm, ": ", round(.data$sum_overflows, digits), - "
", txt$tt_overflow_volume, ": ", - round(.data$overflow_volume_m3, digits), - "

", txt$tt_costs_header, "", - "
", txt$tt_cost_excavation, ": ", - format(round(.data$cost_excavation, 0), big.mark = " ", trim = TRUE), - "
", txt$tt_cost_profiling, ": ", - format(round(.data$cost_profiling, 0), big.mark = " ", trim = TRUE), - "
", txt$tt_cost_filter, ": ", - format(round(.data$cost_filter, 0), big.mark = " ", trim = TRUE), - "
", txt$tt_cost_storage, ": ", - format(round(.data$cost_storage, 0), big.mark = " ", trim = TRUE), - "
", txt$tt_cost_total, ": ", - format(round(.data$cost_total, 0), big.mark = " ", trim = TRUE), "", - "

", txt$tt_params, "
", .data$params_html - ) + text = .data$tooltip_html )) + ggplot2::geom_point(alpha = 0.7, position = pos) + ggplot2::scale_color_manual( diff --git a/man/default_param_labels.Rd b/man/default_param_labels.Rd new file mode 100644 index 0000000..b79e588 --- /dev/null +++ b/man/default_param_labels.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cost_tooltip.R +\name{default_param_labels} +\alias{default_param_labels} +\title{German / English labels for optimisation parameter-grid columns} +\usage{ +default_param_labels(lang = c("de", "en")) +} +\arguments{ +\item{lang}{Character. \code{"de"} or \code{"en"}.} +} +\value{ +A named \code{character} vector: names are \code{param_grid} column names, +values are the display labels. +} +\description{ +Maps the raw \code{param_grid} column names produced by the case-study workflows +to human-readable, unit-carrying labels. Used to translate the +"varying parameters" block in the interactive tooltips of +\code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}} and \code{\link[=plot_cost_overflow_boxplot]{plot_cost_overflow_boxplot()}}, so a +hovered point shows e.g. \code{Muldenflaeche [m2]=125} instead of the raw +\code{mulde_area=125}. +} +\details{ +Unknown columns fall back to their raw name, so a grid gaining a new column +still renders (just untranslated). Override individual entries or pass your +own named vector via the \code{param_labels} argument of the plot functions. +} +\examples{ +default_param_labels("de")[["mulde_area"]] +default_param_labels("en")[["storage_height"]] +} diff --git a/man/plot_cost_overflow_boxplot.Rd b/man/plot_cost_overflow_boxplot.Rd new file mode 100644 index 0000000..f6e7439 --- /dev/null +++ b/man/plot_cost_overflow_boxplot.Rd @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_cost_overflow_boxplot.R +\name{plot_cost_overflow_boxplot} +\alias{plot_cost_overflow_boxplot} +\title{Cost boxplot per overflow-event count, points sized by overflow volume} +\usage{ +plot_cost_overflow_boxplot( + simulation_results_optimisation, + param_grid, + x = 5, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.2, + jitter_seed = 1L, + max_point_size = 6, + box_alpha = 0.35, + point_alpha = 0.6, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + param_labels = NULL, + size_by = c("overflow_volume", "evapotranspiration"), + best_by = c("min_cost", "min_overflow", "max_evapotranspiration"), + label_best = FALSE, + title = NULL, + lab_x = NULL, + lab_y = NULL, + lab_size = NULL, + mark_best = TRUE, + connect_best = TRUE, + legend_position = "right" +) +} +\arguments{ +\item{simulation_results_optimisation}{Data frame with the columns +\code{scenario_name}, \code{n_overflows}, \code{sum_overflows}, \code{mulde_area}, +\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, +\code{element.WB_Oberflaechenablauf_Ueberlauf_}, \code{cost_excavation}, +\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}, +\code{storage_type}. Typically the joined output of +\code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and \code{\link[=compute_costs]{compute_costs()}}.} + +\item{param_grid}{Data frame with parameter grid. Must contain +\code{scenario_name}.} + +\item{x}{Numeric threshold. Counts \verb{0..x} each get their own box; counts +\verb{> x} collapse into a single \code{">x"} box.} + +\item{filter_n_gtx}{Logical. If \code{TRUE}, scenarios with \code{n_overflows > x} +are dropped (removing the \code{">x"} box) before plotting.} + +\item{use_jitter}{Logical. If \code{TRUE}, points are horizontally jittered.} + +\item{jitter_width}{Numeric. Horizontal jitter half-width.} + +\item{jitter_seed}{Integer. Seed for reproducible jitter.} + +\item{max_point_size}{Numeric. Point size for the largest (valid-region) +\code{size_by} value; the smallest maps to a fixed minimum so no point vanishes.} + +\item{box_alpha, point_alpha}{Numeric in \verb{[0, 1]}. Box-fill / point opacity.} + +\item{digits}{Integer. Rounding for numeric values in the tooltip.} + +\item{digits_params}{Integer. Rounding for parameter values in the +tooltip.} + +\item{lang}{Character. Plot language: \code{"de"} or \code{"en"}.} + +\item{param_labels}{Named character vector translating \code{param_grid} columns +to tooltip labels, or \code{NULL} to use \code{\link[=default_param_labels]{default_param_labels()}} for \code{lang}.} + +\item{size_by}{Character. Which variable drives the point area (and its +legend): \code{"overflow_volume"} (default, m3) or \code{"evapotranspiration"} (the +element evapotranspiration share in \%, from \code{element.WB_Evapotranspiration_} +-- larger points then mean \emph{more} evapotranspiration, which is desirable).} + +\item{best_by}{Character. Objective for the highlighted best scenario per +box, with cost as the tie-breaker: \code{"min_cost"} (default; cheapest, ties +broken by \code{scenario_name}), \code{"min_overflow"} (smallest overflow volume) or +\code{"max_evapotranspiration"} (highest evapotranspiration). In the \code{">x"} box +the fewest-overflow scenario is picked first, \code{best_by} then breaking ties.} + +\item{label_best}{Logical. If \code{TRUE}, the best scenario per box is annotated +next to it: overflow volume plus overflow share (\code{"NN m3 / NN \%"}) for +\code{min_overflow}, the evapotranspiration share (\code{"NN \%"}) for +\code{max_evapotranspiration}, or the total cost for \code{min_cost}. Default +\code{FALSE}.} + +\item{title, lab_x, lab_y}{Optional character overrides for the default +language-specific title / axis labels.} + +\item{lab_size}{Optional character override for the size-legend title.} + +\item{mark_best}{Logical. If \code{TRUE} (default), the best scenario per box +(see \code{best_by}) is highlighted with a black-outlined diamond filled in +that box's group colour, so its plotly tooltip inherits the group colour.} + +\item{connect_best}{Logical. If \code{TRUE} (default), the highlighted best +scenarios of \strong{all} boxes (overflow counts \verb{0..x} plus the \code{">x"} +catch-all) are connected by a line -- the best-per-overflow-level frontier.} + +\item{legend_position}{Character. Legend position, default \code{"top"}.} +} +\value{ +A \code{ggplot} object. Convert to interactive via +\code{plotly::ggplotly(p, tooltip = "text")}. +} +\description{ +Companion to \code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}}. For every number of overflow +events (x-axis) it draws a boxplot of the total construction cost (y-axis, +EUR) across all scenarios with that count, overlaid with the individual +scenarios as jittered points whose \strong{size scales with \code{size_by}} -- +the overflow volume (\code{m3}, \code{sum_overflows} (\code{mm}) * \code{mulde_area} (\code{m2}) / +1000; the default) or the element evapotranspiration share (\%). One best +scenario per box is highlighted; \code{best_by} selects its objective -- cheapest, +smallest overflow volume, or highest evapotranspiration (cost as +tie-breaker) -- so the three variants trace three different frontier lines. +\code{label_best} annotates the marker. +} +\details{ +Overflow counts greater than \code{x} are collapsed into a single \code{">x"} +catch-all box (furthest right, coloured red), keeping the axis readable for +the long-tailed 15-year runs (Wien / Bad Aussee reach several hundred +overflow events). Its highlighted scenario is the one with the \strong{fewest} +overflow events above \code{x} (closest to the valid region). Set \code{x} high to +resolve more counts individually, or to \code{max(n_overflows)} to give every +count its own box. + +The point tooltip is \strong{identical} to \code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}}: +scenario, overflow count / sum (\code{mm}) / volume (\code{m3}), the element water +balance (evapotranspiration / infiltration / overflow, \%), the cost breakdown +(EUR) +and the varying \code{param_grid} parameters translated via \code{param_labels}. +Points and boxes are coloured with the same green (low counts) to red +(\code{">x"}) palette as the sibling plots; because the colour merely echoes the +x-axis it carries no separate legend -- only the point-size legend is shown. + +The point-size scale is calibrated to the valid region (\verb{0..x}): the extreme +overflow volumes of the \code{">x"} catch-all are capped and a minimum size keeps +even zero-volume points (the \code{0}-overflow box) visible, so the many-overflow +outliers no longer shrink every valid-region point to an invisible dot. +} +\seealso{ +\code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}} +} diff --git a/man/plot_cost_vs_overflow_volume.Rd b/man/plot_cost_vs_overflow_volume.Rd index f0f8c9f..5592970 100644 --- a/man/plot_cost_vs_overflow_volume.Rd +++ b/man/plot_cost_vs_overflow_volume.Rd @@ -16,6 +16,7 @@ plot_cost_vs_overflow_volume( digits = 2L, digits_params = 4L, lang = c("de", "en"), + param_labels = NULL, title = NULL, lab_x = NULL, lab_y = NULL, @@ -25,10 +26,11 @@ plot_cost_vs_overflow_volume( \arguments{ \item{simulation_results_optimisation}{Data frame with the columns \code{scenario_name}, \code{n_overflows}, \code{sum_overflows}, \code{mulde_area}, -\code{cost_excavation}, \code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, -\code{cost_total}. Typically the joined output of -\code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and -\code{\link[=compute_costs]{compute_costs()}}.} +\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, +\code{element.WB_Oberflaechenablauf_Ueberlauf_}, \code{cost_excavation}, +\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}, +\code{storage_type}. Typically the joined output of +\code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and \code{\link[=compute_costs]{compute_costs()}}.} \item{param_grid}{Data frame with parameter grid. Must contain \code{scenario_name}.} @@ -49,6 +51,9 @@ tooltip.} \item{lang}{Character. Plot language: \code{"de"} or \code{"en"}.} +\item{param_labels}{Named character vector translating \code{param_grid} columns +to tooltip labels, or \code{NULL} to use \code{\link[=default_param_labels]{default_param_labels()}} for \code{lang}.} + \item{title, lab_x, lab_y}{Optional character overrides for the default language-specific title / axis labels.} @@ -71,13 +76,19 @@ surface, as returned by \code{\link[=add_overflow_events_and_waterbalance]{add_o multiplied by \code{mulde_area} (m2) and converted to m3: \code{overflow_volume_m3 = sum_overflows * mulde_area / 1000}. -The tooltip carries the cost breakdown (\code{cost_excavation}, -\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}) plus the -varying parameters from \code{param_grid} (excluding \code{scenario_name}), so the -user can hover over a scatter point and see exactly why it landed where -it did. +The tooltip carries the element water balance +(\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, +\code{element.WB_Oberflaechenablauf_Ueberlauf_}, all as \% of the total water +input) and the cost breakdown (\code{cost_excavation}, \code{cost_profiling}, +\code{cost_filter}, \code{cost_storage}, \code{cost_total}) plus the varying parameters +from \code{param_grid} (excluding \code{scenario_name}), so the user can hover over a +scatter point and see exactly why it landed where it did. The plot language can be switched via \code{lang = "de"} or \code{lang = "en"}. Titles / axis labels / legend / tooltip labels follow the choice unless explicit overrides are supplied. } +\seealso{ +\code{\link[=plot_cost_overflow_boxplot]{plot_cost_overflow_boxplot()}} for the same data / tooltip shown as +a cost-by-overflow-count boxplot. +} diff --git a/vignettes/example_wien_minimal.Rmd b/vignettes/example_wien_minimal.Rmd index 8321142..a40f54a 100644 --- a/vignettes/example_wien_minimal.Rmd +++ b/vignettes/example_wien_minimal.Rmd @@ -169,7 +169,7 @@ DT::datatable( param_grid, filter = "top", options = list(pageLength = 12, autoWidth = TRUE), - caption = "Twelve scenarios — fixed Daniel-reference geometry, sweep of three ET-related engine switches." + caption = "Twelve scenarios \u2014 fixed Daniel-reference geometry, sweep of three ET-related engine switches." ) psi_s_mm <- function(kf_mmh) (3.237 * (kf_mmh / 25.4)^(-0.328)) * 25.4 @@ -476,7 +476,7 @@ DT::datatable( results, filter = "top", options = list(pageLength = 12, autoWidth = TRUE), - caption = "Twelve-scenario simulation results — water balance + overflow events + construction costs (EUR). Sort by the ET share column to see which combination of `keineVerdunstungBeiRegen` / `Hoernschemeyer_aktiv` / `ET0ref_factor` brings the modelled ET share closest to the SWIMM-Urban-Eva reference of ~7%. Scenarios whose water-balance step errored (see chunk log) are present in the table but have NA in the result columns." + caption = "Twelve-scenario simulation results \u2014 water balance + overflow events + construction costs (EUR). Sort by the ET share column to see which combination of `keineVerdunstungBeiRegen` / `Hoernschemeyer_aktiv` / `ET0ref_factor` brings the modelled ET share closest to the SWIMM-Urban-Eva reference of ~7%. Scenarios whose water-balance step errored (see chunk log) are present in the table but have NA in the result columns." ) ``` diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index 42f2053..3edff68 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -5,7 +5,7 @@ date: "2026-02-25" output: html_document: toc: true - toc_depth: 3 + toc_depth: 4 number_sections: true --- @@ -147,12 +147,20 @@ for (site in sites) { } ``` -### Kosten vs. Überlaufvolumen +### Kosten + +Drei komplementäre, interaktive Sichten auf die **Baukosten** der +Szenarien und ihren Zusammenhang mit Überläufen, Wasserhaushalt und +Design-Parametern. Alle drei teilen denselben Punkt-Tooltip +(Wasserhaushalt, Kostenaufteilung, variierende Parameter). + +#### Kosten vs. Überlaufvolumen Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten [€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und `mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, -`>5` = rot, Legende oben). Mouseover zeigt die vollständige +`>5` = rot, Legende oben). Mouseover zeigt den Wasserhaushalt +(Verdunstung, Versickerung, Überlauf in %), die vollständige Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, Gesamt) plus die variierenden Design-Parameter des Szenarios. @@ -167,4 +175,63 @@ for (site in sites) { } ``` +Alle Boxplots zeigen die **Gesamtkosten** [€] (y-Achse) je **Anzahl +Überlaufereignisse** (x-Achse; `0`–`5` einzeln, `>5` = Rest gebündelt; im +`>5`-Kasten wird das Szenario mit den wenigsten Überläufen markiert), +überlagert mit den Szenarien als Punkte. Je Box ist ein **bestes** Szenario +als Raute in der jeweiligen Gruppenfarbe (schwarz umrandet) markiert; die +Markierungen **aller** Klassen sind zur Frontier-Linie verbunden. +Punkt-Mouseover: Wasserhaushalt, Kostenaufteilung, variierende Parameter. +Die drei Varianten optimieren je Box ein **anderes Ziel** (Kosten als +Tie-Break) und ergeben so drei verschiedene Frontier-Linien: + +#### Boxplot – günstigste je Kategorie + +Das **günstigste** Szenario je Box. Punktgröße = Überlaufvolumen [m³]. + +```{r brute_force_plots_cost-boxplot-cheapest, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-cheapest.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Boxplot – geringstes Überlaufvolumen + +Das Szenario je Box mit dem **geringsten Überlaufvolumen** (bei Gleichstand +das günstigste). Die Markierung ist mit ihrem **Überlaufvolumen [m³] und +dessen Anteil [%]** beschriftet. Punktgröße = Überlaufvolumen. + +```{r brute_force_plots_cost-boxplot-min-overflow, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-min-overflow.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Boxplot – höchste Verdunstung + +Das Szenario je Box mit der **höchsten Verdunstung** (bei Gleichstand das +günstigste). Die Markierung ist mit ihrer **Verdunstung [%]** beschriftet; +hier kodiert die **Punktgröße die Verdunstung** statt des Überlaufvolumens. + +```{r brute_force_plots_cost-boxplot-max-evap, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-max-evap.html)\n", + site, + base_dir, + site + )) +} +``` + diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index 18ef075..c33423f 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -113,7 +113,7 @@ storage_height <- c(100, 500, 1000) rain_factor <- 1 bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). -# 8.5 = status-quo H5 default; 3.9 = grass per Hörnschemeyer et al., +# 8.5 = status-quo H5 default; 3.9 = grass per Hoernschemeyer et al., # Water 2023, 15, 2840, Tab. 6, plant type 5 (grasses/herbs). #lai <- c(3.9, 8.5) lai <- 3.9 @@ -240,7 +240,7 @@ timeseries_rain <- if(max(timeseries_et$time) > max(timeseries_rain$time)) { timeseries_rain } -txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Regenmenge: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Regenmenge: %f mm/a)\n", paths$path_rain, 100*sum(is.na(timeseries_rain$value))/nrow(timeseries_rain), 100*sum(timeseries_rain$value == 0, na.rm = TRUE)/nrow(timeseries_rain), @@ -248,7 +248,7 @@ txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Wer message(txt) -txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", paths$path_et, 100*sum(is.na(timeseries_et$value))/nrow(timeseries_et), 100*sum(timeseries_et$value == 0, na.rm = TRUE)/nrow(timeseries_et), @@ -576,6 +576,7 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( use_jitter = TRUE ) +# interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) htmlwidgets::saveWidget( widget = plotly_p, @@ -586,6 +587,54 @@ htmlwidgets::saveWidget( paths$modelname) ) +# statisch ins PDF (WICHTIG!) suppressWarnings(print(p)) dev.off() + + +# Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie +# (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen +# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +cost_boxplots <- list( + list(suffix = "cheapest", best_by = "min_cost", + size_by = "overflow_volume", label_best = FALSE), + list(suffix = "min-overflow", best_by = "min_overflow", + size_by = "overflow_volume", label_best = TRUE), + list(suffix = "max-evap", best_by = "max_evapotranspiration", + size_by = "evapotranspiration", label_best = TRUE) +) +for (cb in cost_boxplots) { + pdff <- sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.pdf", + paths$modelname, cb$suffix) + kwb.utils::preparePdf(pdfFile = pdff) + + p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + size_by = cb$size_by, + best_by = cb$best_by, + label_best = cb$label_best + ) + + # interaktiv als HTML + plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.html", + paths$modelname, cb$suffix), + selfcontained = TRUE, + title = sprintf("'%s' - Cost boxplot (%s)", paths$modelname, cb$suffix) + ) + + # statisch ins PDF (WICHTIG!) + suppressWarnings(print(p)) + dev.off() +} ``` \ No newline at end of file diff --git a/vignettes/workflow_eisenstadt-2005.Rmd b/vignettes/workflow_eisenstadt-2005.Rmd index 7a1c6b4..28526df 100644 --- a/vignettes/workflow_eisenstadt-2005.Rmd +++ b/vignettes/workflow_eisenstadt-2005.Rmd @@ -219,7 +219,7 @@ run_one <- function(i, vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- psi_s_mm(param_grid_tmp$filter_hydraulicconductivity) -# Timeseries (2×N) als tibble? +# Timeseries (2xN) als tibble? if (is.data.frame(vals[["//Kurven/Regen"]])) { vals[["//Kurven/Regen"]]$value <- vals[["//Kurven/Regen"]]$value * param_grid_tmp$rain_factor } @@ -295,10 +295,11 @@ x$Fehlerbeschreibung # add_overflow_events_and_waterbalance() pass loaded all runs at once.) simulation_results_optimisation <- dplyr::bind_rows(scenario_rows) -simulation_results_optimisation <- param_grid %>% +simulation_results_optimisation <- param_grid %>% dplyr::left_join(simulation_results_optimisation, - by = c("scenario_name" = "s_name")) %>% - dplyr::relocate(scenario_name, .before = connected_area) + by = c("scenario_name" = "s_name")) %>% + dplyr::relocate(scenario_name, .before = connected_area) %>% + kwb.raindrop::compute_costs() readr::write_csv(simulation_results_optimisation, file = sprintf("simulation_results_optimisation_%s.csv", @@ -468,6 +469,7 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( use_jitter = TRUE ) +# interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) htmlwidgets::saveWidget( widget = plotly_p, @@ -478,7 +480,55 @@ htmlwidgets::saveWidget( paths$modelname) ) +# statisch ins PDF (WICHTIG!) suppressWarnings(print(p)) dev.off() + +# Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie +# (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen +# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +cost_boxplots <- list( + list(suffix = "cheapest", best_by = "min_cost", + size_by = "overflow_volume", label_best = FALSE), + list(suffix = "min-overflow", best_by = "min_overflow", + size_by = "overflow_volume", label_best = TRUE), + list(suffix = "max-evap", best_by = "max_evapotranspiration", + size_by = "evapotranspiration", label_best = TRUE) +) +for (cb in cost_boxplots) { + pdff <- sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.pdf", + paths$modelname, cb$suffix) + kwb.utils::preparePdf(pdfFile = pdff) + + p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + size_by = cb$size_by, + best_by = cb$best_by, + label_best = cb$label_best + ) + + # interaktiv als HTML + plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.html", + paths$modelname, cb$suffix), + selfcontained = TRUE, + title = sprintf("'%s' - Cost boxplot (%s)", paths$modelname, cb$suffix) + ) + + # statisch ins PDF (WICHTIG!) + suppressWarnings(print(p)) + dev.off() +} + ``` \ No newline at end of file diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index 3d0b38e..63ad501 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -113,7 +113,7 @@ storage_height <- c(100, 500, 1000) rain_factor <- 1 bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). -# 8.5 = status-quo H5 default; 3.9 = grass per Hörnschemeyer et al., +# 8.5 = status-quo H5 default; 3.9 = grass per Hoernschemeyer et al., # Water 2023, 15, 2840, Tab. 6, plant type 5 (grasses/herbs). #lai <- c(3.9, 8.5) lai <- 3.9 @@ -240,7 +240,7 @@ timeseries_rain <- if(max(timeseries_et$time) > max(timeseries_rain$time)) { timeseries_rain } -txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Regenmenge: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Regenmenge: %f mm/a)\n", paths$path_rain, 100*sum(is.na(timeseries_rain$value))/nrow(timeseries_rain), 100*sum(timeseries_rain$value == 0, na.rm = TRUE)/nrow(timeseries_rain), @@ -248,7 +248,7 @@ txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Wer message(txt) -txt <- sprintf("Für den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", paths$path_et, 100*sum(is.na(timeseries_et$value))/nrow(timeseries_et), 100*sum(timeseries_et$value == 0, na.rm = TRUE)/nrow(timeseries_et), @@ -589,4 +589,50 @@ suppressWarnings(print(p)) dev.off() #kwb.utils::finishAndShowPdf(pdff) +# Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie +# (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen +# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +cost_boxplots <- list( + list(suffix = "cheapest", best_by = "min_cost", + size_by = "overflow_volume", label_best = FALSE), + list(suffix = "min-overflow", best_by = "min_overflow", + size_by = "overflow_volume", label_best = TRUE), + list(suffix = "max-evap", best_by = "max_evapotranspiration", + size_by = "evapotranspiration", label_best = TRUE) +) +for (cb in cost_boxplots) { + pdff <- sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.pdf", + paths$modelname, cb$suffix) + kwb.utils::preparePdf(pdfFile = pdff) + + p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + size_by = cb$size_by, + best_by = cb$best_by, + label_best = cb$label_best + ) + + # interaktiv als HTML + plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-by-overflows-boxplot-%s.html", + paths$modelname, cb$suffix), + selfcontained = TRUE, + title = sprintf("'%s' - Cost boxplot (%s)", paths$modelname, cb$suffix) + ) + + # statisch ins PDF (WICHTIG!) + suppressWarnings(print(p)) + dev.off() +} + ``` From 69872f8c4604b52b795487abe5e5f4fba980c59f Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 7 Jul 2026 15:11:55 +0100 Subject: [PATCH 10/34] Show valid-scenario share in cost-plot titles Both plot_cost_vs_overflow_volume() and plot_cost_overflow_boxplot() now append the share of scenarios meeting the validity criterion (n_overflows <= x) to the plot title, e.g. "Kosten vs. Ueberlaufvolumen (39 % mit <= 5 Ueberlaeufen)" / "Cost vs. overflow volume (39 % with <= 5 overflows)". It goes in the title, not a ggplot subtitle: ggplotly drops subtitles, so the share would be lost in the interactive HTML the vignettes export. The scatter title drops its old "(Anzahl Ueberlaeufe <= x)" parenthetical, which the share now supersedes. vignettes/index.Rmd now spells out the per-site validity threshold that drives this share: Eisenstadt <= 1 (1-year simulation), Wien / Bad Aussee <= 5 (15-year rain/ET series). --- NEWS.md | 5 ++++- R/plot_cost_overflow_boxplot.R | 11 ++++++++++- R/plot_cost_vs_overflow_volume.R | 18 +++++++++++------- vignettes/index.Rmd | 12 +++++++++--- 4 files changed, 34 insertions(+), 12 deletions(-) diff --git a/NEWS.md b/NEWS.md index d7434fc..eb54cca 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,7 +7,10 @@ Scatters `cost_total` (EUR) against overflow volume (m³, computed from `sum_overflows` [mm] and `mulde_area` [m²]), points coloured discretely by `n_overflows` with the same `0..x / ">x"` palette - and top legend as the water-balance plot. The plotly tooltip + and top legend as the water-balance plot. Both cost plots report the + **share of scenarios meeting the validity criterion** (`n_overflows` + ≤ `x`) in the plot title (e.g. `(39 % mit ≤ 5 Überläufen)`), since + ggplotly drops ggplot subtitles. The plotly tooltip carries the element water balance (evapotranspiration, infiltration, overflow — all in %), the chosen storage type on its own bold line (bilingual, `Sickerbox / Infiltration box` or diff --git a/R/plot_cost_overflow_boxplot.R b/R/plot_cost_overflow_boxplot.R index 7b08d1e..747596a 100644 --- a/R/plot_cost_overflow_boxplot.R +++ b/R/plot_cost_overflow_boxplot.R @@ -155,7 +155,6 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, min_overflow = txt$best_min_overflow, max_evapotranspiration = txt$best_max_evap) - if (is.null(title)) title <- def_title if (is.null(lab_x)) lab_x <- txt$x if (is.null(lab_y)) lab_y <- txt$y if (is.null(lab_size)) lab_size <- def_size @@ -189,6 +188,16 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, " for discrete axis/palette.") } + # Share of scenarios meeting the validity criterion (n_overflows <= x), + # appended to the auto-generated title (a plotly-safe place -- ggplotly + # drops ggplot subtitles). + valid_pct <- round(100 * mean( + simulation_results_optimisation$n_overflows <= x_int, na.rm = TRUE)) + share_txt <- switch(lang, + de = paste0(valid_pct, " % mit \u2264 ", x_int, " \u00dcberl\u00e4ufen"), + en = paste0(valid_pct, " % with \u2264 ", x_int, " overflows")) + if (is.null(title)) title <- paste0(def_title, " (", share_txt, ")") + param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, digits_params) diff --git a/R/plot_cost_vs_overflow_volume.R b/R/plot_cost_vs_overflow_volume.R index f95e137..62dde87 100644 --- a/R/plot_cost_vs_overflow_volume.R +++ b/R/plot_cost_vs_overflow_volume.R @@ -83,17 +83,13 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, txt <- switch( lang, de = list( - title = paste0( - "Kosten vs. \u00dcberlaufvolumen (Anzahl \u00dcberl\u00e4ufe \u2264 ", x, ")" - ), + title = "Kosten vs. \u00dcberlaufvolumen", x = "Gesamtkosten [\u20ac]", y = "\u00dcberlaufvolumen [m\u00b3]", legend = "Anzahl \u00dcberlaufereignisse" ), en = list( - title = paste0( - "Cost vs. overflow volume (overflow events \u2264 ", x, ")" - ), + title = "Cost vs. overflow volume", x = "Total cost [\u20ac]", y = "Overflow volume [m\u00b3]", legend = "Number of overflow events" @@ -101,7 +97,6 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, ) txt <- c(txt, cost_tooltip_labels(lang)) - if (is.null(title)) title <- txt$title if (is.null(lab_x)) lab_x <- txt$x if (is.null(lab_y)) lab_y <- txt$y @@ -136,6 +131,15 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, " for discrete palette/legend.") } + # Append the share of scenarios meeting the validity criterion + # (n_overflows <= x) to the auto title (ggplotly drops ggplot subtitles). + valid_pct <- round(100 * mean( + simulation_results_optimisation$n_overflows <= x_int, na.rm = TRUE)) + share_txt <- switch(lang, + de = paste0(valid_pct, " % mit \u2264 ", x_int, " \u00dcberl\u00e4ufen"), + en = paste0(valid_pct, " % with \u2264 ", x_int, " overflows")) + if (is.null(title)) title <- paste0(txt$title, " (", share_txt, ")") + param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, digits_params) diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index 3edff68..7ca849c 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -52,11 +52,17 @@ for (site in sites) { # Ergebnisse -Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die -beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in +Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die +beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in unten stehenden Links: -## Tabellen +Als **Gültigkeitskriterium** — die maximal zulässige Anzahl Überlaufereignisse — +wurde passend zur Simulationsdauer gewählt: **Eisenstadt ≤ 1** (Simulationszeit +1 Jahr) und **Wien / Bad Aussee ≤ 5** (15-jährige Regen-/ET-Reihe). Dieser +Schwellenwert steuert die Farbgebung (grün = gültig, rot = zu viele Überläufe) +und den in den Kostenplot-Titeln angegebenen Anteil gültiger Szenarien. + +## Tabellen ```{r brute_force_tabelle, echo = FALSE, results='asis'} for (site in sites) { From 264161f7d2d093f26a9346e665129b7068cacfbd Mon Sep 17 00:00:00 2001 From: mrustl Date: Thu, 9 Jul 2026 08:08:49 +0100 Subject: [PATCH 11/34] Various improvements --- NAMESPACE | 7 +- NEWS.md | 102 +++++++++++ R/cost_tooltip.R | 106 ++++++++++- R/plot_cost_overflow_boxplot.R | 178 +++++++++++++++--- R/plot_cost_vs_evaporation.R | 241 +++++++++++++++++++++++++ R/plot_cost_vs_overflow_volume.R | 48 ++++- R/plot_main_effects.R | 38 +++- R/plot_valid_design_space.R | 100 ++++++++-- R/plot_wb_tradeoff_overflows.R | 144 +++++++++------ R/plotly_split_legend.R | 212 ++++++++++++++++++++++ man/plot_cost_overflow_boxplot.Rd | 45 ++++- man/plot_cost_vs_evaporation.Rd | 96 ++++++++++ man/plot_cost_vs_overflow_volume.Rd | 17 +- man/plot_main_effects.Rd | 5 + man/plot_valid_design_space.Rd | 12 ++ man/plot_wb_tradeoff_overflows.Rd | 10 +- man/plotly_split_legend.Rd | 72 ++++++++ vignettes/index.Rmd | 89 ++++++++- vignettes/workflow_badaussee.Rmd | 185 +++++++++++++++++-- vignettes/workflow_eisenstadt-2005.Rmd | 187 +++++++++++++++++-- vignettes/workflow_wien.Rmd | 185 +++++++++++++++++-- 21 files changed, 1914 insertions(+), 165 deletions(-) create mode 100644 R/plot_cost_vs_evaporation.R create mode 100644 R/plotly_split_legend.R create mode 100644 man/plot_cost_vs_evaporation.Rd create mode 100644 man/plotly_split_legend.Rd diff --git a/NAMESPACE b/NAMESPACE index 395fbb6..d947f13 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,11 +18,13 @@ export(h5_validate_write) export(h5_write_values) export(list_h5_datasets) export(plot_cost_overflow_boxplot) +export(plot_cost_vs_evaporation) export(plot_cost_vs_overflow_volume) export(plot_hpond_vs_ref) export(plot_main_effects) export(plot_valid_design_space) export(plot_wb_tradeoff_overflows) +export(plotly_split_legend) export(read_hdf5_connections) export(read_hdf5_scalars) export(read_hdf5_timeseries) @@ -65,6 +67,7 @@ importFrom(future.apply,future_lapply) importFrom(ggplot2,aes) importFrom(ggplot2,coord_cartesian) importFrom(ggplot2,element_text) +importFrom(ggplot2,facet_grid) importFrom(ggplot2,facet_wrap) importFrom(ggplot2,geom_boxplot) importFrom(ggplot2,geom_jitter) @@ -83,6 +86,7 @@ importFrom(ggplot2,scale_alpha_identity) importFrom(ggplot2,scale_color_manual) importFrom(ggplot2,scale_colour_manual) importFrom(ggplot2,scale_fill_manual) +importFrom(ggplot2,scale_shape_manual) importFrom(ggplot2,scale_size) importFrom(ggplot2,scale_x_continuous) importFrom(ggplot2,scale_x_discrete) @@ -90,7 +94,7 @@ importFrom(ggplot2,scale_y_continuous) importFrom(ggplot2,scale_y_discrete) importFrom(ggplot2,theme) importFrom(ggplot2,theme_bw) -importFrom(ggplot2,theme_minimal) +importFrom(ggplot2,vars) importFrom(grDevices,colorRampPalette) importFrom(hdf5r,H5File) importFrom(kwb.event,hsEvents) @@ -115,3 +119,4 @@ importFrom(tibble,as_tibble) importFrom(tibble,tibble) importFrom(tidyr,pivot_longer) importFrom(tidyr,pivot_wider) +importFrom(utils,modifyList) diff --git a/NEWS.md b/NEWS.md index eb54cca..f100cc9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,108 @@ ## New features +* New exported plot `plot_cost_vs_evaporation()` — third cost view: + scatters `cost_total` (EUR, x) against the element evapotranspiration + share (`element.WB_Evapotranspiration_`, %, y). Points share the + overflow-count palette of the sibling plots and are **shaped by the + storage type** (filled square = infiltration box / Sickerbox, filled + triangle = gravel trench / Schotterrigol); identical tooltip. Rendered + as `*_cost-vs-evaporation.html` in the three case-study vignettes and + linked from `vignettes/index.Rmd` under "Kosten vs. Verdunstung". + +* `plot_cost_overflow_boxplot()` gains `y_var = "cost_per_evap_pct"` + (y-axis = total cost per percentage point of evapotranspiration, + EUR/%; titles, y-label and the `min_cost` objective/label follow) and + `facet_storage_type = TRUE` (two stacked storage-type panels — + infiltration box on top, gravel trench below — each with its own + best-per-box markers and frontier line; `plotly::ggplotly()` keeps + the split as stacked subplots). When both storage types share one + panel (no faceting) the overlaid points are shaped by the storage + type like the scatter siblings; faceted panels keep plain circles + for readability. The vignettes render + the three existing boxplot variants with storage-type panels plus the + new `*_cost-per-evap-boxplot.html` (cheapest EUR/% per class, + point size = evapotranspiration), linked from `vignettes/index.Rmd` + under "Boxplot – Kosten je Prozent Verdunstung". + +* `plot_cost_vs_overflow_volume()` points are now also **shaped by the + storage type** (square/triangle, own legend under the colour legend). + +* The shared cost tooltip gains a derived **"Kosten je % Verdunstung + [€/%]"** line (total cost per percentage point of element + evapotranspiration, "-" when evapotranspiration is 0) right below the + total cost — shown consistently in both cost scatters and all cost + boxplot variants. + +* New **usable storage volume** of the storage layer: + `storage_volume_m3 = mulde_area * storage_height/1000 * + (thetaS - thetaFC)` (usable porosity 0.95 infiltration box / 0.3 + gravel trench). The vignettes add the column to the parameter grid + (grid datatable + results CSV) and the shared cost tooltip shows it + as "Nutzbares Speichervolumen [m³]" right below the storage type + (computed on the fly from the `storage_theta*` columns for existing + result sets without the column). In the "Variierende Parameter" block the raw + storage_type values are now translated too + (`Speichertyp=Schotterrigol` instead of `=gravel_trench`; shared + value labels with the `plot_main_effects()` storage-type panel). + +* The boxplots' point-size legend keys match the plotted markers: with + storage-type shapes in use (no faceting) they are drawn with the grey + square/triangle instead of the default circle; the faceted variants + use circular points and matching circular keys. + +* New exported helper `plotly_split_legend()` — cleans up the + interactive legends: `plotly::ggplotly()` flattens colour + shape + into unreadable `"(0,Sickerbox / Infiltration box)"` tuple entries. + The helper rebuilds the legend from legend-only keys with + unambiguous glyphs: one **neutral circle per overflow class in the + class colour** (clicking toggles both storage types of the class) + plus two **neutral grey** square/triangle keys under a + "Speichertyp" / "Storage type" group title (skippable via + `add_shape_legend = FALSE` for faceted plots) — a coloured + square/triangle key would wrongly suggest one specific + (colour, type) combination. The overlapping combined legend title is + removed and the legend moves to a vertical layout on the right. + Applied in all three vignettes to the cost-vs-overflow, + cost-vs-evaporation, water-balance and design-space HTMLs. + +* `plot_wb_tradeoff_overflows()` no longer crashes with "Can't combine + `mulde_area` and `storage_type` " on two-type + grids: its inline copy of the varying-parameter tooltip block was + replaced by the shared `build_varying_param_html()` helper (the + tooltip parameter names are now translated via + `default_param_labels()`, as in the cost plots). When the results + carry a `storage_type` column, its points are shaped by the storage + type (square/triangle) and the tooltip names the type; single-type + result sets plot as before. + +* `plot_valid_design_space()` gains `facet_storage_type` — two stacked + storage-type panels with **free y-scales**, so disjoint per-type + levels (storage_height: 300–1200 mm boxes vs. 900–3600 mm trenches) + fill their own panel; duplicate-based alpha is then counted per + panel and the points stay plain circles (the strips name the type). + Without faceting, points are shaped by the storage type whenever + `storage_type` varies. The vignettes facet both design-space blocks. + +* `plot_main_effects()` now supports character parameters (the pivot + previously failed on mixed types), keeps numeric level ordering + ("500" no longer sorts after "1000"), and renders `storage_type` as + its own panel with display names (Sickerbox/Schotterrigol or + Infiltration box/Gravel trench). The vignettes add `storage_type` to + the main-effects parameter set. + +* Fixed `build_varying_param_html()` (the shared tooltip helper): it + errored with "Can't combine `storage_height` and + `storage_type` " as soon as the character column + `storage_type` varied across scenarios — i.e. for every grid sweeping + both storage types (`values_transform = as.character` in the pivot). + Numbers in the varying-parameters tooltip block are now formatted + element-wise, so one decimal-valued parameter no longer forces + trailing ".00" onto every other value. The vignettes additionally + drop the storage_theta* helper columns (fully determined by + `storage_type`) from the plotting `param_grid`, keeping tooltips + lean. + * New exported plot `plot_cost_vs_overflow_volume()` — companion to `plot_wb_tradeoff_overflows()` for cost-aware optimisation. Scatters `cost_total` (EUR) against overflow volume (m³, computed diff --git a/R/cost_tooltip.R b/R/cost_tooltip.R index f30c03e..f267b99 100644 --- a/R/cost_tooltip.R +++ b/R/cost_tooltip.R @@ -35,7 +35,8 @@ default_param_labels <- function(lang = c("de", "en")) { bottom_hydraulicconductivity = "Sohl-Leitf\u00e4higkeit kf [mm/h]", rain_factor = "Regenfaktor [-]", lai = "Blattfl\u00e4chenindex LAI [-]", - storage_type = "Speichertyp" + storage_type = "Speichertyp", + storage_volume_m3 = "Nutzbares Speichervolumen [m\u00b3]" ), en = c( connected_area = "Connected area [m\u00b2]", @@ -47,11 +48,34 @@ default_param_labels <- function(lang = c("de", "en")) { bottom_hydraulicconductivity = "Subsoil conductivity kf [mm/h]", rain_factor = "Rain factor [-]", lai = "Leaf area index LAI [-]", - storage_type = "Storage type" + storage_type = "Storage type", + storage_volume_m3 = "Usable storage volume [m\u00b3]" ) ) } +#' Short, language-specific display names for the storage_type values +#' +#' Used wherever the raw `storage_type` values appear as compact text: the +#' "varying parameters" tooltip block (`Speichertyp=Schotterrigol` instead of +#' `Speichertyp=gravel_trench`) and the x-axis of the `plot_main_effects()` +#' storage-type panel. The bold storage-type tooltip line keeps the longer +#' bilingual names from `cost_tooltip_labels()`. +#' +#' @param lang Character. `"de"` or `"en"`. +#' @return Named character vector (names = raw values). +#' @noRd +storage_type_value_labels <- function(lang = c("de", "en")) { + lang <- match.arg(lang) + switch( + lang, + de = c(infiltration_box = "Sickerbox", + gravel_trench = "Schotterrigol"), + en = c(infiltration_box = "Infiltration box", + gravel_trench = "Gravel trench") + ) +} + #' Per-scenario HTML of the varying parameter-grid entries (translated) #' #' Detects the `param_grid` columns that vary across scenarios (excluding @@ -98,16 +122,33 @@ build_varying_param_html <- function(param_grid, lang = c("de", "en"), param_grid %>% dplyr::select("scenario_name", dplyr::all_of(varying_params)) %>% + # values_transform: numeric and character parameters (e.g. storage_type) + # cannot share one `val` column otherwise. tidyr::pivot_longer(-"scenario_name", names_to = "param", - values_to = "val") %>% + values_to = "val", + values_transform = list(val = as.character)) %>% dplyr::mutate( val_chr = purrr::map_chr(.data$val, ~ paste(.x, collapse = ",")), val_num = suppressWarnings(as.numeric(.data$val_chr)), + # format element-wise: a vectorised format() would pad every parameter + # to the maximum number of decimals in the column (e.g. "100.00" + # because another parameter has value 0.95). val_fmt = ifelse( is.na(.data$val_num), .data$val_chr, - format(round(.data$val_num, digits_params), trim = TRUE) + vapply(.data$val_num, + function(v) format(round(v, digits_params), trim = TRUE, + scientific = FALSE), + character(1)) + ), + # storage_type values get their short display names + # (Speichertyp=Schotterrigol instead of =gravel_trench) + val_fmt = ifelse( + .data$param == "storage_type" & + .data$val_chr %in% names(storage_type_value_labels(lang)), + unname(storage_type_value_labels(lang)[.data$val_chr]), + .data$val_fmt ), param_label = dplyr::coalesce(unname(param_labels[.data$param]), .data$param), @@ -140,11 +181,13 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { tt_wb_infil = "Versickerung", tt_wb_overflow = "\u00dcberlauf", tt_cost_total = "Gesamtkosten", + tt_cost_per_evap = "Kosten je % Verdunstung [\u20ac/%]", tt_cost_excavation = "Aushub", tt_cost_profiling = "Profilierung + Begr\u00fcnung", tt_cost_filter = "Bodenfilter", tt_cost_storage = "Speicherschicht", tt_storage_type = "Speichertyp", + tt_storage_volume = "Nutzbares Speichervolumen [m\u00b3]", st_infiltration_box = "Sickerbox / Infiltration box", st_gravel_trench = "Schotterrigol / Gravel trench", tt_costs_header = "Kostenaufteilung [\u20ac]", @@ -160,11 +203,13 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { tt_wb_infil = "Infiltration", tt_wb_overflow = "Overflow", tt_cost_total = "Total cost", + tt_cost_per_evap = "Cost per % evapotranspiration [\u20ac/%]", tt_cost_excavation = "Excavation", tt_cost_profiling = "Profiling + greening", tt_cost_filter = "Soil filter", tt_cost_storage = "Storage layer", tt_storage_type = "Storage type", + tt_storage_volume = "Usable storage volume [m\u00b3]", st_infiltration_box = "Infiltration box / Sickerbox", st_gravel_trench = "Gravel trench / Schotterrigol", tt_costs_header = "Cost breakdown [\u20ac]", @@ -173,6 +218,31 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { ) } +#' Storage-type display factor and marker shapes for the cost plots +#' +#' Maps the raw `storage_type` values to their bilingual display names (from +#' `cost_tooltip_labels()`) and to the fixed marker shapes shared by all cost +#' plots: **filled square (15) = infiltration box (Sickerbox)**, **filled +#' triangle (17) = gravel trench (Schotterrigol)**. Values that are `NA` or +#' unknown fall back to the infiltration box, mirroring `cost_tooltip_text()`. +#' +#' @param storage_type Character vector of raw values +#' (`"infiltration_box"` / `"gravel_trench"`). +#' @param tt Label list from `cost_tooltip_labels()`. +#' @return List with `display` (factor, infiltration box level first) and +#' `shape_values` (named vector for `ggplot2::scale_shape_manual()`). +#' @noRd +storage_type_shapes <- function(storage_type, tt) { + raw <- as.character(storage_type) + disp <- ifelse(!is.na(raw) & raw == "gravel_trench", + tt$st_gravel_trench, tt$st_infiltration_box) + lvls <- c(tt$st_infiltration_box, tt$st_gravel_trench) + list( + display = factor(disp, levels = lvls), + shape_values = stats::setNames(c(15, 17), lvls) + ) +} + #' Assemble the shared cost-plot tooltip HTML for each row of `df` #' #' `df` must carry `scenario_name`, `n_overflows`, `sum_overflows`, @@ -193,6 +263,32 @@ cost_tooltip_text <- function(df, tt, digits = 2L) { } st_disp <- ifelse(!is.na(st_raw) & st_raw == "gravel_trench", tt$st_gravel_trench, tt$st_infiltration_box) + # Derived cost efficiency: total cost per percentage point of element + # evapotranspiration [EUR/%]; undefined ("-") when evapotranspiration is 0. + evap <- df[["element.WB_Evapotranspiration_"]] + cpe <- ifelse(!is.na(df$cost_total) & !is.na(evap) & evap > 0, + df$cost_total / evap, NA_real_) + cpe_fmt <- vapply(cpe, function(v) { + if (is.na(v)) "-" else format(round(v, 0), big.mark = " ", trim = TRUE) + }, character(1)) + # Usable storage volume of the storage layer [m3]: area x height x usable + # porosity (thetaS - thetaFC) of the storage type. Taken from a precomputed + # storage_volume_m3 column when available, otherwise derived from the theta + # columns; the line is omitted for result sets carrying neither. + storage_volume <- if ("storage_volume_m3" %in% names(df)) { + df$storage_volume_m3 + } else if (all(c("mulde_area", "storage_height", "storage_thetaS", + "storage_thetaFC") %in% names(df))) { + df$mulde_area * df$storage_height / 1000 * + (df$storage_thetaS - df$storage_thetaFC) + } else { + NULL + } + storage_volume_line <- if (is.null(storage_volume)) { + "" + } else { + paste0("
", tt$tt_storage_volume, ": ", round(storage_volume, digits)) + } paste0( tt$tt_scenario, ": ", df$scenario_name, "
", tt$tt_n_overflows, ": ", df$n_overflows, @@ -206,6 +302,7 @@ cost_tooltip_text <- function(df, tt, digits = 2L) { "
", tt$tt_wb_overflow, ": ", round(df[["element.WB_Oberflaechenablauf_Ueberlauf_"]], digits), "

", tt$tt_storage_type, ": ", st_disp, "", + storage_volume_line, "

", tt$tt_costs_header, "", "
", tt$tt_cost_excavation, ": ", format(round(df$cost_excavation, 0), big.mark = " ", trim = TRUE), @@ -217,6 +314,7 @@ cost_tooltip_text <- function(df, tt, digits = 2L) { format(round(df$cost_storage, 0), big.mark = " ", trim = TRUE), "
", tt$tt_cost_total, ": ", format(round(df$cost_total, 0), big.mark = " ", trim = TRUE), "", + "
", tt$tt_cost_per_evap, ": ", cpe_fmt, "

", tt$tt_params, "
", df$params_html ) } diff --git a/R/plot_cost_overflow_boxplot.R b/R/plot_cost_overflow_boxplot.R index 747596a..87bc9a8 100644 --- a/R/plot_cost_overflow_boxplot.R +++ b/R/plot_cost_overflow_boxplot.R @@ -26,12 +26,24 @@ #' and the varying `param_grid` parameters translated via `param_labels`. #' Points and boxes are coloured with the same green (low counts) to red #' (`">x"`) palette as the sibling plots; because the colour merely echoes the -#' x-axis it carries no separate legend -- only the point-size legend is shown. +#' x-axis it carries no separate legend. When both storage types share one +#' panel, the overlaid points are additionally **shaped by the storage type** +#' (filled square = infiltration box / Sickerbox, filled triangle = gravel +#' trench / Schotterrigol), matching the scatter siblings, and a storage-type +#' legend is shown next to the point-size legend. With `facet_storage_type = +#' TRUE` the plot splits into two stacked storage-type panels instead; the +#' facet strips then carry that information and the points stay **plain +#' circles** for readability. `y_var = "cost_per_evap_pct"` switches the +#' y-axis to the cost per percentage point of evapotranspiration (EUR/%). #' #' The point-size scale is calibrated to the valid region (`0..x`): the extreme #' overflow volumes of the `">x"` catch-all are capped and a minimum size keeps #' even zero-volume points (the `0`-overflow box) visible, so the many-overflow #' outliers no longer shrink every valid-region point to an invisible dot. +#' When the storage-type shapes are in use (no faceting), its legend keys are +#' drawn with the storage-type marker (grey; the single present shape, or the +#' square when both types are shown) instead of the default circle; the +#' faceted variant uses circular points and matching circular keys. #' #' @inheritParams plot_cost_vs_overflow_volume #' @param x Numeric threshold. Counts `0..x` each get their own box; counts @@ -54,11 +66,32 @@ #' broken by `scenario_name`), `"min_overflow"` (smallest overflow volume) or #' `"max_evapotranspiration"` (highest evapotranspiration). In the `">x"` box #' the fewest-overflow scenario is picked first, `best_by` then breaking ties. +#' "Cost" always refers to the active `y_var`, so with +#' `y_var = "cost_per_evap_pct"` the `"min_cost"` objective picks the +#' scenario with the lowest cost per percentage point of evapotranspiration. +#' @param y_var Character. Which cost measure the y-axis (boxes, points, best +#' markers, frontier) shows: `"cost_total"` (default; total construction +#' cost, EUR) or `"cost_per_evap_pct"` (total cost divided by the element +#' evapotranspiration share, EUR per percentage point -- the cost +#' efficiency of evapotranspiration). Scenarios with zero +#' evapotranspiration have no defined ratio and are dropped from the +#' `"cost_per_evap_pct"` variant. Titles and the y-axis label switch +#' accordingly. +#' @param facet_storage_type Logical. If `TRUE`, the plot is split by +#' `storage_type` into two stacked panels (infiltration box on top, gravel +#' trench below, via `ggplot2::facet_grid()`), each with its own boxes, +#' best-per-box markers and frontier line; the overlaid points then stay +#' plain circles (the strips already name the type). +#' `plotly::ggplotly()` keeps the panel split as stacked subplots. +#' Default `FALSE`. #' @param label_best Logical. If `TRUE`, the best scenario per box is annotated #' next to it: overflow volume plus overflow share (`"NN m3 / NN %"`) for #' `min_overflow`, the evapotranspiration share (`"NN %"`) for -#' `max_evapotranspiration`, or the total cost for `min_cost`. Default -#' `FALSE`. +#' `max_evapotranspiration`, or the active `y_var` value for `min_cost` -- +#' the total cost (`"NN EUR"`) by default, the cost per percentage point of +#' evapotranspiration (`"NN EUR/%"`) with `y_var = "cost_per_evap_pct"`. +#' Default `FALSE`. +#' @param legend_position Character. Legend position, default `"right"`. #' @param mark_best Logical. If `TRUE` (default), the best scenario per box #' (see `best_by`) is highlighted with a black-outlined diamond filled in #' that box's group colour, so its plotly tooltip inherits the group colour. @@ -73,9 +106,10 @@ #' #' @export #' -#' @importFrom dplyr %>% filter mutate left_join case_when group_by arrange desc slice ungroup -#' @importFrom ggplot2 ggplot aes geom_boxplot geom_jitter geom_line geom_point geom_text position_jitter position_nudge scale_size scale_color_manual scale_fill_manual scale_x_discrete labs theme_bw theme element_text +#' @importFrom dplyr %>% filter mutate left_join case_when group_by arrange desc slice ungroup if_else +#' @importFrom ggplot2 ggplot aes geom_boxplot geom_jitter geom_line geom_point geom_text position_jitter position_nudge scale_size scale_color_manual scale_fill_manual scale_shape_manual scale_x_discrete facet_grid vars guides guide_legend labs theme_bw theme element_text #' @importFrom grDevices colorRampPalette +#' @importFrom utils modifyList #' @importFrom rlang .data plot_cost_overflow_boxplot <- function(simulation_results_optimisation, param_grid, @@ -96,6 +130,9 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, best_by = c("min_cost", "min_overflow", "max_evapotranspiration"), + y_var = c("cost_total", + "cost_per_evap_pct"), + facet_storage_type = FALSE, label_best = FALSE, title = NULL, lab_x = NULL, @@ -108,6 +145,7 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, lang <- match.arg(lang) size_by <- match.arg(size_by) best_by <- match.arg(best_by) + y_var <- match.arg(y_var) if (is.null(param_labels)) param_labels <- default_param_labels(lang) size_col <- if (size_by == "evapotranspiration") { @@ -145,6 +183,28 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, ) txt <- c(txt, cost_tooltip_labels(lang)) + # Cost-efficiency variant: y = total cost per percentage point of element + # evapotranspiration [EUR/%] instead of the plain total cost. Only the + # y-dependent labels change; palette / boxes / tooltip stay identical. + y_col <- if (y_var == "cost_per_evap_pct") "cost_per_evap_pct" else "cost_total" + if (y_var == "cost_per_evap_pct") { + txt$y <- switch(lang, + de = "Kosten je Prozent Verdunstung [\u20ac/%]", + en = "Cost per percent evapotranspiration [\u20ac/%]") + evap_prefix <- switch(lang, + de = "Kosten je % Verdunstung", + en = "Cost per % evapotranspiration") + txt$title_cheapest <- paste0(evap_prefix, switch(lang, + de = " \u2014 g\u00fcnstigste je Kategorie", + en = " \u2014 cheapest per class")) + txt$title_min_overflow <- paste0(evap_prefix, switch(lang, + de = " \u2014 geringstes \u00dcberlaufvolumen je Kategorie", + en = " \u2014 lowest overflow volume per class")) + txt$title_max_evap <- paste0(evap_prefix, switch(lang, + de = " \u2014 h\u00f6chste Verdunstung je Kategorie", + en = " \u2014 highest evapotranspiration per class")) + } + def_title <- switch(best_by, min_cost = txt$title_cheapest, min_overflow = txt$title_min_overflow, @@ -194,8 +254,8 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, valid_pct <- round(100 * mean( simulation_results_optimisation$n_overflows <= x_int, na.rm = TRUE)) share_txt <- switch(lang, - de = paste0(valid_pct, " % mit \u2264 ", x_int, " \u00dcberl\u00e4ufen"), - en = paste0(valid_pct, " % with \u2264 ", x_int, " overflows")) + de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), + en = paste0(valid_pct, " % with <= ", x_int, " overflows")) if (is.null(title)) title <- paste0(def_title, " (", share_txt, ")") param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, @@ -224,6 +284,24 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, overflow_cat = factor(.data$overflow_cat, levels = levs) ) + # Cost per percentage point of evapotranspiration [EUR/%]. Scenarios with + # zero evapotranspiration have no defined ratio and are dropped from the + # cost_per_evap_pct variant (the active y column must not be NA). + df <- df %>% + dplyr::mutate( + cost_per_evap_pct = dplyr::if_else( + .data[["element.WB_Evapotranspiration_"]] > 0, + .data$cost_total / .data[["element.WB_Evapotranspiration_"]], + NA_real_ + ) + ) %>% + dplyr::filter(!is.na(.data[[y_col]])) + + # Storage type: display factor for the facet strips and the point shapes + # (filled square = infiltration box, filled triangle = gravel trench). + st <- storage_type_shapes(df$storage_type, txt) + df$storage_type_disp <- st$display + df$tooltip_html <- cost_tooltip_text(df, txt, digits) # Point size: calibrate the scale to the valid region (0..x) and cap the @@ -250,18 +328,24 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, # objective matters there. The frontier line runs through the best of every # box, so the three objectives yield three different lines. best_grp <- df %>% - dplyr::filter(!is.na(.data$overflow_cat), !is.na(.data$cost_total)) %>% - dplyr::group_by(.data$overflow_cat) + dplyr::filter(!is.na(.data$overflow_cat), !is.na(.data[[y_col]])) + # With storage-type facets every panel gets its own best-per-box marker and + # frontier line, so the two technologies stay comparable. + best_grp <- if (isTRUE(facet_storage_type)) { + best_grp %>% dplyr::group_by(.data$storage_type_disp, .data$overflow_cat) + } else { + best_grp %>% dplyr::group_by(.data$overflow_cat) + } best <- switch(best_by, max_evapotranspiration = best_grp %>% dplyr::arrange(.data$n_overflows, dplyr::desc(.data[["element.WB_Evapotranspiration_"]]), - .data$cost_total, .data$scenario_name, .by_group = TRUE), + .data[[y_col]], .data$scenario_name, .by_group = TRUE), min_overflow = best_grp %>% dplyr::arrange(.data$n_overflows, .data$overflow_volume_m3, - .data$cost_total, .data$scenario_name, .by_group = TRUE), + .data[[y_col]], .data$scenario_name, .by_group = TRUE), min_cost = best_grp %>% - dplyr::arrange(.data$n_overflows, .data$cost_total, + dplyr::arrange(.data$n_overflows, .data[[y_col]], .data$scenario_name, .by_group = TRUE) ) best <- best %>% dplyr::slice(1L) %>% dplyr::ungroup() @@ -276,7 +360,8 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, format(round(best[["element.WB_Evapotranspiration_"]], 1), trim = TRUE), " %"), min_cost = paste0( - format(round(best$cost_total, 0), big.mark = " ", trim = TRUE), " \u20ac") + format(round(best[[y_col]], 0), big.mark = " ", trim = TRUE), + if (y_var == "cost_per_evap_pct") " \u20ac/%" else " \u20ac") ) } @@ -298,16 +383,38 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, "identity" } + # Storage-type shapes only when both types share one panel: in the faceted + # layout the strips already name the type, so the points stay plain circles + # (better readable with the size scaling). + use_shapes <- !isTRUE(facet_storage_type) + jitter_mapping <- ggplot2::aes(size = .data$size_plot, + colour = .data$overflow_cat, + text = .data$tooltip_html) + if (use_shapes) { + jitter_mapping <- utils::modifyList( + jitter_mapping, + ggplot2::aes(shape = .data$storage_type_disp) + ) + } + # With shapes in use, the size-legend keys would default to circles, which + # then never occur in the plot; draw them with the storage-type marker + # instead (neutral grey) -- the single present shape, or the square when + # both types are shown. + present_types <- unique(as.character(df$storage_type_disp)) + size_key_shape <- if (length(present_types) == 1L) { + unname(st$shape_values[present_types]) + } else { + 15 + } + p <- ggplot2::ggplot(df, ggplot2::aes(x = .data$overflow_cat, - y = .data$cost_total)) + + y = .data[[y_col]])) + ggplot2::geom_boxplot( ggplot2::aes(fill = .data$overflow_cat), alpha = box_alpha, outlier.shape = NA, colour = "grey40" ) + ggplot2::geom_jitter( - ggplot2::aes(size = .data$size_plot, - colour = .data$overflow_cat, - text = .data$tooltip_html), + jitter_mapping, position = pos, alpha = point_alpha ) + ggplot2::scale_size(range = c(1.5, max_point_size), name = lab_size) + @@ -323,19 +430,46 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, plot.title = ggplot2::element_text(size = 11) ) - # Frontier line across the best of every box (all classes), then the + # Square = infiltration box, triangle = gravel trench -- only when both + # types share one panel. The size-legend keys are then drawn with the same + # marker, so no circle appears in the legend that is absent from the plot. + if (use_shapes) { + p <- p + + ggplot2::scale_shape_manual( + values = st$shape_values, drop = FALSE, + name = txt$tt_storage_type + ) + + ggplot2::guides( + size = ggplot2::guide_legend( + override.aes = list(shape = size_key_shape, colour = "grey30", + alpha = 1) + ) + ) + } + + # Two stacked panels (infiltration box on top, gravel trench below). + # plotly::ggplotly() converts the facets to stacked subplots, so the + # interactive HTML keeps the panel split. + if (isTRUE(facet_storage_type)) { + p <- p + ggplot2::facet_grid( + rows = ggplot2::vars(.data$storage_type_disp) + ) + } + + # Frontier line across the best of every box (all classes; per panel when + # faceting -- facet_grid subsets `best` by storage type), then the # group-coloured best-marker on top of everything. if (isTRUE(connect_best) && nrow(best) > 1L) { p <- p + ggplot2::geom_line( data = best, - ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, group = 1L), + ggplot2::aes(x = .data$overflow_cat, y = .data[[y_col]], group = 1L), colour = "black", linewidth = 0.7, na.rm = TRUE ) } if (isTRUE(mark_best) && nrow(best) > 0L) { p <- p + ggplot2::geom_point( data = best, - ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, + ggplot2::aes(x = .data$overflow_cat, y = .data[[y_col]], fill = .data$overflow_cat, text = .data$tooltip_best), shape = 23, size = 3.2, colour = "black", stroke = 1.2, na.rm = TRUE @@ -344,10 +478,10 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, if (isTRUE(label_best) && "label_text" %in% names(best) && nrow(best) > 0L) { # place the label just above the marker (centred), so long labels such as # "3515 m3 / 35 %" never run off the right edge of the last box. - lab_nudge_y <- 0.045 * diff(range(df$cost_total, na.rm = TRUE)) + lab_nudge_y <- 0.045 * diff(range(df[[y_col]], na.rm = TRUE)) p <- p + ggplot2::geom_text( data = best, - ggplot2::aes(x = .data$overflow_cat, y = .data$cost_total, + ggplot2::aes(x = .data$overflow_cat, y = .data[[y_col]], label = .data$label_text), position = ggplot2::position_nudge(y = lab_nudge_y), hjust = 0.5, vjust = 0, size = 2.8, colour = "black", na.rm = TRUE diff --git a/R/plot_cost_vs_evaporation.R b/R/plot_cost_vs_evaporation.R new file mode 100644 index 0000000..0c28854 --- /dev/null +++ b/R/plot_cost_vs_evaporation.R @@ -0,0 +1,241 @@ +#' Cost vs. evapotranspiration scatter with storage-type shapes +#' +#' Second companion to \code{\link{plot_cost_vs_overflow_volume}} for +#' cost-aware optimisation. Plots the per-scenario **total construction cost** +#' (EUR) on the x-axis against the element **evapotranspiration share** (% of +#' the total water input, from `element.WB_Evapotranspiration_`) on the +#' y-axis. Points are coloured discretely by the **number** of overflow events +#' (same 0..x / >x palette used by the sibling plots, legend at the top) and +#' **shaped by the storage type**: filled square = infiltration box +#' (Sickerbox), filled triangle = gravel trench (Schotterrigol). +#' +#' The tooltip is identical to [plot_cost_vs_overflow_volume()]: scenario, +#' overflow count / sum (mm) / volume (m3), the element water balance +#' (`element.WB_Evapotranspiration_`, `element.WB_InfiltrationNetto_`, +#' `element.WB_Oberflaechenablauf_Ueberlauf_`, all as % of the total water +#' input), the storage type, the usable storage volume of the storage layer +#' (m3), the cost breakdown (`cost_excavation`, +#' `cost_profiling`, `cost_filter`, `cost_storage`, `cost_total`), the derived +#' **cost per percentage point of evapotranspiration** (EUR/%) plus the +#' varying parameters from `param_grid` (excluding `scenario_name`). +#' +#' The plot language can be switched via `lang = "de"` or `lang = "en"`. +#' Titles / axis labels / legend / tooltip labels follow the choice unless +#' explicit overrides are supplied. +#' +#' @inheritParams plot_cost_vs_overflow_volume +#' +#' @return A `ggplot` object. Convert to interactive via +#' `plotly::ggplotly(p, tooltip = "text")`. +#' +#' @seealso [plot_cost_vs_overflow_volume()] for cost vs. overflow volume and +#' [plot_cost_overflow_boxplot()] for the boxplot views (including +#' `y_var = "cost_per_evap_pct"`, the cost per percentage point of +#' evapotranspiration). +#' +#' @export +#' +#' @importFrom dplyr %>% filter mutate left_join case_when +#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual scale_shape_manual labs theme_bw position_jitter theme guides guide_legend +#' @importFrom grDevices colorRampPalette +#' @importFrom rlang .data +plot_cost_vs_evaporation <- function(simulation_results_optimisation, + param_grid, + x = 1, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.15, + jitter_height = 0.15, + jitter_seed = 1L, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + param_labels = NULL, + title = NULL, + lab_x = NULL, + lab_y = NULL, + legend_position = "top") { + + lang <- match.arg(lang) + if (is.null(param_labels)) param_labels <- default_param_labels(lang) + + txt <- switch( + lang, + de = list( + title = "Kosten vs. Verdunstung", + x = "Gesamtkosten [\u20ac]", + y = "Verdunstung [%]", + legend = "Anzahl \u00dcberlaufereignisse" + ), + en = list( + title = "Cost vs. evapotranspiration", + x = "Total cost [\u20ac]", + y = "Evapotranspiration [%]", + legend = "Number of overflow events" + ) + ) + txt <- c(txt, cost_tooltip_labels(lang)) + + if (is.null(lab_x)) lab_x <- txt$x + if (is.null(lab_y)) lab_y <- txt$y + + req_grid <- c("scenario_name") + req_res <- c( + "scenario_name", "n_overflows", "sum_overflows", "mulde_area", + "element.WB_Evapotranspiration_", "element.WB_InfiltrationNetto_", + "element.WB_Oberflaechenablauf_Ueberlauf_", + "cost_excavation", "cost_profiling", "cost_filter", + "cost_storage", "cost_total", "storage_type" + ) + + miss_grid <- setdiff(req_grid, names(param_grid)) + miss_res <- setdiff(req_res, names(simulation_results_optimisation)) + + if (length(miss_grid) > 0) { + stop("param_grid is missing column(s): ", paste(miss_grid, collapse = ", ")) + } + if (length(miss_res) > 0) { + stop( + "simulation_results_optimisation is missing column(s): ", + paste(miss_res, collapse = ", ") + ) + } + if (!is.numeric(x) || length(x) != 1 || is.na(x) || x < 0) { + stop("x must be a single non-negative numeric value.") + } + + x_int <- as.integer(round(x)) + if (!isTRUE(all.equal(x, x_int))) { + warning("x is not an integer; using x_int = ", x_int, + " for discrete palette/legend.") + } + + # Append the share of scenarios meeting the validity criterion + # (n_overflows <= x) to the auto title (ggplotly drops ggplot subtitles). + valid_pct <- round(100 * mean( + simulation_results_optimisation$n_overflows <= x_int, na.rm = TRUE)) + share_txt <- switch(lang, + de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), + en = paste0(valid_pct, " % with <= ", x_int, " overflows")) + if (is.null(title)) title <- paste0(txt$title, " (", share_txt, ")") + + param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, + digits_params) + + df <- simulation_results_optimisation %>% + dplyr::left_join(param_tooltip, by = "scenario_name") %>% + dplyr::filter(!isTRUE(filter_n_gtx) | + is.na(.data$n_overflows) | + .data$n_overflows <= x_int) %>% + dplyr::mutate( + overflow_volume_m3 = .data$sum_overflows * .data$mulde_area / 1000 + ) + + hi_lab <- paste0(">", x_int) + df <- df %>% + dplyr::mutate( + overflow_cat = dplyr::case_when( + is.na(.data$n_overflows) ~ NA_character_, + .data$n_overflows > x_int ~ hi_lab, + TRUE ~ as.character(.data$n_overflows) + ) + ) + + base_levels <- as.character(0:x_int) + levs <- c(base_levels, hi_lab) + + df <- df %>% + dplyr::mutate( + overflow_cat = factor(.data$overflow_cat, levels = levs) + ) + + # Storage type drives the marker shape (square = infiltration box, + # triangle = gravel trench); shared with the sibling cost plots. + st <- storage_type_shapes(df$storage_type, txt) + df$storage_type_disp <- st$display + + df$tooltip_html <- cost_tooltip_text(df, txt, digits) + + if (x_int == 0L) { + pal <- c("0" = "orange", ">0" = "red") + } else if (x_int == 1L) { + pal <- c("0" = "darkgreen", "1" = "orange", ">1" = "red") + } else { + pal_green <- grDevices::colorRampPalette(c("darkgreen", "yellowgreen"))(x_int) + pal_vals <- c(pal_green, "orange", "red") + pal_names <- c(base_levels, hi_lab) + pal <- stats::setNames(pal_vals, pal_names) + } + + legend_breaks <- levs + + pos <- if (isTRUE(use_jitter)) { + ggplot2::position_jitter( + width = jitter_width, + height = jitter_height, + seed = jitter_seed + ) + } else { + "identity" + } + + legend_direction <- if (legend_position %in% c("top", "bottom")) { + "horizontal" + } else { + "vertical" + } + + legend_nrow <- if (legend_direction == "horizontal") 1 else NULL + legend_ncol <- if (legend_direction == "vertical") 1 else NULL + + p <- ggplot2::ggplot(df, ggplot2::aes( + x = .data$cost_total, + y = .data[["element.WB_Evapotranspiration_"]], + color = .data$overflow_cat, + shape = .data$storage_type_disp, + text = .data$tooltip_html + )) + + ggplot2::geom_point(alpha = 0.7, position = pos) + + ggplot2::scale_color_manual( + values = pal, + breaks = legend_breaks, + limits = levs, + drop = FALSE, + name = txt$legend + ) + + ggplot2::scale_shape_manual( + values = st$shape_values, + drop = FALSE, + name = txt$tt_storage_type + ) + + ggplot2::guides( + colour = ggplot2::guide_legend( + direction = legend_direction, + nrow = legend_nrow, + ncol = legend_ncol, + byrow = TRUE, + order = 1 + ), + shape = ggplot2::guide_legend( + direction = legend_direction, + nrow = legend_nrow, + ncol = legend_ncol, + byrow = TRUE, + order = 2 + ) + ) + + ggplot2::labs( + title = title, + x = lab_x, + y = lab_y + ) + + ggplot2::theme_bw() + + ggplot2::theme( + legend.position = legend_position, + legend.direction = legend_direction, + # stack the colour and shape legends so both fit at the top + legend.box = if (legend_direction == "horizontal") "vertical" else "horizontal" + ) + + p +} diff --git a/R/plot_cost_vs_overflow_volume.R b/R/plot_cost_vs_overflow_volume.R index 62dde87..8913d99 100644 --- a/R/plot_cost_vs_overflow_volume.R +++ b/R/plot_cost_vs_overflow_volume.R @@ -4,7 +4,9 @@ #' optimisation. Plots the per-scenario **total construction cost** (EUR) on #' the x-axis against the **overflow volume** (m3) on the y-axis, with the #' points coloured discretely by the **number** of overflow events (same -#' 0..x / >x palette used by `plot_wb_tradeoff_overflows`, legend at the top). +#' 0..x / >x palette used by `plot_wb_tradeoff_overflows`, legend at the top) +#' and **shaped by the storage type**: filled square = infiltration box +#' (Sickerbox), filled triangle = gravel trench (Schotterrigol). #' #' Overflow volume is computed from `sum_overflows` (in mm on the swale #' surface, as returned by [`add_overflow_events_and_waterbalance()`]) @@ -15,9 +17,13 @@ #' (`element.WB_Evapotranspiration_`, `element.WB_InfiltrationNetto_`, #' `element.WB_Oberflaechenablauf_Ueberlauf_`, all as % of the total water #' input) and the cost breakdown (`cost_excavation`, `cost_profiling`, -#' `cost_filter`, `cost_storage`, `cost_total`) plus the varying parameters -#' from `param_grid` (excluding `scenario_name`), so the user can hover over a -#' scatter point and see exactly why it landed where it did. +#' `cost_filter`, `cost_storage`, `cost_total`), the derived **cost per +#' percentage point of evapotranspiration** (EUR/%), the **usable storage +#' volume** of the storage layer (m3; area x height x usable porosity +#' `thetaS - thetaFC`, from a `storage_volume_m3` column or derived from the +#' `storage_theta*` columns) plus the varying parameters from `param_grid` +#' (excluding `scenario_name`), so the user can hover over a scatter point +#' and see exactly why it landed where it did. #' #' The plot language can be switched via `lang = "de"` or `lang = "en"`. #' Titles / axis labels / legend / tooltip labels follow the choice unless @@ -52,12 +58,13 @@ #' `plotly::ggplotly(p, tooltip = "text")`. #' #' @seealso [plot_cost_overflow_boxplot()] for the same data / tooltip shown as -#' a cost-by-overflow-count boxplot. +#' a cost-by-overflow-count boxplot and [plot_cost_vs_evaporation()] for +#' cost vs. the element evapotranspiration share. #' #' @export #' #' @importFrom dplyr %>% filter mutate left_join case_when -#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual labs theme_bw position_jitter theme guides guide_legend +#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual scale_shape_manual labs theme_bw position_jitter theme guides guide_legend #' @importFrom grDevices colorRampPalette #' @importFrom rlang .data plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, @@ -136,8 +143,8 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, valid_pct <- round(100 * mean( simulation_results_optimisation$n_overflows <= x_int, na.rm = TRUE)) share_txt <- switch(lang, - de = paste0(valid_pct, " % mit \u2264 ", x_int, " \u00dcberl\u00e4ufen"), - en = paste0(valid_pct, " % with \u2264 ", x_int, " overflows")) + de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), + en = paste0(valid_pct, " % with <= ", x_int, " overflows")) if (is.null(title)) title <- paste0(txt$title, " (", share_txt, ")") param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, @@ -170,6 +177,11 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, overflow_cat = factor(.data$overflow_cat, levels = levs) ) + # Storage type drives the marker shape (filled square = infiltration box, + # filled triangle = gravel trench); shared with the sibling cost plots. + st <- storage_type_shapes(df$storage_type, txt) + df$storage_type_disp <- st$display + df$tooltip_html <- cost_tooltip_text(df, txt, digits) if (x_int == 0L) { @@ -208,6 +220,7 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, x = .data$cost_total, y = .data$overflow_volume_m3, color = .data$overflow_cat, + shape = .data$storage_type_disp, text = .data$tooltip_html )) + ggplot2::geom_point(alpha = 0.7, position = pos) + @@ -218,12 +231,25 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, drop = FALSE, name = txt$legend ) + + ggplot2::scale_shape_manual( + values = st$shape_values, + drop = FALSE, + name = txt$tt_storage_type + ) + ggplot2::guides( colour = ggplot2::guide_legend( direction = legend_direction, nrow = legend_nrow, ncol = legend_ncol, - byrow = TRUE + byrow = TRUE, + order = 1 + ), + shape = ggplot2::guide_legend( + direction = legend_direction, + nrow = legend_nrow, + ncol = legend_ncol, + byrow = TRUE, + order = 2 ) ) + ggplot2::labs( @@ -234,7 +260,9 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, ggplot2::theme_bw() + ggplot2::theme( legend.position = legend_position, - legend.direction = legend_direction + legend.direction = legend_direction, + # stack the colour and shape legends so both fit at the top + legend.box = if (legend_direction == "horizontal") "vertical" else "horizontal" ) p diff --git a/R/plot_main_effects.R b/R/plot_main_effects.R index 289d8f0..45a3d97 100644 --- a/R/plot_main_effects.R +++ b/R/plot_main_effects.R @@ -8,6 +8,11 @@ #' The function is intended for optimisation or sensitivity grids with many #' parameters, where a single 2D scatter plot is not informative. #' +#' Both numeric and character parameters are supported; a character parameter +#' such as \code{storage_type} gets its own facet panel (its levels are shown +#' as \code{Sickerbox} / \code{Schotterrigol} for \code{lang = "de"}, +#' \code{Infiltration box} / \code{Gravel trench} for \code{lang = "en"}). +#' #' The plot language can be switched via \code{lang = "de"} or #' \code{lang = "en"}. This affects the title, y-axis label, and selected #' parameter labels. @@ -71,8 +76,13 @@ plot_main_effects <- function(df, "filter_height" = "Filterh\u00f6he [mm]", "bottom_hydraulicconductivity" = "hydr. Leitf\u00e4higkeit des Untergrunds [mm/h]", "rain_factor" = "Regenfaktor", - "lai" = "Blattfl\u00e4chenindex (Mulde-Rigole) [m\u00b2/m\u00b2]" + "lai" = "Blattfl\u00e4chenindex (Mulde-Rigole) [m\u00b2/m\u00b2]", + "storage_type" = "Speichertyp" ) + + # Display names for the storage_type levels on the x-axis of its panel + # (shared with the tooltips, see cost_tooltip.R). + storage_value_labels <- storage_type_value_labels(lang) translate_param <- function(x) { if (lang == "de" && x %in% names(param_labels_de)) { @@ -91,13 +101,33 @@ plot_main_effects <- function(df, dl <- df %>% dplyr::select(dplyr::all_of(c(y, params_use))) %>% + # values_transform: numeric and character parameters (e.g. storage_type) + # cannot share one `value` column otherwise. tidyr::pivot_longer( cols = dplyr::all_of(params_use), names_to = "parameter", - values_to = "value" + values_to = "value", + values_transform = list(value = as.character) ) %>% dplyr::mutate( - value = as.factor(.data$value) + value = ifelse( + .data$parameter == "storage_type" & + .data$value %in% names(storage_value_labels), + storage_value_labels[.data$value], + .data$value + ) + ) + + # Order the shared factor levels numerically where possible (a plain + # as.factor on characters would sort "1000" before "500"); non-numeric + # levels (e.g. the storage types) come last, alphabetically. + val_u <- unique(dl$value) + val_n <- suppressWarnings(as.numeric(val_u)) + value_levels <- c(val_u[!is.na(val_n)][order(val_n[!is.na(val_n)])], + sort(val_u[is.na(val_n)])) + dl <- dl %>% + dplyr::mutate( + value = factor(.data$value, levels = value_levels) ) eff <- dl %>% @@ -139,4 +169,4 @@ plot_main_effects <- function(df, } p -} \ No newline at end of file +} diff --git a/R/plot_valid_design_space.R b/R/plot_valid_design_space.R index 4b027a2..14d4db3 100644 --- a/R/plot_valid_design_space.R +++ b/R/plot_valid_design_space.R @@ -73,6 +73,16 @@ #' \code{drop_overflow_gt_valid_max = TRUE}, the x/y axis limits are fixed to #' the full range or full set of levels found in \code{param_grid}, so the #' design-space axes do not shrink after filtering. Default \code{TRUE}. +#' @param facet_storage_type Logical. If \code{TRUE}, the design space is +#' split by \code{storage_type} into two stacked panels (infiltration box on +#' top, gravel trench below) with free y-scales, so disjoint per-type levels +#' (e.g. \code{storage_height}: 300-1200 mm boxes vs. 900-3600 mm trenches) +#' fill their own panel; duplicate counting for \code{alpha_mode = +#' "duplicates"} then happens per panel and the points stay plain circles +#' (the strips already name the type). Requires a \code{storage_type} +#' column in \code{param_grid}. Without faceting, points are shaped by the +#' storage type (filled square = infiltration box, filled triangle = gravel +#' trench) whenever \code{storage_type} varies. Default \code{FALSE}. #' @param lang Character. Plot language: \code{"de"} or \code{"en"}. #' @param title Character or \code{NULL}. Plot title. If \code{NULL}, a #' language-specific default title is used. @@ -88,7 +98,9 @@ #' @importFrom ggplot2 position_identity scale_alpha_identity coord_cartesian #' @importFrom ggplot2 scale_x_discrete scale_y_discrete scale_colour_manual #' @importFrom ggplot2 guides guide_legend theme scale_x_continuous scale_y_continuous +#' @importFrom ggplot2 scale_shape_manual facet_grid vars #' @importFrom rlang .data +#' @importFrom utils modifyList #' @importFrom grDevices colorRampPalette #' @export plot_valid_design_space <- function(param_grid, @@ -111,6 +123,7 @@ plot_valid_design_space <- function(param_grid, alpha_min = 0.20, alpha_max = 1.00, keep_param_grid_limits = TRUE, + facet_storage_type = FALSE, lang = c("de", "en"), title = NULL, subtitle = NULL, @@ -132,10 +145,12 @@ plot_valid_design_space <- function(param_grid, txt <- switch( lang, de = list( + # two lines: the composed title (threshold + both axis labels) is too + # long for one line in the 9-inch PDFs and the interactive HTMLs title = paste0( - "G\u00fcltige L\u00f6sungen (Anzahl \u00dcberlaufereignisse \u2264 ", + "G\u00fcltige L\u00f6sungen (Anzahl \u00dcberlaufereignisse <= ", valid_max, - ") im Designraum: ", + ")\nim Designraum: ", lab_x, " \u00d7 ", lab_y @@ -148,9 +163,9 @@ plot_valid_design_space <- function(param_grid, ), en = list( title = paste0( - "Valid solutions (Number of overflow events \u2264 ", + "Valid solutions (Number of overflow events <= ", valid_max, - ") in design space: ", + ")\nin design space: ", x, " \u00d7 ", y @@ -194,11 +209,16 @@ plot_valid_design_space <- function(param_grid, stop("Missing columns in sim_results: ", paste(miss_res, collapse = ", ")) } + if (isTRUE(facet_storage_type) && !"storage_type" %in% names(param_grid)) { + stop("facet_storage_type = TRUE requires a 'storage_type' column in param_grid.") + } + cand <- setdiff(names(param_grid), id_col) lvl <- vapply(param_grid[cand], function(v) dplyr::n_distinct(v, na.rm = TRUE), numeric(1)) varied_params <- cand[lvl > 1 & lvl <= max_levels] - - keep_pg <- unique(c(id_col, x, y, varied_params)) + + keep_pg <- unique(c(id_col, x, y, varied_params, + if (isTRUE(facet_storage_type)) "storage_type")) d <- dplyr::left_join( dplyr::select(param_grid, dplyr::all_of(keep_pg)), dplyr::select(sim_results, dplyr::all_of(c(id_col, overflow_col))), @@ -213,7 +233,26 @@ plot_valid_design_space <- function(param_grid, if (isTRUE(drop_overflow_gt_valid_max)) { d <- dplyr::filter(d, .data[[overflow_col]] <= valid_max_int) } - + + # Storage-type tagging (filled square = infiltration box, filled triangle = + # gravel trench, as in the cost plots): active whenever storage_type is one + # of the varied parameters -- except in the faceted layout, where the strips + # already name the type and the points stay plain circles for readability. + has_storage_type <- "storage_type" %in% names(d) + if (has_storage_type) { + st_labels <- cost_tooltip_labels(lang) + st <- storage_type_shapes(d$storage_type, st_labels) + d$storage_type_disp <- st$display + } + use_shapes <- has_storage_type && !isTRUE(facet_storage_type) + add_shape <- function(mapping) { + if (use_shapes) { + utils::modifyList(mapping, ggplot2::aes(shape = .data$storage_type_disp)) + } else { + mapping + } + } + other_params <- setdiff(varied_params, c(x, y)) fmt <- function(v) { @@ -274,8 +313,14 @@ plot_valid_design_space <- function(param_grid, legend_breaks <- levs if (alpha_mode == "duplicates") { + # With storage-type facets, identical x/y coordinates only overplot within + # the same panel, so duplicates are counted per storage type. + d <- if (isTRUE(facet_storage_type) && has_storage_type) { + d %>% dplyr::group_by(.data$storage_type_disp, .data[[x]], .data[[y]]) + } else { + d %>% dplyr::group_by(.data[[x]], .data[[y]]) + } d <- d %>% - dplyr::group_by(.data[[x]], .data[[y]]) %>% dplyr::mutate(dup_n = dplyr::n()) %>% dplyr::ungroup() @@ -320,11 +365,11 @@ plot_valid_design_space <- function(param_grid, if (isTRUE(drop_overflow_gt_valid_max)) { p <- ggplot2::ggplot(d, ggplot2::aes(x = .data[[x]], y = .data[[y]])) + ggplot2::geom_point( - ggplot2::aes( + add_shape(ggplot2::aes( colour = .data$overflow_cat, text = .data$hover, alpha = .data$alpha_valid - ), + )), size = size + 0.6, position = pos ) + @@ -359,21 +404,21 @@ plot_valid_design_space <- function(param_grid, p <- ggplot2::ggplot(d, ggplot2::aes(x = .data[[x]], y = .data[[y]])) + ggplot2::geom_point( data = dplyr::filter(d, !.data$valid), - ggplot2::aes( + add_shape(ggplot2::aes( colour = .data$overflow_cat, text = .data$hover, alpha = .data$alpha_invalid - ), + )), size = size, position = pos ) + ggplot2::geom_point( data = dplyr::filter(d, .data$valid), - ggplot2::aes( + add_shape(ggplot2::aes( colour = .data$overflow_cat, text = .data$hover, alpha = .data$alpha_valid - ), + )), size = size + 0.8, position = pos ) + @@ -406,6 +451,30 @@ plot_valid_design_space <- function(param_grid, ) } + if (use_shapes) { + p <- p + + # Square = infiltration box, triangle = gravel trench. + ggplot2::scale_shape_manual( + values = st$shape_values, + drop = FALSE, + name = st_labels$tt_storage_type + ) + + # stack the colour and shape legends so both fit at the top + ggplot2::theme( + legend.box = if (legend_direction == "horizontal") "vertical" else "horizontal" + ) + } + if (isTRUE(facet_storage_type)) { + # Two stacked panels (infiltration box on top, gravel trench below); + # free y-scales let disjoint per-type levels (e.g. storage_height: + # 300-1200 mm boxes vs. 900-3600 mm trenches) fill their own panel. + # plotly::ggplotly() keeps the split as stacked subplots. + p <- p + ggplot2::facet_grid( + rows = ggplot2::vars(.data$storage_type_disp), + scales = "free_y" + ) + } + if (isTRUE(keep_param_grid_limits)) { if (is.numeric(param_grid[[x]]) && is.numeric(param_grid[[y]])) { x_vals <- sort(unique(param_grid[[x]])) @@ -418,7 +487,8 @@ plot_valid_design_space <- function(param_grid, if (isTRUE(drop_overflow_gt_valid_max)) { p <- p + ggplot2::coord_cartesian( xlim = range(x_vals), - ylim = range(y_vals) + # a fixed ylim would override the per-panel free y-scales + ylim = if (isTRUE(facet_storage_type)) NULL else range(y_vals) ) } } else { diff --git a/R/plot_wb_tradeoff_overflows.R b/R/plot_wb_tradeoff_overflows.R index 71c0339..72894d8 100644 --- a/R/plot_wb_tradeoff_overflows.R +++ b/R/plot_wb_tradeoff_overflows.R @@ -18,7 +18,15 @@ #' tooltip labels unless custom labels are supplied explicitly. #' #' Tooltip text additionally includes all parameters from \code{param_grid} that -#' vary across scenarios, excluding \code{scenario_name}. +#' vary across scenarios, excluding \code{scenario_name} (translated via +#' \code{\link{default_param_labels}}; mixed numeric / character parameters +#' such as \code{storage_type} are supported). +#' +#' If \code{simulation_results_optimisation} carries a \code{storage_type} +#' column, the points are additionally **shaped by the storage type** (filled +#' square = infiltration box / Sickerbox, filled triangle = gravel trench / +#' Schotterrigol, as in the cost plots) and the tooltip names the storage +#' type; older single-type result sets plot exactly as before. #' #' @param simulation_results_optimisation Data frame with simulation results. #' Required columns are \code{scenario_name}, \code{n_overflows}, @@ -55,12 +63,10 @@ #' #' @export #' -#' @importFrom dplyr %>% select summarise across everything n_distinct -#' @importFrom dplyr filter pull mutate group_by left_join -#' @importFrom tidyr pivot_longer -#' @importFrom purrr map_chr -#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual labs theme_minimal position_jitter theme +#' @importFrom dplyr %>% filter mutate left_join case_when +#' @importFrom ggplot2 ggplot aes geom_point scale_color_manual scale_shape_manual labs theme_bw position_jitter theme guides guide_legend #' @importFrom grDevices colorRampPalette +#' @importFrom utils modifyList #' @importFrom rlang .data plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, param_grid, @@ -84,7 +90,7 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, lang, de = list( title = paste0( - "Wasserbilanz vs. \u00DCberlaufereignisse (Anzahl \u2264 ", + "Wasserbilanz vs. \u00DCberlaufereignisse (Anzahl <= ", x, ")" ), @@ -101,7 +107,7 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, ), en = list( title = paste0( - "Water balance vs. overflow events (number \u2264 ", + "Water balance vs. overflow events (number <= ", x, ")" ), @@ -157,35 +163,13 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, warning("x is not an integer; using x_int = ", x_int, " for discrete palette/legend.") } - varying_params <- param_grid %>% - dplyr::select(-scenario_name) %>% - dplyr::summarise(dplyr::across(dplyr::everything(), ~ dplyr::n_distinct(.) > 1)) %>% - tidyr::pivot_longer(dplyr::everything(), names_to = "param", values_to = "vary") %>% - dplyr::filter(vary) %>% - dplyr::pull(param) - - if (length(varying_params) == 0) { - param_tooltip <- param_grid %>% - dplyr::select(scenario_name) %>% - dplyr::mutate(params_html = "") - } else { - param_tooltip <- param_grid %>% - dplyr::select(scenario_name, dplyr::all_of(varying_params)) %>% - tidyr::pivot_longer(-scenario_name, names_to = "param", values_to = "val") %>% - dplyr::mutate( - val_chr = purrr::map_chr(val, ~ paste(.x, collapse = ",")), - val_num = suppressWarnings(as.numeric(val_chr)), - val_fmt = ifelse( - is.na(val_num), - val_chr, - format(round(val_num, digits_params), trim = TRUE) - ), - kv = paste0(param, "=", val_fmt) - ) %>% - dplyr::group_by(scenario_name) %>% - dplyr::summarise(params_html = paste(kv, collapse = "
"), .groups = "drop") - } - + # Shared helper (same as the cost plots): handles mixed numeric / character + # parameter columns (e.g. storage_type) and translates the parameter names + # via default_param_labels(). + param_tooltip <- build_varying_param_html(param_grid, lang, + param_labels = NULL, + digits_params = digits_params) + df <- simulation_results_optimisation %>% dplyr::left_join(param_tooltip, by = "scenario_name") %>% dplyr::filter(!isTRUE(filter_n_gtx) | is.na(.data$n_overflows) | .data$n_overflows <= x_int) @@ -207,7 +191,36 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, dplyr::mutate( overflow_cat = factor(.data$overflow_cat, levels = levs) ) - + + # Optional storage-type tagging (filled square = infiltration box, filled + # triangle = gravel trench, as in the cost plots): active when the results + # carry a storage_type column; older single-type result sets plot as before. + has_storage_type <- "storage_type" %in% names(df) + if (has_storage_type) { + st_labels <- cost_tooltip_labels(lang) + st <- storage_type_shapes(df$storage_type, st_labels) + df$storage_type_disp <- st$display + } + + df$tooltip_html <- paste0( + txt$tt_scenario, ": ", df$scenario_name, + "
", txt$tt_n_overflows, ": ", df$n_overflows, + "
", txt$tt_infil, ": ", + round(df[["element.WB_InfiltrationNetto_"]], digits), + "
", txt$tt_evap, ": ", + round(df[["element.WB_Evapotranspiration_"]], digits), + "
", txt$tt_overflow, ": ", + round(df[["element.WB_Oberflaechenablauf_Ueberlauf_"]], digits), + "
", txt$tt_sum_overflows, ": ", df$sum_overflows, + if (has_storage_type) { + paste0("

", st_labels$tt_storage_type, ": ", + as.character(df$storage_type_disp), "") + } else { + "" + }, + "

", txt$tt_params, "
", df$params_html + ) + if (x_int == 0L) { pal <- c("0" = "orange", ">0" = "red") } else if (x_int == 1L) { @@ -240,20 +253,20 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, legend_nrow <- if (legend_direction == "horizontal") 1 else NULL legend_ncol <- if (legend_direction == "vertical") 1 else NULL - p <- ggplot2::ggplot(df, ggplot2::aes( - x = element.WB_InfiltrationNetto_, - y = element.WB_Evapotranspiration_, - color = overflow_cat, - text = paste0( - txt$tt_scenario, ": ", scenario_name, - "
", txt$tt_n_overflows, ": ", n_overflows, - "
", txt$tt_infil, ": ", round(element.WB_InfiltrationNetto_, digits), - "
", txt$tt_evap, ": ", round(element.WB_Evapotranspiration_, digits), - "
", txt$tt_overflow, ": ", round(element.WB_Oberflaechenablauf_Ueberlauf_, digits), - "
", txt$tt_sum_overflows, ": ", sum_overflows, - "

", txt$tt_params, "
", params_html + mapping <- ggplot2::aes( + x = .data[["element.WB_InfiltrationNetto_"]], + y = .data[["element.WB_Evapotranspiration_"]], + color = .data$overflow_cat, + text = .data$tooltip_html + ) + if (has_storage_type) { + mapping <- utils::modifyList( + mapping, + ggplot2::aes(shape = .data$storage_type_disp) ) - )) + + } + + p <- ggplot2::ggplot(df, mapping) + ggplot2::geom_point(alpha = 0.7, position = pos) + ggplot2::scale_color_manual( values = pal, @@ -267,7 +280,8 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, direction = legend_direction, nrow = legend_nrow, ncol = legend_ncol, - byrow = TRUE + byrow = TRUE, + order = 1 ) ) + ggplot2::labs( @@ -278,8 +292,28 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, ggplot2::theme_bw() + ggplot2::theme( legend.position = legend_position, - legend.direction = legend_direction + legend.direction = legend_direction, + # stack the colour and shape legends so both fit at the top + legend.box = if (legend_direction == "horizontal") "vertical" else "horizontal" ) - + + if (has_storage_type) { + p <- p + + ggplot2::scale_shape_manual( + values = st$shape_values, + drop = FALSE, + name = st_labels$tt_storage_type + ) + + ggplot2::guides( + shape = ggplot2::guide_legend( + direction = legend_direction, + nrow = legend_nrow, + ncol = legend_ncol, + byrow = TRUE, + order = 2 + ) + ) + } + p -} \ No newline at end of file +} diff --git a/R/plotly_split_legend.R b/R/plotly_split_legend.R new file mode 100644 index 0000000..2f02a46 --- /dev/null +++ b/R/plotly_split_legend.R @@ -0,0 +1,212 @@ +#' Split the combined (colour, shape) ggplotly legend into two clean legends +#' +#' `plotly::ggplotly()` flattens a ggplot with both a colour and a shape +#' aesthetic into one trace per (colour, shape) combination and names the +#' legend entries as tuples such as `"(0,Sickerbox / Infiltration box)"` -- +#' with two storage types and the 0..x / ">x" overflow palette that yields an +#' unreadable legend. This helper post-processes the plotly object: +#' +#' * the real traces lose their legend entries; instead every overflow class +#' gets one legend-only key drawn as a **neutral circle in the class +#' colour** (a coloured square or triangle would wrongly suggest one +#' specific storage type). The key shares its legend group with the real +#' traces of that class, so clicking it toggles **both** storage types of +#' the class together; +#' * two legend-only keys (**neutral grey** filled square = infiltration box, +#' filled triangle = gravel trench) are appended under their own +#' **storage-type group title**, so the shape encoding is explained +#' separately from the colours -- set `add_shape_legend = FALSE` to skip +#' them (e.g. for storage-type-faceted plots whose strips already label the +#' panels); +#' * the combined `"colour,shape"` legend-title annotation that ggplotly +#' draws over the plot title is removed; group titles take its place and +#' the legend moves to a vertical layout on the right, where the groups +#' stack cleanly. +#' +#' Traces whose name is not a `"(colour,shape)"` tuple (frontier lines, best +#' markers, single-aesthetic plots) are left untouched, so the helper is safe +#' to apply to any of the package's interactive plots. +#' +#' @param pl A plotly object as returned by +#' `plotly::ggplotly(p, tooltip = "text")`. +#' @param lang Character. `"de"` or `"en"`; sets the default legend group +#' titles. +#' @param colour_title Character or `NULL`. Title of the colour legend group. +#' Defaults to the language-specific "Number of overflow events". +#' @param shape_title Character or `NULL`. Title of the storage-type legend +#' group. Defaults to the language-specific "Storage type". +#' @param add_shape_legend Logical. If `TRUE` (default), append the two +#' legend-only storage-type entries. +#' +#' @return The modified plotly object. +#' +#' @examples +#' \dontrun{ +#' p <- plot_cost_vs_evaporation(sim_results, param_grid, x = 5, lang = "de") +#' pl <- plotly::ggplotly(p, tooltip = "text") +#' pl <- plotly_split_legend(pl, lang = "de") +#' } +#' +#' @export +plotly_split_legend <- function(pl, + lang = c("de", "en"), + colour_title = NULL, + shape_title = NULL, + add_shape_legend = TRUE) { + + lang <- match.arg(lang) + tt <- cost_tooltip_labels(lang) + if (is.null(colour_title)) { + colour_title <- switch(lang, + de = "Anzahl \u00dcberlaufereignisse", + en = "Number of overflow events") + } + if (is.null(shape_title)) shape_title <- tt$tt_storage_type + + traces <- pl$x$data + tuple_re <- "^\\((.+?),(.+)\\)$" + seen_colour <- character(0) + colour_swatch <- list() + shape_symbols <- list() + found_tuples <- FALSE + + # Every real (colour, shape) trace loses its legend entry; the legend is + # rebuilt from legend-only dummy traces below, so the colour keys can be + # neutral circles and the storage-type keys neutral grey shapes -- a + # coloured square/triangle key would wrongly suggest one specific + # (colour, type) combination. + for (i in seq_along(traces)) { + nm <- traces[[i]]$name + if (is.null(nm) || length(nm) != 1) next + m <- regmatches(as.character(nm), regexec(tuple_re, as.character(nm)))[[1]] + if (length(m) != 3) next + found_tuples <- TRUE + + colour_lab <- trimws(m[2]) + shape_lab <- trimws(m[3]) + + sym <- traces[[i]]$marker$symbol + if (!is.null(sym) && length(sym) >= 1 && !shape_lab %in% names(shape_symbols)) { + shape_symbols[[shape_lab]] <- sym[[1]] + } + col <- traces[[i]]$marker$color + if (!is.null(col) && length(col) >= 1 && !colour_lab %in% names(colour_swatch)) { + colour_swatch[[colour_lab]] <- col[[1]] + } + if (!colour_lab %in% seen_colour) seen_colour <- c(seen_colour, colour_lab) + + traces[[i]]$name <- colour_lab + traces[[i]]$legendgroup <- colour_lab + traces[[i]]$showlegend <- FALSE + } + + # Layout clean-up shared by both cases: strip the legend-title annotation + # that ggplotly draws over the plot title, convert two-line ggplot titles + # ("\n") to plotly's "
", and move the legend to a vertical layout on + # the right where nothing collides with the title. + fix_layout <- function(pl) { + ann <- pl$x$layout$annotations + if (length(ann) > 0) { + keep <- vapply(ann, function(a) { + txt <- if (is.null(a$text)) "" else gsub("<[^>]+>", "", as.character(a$text)) + !(grepl(colour_title, txt, fixed = TRUE) || + grepl(shape_title, txt, fixed = TRUE)) + }, logical(1)) + pl$x$layout$annotations <- ann[keep] + } + if (!is.null(pl$x$layout$title$text)) { + pl$x$layout$title$text <- gsub("\n", "
", + pl$x$layout$title$text, fixed = TRUE) + } + pl$x$layout$showlegend <- TRUE + pl$x$layout$legend$orientation <- "v" + pl$x$layout$legend$x <- 1.02 + pl$x$layout$legend$xanchor <- "left" + pl$x$layout$legend$y <- 1.0 + pl$x$layout$legend$yanchor <- "top" + pl + } + + # No combined-legend traces (single-aesthetic plot, e.g. the faceted design + # space): keep the existing colour entries, but give the legend its title + # (instead of the removed annotation) and order the classes numerically + # with the ">x" catch-all last. + if (!found_tuples) { + for (i in seq_along(traces)) { + nm <- traces[[i]]$name + nm <- if (is.null(nm)) "" else as.character(nm) + if (grepl("^[0-9]+$", nm)) { + traces[[i]]$legendrank <- 100 + as.numeric(nm) + } else if (grepl("^>", nm)) { + traces[[i]]$legendrank <- 800 + } + } + pl$x$data <- traces + pl$x$layout$legend$title <- list(text = colour_title) + return(fix_layout(pl)) + } + + # Colour classes ordered numerically, the ">x" catch-all after them. + colour_num <- suppressWarnings(as.numeric(seen_colour)) + colour_sorted <- c(seen_colour[!is.na(colour_num)][order(colour_num[!is.na(colour_num)])], + sort(seen_colour[is.na(colour_num)])) + + # Legend-only colour keys: neutral circles in the class colour. They share + # the legendgroup with the real traces of that class, so clicking a key + # still toggles both storage types of the class together. + # Legend-only traces need one null data point (x/y = NA -> [null] in the + # JSON): plotly.js does not create legend entries for traces whose data + # arrays are completely empty. + first_colour <- TRUE + for (lab in colour_sorted) { + tr <- list( + x = NA_real_, y = NA_real_, + type = "scatter", mode = "markers", + marker = list(symbol = "circle", + color = colour_swatch[[lab]], + size = 10), + name = lab, + legendgroup = lab, + legendrank = 100 + match(lab, colour_sorted), + showlegend = TRUE, + hoverinfo = "none" + ) + if (first_colour) { + tr$legendgrouptitle <- list(text = colour_title) + first_colour <- FALSE + } + traces[[length(traces) + 1]] <- tr + } + + # Legend-only storage-type keys: neutral grey square / triangle. + if (isTRUE(add_shape_legend) && length(shape_symbols) > 0) { + first_shape <- TRUE + for (lab in names(shape_symbols)) { + tr <- list( + x = NA_real_, y = NA_real_, + type = "scatter", mode = "markers", + # "#666666" = R "grey40"; R colour names are not valid CSS for + # plotly.js + marker = list(symbol = shape_symbols[[lab]], color = "#666666", + size = 10), + name = lab, + legendgroup = "storage_type_legend", + legendrank = 900 + match(lab, names(shape_symbols)), + showlegend = TRUE, + hoverinfo = "none" + ) + if (first_shape) { + tr$legendgrouptitle <- list(text = shape_title) + first_shape <- FALSE + } + traces[[length(traces) + 1]] <- tr + } + } + + pl$x$data <- traces + + # Group titles replace the legend title in the rebuilt legend. + pl$x$layout$legend$title <- list(text = "") + + fix_layout(pl) +} diff --git a/man/plot_cost_overflow_boxplot.Rd b/man/plot_cost_overflow_boxplot.Rd index f6e7439..1914ff8 100644 --- a/man/plot_cost_overflow_boxplot.Rd +++ b/man/plot_cost_overflow_boxplot.Rd @@ -21,6 +21,8 @@ plot_cost_overflow_boxplot( param_labels = NULL, size_by = c("overflow_volume", "evapotranspiration"), best_by = c("min_cost", "min_overflow", "max_evapotranspiration"), + y_var = c("cost_total", "cost_per_evap_pct"), + facet_storage_type = FALSE, label_best = FALSE, title = NULL, lab_x = NULL, @@ -79,13 +81,35 @@ element evapotranspiration share in \%, from \code{element.WB_Evapotranspiration box, with cost as the tie-breaker: \code{"min_cost"} (default; cheapest, ties broken by \code{scenario_name}), \code{"min_overflow"} (smallest overflow volume) or \code{"max_evapotranspiration"} (highest evapotranspiration). In the \code{">x"} box -the fewest-overflow scenario is picked first, \code{best_by} then breaking ties.} +the fewest-overflow scenario is picked first, \code{best_by} then breaking ties. +"Cost" always refers to the active \code{y_var}, so with +\code{y_var = "cost_per_evap_pct"} the \code{"min_cost"} objective picks the +scenario with the lowest cost per percentage point of evapotranspiration.} + +\item{y_var}{Character. Which cost measure the y-axis (boxes, points, best +markers, frontier) shows: \code{"cost_total"} (default; total construction +cost, EUR) or \code{"cost_per_evap_pct"} (total cost divided by the element +evapotranspiration share, EUR per percentage point -- the cost +efficiency of evapotranspiration). Scenarios with zero +evapotranspiration have no defined ratio and are dropped from the +\code{"cost_per_evap_pct"} variant. Titles and the y-axis label switch +accordingly.} + +\item{facet_storage_type}{Logical. If \code{TRUE}, the plot is split by +\code{storage_type} into two stacked panels (infiltration box on top, gravel +trench below, via \code{ggplot2::facet_grid()}), each with its own boxes, +best-per-box markers and frontier line; the overlaid points then stay +plain circles (the strips already name the type). +\code{plotly::ggplotly()} keeps the panel split as stacked subplots. +Default \code{FALSE}.} \item{label_best}{Logical. If \code{TRUE}, the best scenario per box is annotated next to it: overflow volume plus overflow share (\code{"NN m3 / NN \%"}) for \code{min_overflow}, the evapotranspiration share (\code{"NN \%"}) for -\code{max_evapotranspiration}, or the total cost for \code{min_cost}. Default -\code{FALSE}.} +\code{max_evapotranspiration}, or the active \code{y_var} value for \code{min_cost} -- +the total cost (\code{"NN EUR"}) by default, the cost per percentage point of +evapotranspiration (\code{"NN EUR/\%"}) with \code{y_var = "cost_per_evap_pct"}. +Default \code{FALSE}.} \item{title, lab_x, lab_y}{Optional character overrides for the default language-specific title / axis labels.} @@ -100,7 +124,7 @@ that box's group colour, so its plotly tooltip inherits the group colour.} scenarios of \strong{all} boxes (overflow counts \verb{0..x} plus the \code{">x"} catch-all) are connected by a line -- the best-per-overflow-level frontier.} -\item{legend_position}{Character. Legend position, default \code{"top"}.} +\item{legend_position}{Character. Legend position, default \code{"right"}.} } \value{ A \code{ggplot} object. Convert to interactive via @@ -134,12 +158,23 @@ balance (evapotranspiration / infiltration / overflow, \%), the cost breakdown and the varying \code{param_grid} parameters translated via \code{param_labels}. Points and boxes are coloured with the same green (low counts) to red (\code{">x"}) palette as the sibling plots; because the colour merely echoes the -x-axis it carries no separate legend -- only the point-size legend is shown. +x-axis it carries no separate legend. When both storage types share one +panel, the overlaid points are additionally \strong{shaped by the storage type} +(filled square = infiltration box / Sickerbox, filled triangle = gravel +trench / Schotterrigol), matching the scatter siblings, and a storage-type +legend is shown next to the point-size legend. With \code{facet_storage_type = TRUE} the plot splits into two stacked storage-type panels instead; the +facet strips then carry that information and the points stay \strong{plain +circles} for readability. \code{y_var = "cost_per_evap_pct"} switches the +y-axis to the cost per percentage point of evapotranspiration (EUR/\%). The point-size scale is calibrated to the valid region (\verb{0..x}): the extreme overflow volumes of the \code{">x"} catch-all are capped and a minimum size keeps even zero-volume points (the \code{0}-overflow box) visible, so the many-overflow outliers no longer shrink every valid-region point to an invisible dot. +When the storage-type shapes are in use (no faceting), its legend keys are +drawn with the storage-type marker (grey; the single present shape, or the +square when both types are shown) instead of the default circle; the +faceted variant uses circular points and matching circular keys. } \seealso{ \code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}} diff --git a/man/plot_cost_vs_evaporation.Rd b/man/plot_cost_vs_evaporation.Rd new file mode 100644 index 0000000..692c55a --- /dev/null +++ b/man/plot_cost_vs_evaporation.Rd @@ -0,0 +1,96 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_cost_vs_evaporation.R +\name{plot_cost_vs_evaporation} +\alias{plot_cost_vs_evaporation} +\title{Cost vs. evapotranspiration scatter with storage-type shapes} +\usage{ +plot_cost_vs_evaporation( + simulation_results_optimisation, + param_grid, + x = 1, + filter_n_gtx = FALSE, + use_jitter = TRUE, + jitter_width = 0.15, + jitter_height = 0.15, + jitter_seed = 1L, + digits = 2L, + digits_params = 4L, + lang = c("de", "en"), + param_labels = NULL, + title = NULL, + lab_x = NULL, + lab_y = NULL, + legend_position = "top" +) +} +\arguments{ +\item{simulation_results_optimisation}{Data frame with the columns +\code{scenario_name}, \code{n_overflows}, \code{sum_overflows}, \code{mulde_area}, +\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, +\code{element.WB_Oberflaechenablauf_Ueberlauf_}, \code{cost_excavation}, +\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}, +\code{storage_type}. Typically the joined output of +\code{\link[=add_overflow_events_and_waterbalance]{add_overflow_events_and_waterbalance()}} and \code{\link[=compute_costs]{compute_costs()}}.} + +\item{param_grid}{Data frame with parameter grid. Must contain +\code{scenario_name}.} + +\item{x}{Numeric threshold for the overflow-count colour bucket. Values +greater than \code{x} are pushed into the red \code{">x"} category.} + +\item{filter_n_gtx}{Logical. If \code{TRUE}, scenarios with \code{n_overflows > x} +are dropped before plotting.} + +\item{use_jitter, jitter_width, jitter_height, jitter_seed}{As in +\code{\link[=plot_wb_tradeoff_overflows]{plot_wb_tradeoff_overflows()}}.} + +\item{digits}{Integer. Rounding for numeric values in the tooltip.} + +\item{digits_params}{Integer. Rounding for parameter values in the +tooltip.} + +\item{lang}{Character. Plot language: \code{"de"} or \code{"en"}.} + +\item{param_labels}{Named character vector translating \code{param_grid} columns +to tooltip labels, or \code{NULL} to use \code{\link[=default_param_labels]{default_param_labels()}} for \code{lang}.} + +\item{title, lab_x, lab_y}{Optional character overrides for the default +language-specific title / axis labels.} + +\item{legend_position}{Character. Legend position, default \code{"top"}.} +} +\value{ +A \code{ggplot} object. Convert to interactive via +\code{plotly::ggplotly(p, tooltip = "text")}. +} +\description{ +Second companion to \code{\link{plot_cost_vs_overflow_volume}} for +cost-aware optimisation. Plots the per-scenario \strong{total construction cost} +(EUR) on the x-axis against the element \strong{evapotranspiration share} (\% of +the total water input, from \code{element.WB_Evapotranspiration_}) on the +y-axis. Points are coloured discretely by the \strong{number} of overflow events +(same 0..x / >x palette used by the sibling plots, legend at the top) and +\strong{shaped by the storage type}: filled square = infiltration box +(Sickerbox), filled triangle = gravel trench (Schotterrigol). +} +\details{ +The tooltip is identical to \code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}}: scenario, +overflow count / sum (mm) / volume (m3), the element water balance +(\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, +\code{element.WB_Oberflaechenablauf_Ueberlauf_}, all as \% of the total water +input), the storage type, the usable storage volume of the storage layer +(m3), the cost breakdown (\code{cost_excavation}, +\code{cost_profiling}, \code{cost_filter}, \code{cost_storage}, \code{cost_total}), the derived +\strong{cost per percentage point of evapotranspiration} (EUR/\%) plus the +varying parameters from \code{param_grid} (excluding \code{scenario_name}). + +The plot language can be switched via \code{lang = "de"} or \code{lang = "en"}. +Titles / axis labels / legend / tooltip labels follow the choice unless +explicit overrides are supplied. +} +\seealso{ +\code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}} for cost vs. overflow volume and +\code{\link[=plot_cost_overflow_boxplot]{plot_cost_overflow_boxplot()}} for the boxplot views (including +\code{y_var = "cost_per_evap_pct"}, the cost per percentage point of +evapotranspiration). +} diff --git a/man/plot_cost_vs_overflow_volume.Rd b/man/plot_cost_vs_overflow_volume.Rd index 5592970..078f9f0 100644 --- a/man/plot_cost_vs_overflow_volume.Rd +++ b/man/plot_cost_vs_overflow_volume.Rd @@ -68,7 +68,9 @@ Companion to \code{\link{plot_wb_tradeoff_overflows}} for cost-aware optimisation. Plots the per-scenario \strong{total construction cost} (EUR) on the x-axis against the \strong{overflow volume} (m3) on the y-axis, with the points coloured discretely by the \strong{number} of overflow events (same -0..x / >x palette used by \code{plot_wb_tradeoff_overflows}, legend at the top). +0..x / >x palette used by \code{plot_wb_tradeoff_overflows}, legend at the top) +and \strong{shaped by the storage type}: filled square = infiltration box +(Sickerbox), filled triangle = gravel trench (Schotterrigol). } \details{ Overflow volume is computed from \code{sum_overflows} (in mm on the swale @@ -80,9 +82,13 @@ The tooltip carries the element water balance (\code{element.WB_Evapotranspiration_}, \code{element.WB_InfiltrationNetto_}, \code{element.WB_Oberflaechenablauf_Ueberlauf_}, all as \% of the total water input) and the cost breakdown (\code{cost_excavation}, \code{cost_profiling}, -\code{cost_filter}, \code{cost_storage}, \code{cost_total}) plus the varying parameters -from \code{param_grid} (excluding \code{scenario_name}), so the user can hover over a -scatter point and see exactly why it landed where it did. +\code{cost_filter}, \code{cost_storage}, \code{cost_total}), the derived \strong{cost per +percentage point of evapotranspiration} (EUR/\%), the \strong{usable storage +volume} of the storage layer (m3; area x height x usable porosity +\code{thetaS - thetaFC}, from a \code{storage_volume_m3} column or derived from the +\verb{storage_theta*} columns) plus the varying parameters from \code{param_grid} +(excluding \code{scenario_name}), so the user can hover over a scatter point +and see exactly why it landed where it did. The plot language can be switched via \code{lang = "de"} or \code{lang = "en"}. Titles / axis labels / legend / tooltip labels follow the choice unless @@ -90,5 +96,6 @@ explicit overrides are supplied. } \seealso{ \code{\link[=plot_cost_overflow_boxplot]{plot_cost_overflow_boxplot()}} for the same data / tooltip shown as -a cost-by-overflow-count boxplot. +a cost-by-overflow-count boxplot and \code{\link[=plot_cost_vs_evaporation]{plot_cost_vs_evaporation()}} for +cost vs. the element evapotranspiration share. } diff --git a/man/plot_main_effects.Rd b/man/plot_main_effects.Rd index be88794..b0e8778 100644 --- a/man/plot_main_effects.Rd +++ b/man/plot_main_effects.Rd @@ -45,6 +45,11 @@ median outcome values across parameter levels. The function is intended for optimisation or sensitivity grids with many parameters, where a single 2D scatter plot is not informative. +Both numeric and character parameters are supported; a character parameter +such as \code{storage_type} gets its own facet panel (its levels are shown +as \code{Sickerbox} / \code{Schotterrigol} for \code{lang = "de"}, +\code{Infiltration box} / \code{Gravel trench} for \code{lang = "en"}). + The plot language can be switched via \code{lang = "de"} or \code{lang = "en"}. This affects the title, y-axis label, and selected parameter labels. diff --git a/man/plot_valid_design_space.Rd b/man/plot_valid_design_space.Rd index 98da154..c2752a5 100644 --- a/man/plot_valid_design_space.Rd +++ b/man/plot_valid_design_space.Rd @@ -25,6 +25,7 @@ plot_valid_design_space( alpha_min = 0.2, alpha_max = 1, keep_param_grid_limits = TRUE, + facet_storage_type = FALSE, lang = c("de", "en"), title = NULL, subtitle = NULL, @@ -96,6 +97,17 @@ same x/y. Default \code{"none"}.} the full range or full set of levels found in \code{param_grid}, so the design-space axes do not shrink after filtering. Default \code{TRUE}.} +\item{facet_storage_type}{Logical. If \code{TRUE}, the design space is +split by \code{storage_type} into two stacked panels (infiltration box on +top, gravel trench below) with free y-scales, so disjoint per-type levels +(e.g. \code{storage_height}: 300-1200 mm boxes vs. 900-3600 mm trenches) +fill their own panel; duplicate counting for \code{alpha_mode = + "duplicates"} then happens per panel and the points stay plain circles +(the strips already name the type). Requires a \code{storage_type} +column in \code{param_grid}. Without faceting, points are shaped by the +storage type (filled square = infiltration box, filled triangle = gravel +trench) whenever \code{storage_type} varies. Default \code{FALSE}.} + \item{lang}{Character. Plot language: \code{"de"} or \code{"en"}.} \item{title}{Character or \code{NULL}. Plot title. If \code{NULL}, a diff --git a/man/plot_wb_tradeoff_overflows.Rd b/man/plot_wb_tradeoff_overflows.Rd index 5ef1d63..887ca09 100644 --- a/man/plot_wb_tradeoff_overflows.Rd +++ b/man/plot_wb_tradeoff_overflows.Rd @@ -90,5 +90,13 @@ The plot language can be switched via \code{lang = "de"} or tooltip labels unless custom labels are supplied explicitly. Tooltip text additionally includes all parameters from \code{param_grid} that -vary across scenarios, excluding \code{scenario_name}. +vary across scenarios, excluding \code{scenario_name} (translated via +\code{\link{default_param_labels}}; mixed numeric / character parameters +such as \code{storage_type} are supported). + +If \code{simulation_results_optimisation} carries a \code{storage_type} +column, the points are additionally \strong{shaped by the storage type} (filled +square = infiltration box / Sickerbox, filled triangle = gravel trench / +Schotterrigol, as in the cost plots) and the tooltip names the storage +type; older single-type result sets plot exactly as before. } diff --git a/man/plotly_split_legend.Rd b/man/plotly_split_legend.Rd new file mode 100644 index 0000000..3f30d28 --- /dev/null +++ b/man/plotly_split_legend.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plotly_split_legend.R +\name{plotly_split_legend} +\alias{plotly_split_legend} +\title{Split the combined (colour, shape) ggplotly legend into two clean legends} +\usage{ +plotly_split_legend( + pl, + lang = c("de", "en"), + colour_title = NULL, + shape_title = NULL, + add_shape_legend = TRUE +) +} +\arguments{ +\item{pl}{A plotly object as returned by +\code{plotly::ggplotly(p, tooltip = "text")}.} + +\item{lang}{Character. \code{"de"} or \code{"en"}; sets the default legend group +titles.} + +\item{colour_title}{Character or \code{NULL}. Title of the colour legend group. +Defaults to the language-specific "Number of overflow events".} + +\item{shape_title}{Character or \code{NULL}. Title of the storage-type legend +group. Defaults to the language-specific "Storage type".} + +\item{add_shape_legend}{Logical. If \code{TRUE} (default), append the two +legend-only storage-type entries.} +} +\value{ +The modified plotly object. +} +\description{ +\code{plotly::ggplotly()} flattens a ggplot with both a colour and a shape +aesthetic into one trace per (colour, shape) combination and names the +legend entries as tuples such as \code{"(0,Sickerbox / Infiltration box)"} -- +with two storage types and the 0..x / ">x" overflow palette that yields an +unreadable legend. This helper post-processes the plotly object: +} +\details{ +\itemize{ +\item the real traces lose their legend entries; instead every overflow class +gets one legend-only key drawn as a \strong{neutral circle in the class +colour} (a coloured square or triangle would wrongly suggest one +specific storage type). The key shares its legend group with the real +traces of that class, so clicking it toggles \strong{both} storage types of +the class together; +\item two legend-only keys (\strong{neutral grey} filled square = infiltration box, +filled triangle = gravel trench) are appended under their own +\strong{storage-type group title}, so the shape encoding is explained +separately from the colours -- set \code{add_shape_legend = FALSE} to skip +them (e.g. for storage-type-faceted plots whose strips already label the +panels); +\item the combined \code{"colour,shape"} legend-title annotation that ggplotly +draws over the plot title is removed; group titles take its place and +the legend moves to a vertical layout on the right, where the groups +stack cleanly. +} + +Traces whose name is not a \code{"(colour,shape)"} tuple (frontier lines, best +markers, single-aesthetic plots) are left untouched, so the helper is safe +to apply to any of the package's interactive plots. +} +\examples{ +\dontrun{ +p <- plot_cost_vs_evaporation(sim_results, param_grid, x = 5, lang = "de") +pl <- plotly::ggplotly(p, tooltip = "text") +pl <- plotly_split_legend(pl, lang = "de") +} + +} diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index 7ca849c..c11f2e4 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -96,6 +96,10 @@ for (site in sites) { ### Sensitive Modellparameter +Haupteffekte je Parameter (Violin-/Box-/Punkt-Plots, nach Effektstärke +sortiert). Der **Speichertyp** ist als eigenes Panel enthalten +(Sickerbox vs. Schotterrigol). + ```{r brute_force_plots_main, echo = FALSE, results='asis'} for (site in sites) { cat(sprintf( @@ -109,15 +113,22 @@ for (site in sites) { ### Design Spaces -In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit +In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit **einem weiteren Parameter** (y-Achse) dargestellt. Diese sind im folgenden: -- ***Muldenhöhe*** +- ***Muldenhöhe*** - ***Speicherhöhe*** - ***hydraulische Leitfähigkeit*** des Bodenfilters +Die beiden **Speichertypen** liegen als **zwei Panels untereinander** +(Sickerbox oben, Schotterrigole unten; die Punkte bleiben Kreise, da +die Panel-Streifen den Typ benennen). Die y-Achsen sind je Panel frei +skaliert, so dass z. B. bei +der **Speicherhöhe** jedes Panel nur die für den Typ getesteten Höhen +zeigt (Sickerbox 300–1200 mm, Schotterrigole 900–3600 mm). + ```{r brute_force_plots_design-spaches, echo = FALSE, results='asis'} cat("| Design Space |", paste(sites, collapse = " | "), "|\n") cat("|---|", paste(rep("---", length(sites)), collapse = "|"), "|\n") @@ -142,6 +153,12 @@ for (ds in design_spaces) { ### Wasserbilanz +Streudiagramm **Infiltration [%]** (x) vs. **Verdunstung [%]** (y) je +Szenario, Punktfarbe = Anzahl Überlaufereignisse, Punktform = +**Speichertyp** (Viereck = Sickerbox, Dreieck = Schotterrigole). Der +Tooltip zeigt die Wasserbilanz, den Speichertyp und die variierenden +Design-Parameter. + ```{r brute_force_plots_water-balance, echo = FALSE, results='asis'} for (site in sites) { cat(sprintf( @@ -155,20 +172,26 @@ for (site in sites) { ### Kosten -Drei komplementäre, interaktive Sichten auf die **Baukosten** der +Sechs komplementäre, interaktive Sichten auf die **Baukosten** der Szenarien und ihren Zusammenhang mit Überläufen, Wasserhaushalt und -Design-Parametern. Alle drei teilen denselben Punkt-Tooltip -(Wasserhaushalt, Kostenaufteilung, variierende Parameter). +Design-Parametern. Alle teilen denselben Punkt-Tooltip +(Wasserhaushalt, Kostenaufteilung, variierende Parameter). Der +**Speichertyp** ist überall einheitlich kodiert: in den Streudiagrammen +über die **Punktform** (Viereck = Sickerbox/Infiltration box, +Dreieck = Schotterrigol/Gravel trench), in den Boxplots über **zwei +Panels untereinander** (Sickerbox oben, Schotterrigol unten). #### Kosten vs. Überlaufvolumen Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten [€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und `mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, -`>5` = rot, Legende oben). Mouseover zeigt den Wasserhaushalt +`>5` = rot, Legende oben), Punktform nach **Speichertyp** (Viereck = +Sickerbox, Dreieck = Schotterrigol). Mouseover zeigt den Wasserhaushalt (Verdunstung, Versickerung, Überlauf in %), die vollständige Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, -Gesamt) plus die variierenden Design-Parameter des Szenarios. +Gesamt), die **Kosten je Prozent Verdunstung [€/%]** plus die +variierenden Design-Parameter des Szenarios. ```{r brute_force_plots_cost-overflow, echo = FALSE, results='asis'} for (site in sites) { @@ -181,12 +204,37 @@ for (site in sites) { } ``` +#### Kosten vs. Verdunstung + +Streudiagramm analog zum vorigen, aber mit der **Verdunstung [%]** +(Anteil der Verdunstung am Gesamtwasserinput des Elements) auf der +y-Achse: **x-Achse Gesamtkosten [€]**, Punktfarbe nach **Anzahl +Überlaufereignisse**, Punktform nach **Speichertyp** (Viereck = +Sickerbox, Dreieck = Schotterrigol). Zeigt, wie viel Verdunstung man +je Budget bekommt und welche Szenarien dabei gültig bleiben — +identischer Tooltip. + +```{r brute_force_plots_cost-evaporation, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-vs-evaporation.html)\n", + site, + base_dir, + site + )) +} +``` + Alle Boxplots zeigen die **Gesamtkosten** [€] (y-Achse) je **Anzahl Überlaufereignisse** (x-Achse; `0`–`5` einzeln, `>5` = Rest gebündelt; im `>5`-Kasten wird das Szenario mit den wenigsten Überläufen markiert), -überlagert mit den Szenarien als Punkte. Je Box ist ein **bestes** Szenario +überlagert mit den Szenarien als Punkte (Kreise; die Panel-Streifen +benennen den Typ), und trennen die beiden +**Speichertypen in zwei Panels untereinander** (Sickerbox oben, +Schotterrigol unten). Je Box und Panel ist ein +**bestes** Szenario als Raute in der jeweiligen Gruppenfarbe (schwarz umrandet) markiert; die -Markierungen **aller** Klassen sind zur Frontier-Linie verbunden. +Markierungen **aller** Klassen sind je Panel zur Frontier-Linie verbunden. Punkt-Mouseover: Wasserhaushalt, Kostenaufteilung, variierende Parameter. Die drei Varianten optimieren je Box ein **anderes Ziel** (Kosten als Tie-Break) und ergeben so drei verschiedene Frontier-Linien: @@ -240,4 +288,27 @@ for (site in sites) { } ``` +#### Boxplot – Kosten je Prozent Verdunstung + +Kosteneffizienz der Verdunstung: y-Achse sind die **Kosten je +Prozentpunkt Verdunstung [€/%]** (Gesamtkosten geteilt durch den +Verdunstungsanteil des Szenarios) je **Anzahl Überlaufereignisse**, +wieder mit den beiden **Speichertypen als zwei Panels untereinander**. +Je Box und Panel ist das Szenario mit den **geringsten Kosten je +Prozentpunkt** markiert und mit seinem Wert [€/%] beschriftet; die +**Punktgröße kodiert die Verdunstung [%]**. So lässt sich direkt +ablesen, mit welcher Speichertechnik und welchem Design ein +Prozentpunkt Verdunstung am günstigsten erkauft wird. + +```{r brute_force_plots_cost-per-evap-boxplot, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-per-evap-boxplot.html)\n", + site, + base_dir, + site + )) +} +``` + diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index c33423f..b4d00f4 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -109,7 +109,28 @@ mulde_area <- c(25, 50, 75, 100, 125, 150, 175, 200) mulde_height <- c(100, 200, 300) filter_hydraulicconductivity <- c(36, 180, 360) filter_height <- 300 -storage_height <- c(100, 500, 1000) +# Storage-layer (Speicher = 2nd Bodenschichtung layer) presets per storage type. +# Each type brings its own storage_height levels plus the Speicher soil +# parameters (theta*). They are written to the model in the run loop below: +# storage_height -> Schichtdicken[2] +# Startwerte_theta_ActualSoilMoisture -> Startwerte_theta_ActualSoilMoisture[2] +# thetaWP/thetaFC/thetaS -> //Bodenarten/Speicher/theta* +storage_type <- list( + "infiltration_box" = list( + storage_height = c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.95 + ), + "gravel_trench" = list( + storage_height = 3 * c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.3 + ) +) rain_factor <- 1 bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). @@ -119,6 +140,22 @@ bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) lai <- 3.9 +# storage_height is coupled to storage_type (each type has its own levels), so +# build one row per (storage_type, storage_height) carrying the matching +# Speicher soil parameters, then cross-join with all remaining combinations. +storage_grid <- do.call(rbind, lapply(names(storage_type), function(type_name) { + spec <- storage_type[[type_name]] + data.frame( + storage_type = type_name, + storage_height = spec$storage_height, + storage_theta_start = spec$Startwerte_theta_ActualSoilMoisture, + storage_thetaWP = spec$thetaWP_MoistureAtWiltingPoint, + storage_thetaFC = spec$thetaFC_MoistureAtFieldCapacity, + storage_thetaS = spec$thetaS_MoistureAtSaturation, + stringsAsFactors = FALSE + ) +})) + # Alle Kombinationen erzeugen param_grid_all_combinations <- expand.grid( connected_area = connected_area, @@ -126,16 +163,25 @@ param_grid_all_combinations <- expand.grid( mulde_height = mulde_height, filter_hydraulicconductivity = filter_hydraulicconductivity, filter_height = filter_height, - storage_height = storage_height, bottom_hydraulicconductivity = bottom_hydraulicconductivity, rain_factor = rain_factor, - lai = lai + lai = lai, + stringsAsFactors = FALSE ) +# Cross-join the free parameters with the coupled storage grid. +param_grid_all_combinations <- merge(param_grid_all_combinations, storage_grid, + by = NULL) + param_grid_all_combinations <- param_grid_all_combinations %>% dplyr::bind_cols(tibble::tibble(scenario_name = sprintf("s%05d", seq_len(nrow(param_grid_all_combinations))))) +# Reference = first storage type at its smallest storage_height (storage_height +# is coupled to storage_type, so both are fixed together). +ref_storage_type <- names(storage_type)[1] +ref_storage_height <- min(storage_type[[ref_storage_type]]$storage_height) + ref_scenario <- param_grid_all_combinations %>% dplyr::filter(connected_area == min(unique(param_grid_all_combinations$connected_area)), mulde_area == min(unique(param_grid_all_combinations$mulde_area)), @@ -143,7 +189,8 @@ ref_scenario <- param_grid_all_combinations %>% filter_hydraulicconductivity == min(param_grid_all_combinations$filter_hydraulicconductivity), bottom_hydraulicconductivity == min(unique(param_grid_all_combinations$bottom_hydraulicconductivity)), mulde_height == min(param_grid_all_combinations$mulde_height), - storage_height == min(param_grid_all_combinations$storage_height), + storage_type == ref_storage_type, + storage_height == ref_storage_height, lai == max(param_grid_all_combinations$lai)) %>% dplyr::pull(scenario_name) @@ -159,6 +206,20 @@ param_grid <- param_grid_all_combinations %>% dplyr::filter(scenario_name %in% scenarios_with_single_parameter_variation) param_grid <- param_grid_all_combinations +# Nutzbares Speichervolumen der Speicherschicht [m3] = Muldenflaeche x +# Speicherhoehe x nutzbare Porositaet (thetaS - thetaFC) des Speichertyps +# (Sickerbox 0.95, Schotterrigole 0.3). thetaFC statt thetaWP: nur das +# oberhalb der Feldkapazitaet entwaesserbare Porenvolumen leert sich zwischen +# den Ereignissen und steht als Retentionsvolumen erneut zur Verfuegung; +# Wasser zwischen WP und FC haelt die Schicht gegen die Schwerkraft (in den +# Presets sind thetaFC = thetaWP = 0, beide Definitionen also identisch). +# Erscheint in der Grid-Tabelle, den Ergebnis-CSVs und im Plot-Tooltip. +param_grid <- param_grid %>% + dplyr::mutate( + storage_volume_m3 = mulde_area * storage_height / 1000 * + (storage_thetaS - storage_thetaFC) + ) + DT::datatable(param_grid, filter = "top", options = list(pageLength = 25, @@ -315,9 +376,14 @@ run_one <- function(i, vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- param_grid_tmp$mulde_area vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- param_grid_tmp$mulde_height - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, 0) + vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, param_grid_tmp$storage_theta_start) vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, param_grid_tmp$storage_height) + # Speicher (2nd Bodenschichtung layer) soil parameters depend on the + # storage type (infiltration_box vs. gravel_trench); see `storage_type`. + vals$`//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` <- param_grid_tmp$storage_thetaWP + vals$`//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` <- param_grid_tmp$storage_thetaFC + vals$`//Bodenarten/Speicher/thetaS_MoistureAtSaturation` <- param_grid_tmp$storage_thetaS vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity @@ -424,6 +490,16 @@ htmlwidgets::saveWidget(DT::datatable(simulation_results_optimisation, ### Plot results +# Fuer Plots/Tooltips: die an storage_type gekoppelten Speicher-Bodenparameter +# (storage_theta*) sind durch den Typ bestimmt, also redundant - sie wuerden +# nur jeden Tooltip aufblaehen. Fuer den Modelllauf oben werden sie gebraucht, +# ab hier nicht mehr. storage_volume_m3 bekommt im Tooltip eine eigene Zeile +# (aus den Ergebnisdaten) und fliegt hier ebenfalls raus, sonst stuende es +# doppelt unter "Variierende Parameter". +param_grid <- param_grid %>% + dplyr::select(-dplyr::starts_with("storage_theta"), + -dplyr::any_of("storage_volume_m3")) + params <- c( #"connected_area", "mulde_area", @@ -433,7 +509,8 @@ params <- c( "storage_height", #"bottom_hydraulicconductivity", #"rain_factor", - "lai" + "lai", + "storage_type" ) lang <- "de" @@ -475,6 +552,7 @@ grDevices::pdf(pdff, width = 9, height = 4, onefile = TRUE) alpha_max = 1, drop_overflow_gt_valid_max = FALSE, keep_param_grid_limits = TRUE, + facet_storage_type = TRUE, lang = lang, subtitle = "" ) @@ -515,11 +593,15 @@ for (y in c("mulde_height", "filter_hydraulicconductivity", "storage_height")) { alpha_min = 0.25, alpha_max = 1, drop_overflow_gt_valid_max = FALSE, - keep_param_grid_limits = TRUE + keep_param_grid_limits = TRUE, + facet_storage_type = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; Farb-Legende je Ueberlaufklasse statt + # (Farbe, Form)-Tupeln - die Formen erklaeren die Panel-Beschriftungen. plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang, + add_shape_legend = FALSE) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_design-space_mulde-area_vs_%s.html", @@ -549,8 +631,10 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( use_jitter = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) + # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_water-balance.html", @@ -576,8 +660,10 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( use_jitter = TRUE ) -# interaktiv als HTML +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -595,7 +681,10 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen # (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen +# den Typ bereits benennen. cost_boxplots <- list( list(suffix = "cheapest", best_by = "min_cost", size_by = "overflow_volume", label_best = FALSE), @@ -617,6 +706,7 @@ for (cb in cost_boxplots) { filter_n_gtx = FALSE, use_jitter = TRUE, lang = lang, + facet_storage_type = TRUE, size_by = cb$size_by, best_by = cb$best_by, label_best = cb$label_best @@ -637,4 +727,77 @@ for (cb in cost_boxplots) { suppressWarnings(print(p)) dev.off() } + + +# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), +# Farbe die Anzahl Ueberlaufereignisse. +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_evaporation( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang +) + +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. evapotranspiration", + paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() + + +# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), +# Punktgroesse = Verdunstung. +pdff <- sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + y_var = "cost_per_evap_pct", + facet_storage_type = TRUE, + size_by = "evapotranspiration", + best_by = "min_cost", + label_best = TRUE +) + +# interaktiv als HTML +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost per %% evapotranspiration", paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() ``` \ No newline at end of file diff --git a/vignettes/workflow_eisenstadt-2005.Rmd b/vignettes/workflow_eisenstadt-2005.Rmd index 28526df..2b70676 100644 --- a/vignettes/workflow_eisenstadt-2005.Rmd +++ b/vignettes/workflow_eisenstadt-2005.Rmd @@ -98,11 +98,48 @@ mulde_area <- c(25, 50, 75, 100, 125, 150, 175, 200) mulde_height <- c(100, 200, 300) filter_hydraulicconductivity <- c(36, 180, 360) filter_height <- 300 -storage_height <- c(100, 500, 1000) +# Storage-layer (Speicher = 2nd Bodenschichtung layer) presets per storage type. +# Each type brings its own storage_height levels plus the Speicher soil +# parameters (theta*). They are written to the model in the run loop below: +# storage_height -> Schichtdicken[2] +# Startwerte_theta_ActualSoilMoisture -> Startwerte_theta_ActualSoilMoisture[2] +# thetaWP/thetaFC/thetaS -> //Bodenarten/Speicher/theta* +storage_type <- list( + "infiltration_box" = list( + storage_height = c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.95 + ), + "gravel_trench" = list( + storage_height = 3 * c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.3 + ) +) rain_factor <- 1 bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) +# storage_height is coupled to storage_type (each type has its own levels), so +# build one row per (storage_type, storage_height) carrying the matching +# Speicher soil parameters, then cross-join with all remaining combinations. +storage_grid <- do.call(rbind, lapply(names(storage_type), function(type_name) { + spec <- storage_type[[type_name]] + data.frame( + storage_type = type_name, + storage_height = spec$storage_height, + storage_theta_start = spec$Startwerte_theta_ActualSoilMoisture, + storage_thetaWP = spec$thetaWP_MoistureAtWiltingPoint, + storage_thetaFC = spec$thetaFC_MoistureAtFieldCapacity, + storage_thetaS = spec$thetaS_MoistureAtSaturation, + stringsAsFactors = FALSE + ) +})) + # Alle Kombinationen erzeugen param_grid_all_combinations <- expand.grid( connected_area = connected_area, @@ -110,11 +147,20 @@ param_grid_all_combinations <- expand.grid( mulde_height = mulde_height, filter_hydraulicconductivity = filter_hydraulicconductivity, filter_height = filter_height, - storage_height = storage_height, bottom_hydraulicconductivity = bottom_hydraulicconductivity, - rain_factor = rain_factor + rain_factor = rain_factor, + stringsAsFactors = FALSE ) +# Cross-join the free parameters with the coupled storage grid. +param_grid_all_combinations <- merge(param_grid_all_combinations, storage_grid, + by = NULL) + +# Reference = first storage type at its smallest storage_height (storage_height +# is coupled to storage_type, so both are fixed together). +ref_storage_type <- names(storage_type)[1] +ref_storage_height <- min(storage_type[[ref_storage_type]]$storage_height) + param_grid_all_combinations <- param_grid_all_combinations %>% dplyr::bind_cols(tibble::tibble(scenario_name = sprintf("s%05d", seq_len(nrow(param_grid_all_combinations))))) @@ -126,7 +172,8 @@ ref_scenario <- param_grid_all_combinations %>% filter_hydraulicconductivity == min(param_grid_all_combinations$filter_hydraulicconductivity), bottom_hydraulicconductivity == min(unique(param_grid_all_combinations$bottom_hydraulicconductivity)), mulde_height == min(param_grid_all_combinations$mulde_height), - storage_height == min(param_grid_all_combinations$storage_height)) %>% + storage_type == ref_storage_type, + storage_height == ref_storage_height) %>% dplyr::pull(scenario_name) stopifnot(length(ref_scenario)==1) @@ -141,6 +188,20 @@ scenarios_with_single_parameter_variation <- kwb.raindrop::find_single_param_var # dplyr::filter(scenario_name %in% scenarios_with_single_parameter_variation) param_grid <- param_grid_all_combinations +# Nutzbares Speichervolumen der Speicherschicht [m3] = Muldenflaeche x +# Speicherhoehe x nutzbare Porositaet (thetaS - thetaFC) des Speichertyps +# (Sickerbox 0.95, Schotterrigole 0.3). thetaFC statt thetaWP: nur das +# oberhalb der Feldkapazitaet entwaesserbare Porenvolumen leert sich zwischen +# den Ereignissen und steht als Retentionsvolumen erneut zur Verfuegung; +# Wasser zwischen WP und FC haelt die Schicht gegen die Schwerkraft (in den +# Presets sind thetaFC = thetaWP = 0, beide Definitionen also identisch). +# Erscheint in der Grid-Tabelle, den Ergebnis-CSVs und im Plot-Tooltip. +param_grid <- param_grid %>% + dplyr::mutate( + storage_volume_m3 = mulde_area * storage_height / 1000 * + (storage_thetaS - storage_thetaFC) + ) + DT::datatable(param_grid, filter = "top", options = list(pageLength = 25, @@ -206,9 +267,14 @@ run_one <- function(i, vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- param_grid_tmp$mulde_area vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- param_grid_tmp$mulde_height - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, 0) + vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, param_grid_tmp$storage_theta_start) vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, param_grid_tmp$storage_height) + # Speicher (2nd Bodenschichtung layer) soil parameters depend on the + # storage type (infiltration_box vs. gravel_trench); see `storage_type`. + vals$`//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` <- param_grid_tmp$storage_thetaWP + vals$`//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` <- param_grid_tmp$storage_thetaFC + vals$`//Bodenarten/Speicher/thetaS_MoistureAtSaturation` <- param_grid_tmp$storage_thetaS vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity # Pin LAI to the grass value from Hoernschemeyer et al. (Water 2023, # 15, 2840, Tab. 6, plant type 5 = grasses/herbs); base.h5 ships 8.5. @@ -317,15 +383,26 @@ htmlwidgets::saveWidget(DT::datatable(simulation_results_optimisation, ) ### Plot results +# Fuer Plots/Tooltips: die an storage_type gekoppelten Speicher-Bodenparameter +# (storage_theta*) sind durch den Typ bestimmt, also redundant - sie wuerden +# nur jeden Tooltip aufblaehen. Fuer den Modelllauf oben werden sie gebraucht, +# ab hier nicht mehr. storage_volume_m3 bekommt im Tooltip eine eigene Zeile +# (aus den Ergebnisdaten) und fliegt hier ebenfalls raus, sonst stuende es +# doppelt unter "Variierende Parameter". +param_grid <- param_grid %>% + dplyr::select(-dplyr::starts_with("storage_theta"), + -dplyr::any_of("storage_volume_m3")) + params <- c( #"connected_area", "mulde_area", "mulde_height", "filter_hydraulicconductivity", #"filter_height", - "storage_height" + "storage_height", #"bottom_hydraulicconductivity", - #"rain_factor" + #"rain_factor", + "storage_type" ) lang <- "de" @@ -367,6 +444,7 @@ grDevices::pdf(pdff, width = 9, height = 4, onefile = TRUE) alpha_max = 1, drop_overflow_gt_valid_max = FALSE, keep_param_grid_limits = TRUE, + facet_storage_type = TRUE, lang = lang, subtitle = "" ) @@ -407,11 +485,15 @@ for (y in c("mulde_height", "filter_hydraulicconductivity", "storage_height")) { alpha_min = 0.25, alpha_max = 1, drop_overflow_gt_valid_max = TRUE, - keep_param_grid_limits = TRUE + keep_param_grid_limits = TRUE, + facet_storage_type = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; Farb-Legende je Ueberlaufklasse statt + # (Farbe, Form)-Tupeln - die Formen erklaeren die Panel-Beschriftungen. plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang, + add_shape_legend = FALSE) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_design-space_mulde-area_vs_%s.html", @@ -441,8 +523,10 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( use_jitter = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) + # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_water-balance.html", @@ -469,8 +553,10 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( use_jitter = TRUE ) -# interaktiv als HTML +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -488,7 +574,10 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen # (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen +# den Typ bereits benennen. cost_boxplots <- list( list(suffix = "cheapest", best_by = "min_cost", size_by = "overflow_volume", label_best = FALSE), @@ -510,6 +599,7 @@ for (cb in cost_boxplots) { filter_n_gtx = FALSE, use_jitter = TRUE, lang = lang, + facet_storage_type = TRUE, size_by = cb$size_by, best_by = cb$best_by, label_best = cb$label_best @@ -531,4 +621,77 @@ for (cb in cost_boxplots) { dev.off() } + +# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), +# Farbe die Anzahl Ueberlaufereignisse. +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_evaporation( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang +) + +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. evapotranspiration", + paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() + + +# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), +# Punktgroesse = Verdunstung. +pdff <- sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + y_var = "cost_per_evap_pct", + facet_storage_type = TRUE, + size_by = "evapotranspiration", + best_by = "min_cost", + label_best = TRUE +) + +# interaktiv als HTML +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost per %% evapotranspiration", paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() + ``` \ No newline at end of file diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index 63ad501..c7a61fe 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -109,7 +109,28 @@ mulde_area <- c(25, 50, 75, 100, 125, 150, 175, 200) mulde_height <- c(100, 200, 300) filter_hydraulicconductivity <- c(36, 180, 360) filter_height <- 300 -storage_height <- c(100, 500, 1000) +# Storage-layer (Speicher = 2nd Bodenschichtung layer) presets per storage type. +# Each type brings its own storage_height levels plus the Speicher soil +# parameters (theta*). They are written to the model in the run loop below: +# storage_height -> Schichtdicken[2] +# Startwerte_theta_ActualSoilMoisture -> Startwerte_theta_ActualSoilMoisture[2] +# thetaWP/thetaFC/thetaS -> //Bodenarten/Speicher/theta* +storage_type <- list( + "infiltration_box" = list( + storage_height = c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.95 + ), + "gravel_trench" = list( + storage_height = 3 * c(300, 600, 900, 1200), + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.3 + ) +) rain_factor <- 1 bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) # LAI for Mulde_Rigole only (Dach kept at H5 default). @@ -119,6 +140,22 @@ bottom_hydraulicconductivity <- 12 #c(1,5,10,20,45,90,180,270,360,1860,3600) lai <- 3.9 +# storage_height is coupled to storage_type (each type has its own levels), so +# build one row per (storage_type, storage_height) carrying the matching +# Speicher soil parameters, then cross-join with all remaining combinations. +storage_grid <- do.call(rbind, lapply(names(storage_type), function(type_name) { + spec <- storage_type[[type_name]] + data.frame( + storage_type = type_name, + storage_height = spec$storage_height, + storage_theta_start = spec$Startwerte_theta_ActualSoilMoisture, + storage_thetaWP = spec$thetaWP_MoistureAtWiltingPoint, + storage_thetaFC = spec$thetaFC_MoistureAtFieldCapacity, + storage_thetaS = spec$thetaS_MoistureAtSaturation, + stringsAsFactors = FALSE + ) +})) + # Alle Kombinationen erzeugen param_grid_all_combinations <- expand.grid( connected_area = connected_area, @@ -126,16 +163,25 @@ param_grid_all_combinations <- expand.grid( mulde_height = mulde_height, filter_hydraulicconductivity = filter_hydraulicconductivity, filter_height = filter_height, - storage_height = storage_height, bottom_hydraulicconductivity = bottom_hydraulicconductivity, rain_factor = rain_factor, - lai = lai + lai = lai, + stringsAsFactors = FALSE ) +# Cross-join the free parameters with the coupled storage grid. +param_grid_all_combinations <- merge(param_grid_all_combinations, storage_grid, + by = NULL) + param_grid_all_combinations <- param_grid_all_combinations %>% dplyr::bind_cols(tibble::tibble(scenario_name = sprintf("s%05d", seq_len(nrow(param_grid_all_combinations))))) +# Reference = first storage type at its smallest storage_height (storage_height +# is coupled to storage_type, so both are fixed together). +ref_storage_type <- names(storage_type)[1] +ref_storage_height <- min(storage_type[[ref_storage_type]]$storage_height) + ref_scenario <- param_grid_all_combinations %>% dplyr::filter(connected_area == min(unique(param_grid_all_combinations$connected_area)), mulde_area == min(unique(param_grid_all_combinations$mulde_area)), @@ -143,7 +189,8 @@ ref_scenario <- param_grid_all_combinations %>% filter_hydraulicconductivity == min(param_grid_all_combinations$filter_hydraulicconductivity), bottom_hydraulicconductivity == min(unique(param_grid_all_combinations$bottom_hydraulicconductivity)), mulde_height == min(param_grid_all_combinations$mulde_height), - storage_height == min(param_grid_all_combinations$storage_height), + storage_type == ref_storage_type, + storage_height == ref_storage_height, lai == max(param_grid_all_combinations$lai)) %>% dplyr::pull(scenario_name) @@ -159,6 +206,20 @@ param_grid <- param_grid_all_combinations %>% dplyr::filter(scenario_name %in% scenarios_with_single_parameter_variation) param_grid <- param_grid_all_combinations +# Nutzbares Speichervolumen der Speicherschicht [m3] = Muldenflaeche x +# Speicherhoehe x nutzbare Porositaet (thetaS - thetaFC) des Speichertyps +# (Sickerbox 0.95, Schotterrigole 0.3). thetaFC statt thetaWP: nur das +# oberhalb der Feldkapazitaet entwaesserbare Porenvolumen leert sich zwischen +# den Ereignissen und steht als Retentionsvolumen erneut zur Verfuegung; +# Wasser zwischen WP und FC haelt die Schicht gegen die Schwerkraft (in den +# Presets sind thetaFC = thetaWP = 0, beide Definitionen also identisch). +# Erscheint in der Grid-Tabelle, den Ergebnis-CSVs und im Plot-Tooltip. +param_grid <- param_grid %>% + dplyr::mutate( + storage_volume_m3 = mulde_area * storage_height / 1000 * + (storage_thetaS - storage_thetaFC) + ) + DT::datatable(param_grid, filter = "top", options = list(pageLength = 25, @@ -312,9 +373,14 @@ run_one <- function(i, vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- param_grid_tmp$mulde_area vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- param_grid_tmp$mulde_height - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, 0) + vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- c(0.3, param_grid_tmp$storage_theta_start) vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- c(param_grid_tmp$filter_height, param_grid_tmp$storage_height) + # Speicher (2nd Bodenschichtung layer) soil parameters depend on the + # storage type (infiltration_box vs. gravel_trench); see `storage_type`. + vals$`//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` <- param_grid_tmp$storage_thetaWP + vals$`//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` <- param_grid_tmp$storage_thetaFC + vals$`//Bodenarten/Speicher/thetaS_MoistureAtSaturation` <- param_grid_tmp$storage_thetaS vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- param_grid_tmp$bottom_hydraulicconductivity vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- param_grid_tmp$filter_hydraulicconductivity @@ -420,6 +486,16 @@ htmlwidgets::saveWidget(DT::datatable(simulation_results_optimisation, ### Plot results +# Fuer Plots/Tooltips: die an storage_type gekoppelten Speicher-Bodenparameter +# (storage_theta*) sind durch den Typ bestimmt, also redundant - sie wuerden +# nur jeden Tooltip aufblaehen. Fuer den Modelllauf oben werden sie gebraucht, +# ab hier nicht mehr. storage_volume_m3 bekommt im Tooltip eine eigene Zeile +# (aus den Ergebnisdaten) und fliegt hier ebenfalls raus, sonst stuende es +# doppelt unter "Variierende Parameter". +param_grid <- param_grid %>% + dplyr::select(-dplyr::starts_with("storage_theta"), + -dplyr::any_of("storage_volume_m3")) + params <- c( #"connected_area", "mulde_area", @@ -429,7 +505,8 @@ params <- c( "storage_height", #"bottom_hydraulicconductivity", #"rain_factor", - "lai" + "lai", + "storage_type" ) lang <- "de" @@ -471,6 +548,7 @@ grDevices::pdf(pdff, width = 9, height = 4, onefile = TRUE) alpha_max = 1, drop_overflow_gt_valid_max = FALSE, keep_param_grid_limits = TRUE, + facet_storage_type = TRUE, lang = lang, subtitle = "" ) @@ -511,11 +589,15 @@ for (y in c("mulde_height", "filter_hydraulicconductivity", "storage_height")) { alpha_min = 0.25, alpha_max = 1, drop_overflow_gt_valid_max = FALSE, - keep_param_grid_limits = TRUE + keep_param_grid_limits = TRUE, + facet_storage_type = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; Farb-Legende je Ueberlaufklasse statt + # (Farbe, Form)-Tupeln - die Formen erklaeren die Panel-Beschriftungen. plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang, + add_shape_legend = FALSE) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_design-space_mulde-area_vs_%s.html", @@ -545,8 +627,10 @@ p <- kwb.raindrop::plot_wb_tradeoff_overflows( use_jitter = TRUE ) - # interaktiv als HTML + # interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) + # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_water-balance.html", @@ -573,8 +657,10 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( use_jitter = TRUE ) -# interaktiv als HTML +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -592,7 +678,10 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen # (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. +# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen +# den Typ bereits benennen. cost_boxplots <- list( list(suffix = "cheapest", best_by = "min_cost", size_by = "overflow_volume", label_best = FALSE), @@ -614,6 +703,7 @@ for (cb in cost_boxplots) { filter_n_gtx = FALSE, use_jitter = TRUE, lang = lang, + facet_storage_type = TRUE, size_by = cb$size_by, best_by = cb$best_by, label_best = cb$label_best @@ -635,4 +725,77 @@ for (cb in cost_boxplots) { dev.off() } + +# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), +# Farbe die Anzahl Ueberlaufereignisse. +pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_vs_evaporation( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang +) + +# interaktiv als HTML; getrennte Legenden (Ueberlaufklassen + Speichertyp) +# statt der (Farbe, Form)-Tupel von ggplotly +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost vs. evapotranspiration", + paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() + + +# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, +# Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), +# Punktgroesse = Verdunstung. +pdff <- sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", + paths$modelname) +kwb.utils::preparePdf(pdfFile = pdff) + +p <- kwb.raindrop::plot_cost_overflow_boxplot( + simulation_results_optimisation = simulation_results_optimisation, + param_grid = param_grid, + x = max_n_overflows, + filter_n_gtx = FALSE, + use_jitter = TRUE, + lang = lang, + y_var = "cost_per_evap_pct", + facet_storage_type = TRUE, + size_by = "evapotranspiration", + best_by = "min_cost", + label_best = TRUE +) + +# interaktiv als HTML +plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +htmlwidgets::saveWidget( + widget = plotly_p, + file = sprintf( + "simulation_results_optimisation_%s_cost-per-evap-boxplot.html", + paths$modelname), + selfcontained = TRUE, + title = sprintf("'%s' - Cost per %% evapotranspiration", paths$modelname) +) + +# statisch ins PDF (WICHTIG!) +suppressWarnings(print(p)) +dev.off() + ``` From e3df6689292fc2482423e96558aceffc957ee016 Mon Sep 17 00:00:00 2001 From: mrustl Date: Thu, 9 Jul 2026 17:31:31 +0100 Subject: [PATCH 12/34] Improve and complete "brute-force" results --- NAMESPACE | 2 + NEWS.md | 62 ++- R/compute_costs.R | 52 ++ R/cost_tooltip.R | 92 ++-- R/plot_cost_overflow_boxplot.R | 94 +++- R/plot_cost_vs_evaporation.R | 22 +- R/plot_cost_vs_overflow_volume.R | 24 +- R/plot_valid_design_space.R | 28 +- R/plot_wb_tradeoff_overflows.R | 22 +- R/plotly_split_legend.R | 104 +++- man/cost_rates_caption.Rd | 34 ++ man/plot_cost_overflow_boxplot.Rd | 24 +- man/plot_cost_vs_evaporation.Rd | 8 + man/plot_cost_vs_overflow_volume.Rd | 8 + man/plot_valid_design_space.Rd | 2 +- man/plotly_add_caption.Rd | 36 ++ man/plotly_split_legend.Rd | 6 +- vignettes/index.Rmd | 642 +++++++++++++------------ vignettes/workflow_badaussee.Rmd | 21 +- vignettes/workflow_eisenstadt-2005.Rmd | 19 +- vignettes/workflow_wien.Rmd | 21 +- 21 files changed, 900 insertions(+), 423 deletions(-) create mode 100644 man/cost_rates_caption.Rd create mode 100644 man/plotly_add_caption.Rd diff --git a/NAMESPACE b/NAMESPACE index d947f13..6e8323e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ export("%>%") export(add_overflow_events_and_waterbalance) export(compute_costs) +export(cost_rates_caption) export(default_canonical_wb_variables) export(default_cost_rates) export(default_param_labels) @@ -24,6 +25,7 @@ export(plot_hpond_vs_ref) export(plot_main_effects) export(plot_valid_design_space) export(plot_wb_tradeoff_overflows) +export(plotly_add_caption) export(plotly_split_legend) export(read_hdf5_connections) export(read_hdf5_scalars) diff --git a/NEWS.md b/NEWS.md index f100cc9..3f6bb77 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,11 +9,17 @@ storage type** (filled square = infiltration box / Sickerbox, filled triangle = gravel trench / Schotterrigol); identical tooltip. Rendered as `*_cost-vs-evaporation.html` in the three case-study vignettes and - linked from `vignettes/index.Rmd` under "Kosten vs. Verdunstung". + linked from `vignettes/index.Rmd` under "Kosten vs. Evapotranspiration". * `plot_cost_overflow_boxplot()` gains `y_var = "cost_per_evap_pct"` - (y-axis = total cost per percentage point of evapotranspiration, - EUR/%; titles, y-label and the `min_cost` objective/label follow) and + (y-axis = total cost per percentage point of evapotranspiration + **above the reference minimum** — the lowest evapotranspiration among + the scenarios satisfying the validity criterion (`n_overflows <= x`; + fallback: complete run) —, EUR/%; the reference (minimum share, + criterion and scenario id) is named on a second title line, and + `label_best = TRUE` annotates the evapotranspiration gain + `"(+NN % Evapotranspiration)"` after the price; titles, y-label + and the `min_cost` objective/label follow) and `facet_storage_type = TRUE` (two stacked storage-type panels — infiltration box on top, gravel trench below — each with its own best-per-box markers and frontier line; `plotly::ggplotly()` keeps @@ -24,25 +30,33 @@ the three existing boxplot variants with storage-type panels plus the new `*_cost-per-evap-boxplot.html` (cheapest EUR/% per class, point size = evapotranspiration), linked from `vignettes/index.Rmd` - under "Boxplot – Kosten je Prozent Verdunstung". + under "Boxplot – Kosten je Prozent Evapotranspiration". * `plot_cost_vs_overflow_volume()` points are now also **shaped by the storage type** (square/triangle, own legend under the colour legend). -* The shared cost tooltip gains a derived **"Kosten je % Verdunstung - [€/%]"** line (total cost per percentage point of element - evapotranspiration, "-" when evapotranspiration is 0) right below the - total cost — shown consistently in both cost scatters and all cost - boxplot variants. +* The shared cost tooltip gains a derived **"Kosten je % Evapotranspiration + (über Min. von X %) [€/%]"** line right below the total cost: the + total cost per percentage point of element evapotranspiration + **above the reference minimum** (the lowest evapotranspiration among + the scenarios satisfying the validity criterion `n_overflows <= x`; + fallback: complete run) — the baseline comes "for free", only the + gain is paid for. The reference value is named in the line; "-" at or + below the minimum. Shown consistently in both cost scatters and all + cost boxplot variants. German labels consistently say + **"Evapotranspiration"** instead of "Verdunstung" throughout. * New **usable storage volume** of the storage layer: `storage_volume_m3 = mulde_area * storage_height/1000 * (thetaS - thetaFC)` (usable porosity 0.95 infiltration box / 0.3 gravel trench). The vignettes add the column to the parameter grid - (grid datatable + results CSV) and the shared cost tooltip shows it - as "Nutzbares Speichervolumen [m³]" right below the storage type - (computed on the fly from the `storage_theta*` columns for existing - result sets without the column). In the "Variierende Parameter" block the raw + (grid datatable + results CSV) and the tooltips of **all** scenario + plots show it as "Nutzbares Speichervolumen [m³]" — the cost scatters + and boxplots (right below the storage type), the water-balance + trade-off plot and the design-space plots (there sourced from + `sim_results`, since the plotting grid drops the helper columns) — + computed on the fly from the `storage_theta*` columns for existing + result sets without the column. In the "Variierende Parameter" block the raw storage_type values are now translated too (`Speichertyp=Schotterrigol` instead of `=gravel_trench`; shared value labels with the `plot_main_effects()` storage-type panel). @@ -52,6 +66,21 @@ square/triangle instead of the default circle; the faceted variants use circular points and matching circular keys. +* Storage-type names in legends and facet strips are now the **short, + language-specific** ones ("Sickerbox" / "Schotterrigol" for `lang = + "de"`, "Infiltration box" / "Gravel trench" for `"en"`); only the + bold tooltip line keeps the long bilingual form. + +* All cost plots now carry a **caption naming the unit-cost rates** + they were computed with (new exported `cost_rates_caption()`, built + from [`default_cost_rates()`]: Aushub 70 €/m³ · Profilierung + + Begrünung 10 €/m² · Bodenfilter 200 €/m³ · Sickerbox 350 €/m³ · + Schotterrigol 50 €/m³, incl. installation). ggplot renders it at the + bottom of the PDFs (`caption` argument, `""` to drop); since + `plotly::ggplotly()` drops captions, the new exported + `plotly_add_caption()` re-adds it as a bottom annotation in the + interactive HTMLs (wired up in all three vignettes). + * New exported helper `plotly_split_legend()` — cleans up the interactive legends: `plotly::ggplotly()` flattens colour + shape into unreadable `"(0,Sickerbox / Infiltration box)"` tuple entries. @@ -62,7 +91,10 @@ "Speichertyp" / "Storage type" group title (skippable via `add_shape_legend = FALSE` for faceted plots) — a coloured square/triangle key would wrongly suggest one specific - (colour, type) combination. The overlapping combined legend title is + (colour, type) combination. The storage-type keys are **individually + clickable** (a JavaScript handler toggles all traces with that marker + symbol, since the traces' only legend group is taken by the overflow + class); the overlapping combined legend title is removed and the legend moves to a vertical layout on the right. Applied in all three vignettes to the cost-vs-overflow, cost-vs-evaporation, water-balance and design-space HTMLs. @@ -250,7 +282,7 @@ * New vignette `example_wien_minimal`: a self-contained smoke test of the full input → engine → results loop on Wien. Now extended into an ET-diagnostics grid that sweeps three engine switches — - `keineVerdunstungBeiRegen`, `Hoernschemeyer_aktiv` and the + `keineEvapotranspirationBeiRegen`, `Hoernschemeyer_aktiv` and the `ET0ref_GrasReferenzverdunstung` factor (`0`, `1`, `100`) — at Daniel's reference geometry (12 scenarios total). Daniel's three XLSX-review corrections (`Dach/Evapotranspiration_aktiv = 0`, diff --git a/R/compute_costs.R b/R/compute_costs.R index 75d810b..6651673 100644 --- a/R/compute_costs.R +++ b/R/compute_costs.R @@ -27,6 +27,58 @@ default_cost_rates <- function() { ) } +#' Caption line naming the unit-cost rates behind the cost plots +#' +#' Formats the unit-cost rates (EUR per m2 / m3, see [default_cost_rates()]) +#' as a single-line caption for the cost plots, so every figure names the +#' rates its EUR values were computed with. Used as the default `caption` of +#' [plot_cost_vs_overflow_volume()], [plot_cost_vs_evaporation()] and +#' [plot_cost_overflow_boxplot()] (rendered by ggplot at the bottom of the +#' PDFs) and passed to [plotly_add_caption()] for the interactive HTMLs +#' (`plotly::ggplotly()` drops ggplot captions). +#' +#' If the costs were computed with non-default rates, pass the same +#' `cost_rates` list here so the caption matches the numbers. +#' +#' @param lang Character. `"de"` or `"en"`. +#' @param cost_rates `list` of unit costs as returned by +#' [default_cost_rates()]. +#' +#' @return `character(1)`, a single line. +#' +#' @examples +#' cost_rates_caption("de") +#' +#' @export +cost_rates_caption <- function(lang = c("de", "en"), + cost_rates = default_cost_rates()) { + lang <- match.arg(lang) + f <- function(v) format(v, trim = TRUE, big.mark = " ", scientific = FALSE) + switch( + lang, + de = paste0( + "Kostens\u00e4tze (inkl. Einbau): Aushub ", + f(cost_rates$excavation_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "Profilierung + Begr\u00fcnung ", + f(cost_rates$profiling_eur_per_m2), " \u20ac/m\u00b2 \u00b7 ", + "Bodenfilter ", f(cost_rates$filter_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "Sickerbox ", + f(cost_rates$infiltration_box_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "Schotterrigol ", f(cost_rates$gravel_trench_eur_per_m3), " \u20ac/m\u00b3" + ), + en = paste0( + "Cost rates (incl. installation): excavation ", + f(cost_rates$excavation_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "profiling + greening ", + f(cost_rates$profiling_eur_per_m2), " \u20ac/m\u00b2 \u00b7 ", + "soil filter ", f(cost_rates$filter_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "infiltration box ", + f(cost_rates$infiltration_box_eur_per_m3), " \u20ac/m\u00b3 \u00b7 ", + "gravel trench ", f(cost_rates$gravel_trench_eur_per_m3), " \u20ac/m\u00b3" + ) + ) +} + #' Compute construction costs for an infiltration-swale parameter grid #' #' Given a parameter grid that drives the simulation, attach a per-scenario diff --git a/R/cost_tooltip.R b/R/cost_tooltip.R index f267b99..cb492ec 100644 --- a/R/cost_tooltip.R +++ b/R/cost_tooltip.R @@ -177,11 +177,12 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { tt_sum_overflows_mm = "Summe \u00dcberl\u00e4ufe [mm]", tt_overflow_volume = "\u00dcberlaufvolumen [m\u00b3]", tt_wb_header = "Wasserhaushalt [%]", - tt_wb_evap = "Verdunstung", + tt_wb_evap = "Evapotranspiration", tt_wb_infil = "Versickerung", tt_wb_overflow = "\u00dcberlauf", tt_cost_total = "Gesamtkosten", - tt_cost_per_evap = "Kosten je % Verdunstung [\u20ac/%]", + tt_cost_per_evap = "Kosten je % Evapotranspiration", + tt_above_min = "\u00fcber Min. von", tt_cost_excavation = "Aushub", tt_cost_profiling = "Profilierung + Begr\u00fcnung", tt_cost_filter = "Bodenfilter", @@ -203,7 +204,8 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { tt_wb_infil = "Infiltration", tt_wb_overflow = "Overflow", tt_cost_total = "Total cost", - tt_cost_per_evap = "Cost per % evapotranspiration [\u20ac/%]", + tt_cost_per_evap = "Cost per % evapotranspiration", + tt_above_min = "above min. of", tt_cost_excavation = "Excavation", tt_cost_profiling = "Profiling + greening", tt_cost_filter = "Soil filter", @@ -220,29 +222,56 @@ cost_tooltip_labels <- function(lang = c("de", "en")) { #' Storage-type display factor and marker shapes for the cost plots #' -#' Maps the raw `storage_type` values to their bilingual display names (from -#' `cost_tooltip_labels()`) and to the fixed marker shapes shared by all cost -#' plots: **filled square (15) = infiltration box (Sickerbox)**, **filled -#' triangle (17) = gravel trench (Schotterrigol)**. Values that are `NA` or -#' unknown fall back to the infiltration box, mirroring `cost_tooltip_text()`. +#' Maps the raw `storage_type` values to their **short, language-specific** +#' display names (from `storage_type_value_labels()`; e.g. "Sickerbox" / +#' "Schotterrigol" for `lang = "de"`) and to the fixed marker shapes shared +#' by all cost plots: **filled square (15) = infiltration box**, **filled +#' triangle (17) = gravel trench**. Used for legends and facet strips; the +#' tooltip's bold storage-type line keeps the longer bilingual names from +#' `cost_tooltip_labels()`. Values that are `NA` or unknown fall back to the +#' infiltration box, mirroring `cost_tooltip_text()`. #' #' @param storage_type Character vector of raw values #' (`"infiltration_box"` / `"gravel_trench"`). -#' @param tt Label list from `cost_tooltip_labels()`. +#' @param lang Character. `"de"` or `"en"`. #' @return List with `display` (factor, infiltration box level first) and #' `shape_values` (named vector for `ggplot2::scale_shape_manual()`). #' @noRd -storage_type_shapes <- function(storage_type, tt) { +storage_type_shapes <- function(storage_type, lang = c("de", "en")) { + lang <- match.arg(lang) + labels <- storage_type_value_labels(lang) raw <- as.character(storage_type) disp <- ifelse(!is.na(raw) & raw == "gravel_trench", - tt$st_gravel_trench, tt$st_infiltration_box) - lvls <- c(tt$st_infiltration_box, tt$st_gravel_trench) + labels[["gravel_trench"]], labels[["infiltration_box"]]) + lvls <- unname(labels[c("infiltration_box", "gravel_trench")]) list( display = factor(disp, levels = lvls), shape_values = stats::setNames(c(15, 17), lvls) ) } +#' Usable storage volume of the storage layer [m3] per row +#' +#' Area x height x usable porosity (thetaS - thetaFC) of the storage type. +#' Taken from a precomputed `storage_volume_m3` column when available, +#' otherwise derived from the `storage_theta*` columns; `NULL` when neither +#' is present (old result sets), so callers can omit their tooltip line. +#' +#' @param df Data frame (results or parameter grid). +#' @return Numeric vector or `NULL`. +#' @noRd +storage_volume_from_df <- function(df) { + if ("storage_volume_m3" %in% names(df)) { + df$storage_volume_m3 + } else if (all(c("mulde_area", "storage_height", "storage_thetaS", + "storage_thetaFC") %in% names(df))) { + df$mulde_area * df$storage_height / 1000 * + (df$storage_thetaS - df$storage_thetaFC) + } else { + NULL + } +} + #' Assemble the shared cost-plot tooltip HTML for each row of `df` #' #' `df` must carry `scenario_name`, `n_overflows`, `sum_overflows`, @@ -253,9 +282,13 @@ storage_type_shapes <- function(storage_type, tt) { #' @param df Data frame with the columns listed above. #' @param tt Label list from `cost_tooltip_labels()`. #' @param digits Integer. Rounding for the numeric tooltip values. +#' @param evap_min Numeric. Minimum element evapotranspiration share [%] of +#' the complete model run — the reference for the cost-per-percent line. +#' `NULL` falls back to the minimum within `df` (identical as long as `df` +#' is unfiltered). #' @return Character vector, length `nrow(df)`. #' @noRd -cost_tooltip_text <- function(df, tt, digits = 2L) { +cost_tooltip_text <- function(df, tt, digits = 2L, evap_min = NULL) { st_raw <- if ("storage_type" %in% names(df)) { as.character(df$storage_type) } else { @@ -264,26 +297,25 @@ cost_tooltip_text <- function(df, tt, digits = 2L) { st_disp <- ifelse(!is.na(st_raw) & st_raw == "gravel_trench", tt$st_gravel_trench, tt$st_infiltration_box) # Derived cost efficiency: total cost per percentage point of element - # evapotranspiration [EUR/%]; undefined ("-") when evapotranspiration is 0. + # evapotranspiration ABOVE the run minimum [EUR/%] -- the baseline + # evapotranspiration comes "for free", only the gain beyond the worst + # scenario is paid for. Undefined ("-") at or below the minimum (the + # minimum scenario itself has no defined marginal cost). evap <- df[["element.WB_Evapotranspiration_"]] - cpe <- ifelse(!is.na(df$cost_total) & !is.na(evap) & evap > 0, - df$cost_total / evap, NA_real_) + if (is.null(evap_min)) { + evap_min <- suppressWarnings(min(evap, na.rm = TRUE)) + } + evap_delta <- evap - evap_min + cpe <- ifelse(!is.na(df$cost_total) & !is.na(evap_delta) & evap_delta > 0, + df$cost_total / evap_delta, NA_real_) cpe_fmt <- vapply(cpe, function(v) { if (is.na(v)) "-" else format(round(v, 0), big.mark = " ", trim = TRUE) }, character(1)) - # Usable storage volume of the storage layer [m3]: area x height x usable - # porosity (thetaS - thetaFC) of the storage type. Taken from a precomputed - # storage_volume_m3 column when available, otherwise derived from the theta - # columns; the line is omitted for result sets carrying neither. - storage_volume <- if ("storage_volume_m3" %in% names(df)) { - df$storage_volume_m3 - } else if (all(c("mulde_area", "storage_height", "storage_thetaS", - "storage_thetaFC") %in% names(df))) { - df$mulde_area * df$storage_height / 1000 * - (df$storage_thetaS - df$storage_thetaFC) - } else { - NULL - } + cpe_label <- paste0(tt$tt_cost_per_evap, " (", tt$tt_above_min, " ", + round(evap_min, digits), " %) [\u20ac/%]") + # Usable storage volume line; omitted for result sets where it is not + # derivable (see storage_volume_from_df()). + storage_volume <- storage_volume_from_df(df) storage_volume_line <- if (is.null(storage_volume)) { "" } else { @@ -314,7 +346,7 @@ cost_tooltip_text <- function(df, tt, digits = 2L) { format(round(df$cost_storage, 0), big.mark = " ", trim = TRUE), "
", tt$tt_cost_total, ": ", format(round(df$cost_total, 0), big.mark = " ", trim = TRUE), "", - "
", tt$tt_cost_per_evap, ": ", cpe_fmt, + "
", cpe_label, ": ", cpe_fmt, "

", tt$tt_params, "
", df$params_html ) } diff --git a/R/plot_cost_overflow_boxplot.R b/R/plot_cost_overflow_boxplot.R index 87bc9a8..99305b4 100644 --- a/R/plot_cost_overflow_boxplot.R +++ b/R/plot_cost_overflow_boxplot.R @@ -72,11 +72,17 @@ #' @param y_var Character. Which cost measure the y-axis (boxes, points, best #' markers, frontier) shows: `"cost_total"` (default; total construction #' cost, EUR) or `"cost_per_evap_pct"` (total cost divided by the element -#' evapotranspiration share, EUR per percentage point -- the cost -#' efficiency of evapotranspiration). Scenarios with zero -#' evapotranspiration have no defined ratio and are dropped from the -#' `"cost_per_evap_pct"` variant. Titles and the y-axis label switch -#' accordingly. +#' evapotranspiration share **above the reference minimum**, EUR per +#' percentage point -- the marginal cost efficiency of evapotranspiration; +#' the baseline comes "for free"). The reference is the **lowest +#' evapotranspiration among the scenarios that satisfy the validity +#' criterion** (`n_overflows <= x`; fallback: the complete run when none +#' does) and is named -- share, criterion and scenario id -- on a second +#' title line. Scenarios at or below the reference (including the reference +#' scenario itself) have no defined marginal cost and are dropped from the +#' `"cost_per_evap_pct"` variant; `label_best = TRUE` additionally +#' annotates the evapotranspiration gain (`"(+NN % Evapotranspiration)"`) +#' after the price. Titles and the y-axis label switch accordingly. #' @param facet_storage_type Logical. If `TRUE`, the plot is split by #' `storage_type` into two stacked panels (infiltration box on top, gravel #' trench below, via `ggplot2::facet_grid()`), each with its own boxes, @@ -137,6 +143,7 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, lab_size = NULL, mark_best = TRUE, connect_best = TRUE, @@ -161,12 +168,12 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, y = "Gesamtkosten [\u20ac]", title_cheapest = "Kosten je \u00dcberlaufanzahl \u2014 g\u00fcnstigste je Kategorie", title_min_overflow = "Kosten je \u00dcberlaufanzahl \u2014 geringstes \u00dcberlaufvolumen je Kategorie", - title_max_evap = "Kosten je \u00dcberlaufanzahl \u2014 h\u00f6chste Verdunstung je Kategorie", + title_max_evap = "Kosten je \u00dcberlaufanzahl \u2014 h\u00f6chste Evapotranspiration je Kategorie", size_volume = "\u00dcberlaufvolumen [m\u00b3]", - size_evap = "Verdunstung [%]", + size_evap = "Evapotranspiration [%]", best_cheapest = "G\u00fcnstigste L\u00f6sung", best_min_overflow = "Geringstes \u00dcberlaufvolumen", - best_max_evap = "H\u00f6chste Verdunstung" + best_max_evap = "H\u00f6chste Evapotranspiration" ), en = list( x = "Number of overflow events", @@ -189,10 +196,10 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, y_col <- if (y_var == "cost_per_evap_pct") "cost_per_evap_pct" else "cost_total" if (y_var == "cost_per_evap_pct") { txt$y <- switch(lang, - de = "Kosten je Prozent Verdunstung [\u20ac/%]", - en = "Cost per percent evapotranspiration [\u20ac/%]") + de = "Kosten je Prozent Evapotranspiration \u00fcber Minimum [\u20ac/%]", + en = "Cost per percent evapotranspiration above minimum [\u20ac/%]") evap_prefix <- switch(lang, - de = "Kosten je % Verdunstung", + de = "Kosten je % Evapotranspiration", en = "Cost per % evapotranspiration") txt$title_cheapest <- paste0(evap_prefix, switch(lang, de = " \u2014 g\u00fcnstigste je Kategorie", @@ -201,7 +208,7 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, de = " \u2014 geringstes \u00dcberlaufvolumen je Kategorie", en = " \u2014 lowest overflow volume per class")) txt$title_max_evap <- paste0(evap_prefix, switch(lang, - de = " \u2014 h\u00f6chste Verdunstung je Kategorie", + de = " \u2014 h\u00f6chste Evapotranspiration je Kategorie", en = " \u2014 highest evapotranspiration per class")) } @@ -248,6 +255,19 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, " for discrete axis/palette.") } + # Reference for the cost-per-percent-evapotranspiration measure: the + # minimum evapotranspiration among the scenarios that SATISFY the validity + # criterion (n_overflows <= x); computed before any filtering, falls back + # to the complete run when no scenario is valid. The matching scenario id + # is named in the title. + evap_all <- simulation_results_optimisation[["element.WB_Evapotranspiration_"]] + valid_mask <- !is.na(simulation_results_optimisation$n_overflows) & + simulation_results_optimisation$n_overflows <= x_int & !is.na(evap_all) + ref_idx <- if (any(valid_mask)) which(valid_mask) else seq_along(evap_all) + evap_min <- suppressWarnings(min(evap_all[ref_idx], na.rm = TRUE)) + evap_min_scenario <- simulation_results_optimisation$scenario_name[ + ref_idx[which.min(evap_all[ref_idx])]] + # Share of scenarios meeting the validity criterion (n_overflows <= x), # appended to the auto-generated title (a plotly-safe place -- ggplotly # drops ggplot subtitles). @@ -256,7 +276,22 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, share_txt <- switch(lang, de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), en = paste0(valid_pct, " % with <= ", x_int, " overflows")) - if (is.null(title)) title <- paste0(def_title, " (", share_txt, ")") + if (is.null(title)) { + title <- paste0(def_title, " (", share_txt, ")") + if (y_var == "cost_per_evap_pct") { + # name the reference of the marginal measure in the title + title <- paste0(title, "\n", switch(lang, + de = paste0("Referenz: minimale Evapotranspiration der g\u00fcltigen ", + "Szenarien (<= ", x_int, " \u00dcberl\u00e4ufe): ", + round(evap_min, 1), " % (Szenario ", + evap_min_scenario, ")"), + en = paste0("Reference: minimum evapotranspiration of the valid ", + "scenarios (<= ", x_int, " overflows): ", + round(evap_min, 1), " % (scenario ", + evap_min_scenario, ")"))) + } + } + if (is.null(caption)) caption <- cost_rates_caption(lang) param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, digits_params) @@ -284,14 +319,18 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, overflow_cat = factor(.data$overflow_cat, levels = levs) ) - # Cost per percentage point of evapotranspiration [EUR/%]. Scenarios with - # zero evapotranspiration have no defined ratio and are dropped from the - # cost_per_evap_pct variant (the active y column must not be NA). + # Cost per percentage point of evapotranspiration ABOVE the run minimum + # [EUR/%]: the baseline evapotranspiration comes "for free", only the gain + # beyond the worst scenario is paid for. Scenarios at the minimum (incl. + # the reference scenario itself) have no defined marginal cost and are + # dropped from the cost_per_evap_pct variant (the active y column must not + # be NA). df <- df %>% dplyr::mutate( cost_per_evap_pct = dplyr::if_else( - .data[["element.WB_Evapotranspiration_"]] > 0, - .data$cost_total / .data[["element.WB_Evapotranspiration_"]], + .data[["element.WB_Evapotranspiration_"]] - evap_min > 0, + .data$cost_total / + (.data[["element.WB_Evapotranspiration_"]] - evap_min), NA_real_ ) ) %>% @@ -299,10 +338,10 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, # Storage type: display factor for the facet strips and the point shapes # (filled square = infiltration box, filled triangle = gravel trench). - st <- storage_type_shapes(df$storage_type, txt) + st <- storage_type_shapes(df$storage_type, lang) df$storage_type_disp <- st$display - df$tooltip_html <- cost_tooltip_text(df, txt, digits) + df$tooltip_html <- cost_tooltip_text(df, txt, digits, evap_min = evap_min) # Point size: calibrate the scale to the valid region (0..x) and cap the # extreme ">x" values, otherwise the many-overflow outliers (overflow @@ -361,7 +400,17 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, trim = TRUE), " %"), min_cost = paste0( format(round(best[[y_col]], 0), big.mark = " ", trim = TRUE), - if (y_var == "cost_per_evap_pct") " \u20ac/%" else " \u20ac") + if (y_var == "cost_per_evap_pct") { + # ... and the evapotranspiration gain over the reference minimum + # that this price buys + paste0(" \u20ac/% (+", + format(round(best[["element.WB_Evapotranspiration_"]] - + evap_min, 1), trim = TRUE), + " % ", switch(lang, de = "Evapotranspiration", + en = "evapotranspiration"), ")") + } else { + " \u20ac" + }) ) } @@ -423,7 +472,8 @@ plot_cost_overflow_boxplot <- function(simulation_results_optimisation, ggplot2::scale_color_manual(values = pal, limits = levs, drop = FALSE, guide = "none") + ggplot2::scale_x_discrete(drop = FALSE) + - ggplot2::labs(title = title, x = lab_x, y = lab_y) + + ggplot2::labs(title = title, x = lab_x, y = lab_y, + caption = if (nzchar(caption)) caption else NULL) + ggplot2::theme_bw() + ggplot2::theme( legend.position = legend_position, diff --git a/R/plot_cost_vs_evaporation.R b/R/plot_cost_vs_evaporation.R index 0c28854..3e70d9a 100644 --- a/R/plot_cost_vs_evaporation.R +++ b/R/plot_cost_vs_evaporation.R @@ -54,6 +54,7 @@ plot_cost_vs_evaporation <- function(simulation_results_optimisation, title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, legend_position = "top") { lang <- match.arg(lang) @@ -62,9 +63,9 @@ plot_cost_vs_evaporation <- function(simulation_results_optimisation, txt <- switch( lang, de = list( - title = "Kosten vs. Verdunstung", + title = "Kosten vs. Evapotranspiration", x = "Gesamtkosten [\u20ac]", - y = "Verdunstung [%]", + y = "Evapotranspiration [%]", legend = "Anzahl \u00dcberlaufereignisse" ), en = list( @@ -118,6 +119,7 @@ plot_cost_vs_evaporation <- function(simulation_results_optimisation, de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), en = paste0(valid_pct, " % with <= ", x_int, " overflows")) if (is.null(title)) title <- paste0(txt$title, " (", share_txt, ")") + if (is.null(caption)) caption <- cost_rates_caption(lang) param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, digits_params) @@ -151,10 +153,19 @@ plot_cost_vs_evaporation <- function(simulation_results_optimisation, # Storage type drives the marker shape (square = infiltration box, # triangle = gravel trench); shared with the sibling cost plots. - st <- storage_type_shapes(df$storage_type, txt) + st <- storage_type_shapes(df$storage_type, lang) df$storage_type_disp <- st$display - df$tooltip_html <- cost_tooltip_text(df, txt, digits) + # Reference for the tooltip's cost-per-percent-evapotranspiration line: + # minimum evapotranspiration among the scenarios that satisfy the validity + # criterion (n_overflows <= x); computed before any filtering, falls back + # to the complete run when no scenario is valid. + evap_all <- simulation_results_optimisation[["element.WB_Evapotranspiration_"]] + valid_mask <- !is.na(simulation_results_optimisation$n_overflows) & + simulation_results_optimisation$n_overflows <= x_int & !is.na(evap_all) + evap_min <- suppressWarnings(min( + if (any(valid_mask)) evap_all[valid_mask] else evap_all, na.rm = TRUE)) + df$tooltip_html <- cost_tooltip_text(df, txt, digits, evap_min = evap_min) if (x_int == 0L) { pal <- c("0" = "orange", ">0" = "red") @@ -227,7 +238,8 @@ plot_cost_vs_evaporation <- function(simulation_results_optimisation, ggplot2::labs( title = title, x = lab_x, - y = lab_y + y = lab_y, + caption = if (nzchar(caption)) caption else NULL ) + ggplot2::theme_bw() + ggplot2::theme( diff --git a/R/plot_cost_vs_overflow_volume.R b/R/plot_cost_vs_overflow_volume.R index 8913d99..97dd2c2 100644 --- a/R/plot_cost_vs_overflow_volume.R +++ b/R/plot_cost_vs_overflow_volume.R @@ -52,6 +52,12 @@ #' to tooltip labels, or `NULL` to use [default_param_labels()] for `lang`. #' @param title,lab_x,lab_y Optional character overrides for the default #' language-specific title / axis labels. +#' @param caption Character or `NULL`. Caption below the plot naming the +#' unit-cost rates the EUR values were computed with. `NULL` (default) +#' uses [cost_rates_caption()] with the [default_cost_rates()]; pass your +#' own string if the costs were computed with different rates, or `""` to +#' drop the caption. Note that `plotly::ggplotly()` drops ggplot captions +#' -- re-add it to the interactive version via [plotly_add_caption()]. #' @param legend_position Character. Legend position, default `"top"`. #' #' @return A `ggplot` object. Convert to interactive via @@ -82,6 +88,7 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, legend_position = "top") { lang <- match.arg(lang) @@ -146,6 +153,7 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, de = paste0(valid_pct, " % mit <= ", x_int, " \u00dcberl\u00e4ufen"), en = paste0(valid_pct, " % with <= ", x_int, " overflows")) if (is.null(title)) title <- paste0(txt$title, " (", share_txt, ")") + if (is.null(caption)) caption <- cost_rates_caption(lang) param_tooltip <- build_varying_param_html(param_grid, lang, param_labels, digits_params) @@ -179,10 +187,19 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, # Storage type drives the marker shape (filled square = infiltration box, # filled triangle = gravel trench); shared with the sibling cost plots. - st <- storage_type_shapes(df$storage_type, txt) + st <- storage_type_shapes(df$storage_type, lang) df$storage_type_disp <- st$display - df$tooltip_html <- cost_tooltip_text(df, txt, digits) + # Reference for the tooltip's cost-per-percent-evapotranspiration line: + # minimum evapotranspiration among the scenarios that satisfy the validity + # criterion (n_overflows <= x); computed before any filtering, falls back + # to the complete run when no scenario is valid. + evap_all <- simulation_results_optimisation[["element.WB_Evapotranspiration_"]] + valid_mask <- !is.na(simulation_results_optimisation$n_overflows) & + simulation_results_optimisation$n_overflows <= x_int & !is.na(evap_all) + evap_min <- suppressWarnings(min( + if (any(valid_mask)) evap_all[valid_mask] else evap_all, na.rm = TRUE)) + df$tooltip_html <- cost_tooltip_text(df, txt, digits, evap_min = evap_min) if (x_int == 0L) { pal <- c("0" = "orange", ">0" = "red") @@ -255,7 +272,8 @@ plot_cost_vs_overflow_volume <- function(simulation_results_optimisation, ggplot2::labs( title = title, x = lab_x, - y = lab_y + y = lab_y, + caption = if (nzchar(caption)) caption else NULL ) + ggplot2::theme_bw() + ggplot2::theme( diff --git a/R/plot_valid_design_space.R b/R/plot_valid_design_space.R index 14d4db3..849074b 100644 --- a/R/plot_valid_design_space.R +++ b/R/plot_valid_design_space.R @@ -219,9 +219,19 @@ plot_valid_design_space <- function(param_grid, keep_pg <- unique(c(id_col, x, y, varied_params, if (isTRUE(facet_storage_type)) "storage_type")) + + # Usable storage volume [m3] for the tooltip, taken from the results side + # (precomputed storage_volume_m3 column or derived from the storage_theta* + # columns there) unless param_grid already carries the column itself. + sim_sel <- dplyr::select(sim_results, dplyr::all_of(c(id_col, overflow_col))) + if (!"storage_volume_m3" %in% keep_pg) { + sim_volume <- storage_volume_from_df(sim_results) + if (!is.null(sim_volume)) sim_sel$storage_volume_m3 <- sim_volume + } + d <- dplyr::left_join( dplyr::select(param_grid, dplyr::all_of(keep_pg)), - dplyr::select(sim_results, dplyr::all_of(c(id_col, overflow_col))), + sim_sel, by = id_col ) @@ -238,10 +248,10 @@ plot_valid_design_space <- function(param_grid, # gravel trench, as in the cost plots): active whenever storage_type is one # of the varied parameters -- except in the faceted layout, where the strips # already name the type and the points stay plain circles for readability. + st_labels <- cost_tooltip_labels(lang) has_storage_type <- "storage_type" %in% names(d) if (has_storage_type) { - st_labels <- cost_tooltip_labels(lang) - st <- storage_type_shapes(d$storage_type, st_labels) + st <- storage_type_shapes(d$storage_type, lang) d$storage_type_disp <- st$display } use_shapes <- has_storage_type && !isTRUE(facet_storage_type) @@ -253,7 +263,9 @@ plot_valid_design_space <- function(param_grid, } } - other_params <- setdiff(varied_params, c(x, y)) + # storage_volume_m3 gets its own dedicated tooltip line below, so keep it + # out of the generic "other parameters" block. + other_params <- setdiff(varied_params, c(x, y, "storage_volume_m3")) fmt <- function(v) { if (is.numeric(v)) { @@ -272,11 +284,19 @@ plot_valid_design_space <- function(param_grid, "" } + vol_line <- if ("storage_volume_m3" %in% names(d)) { + paste0("
", st_labels$tt_storage_volume, ": ", + fmt(d$storage_volume_m3)) + } else { + "" + } + d$hover <- paste0( "", txt$tt_id, ": ", d[[id_col]], "
", txt$tt_overflow, ": ", fmt(d[[overflow_col]]), "
", lab_x, ": ", fmt(d[[x]]), "
", lab_y, ": ", fmt(d[[y]]), + vol_line, other_block ) diff --git a/R/plot_wb_tradeoff_overflows.R b/R/plot_wb_tradeoff_overflows.R index 72894d8..9da99e1 100644 --- a/R/plot_wb_tradeoff_overflows.R +++ b/R/plot_wb_tradeoff_overflows.R @@ -195,12 +195,22 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, # Optional storage-type tagging (filled square = infiltration box, filled # triangle = gravel trench, as in the cost plots): active when the results # carry a storage_type column; older single-type result sets plot as before. + st_labels <- cost_tooltip_labels(lang) has_storage_type <- "storage_type" %in% names(df) if (has_storage_type) { - st_labels <- cost_tooltip_labels(lang) - st <- storage_type_shapes(df$storage_type, st_labels) + # short language-specific names for the legend keys ... + st <- storage_type_shapes(df$storage_type, lang) df$storage_type_disp <- st$display + # ... but the bilingual names for the tooltip line, matching the cost + # plots' tooltips + st_raw <- as.character(df$storage_type) + df$storage_type_tooltip <- ifelse( + !is.na(st_raw) & st_raw == "gravel_trench", + st_labels$st_gravel_trench, st_labels$st_infiltration_box) } + # Usable storage volume of the storage layer [m3] (precomputed column or + # derived from the storage_theta* columns); line omitted if not derivable. + storage_volume <- storage_volume_from_df(df) df$tooltip_html <- paste0( txt$tt_scenario, ": ", df$scenario_name, @@ -214,7 +224,13 @@ plot_wb_tradeoff_overflows <- function(simulation_results_optimisation, "
", txt$tt_sum_overflows, ": ", df$sum_overflows, if (has_storage_type) { paste0("

", st_labels$tt_storage_type, ": ", - as.character(df$storage_type_disp), "") + df$storage_type_tooltip, "") + } else { + "" + }, + if (!is.null(storage_volume)) { + paste0("
", st_labels$tt_storage_volume, ": ", + round(storage_volume, digits)) } else { "" }, diff --git a/R/plotly_split_legend.R b/R/plotly_split_legend.R index 2f02a46..e4d9519 100644 --- a/R/plotly_split_legend.R +++ b/R/plotly_split_legend.R @@ -17,7 +17,11 @@ #' **storage-type group title**, so the shape encoding is explained #' separately from the colours -- set `add_shape_legend = FALSE` to skip #' them (e.g. for storage-type-faceted plots whose strips already label the -#' panels); +#' panels). The keys are **clickable**: since a plotly trace can only carry +#' one legend group (taken by the overflow class), a small JavaScript +#' handler (via `htmlwidgets::onRender()`) toggles all traces drawn with +#' that marker symbol, so each storage type can be shown or hidden +#' individually; the key greys out to reflect the state; #' * the combined `"colour,shape"` legend-title annotation that ggplotly #' draws over the plot title is removed; group titles take its place and #' the legend moves to a vertical layout on the right, where the groups @@ -179,7 +183,8 @@ plotly_split_legend <- function(pl, } # Legend-only storage-type keys: neutral grey square / triangle. - if (isTRUE(add_shape_legend) && length(shape_symbols) > 0) { + has_shape_keys <- isTRUE(add_shape_legend) && length(shape_symbols) > 0 + if (has_shape_keys) { first_shape <- TRUE for (lab in names(shape_symbols)) { tr <- list( @@ -208,5 +213,98 @@ plotly_split_legend <- function(pl, # Group titles replace the legend title in the rebuilt legend. pl$x$layout$legend$title <- list(text = "") - fix_layout(pl) + pl <- fix_layout(pl) + + # Make the storage-type keys interactive: a trace can only belong to one + # legend group (taken by the overflow class), so clicking a square/triangle + # key toggles all real traces with that marker symbol via a small + # plotly_legendclick handler; the key itself greys out to show the state. + if (has_shape_keys && requireNamespace("htmlwidgets", quietly = TRUE)) { + js_toggle <- paste0( + "function(el, x) {", + " el.on('plotly_legendclick', function(d) {", + " var tr = el.data[d.curveNumber];", + " if (!tr || tr.legendgroup !== 'storage_type_legend') return true;", + " var sym = tr.marker.symbol;", + " var idx = [];", + " var target = null;", + " el.data.forEach(function(t, i) {", + " var isKey = t.legendgroup === 'storage_type_legend';", + " var symMatch = t.marker && t.marker.symbol === sym;", + " if (symMatch && (!isKey || i === d.curveNumber)) {", + " idx.push(i);", + " if (!isKey && target === null) {", + " target = (t.visible === undefined || t.visible === true) ?", + " 'legendonly' : true;", + " }", + " }", + " });", + " if (target === null) return true;", + " Plotly.restyle(el, {visible: target}, idx);", + " return false;", + " });", + "}" + ) + pl <- htmlwidgets::onRender(pl, js_toggle) + } + + pl +} + +#' Add a caption annotation to a ggplotly object +#' +#' `plotly::ggplotly()` drops ggplot captions (and subtitles). This helper +#' re-adds the caption as a small grey annotation below the plot area (bottom +#' left, under the x-axis title) and widens the bottom margin accordingly. +#' `\n` line breaks are converted to `
`. +#' +#' Used by the vignettes together with [cost_rates_caption()] so the +#' interactive cost plots name the unit-cost rates they were computed with. +#' +#' @param pl A plotly object as returned by `plotly::ggplotly()`. +#' @param caption Character. The caption text; `NULL` or `""` returns `pl` +#' unchanged. +#' @param font_size Numeric. Caption font size in px. Default 10. +#' +#' @return The modified plotly object. +#' +#' @examples +#' \dontrun{ +#' pl <- plotly::ggplotly(p, tooltip = "text") +#' pl <- plotly_add_caption(pl, cost_rates_caption("de")) +#' } +#' +#' @export +plotly_add_caption <- function(pl, caption, font_size = 10) { + if (is.null(caption) || !nzchar(caption)) return(pl) + # Two-line ggplot titles ("\n") need "
" in plotly and a little more + # headroom (relevant for plots that do not pass plotly_split_legend(), + # e.g. the cost boxplots with their reference line in the title). + if (!is.null(pl$x$layout$title$text)) { + pl$x$layout$title$text <- gsub("\n", "
", + pl$x$layout$title$text, fixed = TRUE) + if (grepl("
", pl$x$layout$title$text, fixed = TRUE) && + (is.null(pl$x$layout$margin$t) || pl$x$layout$margin$t < 75)) { + pl$x$layout$margin$t <- 75 + } + } + # Anchored to the bottom of the plot area with a fixed PIXEL offset + # (yshift): a paper-coordinate offset would scale with the plot height and + # push the caption out of the margin on tall (e.g. faceted) plots. + ann <- list( + text = gsub("\n", "
", caption, fixed = TRUE), + x = 0, y = 0, + xref = "paper", yref = "paper", + xanchor = "left", yanchor = "top", + yshift = -58, + showarrow = FALSE, + align = "left", + font = list(size = font_size, color = "#666666") + ) + pl$x$layout$annotations <- c(pl$x$layout$annotations, list(ann)) + # room below the x-axis tick labels and title for the caption line + if (is.null(pl$x$layout$margin$b) || pl$x$layout$margin$b < 85) { + pl$x$layout$margin$b <- 85 + } + pl } diff --git a/man/cost_rates_caption.Rd b/man/cost_rates_caption.Rd new file mode 100644 index 0000000..4001158 --- /dev/null +++ b/man/cost_rates_caption.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/compute_costs.R +\name{cost_rates_caption} +\alias{cost_rates_caption} +\title{Caption line naming the unit-cost rates behind the cost plots} +\usage{ +cost_rates_caption(lang = c("de", "en"), cost_rates = default_cost_rates()) +} +\arguments{ +\item{lang}{Character. \code{"de"} or \code{"en"}.} + +\item{cost_rates}{\code{list} of unit costs as returned by +\code{\link[=default_cost_rates]{default_cost_rates()}}.} +} +\value{ +\code{character(1)}, a single line. +} +\description{ +Formats the unit-cost rates (EUR per m2 / m3, see \code{\link[=default_cost_rates]{default_cost_rates()}}) +as a single-line caption for the cost plots, so every figure names the +rates its EUR values were computed with. Used as the default \code{caption} of +\code{\link[=plot_cost_vs_overflow_volume]{plot_cost_vs_overflow_volume()}}, \code{\link[=plot_cost_vs_evaporation]{plot_cost_vs_evaporation()}} and +\code{\link[=plot_cost_overflow_boxplot]{plot_cost_overflow_boxplot()}} (rendered by ggplot at the bottom of the +PDFs) and passed to \code{\link[=plotly_add_caption]{plotly_add_caption()}} for the interactive HTMLs +(\code{plotly::ggplotly()} drops ggplot captions). +} +\details{ +If the costs were computed with non-default rates, pass the same +\code{cost_rates} list here so the caption matches the numbers. +} +\examples{ +cost_rates_caption("de") + +} diff --git a/man/plot_cost_overflow_boxplot.Rd b/man/plot_cost_overflow_boxplot.Rd index 1914ff8..8432989 100644 --- a/man/plot_cost_overflow_boxplot.Rd +++ b/man/plot_cost_overflow_boxplot.Rd @@ -27,6 +27,7 @@ plot_cost_overflow_boxplot( title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, lab_size = NULL, mark_best = TRUE, connect_best = TRUE, @@ -89,11 +90,17 @@ scenario with the lowest cost per percentage point of evapotranspiration.} \item{y_var}{Character. Which cost measure the y-axis (boxes, points, best markers, frontier) shows: \code{"cost_total"} (default; total construction cost, EUR) or \code{"cost_per_evap_pct"} (total cost divided by the element -evapotranspiration share, EUR per percentage point -- the cost -efficiency of evapotranspiration). Scenarios with zero -evapotranspiration have no defined ratio and are dropped from the -\code{"cost_per_evap_pct"} variant. Titles and the y-axis label switch -accordingly.} +evapotranspiration share \strong{above the reference minimum}, EUR per +percentage point -- the marginal cost efficiency of evapotranspiration; +the baseline comes "for free"). The reference is the \strong{lowest +evapotranspiration among the scenarios that satisfy the validity +criterion} (\code{n_overflows <= x}; fallback: the complete run when none +does) and is named -- share, criterion and scenario id -- on a second +title line. Scenarios at or below the reference (including the reference +scenario itself) have no defined marginal cost and are dropped from the +\code{"cost_per_evap_pct"} variant; \code{label_best = TRUE} additionally +annotates the evapotranspiration gain (\code{"(+NN \% Evapotranspiration)"}) +after the price. Titles and the y-axis label switch accordingly.} \item{facet_storage_type}{Logical. If \code{TRUE}, the plot is split by \code{storage_type} into two stacked panels (infiltration box on top, gravel @@ -114,6 +121,13 @@ Default \code{FALSE}.} \item{title, lab_x, lab_y}{Optional character overrides for the default language-specific title / axis labels.} +\item{caption}{Character or \code{NULL}. Caption below the plot naming the +unit-cost rates the EUR values were computed with. \code{NULL} (default) +uses \code{\link[=cost_rates_caption]{cost_rates_caption()}} with the \code{\link[=default_cost_rates]{default_cost_rates()}}; pass your +own string if the costs were computed with different rates, or \code{""} to +drop the caption. Note that \code{plotly::ggplotly()} drops ggplot captions +-- re-add it to the interactive version via \code{\link[=plotly_add_caption]{plotly_add_caption()}}.} + \item{lab_size}{Optional character override for the size-legend title.} \item{mark_best}{Logical. If \code{TRUE} (default), the best scenario per box diff --git a/man/plot_cost_vs_evaporation.Rd b/man/plot_cost_vs_evaporation.Rd index 692c55a..9296a30 100644 --- a/man/plot_cost_vs_evaporation.Rd +++ b/man/plot_cost_vs_evaporation.Rd @@ -20,6 +20,7 @@ plot_cost_vs_evaporation( title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, legend_position = "top" ) } @@ -57,6 +58,13 @@ to tooltip labels, or \code{NULL} to use \code{\link[=default_param_labels]{defa \item{title, lab_x, lab_y}{Optional character overrides for the default language-specific title / axis labels.} +\item{caption}{Character or \code{NULL}. Caption below the plot naming the +unit-cost rates the EUR values were computed with. \code{NULL} (default) +uses \code{\link[=cost_rates_caption]{cost_rates_caption()}} with the \code{\link[=default_cost_rates]{default_cost_rates()}}; pass your +own string if the costs were computed with different rates, or \code{""} to +drop the caption. Note that \code{plotly::ggplotly()} drops ggplot captions +-- re-add it to the interactive version via \code{\link[=plotly_add_caption]{plotly_add_caption()}}.} + \item{legend_position}{Character. Legend position, default \code{"top"}.} } \value{ diff --git a/man/plot_cost_vs_overflow_volume.Rd b/man/plot_cost_vs_overflow_volume.Rd index 078f9f0..7599e76 100644 --- a/man/plot_cost_vs_overflow_volume.Rd +++ b/man/plot_cost_vs_overflow_volume.Rd @@ -20,6 +20,7 @@ plot_cost_vs_overflow_volume( title = NULL, lab_x = NULL, lab_y = NULL, + caption = NULL, legend_position = "top" ) } @@ -57,6 +58,13 @@ to tooltip labels, or \code{NULL} to use \code{\link[=default_param_labels]{defa \item{title, lab_x, lab_y}{Optional character overrides for the default language-specific title / axis labels.} +\item{caption}{Character or \code{NULL}. Caption below the plot naming the +unit-cost rates the EUR values were computed with. \code{NULL} (default) +uses \code{\link[=cost_rates_caption]{cost_rates_caption()}} with the \code{\link[=default_cost_rates]{default_cost_rates()}}; pass your +own string if the costs were computed with different rates, or \code{""} to +drop the caption. Note that \code{plotly::ggplotly()} drops ggplot captions +-- re-add it to the interactive version via \code{\link[=plotly_add_caption]{plotly_add_caption()}}.} + \item{legend_position}{Character. Legend position, default \code{"top"}.} } \value{ diff --git a/man/plot_valid_design_space.Rd b/man/plot_valid_design_space.Rd index c2752a5..f40f2e6 100644 --- a/man/plot_valid_design_space.Rd +++ b/man/plot_valid_design_space.Rd @@ -102,7 +102,7 @@ split by \code{storage_type} into two stacked panels (infiltration box on top, gravel trench below) with free y-scales, so disjoint per-type levels (e.g. \code{storage_height}: 300-1200 mm boxes vs. 900-3600 mm trenches) fill their own panel; duplicate counting for \code{alpha_mode = - "duplicates"} then happens per panel and the points stay plain circles +"duplicates"} then happens per panel and the points stay plain circles (the strips already name the type). Requires a \code{storage_type} column in \code{param_grid}. Without faceting, points are shaped by the storage type (filled square = infiltration box, filled triangle = gravel diff --git a/man/plotly_add_caption.Rd b/man/plotly_add_caption.Rd new file mode 100644 index 0000000..d7424bd --- /dev/null +++ b/man/plotly_add_caption.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plotly_split_legend.R +\name{plotly_add_caption} +\alias{plotly_add_caption} +\title{Add a caption annotation to a ggplotly object} +\usage{ +plotly_add_caption(pl, caption, font_size = 10) +} +\arguments{ +\item{pl}{A plotly object as returned by \code{plotly::ggplotly()}.} + +\item{caption}{Character. The caption text; \code{NULL} or \code{""} returns \code{pl} +unchanged.} + +\item{font_size}{Numeric. Caption font size in px. Default 10.} +} +\value{ +The modified plotly object. +} +\description{ +\code{plotly::ggplotly()} drops ggplot captions (and subtitles). This helper +re-adds the caption as a small grey annotation below the plot area (bottom +left, under the x-axis title) and widens the bottom margin accordingly. +\verb{\\n} line breaks are converted to \verb{
}. +} +\details{ +Used by the vignettes together with \code{\link[=cost_rates_caption]{cost_rates_caption()}} so the +interactive cost plots name the unit-cost rates they were computed with. +} +\examples{ +\dontrun{ +pl <- plotly::ggplotly(p, tooltip = "text") +pl <- plotly_add_caption(pl, cost_rates_caption("de")) +} + +} diff --git a/man/plotly_split_legend.Rd b/man/plotly_split_legend.Rd index 3f30d28..6307cf1 100644 --- a/man/plotly_split_legend.Rd +++ b/man/plotly_split_legend.Rd @@ -51,7 +51,11 @@ filled triangle = gravel trench) are appended under their own \strong{storage-type group title}, so the shape encoding is explained separately from the colours -- set \code{add_shape_legend = FALSE} to skip them (e.g. for storage-type-faceted plots whose strips already label the -panels); +panels). The keys are \strong{clickable}: since a plotly trace can only carry +one legend group (taken by the overflow class), a small JavaScript +handler (via \code{htmlwidgets::onRender()}) toggles all traces drawn with +that marker symbol, so each storage type can be shown or hidden +individually; the key greys out to reflect the state; \item the combined \code{"colour,shape"} legend-title annotation that ggplotly draws over the plot title is removed; group titles take its place and the legend moves to a vertical layout on the right, where the groups diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index c11f2e4..a51ad15 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -1,314 +1,328 @@ ---- -title: "RainDrop Optimierung – Brute Force" -author: "Michael Rustler" -date: "2026-02-25" -output: - html_document: - toc: true - toc_depth: 4 - number_sections: true ---- - -```{r setup, include=FALSE} -knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) - -sites <- c("Eisenstadt_2005", "Wien", "BadAussee") - -# index.html liegt im gleichen Verzeichnis wie der Ordner "brute-force" -base_dir <- "." - -design_spaces <- paste0( - "mulde-area_vs_", - c("filter_hydraulicconductivity", "mulde_height", "storage_height") -) - -rel <- function(...) file.path(..., fsep = "/") - -md_link_line <- function(label, href) sprintf("- [%s](%s)", label, href) - -md_list <- function(lines) knitr::asis_output(paste(lines, collapse = "\n")) -``` - -# Hintergrund - -xxx - -# Methodik - -Die Modellierung erfolgte in R mit dem R Paket [kwb.raindrop](https://github.com/kwb-r/kwb.raindrop). -Das genaue Vorgehen ist für jede Fallstudie im folgenden im R Markdown reproduzierbar -dokumentiert. - -```{r brute_force_rmarkdown, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/workflow_%s.html)\n", - site, - base_dir, - site - )) -} -``` - -# Ergebnisse - -Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die -beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in -unten stehenden Links: - -Als **Gültigkeitskriterium** — die maximal zulässige Anzahl Überlaufereignisse — -wurde passend zur Simulationsdauer gewählt: **Eisenstadt ≤ 1** (Simulationszeit -1 Jahr) und **Wien / Bad Aussee ≤ 5** (15-jährige Regen-/ET-Reihe). Dieser -Schwellenwert steuert die Farbgebung (grün = gültig, rot = zu viele Überläufe) -und den in den Kostenplot-Titeln angegebenen Anteil gültiger Szenarien. - -## Tabellen - -```{r brute_force_tabelle, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s.html)\n", - site, - base_dir, - site - )) -} - -``` - -## CSV - -Die in den [obenstehenden Tabellen](#tabellen) dargestellten Ergebnisse können auch als `.csv` Datei -heruntergeladen werden. - -```{r brute_force_csv, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s.csv)\n", - site, - base_dir, - site - )) -} -``` - -## Interaktive Visualisierungen - -### Sensitive Modellparameter - -Haupteffekte je Parameter (Violin-/Box-/Punkt-Plots, nach Effektstärke -sortiert). Der **Speichertyp** ist als eigenes Panel enthalten -(Sickerbox vs. Schotterrigol). - -```{r brute_force_plots_main, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_main-effects.html)\n", - site, - base_dir, - site - )) -} -``` - -### Design Spaces - -In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit -**einem weiteren Parameter** (y-Achse) dargestellt. Diese sind im folgenden: - -- ***Muldenhöhe*** - -- ***Speicherhöhe*** - -- ***hydraulische Leitfähigkeit*** des Bodenfilters - -Die beiden **Speichertypen** liegen als **zwei Panels untereinander** -(Sickerbox oben, Schotterrigole unten; die Punkte bleiben Kreise, da -die Panel-Streifen den Typ benennen). Die y-Achsen sind je Panel frei -skaliert, so dass z. B. bei -der **Speicherhöhe** jedes Panel nur die für den Typ getesteten Höhen -zeigt (Sickerbox 300–1200 mm, Schotterrigole 900–3600 mm). - -```{r brute_force_plots_design-spaches, echo = FALSE, results='asis'} -cat("| Design Space |", paste(sites, collapse = " | "), "|\n") -cat("|---|", paste(rep("---", length(sites)), collapse = "|"), "|\n") - -for (ds in design_spaces) { - - ds_label <- sub("^mulde-area_vs_", "", ds) - - row_links <- sapply(sites, function(site) { - sprintf( - "[%s](%s/simulation_results_optimisation_%s_design-space_%s.html)", - ds_label, - base_dir, - site, - ds - ) - }) - - cat("|", ds_label, "|", paste(row_links, collapse = " | "), "|\n") -} -``` - -### Wasserbilanz - -Streudiagramm **Infiltration [%]** (x) vs. **Verdunstung [%]** (y) je -Szenario, Punktfarbe = Anzahl Überlaufereignisse, Punktform = -**Speichertyp** (Viereck = Sickerbox, Dreieck = Schotterrigole). Der -Tooltip zeigt die Wasserbilanz, den Speichertyp und die variierenden -Design-Parameter. - -```{r brute_force_plots_water-balance, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_water-balance.html)\n", - site, - base_dir, - site - )) -} -``` - -### Kosten - -Sechs komplementäre, interaktive Sichten auf die **Baukosten** der -Szenarien und ihren Zusammenhang mit Überläufen, Wasserhaushalt und -Design-Parametern. Alle teilen denselben Punkt-Tooltip -(Wasserhaushalt, Kostenaufteilung, variierende Parameter). Der -**Speichertyp** ist überall einheitlich kodiert: in den Streudiagrammen -über die **Punktform** (Viereck = Sickerbox/Infiltration box, -Dreieck = Schotterrigol/Gravel trench), in den Boxplots über **zwei -Panels untereinander** (Sickerbox oben, Schotterrigol unten). - -#### Kosten vs. Überlaufvolumen - -Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten -[€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und -`mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, -`>5` = rot, Legende oben), Punktform nach **Speichertyp** (Viereck = -Sickerbox, Dreieck = Schotterrigol). Mouseover zeigt den Wasserhaushalt -(Verdunstung, Versickerung, Überlauf in %), die vollständige -Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, -Gesamt), die **Kosten je Prozent Verdunstung [€/%]** plus die -variierenden Design-Parameter des Szenarios. - -```{r brute_force_plots_cost-overflow, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-vs-overflow-volume.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Kosten vs. Verdunstung - -Streudiagramm analog zum vorigen, aber mit der **Verdunstung [%]** -(Anteil der Verdunstung am Gesamtwasserinput des Elements) auf der -y-Achse: **x-Achse Gesamtkosten [€]**, Punktfarbe nach **Anzahl -Überlaufereignisse**, Punktform nach **Speichertyp** (Viereck = -Sickerbox, Dreieck = Schotterrigol). Zeigt, wie viel Verdunstung man -je Budget bekommt und welche Szenarien dabei gültig bleiben — -identischer Tooltip. - -```{r brute_force_plots_cost-evaporation, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-vs-evaporation.html)\n", - site, - base_dir, - site - )) -} -``` - -Alle Boxplots zeigen die **Gesamtkosten** [€] (y-Achse) je **Anzahl -Überlaufereignisse** (x-Achse; `0`–`5` einzeln, `>5` = Rest gebündelt; im -`>5`-Kasten wird das Szenario mit den wenigsten Überläufen markiert), -überlagert mit den Szenarien als Punkte (Kreise; die Panel-Streifen -benennen den Typ), und trennen die beiden -**Speichertypen in zwei Panels untereinander** (Sickerbox oben, -Schotterrigol unten). Je Box und Panel ist ein -**bestes** Szenario -als Raute in der jeweiligen Gruppenfarbe (schwarz umrandet) markiert; die -Markierungen **aller** Klassen sind je Panel zur Frontier-Linie verbunden. -Punkt-Mouseover: Wasserhaushalt, Kostenaufteilung, variierende Parameter. -Die drei Varianten optimieren je Box ein **anderes Ziel** (Kosten als -Tie-Break) und ergeben so drei verschiedene Frontier-Linien: - -#### Boxplot – günstigste je Kategorie - -Das **günstigste** Szenario je Box. Punktgröße = Überlaufvolumen [m³]. - -```{r brute_force_plots_cost-boxplot-cheapest, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-cheapest.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – geringstes Überlaufvolumen - -Das Szenario je Box mit dem **geringsten Überlaufvolumen** (bei Gleichstand -das günstigste). Die Markierung ist mit ihrem **Überlaufvolumen [m³] und -dessen Anteil [%]** beschriftet. Punktgröße = Überlaufvolumen. - -```{r brute_force_plots_cost-boxplot-min-overflow, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-min-overflow.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – höchste Verdunstung - -Das Szenario je Box mit der **höchsten Verdunstung** (bei Gleichstand das -günstigste). Die Markierung ist mit ihrer **Verdunstung [%]** beschriftet; -hier kodiert die **Punktgröße die Verdunstung** statt des Überlaufvolumens. - -```{r brute_force_plots_cost-boxplot-max-evap, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-max-evap.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – Kosten je Prozent Verdunstung - -Kosteneffizienz der Verdunstung: y-Achse sind die **Kosten je -Prozentpunkt Verdunstung [€/%]** (Gesamtkosten geteilt durch den -Verdunstungsanteil des Szenarios) je **Anzahl Überlaufereignisse**, -wieder mit den beiden **Speichertypen als zwei Panels untereinander**. -Je Box und Panel ist das Szenario mit den **geringsten Kosten je -Prozentpunkt** markiert und mit seinem Wert [€/%] beschriftet; die -**Punktgröße kodiert die Verdunstung [%]**. So lässt sich direkt -ablesen, mit welcher Speichertechnik und welchem Design ein -Prozentpunkt Verdunstung am günstigsten erkauft wird. - -```{r brute_force_plots_cost-per-evap-boxplot, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-per-evap-boxplot.html)\n", - site, - base_dir, - site - )) -} -``` - - +--- +title: "RainDrop Optimierung – Brute Force" +author: "Michael Rustler" +date: "2026-02-25" +output: + html_document: + toc: true + toc_depth: 4 + number_sections: true +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) + +sites <- c("Eisenstadt_2005", "Wien", "BadAussee") + +# index.html liegt im gleichen Verzeichnis wie der Ordner "brute-force" +base_dir <- "." + +design_spaces <- paste0( + "mulde-area_vs_", + c("filter_hydraulicconductivity", "mulde_height", "storage_height") +) + +rel <- function(...) file.path(..., fsep = "/") + +md_link_line <- function(label, href) sprintf("- [%s](%s)", label, href) + +md_list <- function(lines) knitr::asis_output(paste(lines, collapse = "\n")) +``` + +# Hintergrund + +xxx + +# Methodik + +Die Modellierung erfolgte in R mit dem R Paket [kwb.raindrop](https://github.com/kwb-r/kwb.raindrop). +Das genaue Vorgehen ist für jede Fallstudie im folgenden im R Markdown reproduzierbar +dokumentiert. + +```{r brute_force_rmarkdown, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/workflow_%s.html)\n", + site, + base_dir, + site + )) +} +``` + +# Ergebnisse + +Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die +beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in +unten stehenden Links: + +Als **Gültigkeitskriterium** — die maximal zulässige Anzahl Überlaufereignisse — +wurde passend zur Simulationsdauer gewählt: **Eisenstadt ≤ 1** (Simulationszeit +1 Jahr) und **Wien / Bad Aussee ≤ 5** (15-jährige Regen-/ET-Reihe). Dieser +Schwellenwert steuert die Farbgebung (grün = gültig, rot = zu viele Überläufe) +und den in den Kostenplot-Titeln angegebenen Anteil gültiger Szenarien. + +## Tabellen + +```{r brute_force_tabelle, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s.html)\n", + site, + base_dir, + site + )) +} + +``` + +## CSV + +Die in den [obenstehenden Tabellen](#tabellen) dargestellten Ergebnisse können auch als `.csv` Datei +heruntergeladen werden. + +```{r brute_force_csv, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s.csv)\n", + site, + base_dir, + site + )) +} +``` + +## Interaktive Visualisierungen + +### Sensitive Modellparameter + +Haupteffekte je Parameter (Violin-/Box-/Punkt-Plots, nach Effektstärke +sortiert). Der **Speichertyp** ist als eigenes Panel enthalten +(Sickerbox vs. Schotterrigol). + +```{r brute_force_plots_main, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_main-effects.html)\n", + site, + base_dir, + site + )) +} +``` + +### Design Spaces + +In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit +**einem weiteren Parameter** (y-Achse) dargestellt. Diese sind im folgenden: + +- ***Muldenhöhe*** + +- ***Speicherhöhe*** + +- ***hydraulische Leitfähigkeit*** des Bodenfilters + +Die beiden **Speichertypen** liegen als **zwei Panels untereinander** +(Sickerbox oben, Schotterrigole unten; die Punkte bleiben Kreise, da +die Panel-Streifen den Typ benennen). Die y-Achsen sind je Panel frei +skaliert, so dass z. B. bei +der **Speicherhöhe** jedes Panel nur die für den Typ getesteten Höhen +zeigt (Sickerbox 300–1200 mm, Schotterrigole 900–3600 mm). + +```{r brute_force_plots_design-spaches, echo = FALSE, results='asis'} +cat("| Design Space |", paste(sites, collapse = " | "), "|\n") +cat("|---|", paste(rep("---", length(sites)), collapse = "|"), "|\n") + +for (ds in design_spaces) { + + ds_label <- sub("^mulde-area_vs_", "", ds) + + row_links <- sapply(sites, function(site) { + sprintf( + "[%s](%s/simulation_results_optimisation_%s_design-space_%s.html)", + ds_label, + base_dir, + site, + ds + ) + }) + + cat("|", ds_label, "|", paste(row_links, collapse = " | "), "|\n") +} +``` + +### Wasserbilanz + +Streudiagramm **Infiltration [%]** (x) vs. **Evapotranspiration [%]** (y) je +Szenario, Punktfarbe = Anzahl Überlaufereignisse, Punktform = +**Speichertyp** (Viereck = Sickerbox, Dreieck = Schotterrigole). Der +Tooltip zeigt die Wasserbilanz, den Speichertyp und die variierenden +Design-Parameter. + +```{r brute_force_plots_water-balance, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_water-balance.html)\n", + site, + base_dir, + site + )) +} +``` + +### Kosten + +Sechs komplementäre, interaktive Sichten auf die **Baukosten** der +Szenarien und ihren Zusammenhang mit Überläufen, Wasserhaushalt und +Design-Parametern. Alle teilen denselben Punkt-Tooltip +(Wasserhaushalt, Kostenaufteilung, variierende Parameter). Der +**Speichertyp** ist überall einheitlich kodiert: in den Streudiagrammen +über die **Punktform** (Viereck = Sickerbox/Infiltration box, +Dreieck = Schotterrigol/Gravel trench), in den Boxplots über **zwei +Panels untereinander** (Sickerbox oben, Schotterrigol unten). + +#### Kosten vs. Überlaufvolumen + +Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten +[€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und +`mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, +`>5` = rot, Legende oben), Punktform nach **Speichertyp** (Viereck = +Sickerbox, Dreieck = Schotterrigol). Mouseover zeigt den Wasserhaushalt +(Evapotranspiration, Versickerung, Überlauf in %), das nutzbare +Speichervolumen, die vollständige +Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, +Gesamt), die **Kosten je Prozent Evapotranspiration über dem +Referenz-Minimum der gültigen Szenarien [€/%]** (Referenzwert in der +Tooltip-Zeile genannt) plus +die variierenden Design-Parameter des Szenarios. + +```{r brute_force_plots_cost-overflow, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-vs-overflow-volume.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Kosten vs. Evapotranspiration + +Streudiagramm analog zum vorigen, aber mit der **Evapotranspiration [%]** +(Anteil der Evapotranspiration am Gesamtwasserinput des Elements) auf der +y-Achse: **x-Achse Gesamtkosten [€]**, Punktfarbe nach **Anzahl +Überlaufereignisse**, Punktform nach **Speichertyp** (Viereck = +Sickerbox, Dreieck = Schotterrigol). Zeigt, wie viel Evapotranspiration man +je Budget bekommt und welche Szenarien dabei gültig bleiben — +identischer Tooltip. + +```{r brute_force_plots_cost-evaporation, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-vs-evaporation.html)\n", + site, + base_dir, + site + )) +} +``` + +Alle Boxplots zeigen die **Gesamtkosten** [€] (y-Achse) je **Anzahl +Überlaufereignisse** (x-Achse; `0`–`5` einzeln, `>5` = Rest gebündelt; im +`>5`-Kasten wird das Szenario mit den wenigsten Überläufen markiert), +überlagert mit den Szenarien als Punkte (Kreise; die Panel-Streifen +benennen den Typ), und trennen die beiden +**Speichertypen in zwei Panels untereinander** (Sickerbox oben, +Schotterrigol unten). Je Box und Panel ist ein +**bestes** Szenario +als Raute in der jeweiligen Gruppenfarbe (schwarz umrandet) markiert; die +Markierungen **aller** Klassen sind je Panel zur Frontier-Linie verbunden. +Punkt-Mouseover: Wasserhaushalt, Kostenaufteilung, variierende Parameter. +Die drei Varianten optimieren je Box ein **anderes Ziel** (Kosten als +Tie-Break) und ergeben so drei verschiedene Frontier-Linien: + +#### Boxplot – günstigste je Kategorie + +Das **günstigste** Szenario je Box. Punktgröße = Überlaufvolumen [m³]. + +```{r brute_force_plots_cost-boxplot-cheapest, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-cheapest.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Boxplot – geringstes Überlaufvolumen + +Das Szenario je Box mit dem **geringsten Überlaufvolumen** (bei Gleichstand +das günstigste). Die Markierung ist mit ihrem **Überlaufvolumen [m³] und +dessen Anteil [%]** beschriftet. Punktgröße = Überlaufvolumen. + +```{r brute_force_plots_cost-boxplot-min-overflow, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-min-overflow.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Boxplot – höchste Evapotranspiration + +Das Szenario je Box mit der **höchsten Evapotranspiration** (bei Gleichstand das +günstigste). Die Markierung ist mit ihrer **Evapotranspiration [%]** beschriftet; +hier kodiert die **Punktgröße die Evapotranspiration** statt des Überlaufvolumens. + +```{r brute_force_plots_cost-boxplot-max-evap, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-max-evap.html)\n", + site, + base_dir, + site + )) +} +``` + +#### Boxplot – Kosten je Prozent Evapotranspiration + +**Marginale** Kosteneffizienz der Evapotranspiration: y-Achse sind die +**Kosten je Prozentpunkt Evapotranspiration über dem Referenz-Minimum +[€/%]** — Gesamtkosten geteilt durch die Mehr-Evapotranspiration +gegenüber der Referenz. Die Referenz ist die **minimale +Evapotranspiration der gültigen Szenarien** (Anzahl Überlaufereignisse +≤ Schwellenwert; gibt es keine gültigen, der komplette Modelllauf) — +diese Basis-Evapotranspiration ist damit „gratis"; bezahlt wird nur der +Zugewinn. Die **Referenz** (minimale Evapotranspiration [%], +Gültigkeitskriterium und zugehörige +Szenario-ID) steht in der zweiten Titelzeile; Szenarien auf oder unter +der Referenz (inkl. des Referenz-Szenarios selbst) haben keine +definierte Kennzahl und entfallen im Plot. Aufteilung +je **Anzahl Überlaufereignisse**, +wieder mit den beiden **Speichertypen als zwei Panels untereinander**. +Je Box und Panel ist das Szenario mit den **geringsten Kosten je +Prozentpunkt** markiert und mit seinem Wert [€/%] plus dem erkauften +Zugewinn **„(+ x.x % Evapotranspiration)"** beschriftet; die +**Punktgröße kodiert die Evapotranspiration [%]**. So lässt sich direkt +ablesen, mit welcher Speichertechnik und welchem Design ein +zusätzlicher Prozentpunkt Evapotranspiration am günstigsten erkauft wird. + +```{r brute_force_plots_cost-per-evap-boxplot, echo = FALSE, results='asis'} +for (site in sites) { + cat(sprintf( + "- [%s](%s/simulation_results_optimisation_%s_cost-per-evap-boxplot.html)\n", + site, + base_dir, + site + )) +} +``` + + diff --git a/vignettes/workflow_badaussee.Rmd b/vignettes/workflow_badaussee.Rmd index b4d00f4..89f6f27 100644 --- a/vignettes/workflow_badaussee.Rmd +++ b/vignettes/workflow_badaussee.Rmd @@ -309,7 +309,7 @@ txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% message(txt) -txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Evapotranspirations: %f mm/a)\n", paths$path_et, 100*sum(is.na(timeseries_et$value))/nrow(timeseries_et), 100*sum(timeseries_et$value == 0, na.rm = TRUE)/nrow(timeseries_et), @@ -516,6 +516,11 @@ params <- c( lang <- "de" max_n_overflows <- 5 +# Kostensaetze-Caption fuer die interaktiven Kostenplots: ggplotly verwirft +# ggplot-Captions, daher wird sie dort per plotly_add_caption() nachgeruestet; +# die PDFs bekommen sie automatisch ueber den caption-Default der Funktionen. +cost_caption <- kwb.raindrop::cost_rates_caption(lang) + pdff <- sprintf("simulation_results_optimisation_%s_main-effects.pdf", paths$modelname) @@ -664,6 +669,7 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -680,8 +686,8 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen -# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# (Label m3 + %); (iii) hoechste Evapotranspiration (Label %, Punktgroesse = +# Evapotranspiration). x = max_n_overflows, Linie ueber alle Klassen. Die beiden # Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen # den Typ bereits benennen. @@ -714,6 +720,7 @@ for (cb in cost_boxplots) { # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( @@ -729,7 +736,7 @@ for (cb in cost_boxplots) { } -# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# Kosten vs. Evapotranspiration: Streudiagramm ueber den Design-Raum, Punktform # kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), # Farbe die Anzahl Ueberlaufereignisse. pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", @@ -749,6 +756,7 @@ p <- kwb.raindrop::plot_cost_vs_evaporation( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", @@ -763,10 +771,10 @@ suppressWarnings(print(p)) dev.off() -# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# Kosten je Prozent Evapotranspiration [EUR/%]: Boxplot je Ueberlaufklasse mit den # beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), -# Punktgroesse = Verdunstung. +# Punktgroesse = Evapotranspiration. pdff <- sprintf( "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", paths$modelname) @@ -788,6 +796,7 @@ p <- kwb.raindrop::plot_cost_overflow_boxplot( # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( diff --git a/vignettes/workflow_eisenstadt-2005.Rmd b/vignettes/workflow_eisenstadt-2005.Rmd index 2b70676..b21d339 100644 --- a/vignettes/workflow_eisenstadt-2005.Rmd +++ b/vignettes/workflow_eisenstadt-2005.Rmd @@ -408,6 +408,11 @@ params <- c( lang <- "de" max_n_overflows <- 1 +# Kostensaetze-Caption fuer die interaktiven Kostenplots: ggplotly verwirft +# ggplot-Captions, daher wird sie dort per plotly_add_caption() nachgeruestet; +# die PDFs bekommen sie automatisch ueber den caption-Default der Funktionen. +cost_caption <- kwb.raindrop::cost_rates_caption(lang) + pdff <- sprintf("simulation_results_optimisation_%s_main-effects.pdf", paths$modelname) @@ -557,6 +562,7 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -573,8 +579,8 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen -# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# (Label m3 + %); (iii) hoechste Evapotranspiration (Label %, Punktgroesse = +# Evapotranspiration). x = max_n_overflows, Linie ueber alle Klassen. Die beiden # Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen # den Typ bereits benennen. @@ -607,6 +613,7 @@ for (cb in cost_boxplots) { # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( @@ -622,7 +629,7 @@ for (cb in cost_boxplots) { } -# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# Kosten vs. Evapotranspiration: Streudiagramm ueber den Design-Raum, Punktform # kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), # Farbe die Anzahl Ueberlaufereignisse. pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", @@ -642,6 +649,7 @@ p <- kwb.raindrop::plot_cost_vs_evaporation( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", @@ -656,10 +664,10 @@ suppressWarnings(print(p)) dev.off() -# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# Kosten je Prozent Evapotranspiration [EUR/%]: Boxplot je Ueberlaufklasse mit den # beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), -# Punktgroesse = Verdunstung. +# Punktgroesse = Evapotranspiration. pdff <- sprintf( "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", paths$modelname) @@ -681,6 +689,7 @@ p <- kwb.raindrop::plot_cost_overflow_boxplot( # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( diff --git a/vignettes/workflow_wien.Rmd b/vignettes/workflow_wien.Rmd index c7a61fe..fab82b8 100644 --- a/vignettes/workflow_wien.Rmd +++ b/vignettes/workflow_wien.Rmd @@ -309,7 +309,7 @@ txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% message(txt) -txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Verdunstungs: %f mm/a)\n", +txt <- sprintf("F\u00fcr den Datensatz '%s' gibt es %.2f %% NA Werte und %.2f %% Werte die gleich Null sind. (Evapotranspirations: %f mm/a)\n", paths$path_et, 100*sum(is.na(timeseries_et$value))/nrow(timeseries_et), 100*sum(timeseries_et$value == 0, na.rm = TRUE)/nrow(timeseries_et), @@ -512,6 +512,11 @@ params <- c( lang <- "de" max_n_overflows <- 5 +# Kostensaetze-Caption fuer die interaktiven Kostenplots: ggplotly verwirft +# ggplot-Captions, daher wird sie dort per plotly_add_caption() nachgeruestet; +# die PDFs bekommen sie automatisch ueber den caption-Default der Funktionen. +cost_caption <- kwb.raindrop::cost_rates_caption(lang) + pdff <- sprintf("simulation_results_optimisation_%s_main-effects.pdf", paths$modelname) @@ -661,6 +666,7 @@ p <- kwb.raindrop::plot_cost_vs_overflow_volume( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-overflow-volume.html", @@ -677,8 +683,8 @@ dev.off() # Drei Kosten-Boxplots mit unterschiedlichem Optimierungsziel je Kategorie # (Kosten als Tie-Break): (i) guenstigste; (ii) geringstes Ueberlaufvolumen -# (Label m3 + %); (iii) hoechste Verdunstung (Label %, Punktgroesse = -# Verdunstung). x = max_n_overflows, Linie ueber alle Klassen. Die beiden +# (Label m3 + %); (iii) hoechste Evapotranspiration (Label %, Punktgroesse = +# Evapotranspiration). x = max_n_overflows, Linie ueber alle Klassen. Die beiden # Speichertypen liegen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); die Punkte bleiben Kreise, da die Panel-Streifen # den Typ bereits benennen. @@ -711,6 +717,7 @@ for (cb in cost_boxplots) { # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) + plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( @@ -726,7 +733,7 @@ for (cb in cost_boxplots) { } -# Kosten vs. Verdunstung: Streudiagramm ueber den Design-Raum, Punktform +# Kosten vs. Evapotranspiration: Streudiagramm ueber den Design-Raum, Punktform # kodiert den Speichertyp (Viereck = Sickerbox, Dreieck = Schotterrigol), # Farbe die Anzahl Ueberlaufereignisse. pdff <- sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.pdf", @@ -746,6 +753,7 @@ p <- kwb.raindrop::plot_cost_vs_evaporation( # statt der (Farbe, Form)-Tupel von ggplotly plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) plotly_p <- kwb.raindrop::plotly_split_legend(plotly_p, lang = lang) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf("simulation_results_optimisation_%s_cost-vs-evaporation.html", @@ -760,10 +768,10 @@ suppressWarnings(print(p)) dev.off() -# Kosten je Prozent Verdunstung [EUR/%]: Boxplot je Ueberlaufklasse mit den +# Kosten je Prozent Evapotranspiration [EUR/%]: Boxplot je Ueberlaufklasse mit den # beiden Speichertypen als zwei Panels untereinander (Sickerbox oben, # Schotterrigol unten); guenstigstes Szenario je Box markiert (Label EUR/%), -# Punktgroesse = Verdunstung. +# Punktgroesse = Evapotranspiration. pdff <- sprintf( "simulation_results_optimisation_%s_cost-per-evap-boxplot.pdf", paths$modelname) @@ -785,6 +793,7 @@ p <- kwb.raindrop::plot_cost_overflow_boxplot( # interaktiv als HTML plotly_p <- suppressWarnings(plotly::ggplotly(p, tooltip = "text")) +plotly_p <- kwb.raindrop::plotly_add_caption(plotly_p, cost_caption) htmlwidgets::saveWidget( widget = plotly_p, file = sprintf( From c9b4984f8596253790520ecf8559a3c148107223 Mon Sep 17 00:00:00 2001 From: mrustl Date: Thu, 9 Jul 2026 17:33:11 +0100 Subject: [PATCH 13/34] Update date on generation --- vignettes/index.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd index a51ad15..ad13d7f 100644 --- a/vignettes/index.Rmd +++ b/vignettes/index.Rmd @@ -1,7 +1,7 @@ --- title: "RainDrop Optimierung – Brute Force" author: "Michael Rustler" -date: "2026-02-25" +date: "`r Sys.Date()`" output: html_document: toc: true From a1755f5a1308549acb1d1280ccaacd4548fa5d05 Mon Sep 17 00:00:00 2001 From: mrustl Date: Fri, 10 Jul 2026 11:06:19 +0100 Subject: [PATCH 14/34] Add monotoncity_analysis reports see also: https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/ --- .Rbuildignore | 1 + .gitignore | 14 + vignettes/monotonicity_analysis.Rmd | 455 ++++++++++++++++++++++++++++ 3 files changed, 470 insertions(+) create mode 100644 vignettes/monotonicity_analysis.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index aaee986..b2336fa 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -9,5 +9,6 @@ ^index\.md$ ^README\.md$ ^vignettes/index\.Rmd$ +^vignettes/monotonicity_analysis$ ^\.positai$ ^\.claude$ diff --git a/.gitignore b/.gitignore index 5c9c9ee..4024089 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,17 @@ docs inst/doc .positai + +# Von den Vignetten erzeugte Ergebnisdateien (Workflows: simulation_results_*; +# monotonicity_analysis.Rmd: mono_*). Reproduzierbar durch erneutes Rendern +# -> nicht einchecken. HTML- und R-Dateien unter vignettes/ ignoriert +# bereits vignettes/.gitignore (*.html, *.R). +vignettes/*.csv +vignettes/*.pdf +vignettes/figure/ +Rplots.pdf + +# Deploy-Ordner der Monotonie-Analyse: komplett unversioniert. Achtung: +# Das betrifft auch den handgeschriebenen Ergebnisbericht index.html +# (liegt lokal, als claude.ai-Artefakt und deployt auf dem Server). +vignettes/monotonicity_analysis/ diff --git a/vignettes/monotonicity_analysis.Rmd b/vignettes/monotonicity_analysis.Rmd new file mode 100644 index 0000000..544f0de --- /dev/null +++ b/vignettes/monotonicity_analysis.Rmd @@ -0,0 +1,455 @@ +--- +title: "Monotonie-Check der Optimierungsergebnisse" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Monotonie-Check der Optimierungsergebnisse} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE, eval = TRUE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.width = 7, + fig.height = 3.2 +) + +# Diese Vignette wertet die Ergebnis-CSVs der drei Workflow-Vignetten aus +# (workflow_badaussee, workflow_eisenstadt-2005, workflow_wien). Sie ist +# bedingt: alle Analyse-Chunks laufen nur, wenn die CSVs neben dieser +# Datei liegen -- also NACH einem lokalen Lauf der Workflows (Windows + +# Engine). Auf CI/GitHub Actions wird nur der Text gerendert. +result_files <- c( + BadAussee = "simulation_results_optimisation_BadAussee.csv", + Eisenstadt = "simulation_results_optimisation_Eisenstadt_2005.csv", + Wien = "simulation_results_optimisation_Wien.csv" +) +results_available <- all(file.exists(result_files)) + +# Auf GH Actions (pkgdown-Deploy) liegt der Ergebnisbericht (index.html) +# nicht neben dem gerenderten Artikel -- der Link darauf wird dann nicht +# gesetzt (nur beim lokalen Rendern in den Ordner monotonicity_analysis/). +is_ghactions <- tolower(Sys.getenv("GITHUB_ACTIONS")) == "true" || + tolower(Sys.getenv("CI")) %in% c("true", "1", "yes") +``` + +## Worum geht es? + +Der geplante Optimierer sucht die günstigste Muldenkonfiguration per +**Bisektion** (Intervallhalbierung): "Zu klein" → größer probieren, +"reicht" → kleiner probieren. Das funktioniert nur, wenn eine Regel gilt: + +> **Monotonie:** Wird das Bauwerk größer (mehr Fläche, mehr Tiefe, mehr +> Speicher, durchlässigerer Filter), darf es niemals *mehr* +> Überlaufereignisse geben als vorher. + +Diese Vignette prüft die Regel an allen Nachbarpaaren des Brute-Force-Rasters +(je Standort 576 Läufe, 1 704 Vergleichspaare — insgesamt 5 112). +Verglichen werden immer zwei Läufe, die sich **nur in einem Parameter um eine +Stufe** unterscheiden. Zusätzlich geprüft: das Überlaufvolumen in m³ +(`sum_overflows` ist mm Wassersäule über der Muldenfläche, daher +m³ = mm × Muldenfläche / 1000), die Verdunstung sowie zwei +Struktur-Eigenschaften, die der Optimierer nutzt (Ambiguitätsband, +Schwellentreppe, kf-Dominanz). + +## Voraussetzungen + +Diese Vignette **nach den drei Workflow-Vignetten ausführen** — sie liest +deren Ergebnisdateien (`simulation_results_optimisation_*.csv`) aus dem +`vignettes/`-Verzeichnis. + +```{r availability_note, echo = FALSE, results = 'asis', eval = !results_available} +cat(paste0( + "> **Hinweis:** Es wurden keine Ergebnisdateien gefunden — die ", + "Analyse-Chunks wurden übersprungen. Bitte zuerst die Workflow-Vignetten ", + "(Bad Aussee, Eisenstadt 2005, Wien) lokal ausführen (Windows + Engine) ", + "und diese Vignette anschließend erneut rendern.\n" +)) +``` + +### Verwendete Dateien und Ablage-Struktur + +Die Links folgen der Deploy-Struktur auf dem Server: Diese Analyse, der +Ergebnisbericht und die Detailtabellen liegen unter +`…/optimisation/monotonicity_analysis/`, die Ergebnisse der +Workflow-Vignetten unter `…/optimisation/brute-force/`. Damit die Links auch +lokal stimmen, wird diese Vignette in den gleichnamigen Unterordner +gerendert: + +```r +rmarkdown::render("monotonicity_analysis.Rmd", + output_dir = "monotonicity_analysis") +``` + +(Eingelesen werden die CSVs unverändert aus `vignettes/`, wo die Workflows +sie ablegen — nur die Links zeigen auf die Deploy-Orte.) + +| Standort | Eingangsdaten (CSV) | Interaktive Ergebnistabelle | +|----------|---------------------|-----------------------------| +| Bad Aussee | [CSV](../brute-force/simulation_results_optimisation_BadAussee.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_BadAussee.html) | +| Eisenstadt 2005 | [CSV](../brute-force/simulation_results_optimisation_Eisenstadt_2005.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_Eisenstadt_2005.html) | +| Wien | [CSV](../brute-force/simulation_results_optimisation_Wien.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_Wien.html) | + +```{r report_link, echo = FALSE, results = 'asis', eval = !is_ghactions} +cat(paste0( + "Der zusammenfassende, allgemeinverständliche Ergebnisbericht (Artefakt, ", + "Titel: „Monotonie-Analyse RAINDROP“) liegt als [index.html](index.html) ", + "direkt neben dieser Seite — als Verzeichnis-Startseite von ", + "`…/optimisation/monotonicity_analysis/`. Nicht zu verwechseln mit dem ", + "„Brute-Force“-Linkhub: Dessen Quelle `index.Rmd` liegt in `vignettes/`, ", + "sein gerendertes `index.html` eine Ebene über dieser Seite.\n" +)) +``` + +```{r libraries, eval = results_available, message = FALSE} +library(dplyr) +library(ggplot2) + +geom_params <- c("mulde_area", "mulde_height", "filter_hydraulicconductivity", + "storage_type", "storage_height") +check_params <- setdiff(geom_params, "storage_type") + +results <- lapply(result_files, function(f) { + readr::read_csv(f, show_col_types = FALSE) %>% + # Die Engine liefert die Ueberlaufrate in mm/h bezogen auf die + # Muldenflaeche; sum_overflows ist damit mm Wassersaeule. + # Volumen: m3 = mm x Muldenflaeche / 1000. + mutate(overflow_volume_m3 = sum_overflows * mulde_area / 1000) +}) + +# Alle Nachbarschritte entlang eines Parameters: alle uebrigen Parameter +# fixieren ("Gruppe"), nach dem Parameter sortieren, jeden Uebergang zum +# Nachbarwert als Schritt ausgeben. Verletzung :<=> dn > 0. +step_table <- function(d, v) { + grp <- setdiff(geom_params, v) + d %>% + group_by(across(all_of(grp))) %>% + arrange(.data[[v]], .by_group = TRUE) %>% + mutate(val_from = lag(.data[[v]]), + val_to = .data[[v]], + n_from = lag(n_overflows), + vol_from = lag(overflow_volume_m3), + et_from = lag(element.WB_Evapotranspiration_), + is_last = row_number() == n()) %>% + ungroup() %>% + filter(!is.na(val_from)) %>% + mutate(dn = n_overflows - n_from, + dvol = overflow_volume_m3 - vol_from, + det = element.WB_Evapotranspiration_ - et_from) +} + +steps_all <- purrr::map_dfr(names(results), function(site) { + purrr::map_dfr(check_params, function(v) { + step_table(results[[site]], v) %>% mutate(site = site, param = v) + }) +}) +``` + +## 1 Schrittverteilung: fällt, Plateau oder steigt? + +Plateaus (keine Änderung) sind unkritisch — sie sind die flachen Stufen der +Treppenfunktion und entstehen vor allem dort, wo bereits n = 0 +erreicht ist. Kritisch sind nur Anstiege ("mehr Überläufe trotz größer"). + +```{r step_distribution, eval = results_available} +step_distribution <- steps_all %>% + group_by(site, param) %>% + summarise(steps = n(), + faellt = sum(dn < 0), + plateau = sum(dn == 0), + steigt = sum(dn > 0), + steigt_anteil_pct = round(100 * mean(dn > 0), 2), + max_sprung = max(dn), + .groups = "drop") + +knitr::kable(step_distribution) +``` + +## 2 Die Verletzungen im Detail + +Jede Verletzung wird mit ihrer Volumen-Gegenprobe (in m³) gezeigt: Fällt das +Überlaufvolumen am selben Schritt weiter, ist der Anstieg des Zählers ein +Artefakt der Ereignistrennung (Pausen > 4 h teilen ein langes +Überlaufereignis in zwei gezählte), keine echte Verschlechterung. + +```{r violations, eval = results_available} +violations <- steps_all %>% + filter(dn > 0) %>% + transmute(site, param, + kontext = paste0("h_m ", mulde_height, + " | kf ", filter_hydraulicconductivity, + " | ", storage_type, + ifelse(param == "storage_height", "", + paste0(" ", storage_height))), + von = val_from, nach = val_to, + n = paste0(n_from, " → ", n_overflows), + volumen_m3 = paste0(round(vol_from, 1), " → ", + round(overflow_volume_m3, 1)), + volumen_delta_pct = round(100 * dvol / vol_from, 1), + am_rasterrand = is_last) + +DT::datatable(violations, filter = "top", + options = list(pageLength = 25, autoWidth = TRUE)) +``` + +Zur Anschauung dieselbe Bauweise an allen drei Standorten (Muldentiefe +300 mm, kf 360 mm/h, Sickerbox 300 mm): Der Zähler fällt +überall steil — nur in Bad Aussee springt er am letzten Rasterschritt von +1 auf 2 (roter Punkt), während das Volumen auch dort weiter fällt. + +```{r example_series, eval = results_available, warning = FALSE} +example_series <- purrr::map_dfr(names(results), function(site) { + results[[site]] %>% + filter(mulde_height == 300, filter_hydraulicconductivity == 360, + storage_type == "infiltration_box", storage_height == 300) %>% + arrange(mulde_area) %>% + mutate(site = site, + verletzung = n_overflows > lag(n_overflows, default = Inf)) +}) + +ggplot(example_series, aes(mulde_area, n_overflows)) + + geom_line(colour = "grey50") + + geom_point(aes(colour = verletzung), size = 2, show.legend = FALSE) + + scale_colour_manual(values = c(`FALSE` = "steelblue4", `TRUE` = "firebrick")) + + scale_y_sqrt() + + facet_wrap(~ site, scales = "free_y") + + labs(title = "Ueberlaufereignisse je Muldenflaeche (Wurzel-Skala)", + x = "Muldenflaeche [m2]", y = "Anzahl Ueberlaufereignisse") + + theme_bw() + +ggplot(example_series, aes(mulde_area, overflow_volume_m3)) + + geom_line(colour = "grey50") + + geom_point(colour = "springgreen4", size = 2) + + scale_y_sqrt() + + facet_wrap(~ site, scales = "free_y") + + labs(title = "Ueberlaufvolumen je Muldenflaeche (Wurzel-Skala): faellt ausnahmslos", + x = "Muldenflaeche [m2]", y = "Ueberlaufvolumen [m3]") + + theme_bw() +``` + +## 3 Gegenprobe: das Überlaufvolumen (m³) + +Auch in m³ gerechnet (mm Wassersäule × Muldenfläche / 1000 — entlang der +Fläche wächst der Umrechnungsfaktor mit, die Monotonie ist also nicht +automatisch übertragbar) gilt das Ergebnis: + +```{r volume, eval = results_available} +volume_check <- steps_all %>% + group_by(site) %>% + summarise(steps = n(), + volumen_steigt = sum(dvol > 1e-9), + plateau = sum(abs(dvol) <= 1e-9), + volumen_faellt = sum(dvol < -1e-9), + .groups = "drop") + +knitr::kable(volume_check) +``` + +## 4 Verdunstung: hängt nur an der Fläche + +```{r et, eval = results_available} +et_check <- steps_all %>% + group_by(site, param) %>% + summarise(steigt_pct = round(100 * mean(det > 1e-9), 1), + flach_pct = round(100 * mean(abs(det) <= 1e-9), 1), + faellt_pct = round(100 * mean(det < -1e-9), 1), + .groups = "drop") + +knitr::kable(et_check) +``` + +Konsequenz für das Sekundärziel "Verdunstung maximieren": Der Trade-off +Kosten ↔ Verdunstung verläuft eindimensional entlang der +Muldenfläche — mehr Verdunstung gibt es nur über mehr Fläche. + +## 5 Ambiguitätsband und Schwellentreppe + +Für die Bisektion relevant: Gibt es Konfigurationsgruppen, in denen oberhalb +der ersten zulässigen Fläche wieder eine unzulässige liegt (Ambiguitätsband)? +Und ist die Schwellentreppe a*(x) — die kleinste zulässige Fläche je +Überlaufziel x — monoton (ein lockereres Ziel verlangt nie mehr Fläche)? + +```{r ambiguity, eval = results_available} +grp_area <- setdiff(geom_params, "mulde_area") + +ambiguity <- purrr::map_dfr(names(results), function(site) { + purrr::map_dfr(0:5, function(x) { + results[[site]] %>% + group_by(across(all_of(grp_area))) %>% + summarise(first_ok = ifelse(any(n_overflows <= x), + min(mulde_area[n_overflows <= x]), NA), + last_bad = ifelse(any(n_overflows > x), + max(mulde_area[n_overflows > x]), NA), + .groups = "drop") %>% + summarise(site = site, x = x, + gruppen = n(), + mit_loesung = sum(!is.na(first_ok)), + ambig = sum(!is.na(first_ok) & !is.na(last_bad) & + last_bad > first_ok), + max_band_m2 = max(c(0, (last_bad - first_ok)[ + !is.na(first_ok) & !is.na(last_bad)]), na.rm = TRUE)) + }) +}) + +knitr::kable(ambiguity) + +staircase <- purrr::map_dfr(names(results), function(site) { + results[[site]] %>% + group_by(across(all_of(grp_area))) %>% + reframe(x = 0:5, + a_star = sapply(0:5, function(x) + ifelse(any(n_overflows <= x), + min(mulde_area[n_overflows <= x]), NA))) %>% + group_by(across(all_of(grp_area))) %>% + summarise(treppen_verletzungen = { + a <- a_star[order(x)] + a <- a[!is.na(a)] + if (length(a) > 1) sum(diff(a) > 0) else 0L + }, .groups = "drop") %>% + summarise(site = site, branches = n(), + treppen_verletzungen = sum(treppen_verletzungen)) +}) + +knitr::kable(staircase) +``` + +## 6 kf-Dominanz: der Filter ist ein Gratis-Hebel + +Die Filterdurchlässigkeit kostet nichts (sie taucht in `compute_costs()` +nicht auf). Wenn sie gleichzeitig die Verdunstung nicht verändert und die +Überläufe nie erhöht, kann der Optimierer sie fest auf das Maximum setzen. + +```{r kf_dominance, eval = results_available} +kf_dominance <- purrr::map_dfr(names(results), function(site) { + results[[site]] %>% + group_by(filter_hydraulicconductivity) %>% + summarise(site = site, + mittlere_ET_pct = round(mean(element.WB_Evapotranspiration_), 2), + mittlere_n_overflows = round(mean(n_overflows), 1), + mittleres_volumen_m3 = round(mean(overflow_volume_m3), 1), + .groups = "drop") +}) + +knitr::kable(kf_dominance) +``` + +## 7 Warmstart: billigstes zulässiges Raster-Design je Ziel x + +Diese Tabelle ist der Startpunkt der Bisektion: das jeweils günstigste +zulässige Design aus dem vorhandenen Raster (bei kf = Maximum), je +Überlaufziel x und Speichertyp. Der Optimierer verfeinert nur noch im +25-m²-Bracket darunter. + +```{r warmstart, eval = results_available} +warmstart <- purrr::map_dfr(names(results), function(site) { + d <- results[[site]] %>% + filter(filter_hydraulicconductivity == max(filter_hydraulicconductivity)) + purrr::map_dfr(0:5, function(x) { + d %>% + filter(n_overflows <= x) %>% + group_by(storage_type) %>% + slice_min(cost_total, n = 1, with_ties = FALSE) %>% + ungroup() %>% + transmute(site = site, x = x, storage_type, mulde_area, mulde_height, + storage_height, cost_total, + overflow_volume_m3 = round(overflow_volume_m3, 1), + ET_pct = round(element.WB_Evapotranspiration_, 1)) + }) +}) + +DT::datatable(warmstart, filter = "top", + options = list(pageLength = 12, autoWidth = TRUE)) +``` + +## Fazit: Regeln für den Optimierer + +Stand der letzten vollständigen Auswertung (2026-07-10): 5 112 +Vergleichspaare, 13 Verletzungen (0,25 %), alle mit Sprunghöhe genau +1 +und fallendem Volumen — Eisenstadt 0, Wien 1 (bei n ≈ 287, +irrelevant für x ≤ 5), Bad Aussee 12 (alle am Rasterrand +175 → 200 m², Niveau n = 1). Das +Überlaufvolumen stieg in keinem einzigen Vergleich. **Die +Monotonie-Voraussetzung der Bisektion ist damit erfüllt**, abgesichert durch +drei Regeln: + +1. **Grid-Warmstart:** Bisektion nur im 25-m²-Bracket um das bekannte + `first_ok` aus dem Raster verfeinern — dort ist die Grenze an allen drei + Standorten eindeutig. +2. **Rand-Guard statt Abbruch:** Fällt der obere Intervallrand nur um +1 + über das Ziel (n = x + 1), erst Cache-/Rasterpunkte darunter + prüfen, bevor "keine Lösung" gemeldet wird. +3. **Volumen als Schiedsrichter:** Bei jedem nicht-monotonen Flip prüfen, ob + `sum_overflows` weiter gefallen ist. Ja → bekannter Zähl-Wobble, + weiterrechnen. Nein → Warnung (bisher nie aufgetreten) — der eingebaute + Rauchmelder für künftige Standorte. + +Beim Hinzufügen eines neuen Standorts: Workflows laufen lassen und diese +Vignette erneut rendern. Zeigt Abschnitt 1 Sprünge > +1 oder Abschnitt 3 +steigendes Volumen, ist die Bisektion für diesen Standort nicht abgesichert. + +```{r export, eval = results_available, message = FALSE} +save_table_html <- function(df, file, title) { + htmlwidgets::saveWidget( + DT::datatable(df, filter = "top", + options = list(pageLength = 25, autoWidth = TRUE)), + file = file, selfcontained = TRUE, title = title + ) + # saveWidget() laesst bei Zielpfaden ausserhalb des Arbeitsverzeichnisses + # den "_files"-lib-Ordner stehen, obwohl die Datei selfcontained + # ist -> redundante Duplikate aufraeumen. + unlink(sub("\\.html$", "_files", file), recursive = TRUE) +} + +exports <- list( + mono_step_distribution = list(df = step_distribution, + titel = "Monotonie: Schrittverteilung"), + mono_violations_detail = list(df = violations, + titel = "Monotonie: Verletzungen im Detail"), + mono_volume = list(df = volume_check, + titel = "Monotonie: Ueberlaufvolumen (m3)"), + mono_et = list(df = et_check, + titel = "Monotonie: Verdunstung"), + mono_ambiguity = list(df = ambiguity, + titel = "Ambiguitaetsband je Ziel x"), + mono_staircase = list(df = staircase, + titel = "Schwellentreppe a*(x)"), + mono_kf_dominance = list(df = kf_dominance, + titel = "kf-Dominanz"), + mono_warmstart_designs = list(df = warmstart, + titel = "Warmstart-Designs") +) + +# Exporte in den Unterordner des Ergebnisberichts (index.html), damit der +# gesamte Ordner monotonicity_analysis/ als eine Einheit deploybar ist. +out_dir <- "monotonicity_analysis" +dir.create(out_dir, showWarnings = FALSE) + +for (name in names(exports)) { + readr::write_csv(exports[[name]]$df, file.path(out_dir, paste0(name, ".csv"))) + save_table_html(exports[[name]]$df, file.path(out_dir, paste0(name, ".html")), + title = exports[[name]]$titel) +} + +# Den Rmd-Quellcode mit in den Deploy-Ordner kopieren, damit der Link +# "monotonicity_analysis.Rmd" des Ergebnisberichts (index.html) dort +# funktioniert. +invisible(file.copy("monotonicity_analysis.Rmd", + file.path(out_dir, "monotonicity_analysis.Rmd"), + overwrite = TRUE)) +``` + +Die exportierten Detailtabellen liegen neben dieser Seite (im Unterordner +`monotonicity_analysis/`), jeweils als CSV und als interaktive +HTML-Tabelle: + +| Tabelle | Inhalt | CSV | HTML | +|---------|--------|-----|------| +| Schrittverteilung | fällt / Plateau / steigt je Standort × Parameter | [CSV](mono_step_distribution.csv) | [HTML](mono_step_distribution.html) | +| Verletzungen | alle 13 Fälle mit Volumen-Gegenprobe (m³) | [CSV](mono_violations_detail.csv) | [HTML](mono_violations_detail.html) | +| Überlaufvolumen | Monotonie des Volumens in m³ | [CSV](mono_volume.csv) | [HTML](mono_volume.html) | +| Verdunstung | ET-Richtung je Parameter | [CSV](mono_et.csv) | [HTML](mono_et.html) | +| Ambiguitätsband | Eindeutigkeit der Zulässigkeitsgrenze je Ziel x | [CSV](mono_ambiguity.csv) | [HTML](mono_ambiguity.html) | +| Schwellentreppe | Monotonie von a*(x) je Branch | [CSV](mono_staircase.csv) | [HTML](mono_staircase.html) | +| kf-Dominanz | ET / Überläufe / Volumen je kf-Stufe | [CSV](mono_kf_dominance.csv) | [HTML](mono_kf_dominance.html) | +| Warmstart-Designs | billigstes zulässiges Raster-Design je x und Speichertyp | [CSV](mono_warmstart_designs.csv) | [HTML](mono_warmstart_designs.html) | From b76ab38aa3371affebf4a4b7bbebc52b318e0e00 Mon Sep 17 00:00:00 2001 From: mrustl Date: Fri, 10 Jul 2026 16:38:16 +0100 Subject: [PATCH 15/34] First optimsation approach --- DESCRIPTION | 4 +- NAMESPACE | 8 + NEWS.md | 64 +++++ R/cost_tooltip.R | 4 +- R/find_min_feasible.R | 196 +++++++++++++ R/make_swale_runner.R | 188 +++++++++++++ R/optimise_swale_design.R | 282 +++++++++++++++++++ R/read_site_timeseries.R | 83 ++++++ R/stack_levels.R | 115 ++++++++ man/default_storage_spec.Rd | 32 +++ man/default_storage_types.Rd | 18 ++ man/find_min_feasible.Rd | 83 ++++++ man/make_swale_runner.Rd | 74 +++++ man/optimise_swale_design.Rd | 83 ++++++ man/read_site_timeseries.Rd | 35 +++ man/sickerbox_level_presets.Rd | 23 ++ man/stack_levels.Rd | 31 +++ tests/testthat.R | 4 + tests/testthat/test-find_min_feasible.R | 87 ++++++ tests/testthat/test-optimise_swale_design.R | 129 +++++++++ tests/testthat/test-stack_levels.R | 22 ++ vignettes/workflow_optimisation.Rmd | 293 ++++++++++++++++++++ 22 files changed, 1855 insertions(+), 3 deletions(-) create mode 100644 R/find_min_feasible.R create mode 100644 R/make_swale_runner.R create mode 100644 R/optimise_swale_design.R create mode 100644 R/read_site_timeseries.R create mode 100644 R/stack_levels.R create mode 100644 man/default_storage_spec.Rd create mode 100644 man/default_storage_types.Rd create mode 100644 man/find_min_feasible.Rd create mode 100644 man/make_swale_runner.Rd create mode 100644 man/optimise_swale_design.Rd create mode 100644 man/read_site_timeseries.Rd create mode 100644 man/sickerbox_level_presets.Rd create mode 100644 man/stack_levels.Rd create mode 100644 tests/testthat.R create mode 100644 tests/testthat/test-find_min_feasible.R create mode 100644 tests/testthat/test-optimise_swale_design.R create mode 100644 tests/testthat/test-stack_levels.R create mode 100644 vignettes/workflow_optimisation.Rmd diff --git a/DESCRIPTION b/DESCRIPTION index 56be511..3f6e263 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,9 +41,11 @@ Suggests: plotly, readr, rmarkdown, + testthat (>= 3.0.0), writexl -VignetteBuilder: +VignetteBuilder: knitr +Config/testthat/edition: 3 Remotes: github::kwb-r/kwb.event, github::kwb-r/kwb.utils diff --git a/NAMESPACE b/NAMESPACE index 6e8323e..08ebe14 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,7 +7,10 @@ export(cost_rates_caption) export(default_canonical_wb_variables) export(default_cost_rates) export(default_param_labels) +export(default_storage_spec) +export(default_storage_types) export(download_engine) +export(find_min_feasible) export(find_single_param_variations) export(get_simulation_results_all) export(get_simulation_results_optim) @@ -18,6 +21,8 @@ export(h5_read_values) export(h5_validate_write) export(h5_write_values) export(list_h5_datasets) +export(make_swale_runner) +export(optimise_swale_design) export(plot_cost_overflow_boxplot) export(plot_cost_vs_evaporation) export(plot_cost_vs_overflow_volume) @@ -31,8 +36,11 @@ export(read_hdf5_connections) export(read_hdf5_scalars) export(read_hdf5_timeseries) export(read_raindrop_errors) +export(read_site_timeseries) export(run_model) export(run_scenarios) +export(sickerbox_level_presets) +export(stack_levels) importFrom(dplyr,"%>%") importFrom(dplyr,across) importFrom(dplyr,all_of) diff --git a/NEWS.md b/NEWS.md index 3f6bb77..fd71f28 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,70 @@ ## New features +* New **swale-design optimiser** — finds the cost-minimal design per + overflow target (`n_overflows <= x`) with roughly ten engine runs per + (storage type, target) cell instead of a full factorial sweep, at finer + resolution (2 m² / 10 mm instead of 25 m² / 100 mm grid steps): + - `find_min_feasible()` — the single primitive everything is built + from: bisection for the smallest feasible value of one design + parameter, over continuous bounds (`lower`/`upper`/`tol`) or discrete + stack `levels` (binary search). Evaluations are memoised and two + safety rules from the monotonicity analysis are built in: an **edge + guard** for the +1 event-counting wobble of the 4-h event separation + (a descending ladder below an "infeasible by exactly one event" upper + edge, so the Bad Aussee 175-m²-feasible/200-m²-infeasible pattern + cannot eat a solution) and a **volume referee** that warns — and + flags the result — iff the overflow count *and* the overflow volume + increase together (real non-monotonicity; never observed in the + 5 112 validation comparisons). + - `optimise_swale_design()` — coordinate descent in cost order: shrink + `mulde_area` (the expensive lever) first, then `mulde_height` (the + cheap one); the storage layer starts at its smallest level and is + escalated only when the area is stuck at its upper bound. One shared + evaluation cache spans all `x_targets` and both storage types (a run + classifies itself for every target at once), warm-start brackets are + derived from prior brute-force results (CSV schema of the + workflows), `max_total_depth` adds an analytic depth constraint + (DWA-A 138 groundwater clearance / cover requirements) that costs no + simulation runs, and "infeasible within bounds" is a regular result + status, not an error. Costs are attached via `compute_costs()`; all + evaluated designs ship as attribute `"evaluations"`. + - `make_swale_runner()` — package-level refactoring of the `run_one()` + function previously duplicated across the three case-study + vignettes: one closure factory covering both variants (Eisenstadt: + `base.h5` rain curve scaled by `rain_factor`; Wien / Bad Aussee: own + rain + ET0 series in mm/h incl. the Growth/Shading end-time fix). + Returns the thinned one-row optimisation result augmented with + `overflow_volume_m3` (= `sum_overflows` [mm] × `mulde_area` / 1000). + - `stack_levels()`, `sickerbox_level_presets()`, + `default_storage_spec()`, `default_storage_types()` — storage-layer + search spaces: achievable stack heights from module heights (incl. + mixed combinations such as Rigofill full + half block), manufacturer + presets (GRAF, Fränkische, ACO, Wavin; verify against data sheets + before productive runs) with the brute-force grid levels + 300/600/900/1200 mm as the default, and the gravel-trench range + coupled at 3 × the box range (usable-porosity ratio 0.95 / 0.3). + +* New conditional vignette `monotonicity_analysis` — validates the + optimiser's core assumption on the three brute-force result sets + (5 112 neighbour comparisons): `n_overflows` is quasi-monotone in + every design parameter (13 violations, all +1 counting artefacts of + the 4-h event separation), the overflow volume (in m³) is monotone + without exception, ET depends on `mulde_area` only, and the filter + conductivity is a cost-free dominant lever (fix at maximum). Renders + after the three workflow vignettes into + `vignettes/monotonicity_analysis/` (deploy unit with the plain-language + report `index.html` and the exported `mono_*` detail tables as CSV + + interactive HTML). + +* **testthat suite added** (edition 3; `tests/testthat/`): unit tests for + the bisection primitive (threshold accuracy, run counts, wobble guard, + volume referee, discrete levels) and end-to-end optimiser tests + against a synthetic monotone hydraulic model, verified against a fine + brute-force reference (cost within 5 %, monotone cost-effectiveness + curve, storage escalation, infeasibility handling, warm-start + savings, `max_total_depth`). + * New exported plot `plot_cost_vs_evaporation()` — third cost view: scatters `cost_total` (EUR, x) against the element evapotranspiration share (`element.WB_Evapotranspiration_`, %, y). Points share the diff --git a/R/cost_tooltip.R b/R/cost_tooltip.R index cb492ec..00de3da 100644 --- a/R/cost_tooltip.R +++ b/R/cost_tooltip.R @@ -250,7 +250,7 @@ storage_type_shapes <- function(storage_type, lang = c("de", "en")) { ) } -#' Usable storage volume of the storage layer [m3] per row +#' Usable storage volume of the storage layer (m3) per row #' #' Area x height x usable porosity (thetaS - thetaFC) of the storage type. #' Taken from a precomputed `storage_volume_m3` column when available, @@ -282,7 +282,7 @@ storage_volume_from_df <- function(df) { #' @param df Data frame with the columns listed above. #' @param tt Label list from `cost_tooltip_labels()`. #' @param digits Integer. Rounding for the numeric tooltip values. -#' @param evap_min Numeric. Minimum element evapotranspiration share [%] of +#' @param evap_min Numeric. Minimum element evapotranspiration share (%) of #' the complete model run — the reference for the cost-per-percent line. #' `NULL` falls back to the minimum within `df` (identical as long as `df` #' is unfiltered). diff --git a/R/find_min_feasible.R b/R/find_min_feasible.R new file mode 100644 index 0000000..ef6c228 --- /dev/null +++ b/R/find_min_feasible.R @@ -0,0 +1,196 @@ +#' Smallest feasible parameter value via bisection (monotone threshold search) +#' +#' Core building block of the swale-design optimiser: finds the smallest +#' value of one design parameter for which the overflow target is met +#' (`n_overflows <= x_max`), assuming quasi-monotone feasibility (larger +#' value = never more overflows; verified for the RAINDROP model in the +#' `monotonicity_analysis` vignette). Each evaluation halves the search +#' interval, so `ceiling(log2(range / tol))` evaluations suffice. +#' +#' Two safety rules from the monotonicity analysis are built in: +#' \itemize{ +#' \item \strong{Edge guard}: if the upper bound is infeasible by no more +#' than `wobble` events (the +1 counting artefact of the 4-h event +#' separation), a descending ladder below the edge searches for a +#' feasible anchor before the branch is declared infeasible. +#' \item \strong{Volume referee}: whenever `n_overflows` increases with +#' the parameter (a counting flip), the overflow volume must have +#' decreased; if the volume increased as well, a warning is emitted and +#' `monotonicity_violation` is set (real non-monotonicity -- never +#' observed at the three validation sites). +#' } +#' +#' @param evaluate `function(value)` returning a list / one-row data.frame +#' with at least `n_overflows`; if it also contains `volume_column`, the +#' volume referee is active. Evaluations are memoised per value. +#' @param x_max Feasibility target: feasible iff `n_overflows <= x_max`. +#' @param lower,upper Numeric search bounds (continuous mode). +#' @param tol Resolution of the continuous search (same unit as the value). +#' @param levels Sorted numeric vector of discrete candidate values +#' (discrete mode, e.g. Sickerbox stack heights). If given, `lower`, +#' `upper` and `tol` are ignored and a binary search over the levels is +#' performed. +#' @param wobble Maximum counting-artefact size tolerated by the edge guard +#' (default 1, matching the observed +1 flips). +#' @param volume_column Name of the volume element in the `evaluate` result +#' used by the volume referee (default `"overflow_volume_m3"`). +#' @param verbose Print one line per evaluation. +#' +#' @return List with +#' \describe{ +#' \item{value}{smallest feasible value, or `NA` if infeasible} +#' \item{n_overflows}{overflow count at `value`} +#' \item{status}{`"ok"`, `"at_lower_bound"` (already feasible at the lower +#' end -- caller may widen the bracket) or `"infeasible"`} +#' \item{evaluations}{tibble of all evaluated values (value, n_overflows, +#' volume), sorted by value} +#' \item{n_evaluations}{number of distinct evaluations} +#' \item{monotonicity_violation}{`TRUE` if the volume referee fired} +#' } +#' +#' @examples +#' # synthetic monotone step function: feasible from 137.4 m2 on +#' f <- function(v) list(n_overflows = if (v >= 137.4) 0L else 10L) +#' find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2)$value +#' +#' @export +find_min_feasible <- function(evaluate, + x_max, + lower = NULL, + upper = NULL, + tol = 1, + levels = NULL, + wobble = 1L, + volume_column = "overflow_volume_m3", + verbose = FALSE) { + + discrete <- !is.null(levels) + if (discrete) { + grid <- sort(unique(levels)) + axis_lo <- 0 # virtual: below the smallest level + axis_hi <- length(grid) + axis_tol <- 1 + to_value <- function(i) grid[[i]] + } else { + stopifnot(is.numeric(lower), is.numeric(upper), upper > lower, tol > 0) + axis_lo <- lower + axis_hi <- upper + axis_tol <- tol + to_value <- identity + } + + evals <- new.env(parent = emptyenv()) + eval_at <- function(axis_pos) { + v <- to_value(axis_pos) + key <- format(v, digits = 15) + if (!is.null(evals[[key]])) return(evals[[key]]) + res <- as.list(evaluate(v)) + if (!"n_overflows" %in% names(res)) { + stop("find_min_feasible(): evaluate() must return an element 'n_overflows'") + } + row <- list( + value = v, + n_overflows = as.numeric(res$n_overflows), + volume = if (volume_column %in% names(res)) { + as.numeric(res[[volume_column]]) + } else { + NA_real_ + } + ) + assign(key, row, envir = evals) + if (isTRUE(verbose)) { + message(sprintf(" eval %s -> n_overflows = %s", + format(v), format(row$n_overflows))) + } + row + } + feasible <- function(axis_pos) { + n <- eval_at(axis_pos)$n_overflows + !is.na(n) && n <= x_max + } + + status <- "ok" + + # 1) Upper edge: with monotone feasibility the whole range is infeasible + # if the upper edge is -- unless the edge is a +1 counting wobble, in + # which case a descending ladder looks for a feasible anchor below. + if (!feasible(axis_hi)) { + n_hi <- eval_at(axis_hi)$n_overflows + anchor <- NA_real_ + if (!is.na(n_hi) && n_hi <= x_max + wobble) { + offset <- axis_tol + repeat { + p <- axis_hi - offset + if (discrete) p <- ceiling(p) + if (p <= axis_lo) break + if (feasible(p)) { + anchor <- p + break + } + offset <- offset * 2 + } + } + if (is.na(anchor)) { + status <- "infeasible" + } else { + axis_hi <- anchor + } + } + + # 2) Bisection: invariant lo infeasible (or virtual/edge), hi feasible. + best <- NA_real_ + if (!identical(status, "infeasible")) { + lo <- axis_lo + hi <- axis_hi + if (!discrete && feasible(lo)) { + hi <- lo # optimum at (or below) the lower end + } + while ((hi - lo) > axis_tol) { + mid <- (lo + hi) / 2 + if (discrete) mid <- floor(mid) + if (mid <= lo || mid >= hi) break + if (feasible(mid)) hi <- mid else lo <- mid + } + best <- hi + at_lower <- if (discrete) best <= 1 else best <= axis_lo + if (at_lower) status <- "at_lower_bound" + } + + # 3) Volume referee over all evaluations of this search + ev <- do.call(rbind, lapply(ls(evals), function(k) { + e <- get(k, envir = evals) + data.frame(value = e$value, n_overflows = e$n_overflows, + volume = e$volume) + })) + ev <- ev[order(ev$value), , drop = FALSE] + rownames(ev) <- NULL + monotonicity_violation <- FALSE + if (nrow(ev) >= 2) { + dn <- diff(ev$n_overflows) + dv <- diff(ev$volume) + flips <- which(!is.na(dn) & dn > 0) + real <- flips[!is.na(dv[flips]) & dv[flips] > 1e-9] + if (length(real) > 0) { + monotonicity_violation <- TRUE + warning(sprintf( + paste0("find_min_feasible(): n_overflows AND overflow volume ", + "increase between value %s and %s -- real non-monotonicity, ", + "bisection result unreliable for this branch."), + format(ev$value[real[1]]), format(ev$value[real[1] + 1]) + ), call. = FALSE) + } + } + + list( + value = if (identical(status, "infeasible")) NA_real_ else to_value(best), + n_overflows = if (identical(status, "infeasible")) { + NA_real_ + } else { + eval_at(best)$n_overflows + }, + status = status, + evaluations = tibble::as_tibble(ev), + n_evaluations = nrow(ev), + monotonicity_violation = monotonicity_violation + ) +} diff --git a/R/make_swale_runner.R b/R/make_swale_runner.R new file mode 100644 index 0000000..ab766aa --- /dev/null +++ b/R/make_swale_runner.R @@ -0,0 +1,188 @@ +#' Capillary suction from hydraulic conductivity (Rawls fit) +#' +#' Suction head Psi_s in mm as a function of the saturated hydraulic +#' conductivity in mm/h, as used by the workflow vignettes. +#' +#' @param kf_mmh Saturated hydraulic conductivity in mm/h. +#' @return Suction head in mm. +#' @keywords internal +#' @noRd +psi_s_mm <- function(kf_mmh) { + (3.237 * (kf_mmh / 25.4)^(-0.328)) * 25.4 +} + +#' Create a site-specific single-scenario runner for the optimiser +#' +#' Factors the `run_one()` function that was duplicated across the three +#' workflow vignettes (Eisenstadt 2005, Wien, Bad Aussee) into one +#' package-level closure factory. The returned function runs the RAINDROP +#' engine for one parameter set and returns the thinned one-row +#' optimisation result (overflow events + water balance), augmented with +#' the input parameters and the overflow volume in m3. +#' +#' Site differences are covered by the arguments: Eisenstadt scales the +#' rain curve shipped in `base.h5` by `rain_factor` (leave +#' `timeseries_rain` = `NULL`), Wien and Bad Aussee replace the rain and +#' ET0 curves entirely (`timeseries_rain` / `timeseries_et`, values in +#' mm/h as written by the vignettes). +#' +#' @param path_list Path definition list as used by the workflow vignettes +#' (resolvable with `kwb.utils::resolve()`, must contain `path_base`, +#' `path_exe`, `dir_input`, `dir_output`, `dir_target_output`, +#' `path_target_input`, `path_results_hdf5_element`, +#' `path_results_hdf5_flaeche`, `file_target`). +#' @param timestep_hours Engine time step in hours (default 0.1). +#' @param timeseries_rain Optional data.frame `time`/`value` (mm/h) written +#' to `//Kurven/Regen`; when given, `//Kurven/Growth_1` and +#' `//Kurven/Shading_1` end times are extended to the rain series end and +#' `rain_factor` is ignored. +#' @param timeseries_et Optional data.frame `time`/`value` (mm/h) written +#' to `//Kurven/ET0`. +#' @param storage_types Soil presets of the storage layer per storage type, +#' see [default_storage_types()]. +#' @param event_separation_hours Event separation for overflow counting +#' (default 4, as in the vignettes and the monotonicity analysis). +#' @param scenario_prefix Prefix for generated scenario names (default +#' `"o"` -> `o00001`, `o00002`, ... -- distinct from the grid runs +#' `s00001` ...). +#' @param debug Passed on to the engine/reader helpers. +#' +#' @return `function(params)` where `params` is a named list (or one-row +#' data.frame) with `mulde_area`, `mulde_height` (mm), `storage_type`, +#' `storage_height` (mm), `connected_area` (m2), `filter_height` (mm), +#' `filter_hydraulicconductivity` (mm/h), `bottom_hydraulicconductivity` +#' (mm/h) and optionally `rain_factor` (default 1) and `lai` +#' (default 3.9). It returns a one-row tibble with the parameters, the +#' scenario name and the optimisation metrics (`n_overflows`, +#' `sum_overflows` in mm, `overflow_volume_m3`, water-balance shares). +#' +#' @seealso [optimise_swale_design()], [find_min_feasible()] +#' @export +make_swale_runner <- function(path_list, + timestep_hours = 0.1, + timeseries_rain = NULL, + timeseries_et = NULL, + storage_types = default_storage_types(), + event_separation_hours = 4, + scenario_prefix = "o", + debug = FALSE) { + + counter <- 0L + + function(params) { + params <- as.list(params) + required <- c("mulde_area", "mulde_height", "storage_type", + "storage_height", "connected_area", "filter_height", + "filter_hydraulicconductivity", + "bottom_hydraulicconductivity") + missing <- setdiff(required, names(params)) + if (length(missing) > 0) { + stop("make_swale_runner(): params is missing: ", + paste(missing, collapse = ", ")) + } + st <- storage_types[[params$storage_type]] + if (is.null(st)) { + stop("make_swale_runner(): unknown storage_type '", + params$storage_type, "'") + } + rain_factor <- if (is.null(params$rain_factor)) 1 else params$rain_factor + lai <- if (is.null(params$lai)) 3.9 else params$lai + + counter <<- counter + 1L + s_name <- sprintf("%s%05d", scenario_prefix, counter) + paths <- kwb.utils::resolve(path_list, dir_target = s_name) + + fs::dir_create(paths$dir_input, recurse = TRUE) + fs::dir_create(paths$dir_output, recurse = TRUE) + fs::dir_create(paths$dir_target_output, recurse = TRUE) + + fs::file_copy(path = paths$path_base, + new_path = paths$path_target_input, + overwrite = TRUE) + + h5 <- hdf5r::H5File$new(paths$path_target_input, mode = "a") + on.exit(try(h5$close_all(), silent = TRUE), add = TRUE) + + new_path <- stringr::str_c( + normalizePath(fs::path_abs(paths$dir_target_output)), "\\" + ) + + vals <- h5_read_values(h5) + + vals$`//Berechnungsparameter/Ergebnispfad` <- new_path + vals$`//Berechnungsparameter/Zeitschritt_Infiltration` <- timestep_hours + vals$`//Berechnungsparameter/Zeitschritt_ET` <- timestep_hours + vals$`//Berechnungsparameter/Zeitschritt_Verschaltungen` <- timestep_hours + vals$`//Berechnungsparameter/R-Plots` <- 0 + vals$`//Berechnungsparameter/Ausgabemodus` <- "Optimierung" + vals$`//Berechnungsparameter/Evapotranspiration_aktiv` <- 1 + + vals$`//Massnahmenelemente/Dach/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 + vals$`//Massnahmenelemente/Dach/Allgemein/Flaeche` <- params$connected_area + + vals$`//Massnahmenelemente/Mulde_Rigole/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 + vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 + vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- params$mulde_area + vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- params$mulde_height + vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- + c(0.3, st$Startwerte_theta_ActualSoilMoisture) + vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- + c(params$filter_height, params$storage_height) + vals$`//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` <- st$thetaWP_MoistureAtWiltingPoint + vals$`//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` <- st$thetaFC_MoistureAtFieldCapacity + vals$`//Bodenarten/Speicher/thetaS_MoistureAtSaturation` <- st$thetaS_MoistureAtSaturation + vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- + params$bottom_hydraulicconductivity + vals$`//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` <- lai + + vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- + params$filter_hydraulicconductivity + vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- + psi_s_mm(params$filter_hydraulicconductivity) + + if (!is.null(timeseries_et)) { + vals$`//Kurven/ET0` <- timeseries_et + } + if (!is.null(timeseries_rain)) { + vals$`//Kurven/Regen` <- timeseries_rain + vals$`//Kurven/Growth_1`$time[2] <- max(timeseries_rain$time) + vals$`//Kurven/Shading_1`$time[2] <- max(timeseries_rain$time) + } else if (is.data.frame(vals[["//Kurven/Regen"]])) { + vals[["//Kurven/Regen"]]$value <- + vals[["//Kurven/Regen"]]$value * rain_factor + } + + h5_write_values(h5, vals, resize = TRUE, + scalar_strategy = "error", verbose = FALSE) + h5$close_all() + + run_model(path_exe = paths$path_exe, + path_input = paths$path_target_input, + debug = debug) + + # Thin immediately (lean read), exactly like the vignettes' run_one() + sim_one <- get_simulation_results_optim( + paths = paths, + path_list = path_list, + simulation_names = s_name, + debug = debug, + lean = TRUE + ) + + row <- add_overflow_events_and_waterbalance( + simulation_results = sim_one, + event_separation_hours = event_separation_hours, + canonical_variables = default_canonical_wb_variables() + ) + + dplyr::bind_cols( + tibble::as_tibble(params[required]), + tibble::tibble(rain_factor = rain_factor, lai = lai), + row + ) %>% + dplyr::mutate( + # sum_overflows is mm water column over the swale area + overflow_volume_m3 = .data$sum_overflows * .data$mulde_area / 1000 + ) + } +} diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R new file mode 100644 index 0000000..a5ae954 --- /dev/null +++ b/R/optimise_swale_design.R @@ -0,0 +1,282 @@ +#' Warm-start area bracket from prior (brute-force) results +#' +#' Narrows the mulde_area search interval to one grid step around the +#' cheapest feasible grid cell of the matching branch, if prior results +#' contain it. Falls back to the full bounds otherwise. +#' +#' @keywords internal +#' @noRd +area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { + needed <- c("storage_type", "storage_height", "mulde_height", "mulde_area", + "n_overflows", "filter_hydraulicconductivity") + if (is.null(prior) || !all(needed %in% names(prior))) return(bounds) + kf_max <- suppressWarnings( + max(prior$filter_hydraulicconductivity, na.rm = TRUE) + ) + d <- prior[prior$storage_type == type & + prior$filter_hydraulicconductivity == kf_max & + prior$storage_height == h_s & + prior$mulde_height == h_m, , drop = FALSE] + if (nrow(d) < 2) return(bounds) + ok <- d$mulde_area[!is.na(d$n_overflows) & d$n_overflows <= x] + if (length(ok) == 0) return(bounds) + first_ok <- min(ok) + areas <- sort(unique(d$mulde_area)) + step <- if (length(areas) > 1) min(diff(areas)) else diff(bounds) + lo <- max(bounds[1], first_ok - step) + hi <- min(bounds[2], first_ok) + if (hi <= lo) bounds else c(lo, hi) +} + +#' Find the cost-optimal swale design per overflow target +#' +#' Coordinate-descent optimiser built from a single primitive +#' ([find_min_feasible()], bisection over one parameter): shrink the +#' expensive lever first (`mulde_area`), then the cheap one +#' (`mulde_height`); the storage layer starts at its smallest level and is +#' only escalated when the area is stuck at its upper bound. The filter +#' conductivity is expected to be fixed at the maximum via `fixed` (it is +#' cost-free and dominant, see the `monotonicity_analysis` vignette). Every +#' engine run is cached, so the sweep over all `x_targets` and both storage +#' types shares evaluations. +#' +#' @param run_fn `function(params)` running one scenario and returning at +#' least `n_overflows` plus `sum_overflows` (mm) or `overflow_volume_m3`; +#' typically created with [make_swale_runner()]. `params` is a named list +#' of `mulde_area`, `mulde_height`, `storage_type`, `storage_height` plus +#' everything in `fixed`. +#' @param x_targets Integer vector of overflow targets (feasible :<=> +#' `n_overflows <= x`), default `0:5`. +#' @param area_bounds,area_tol Search range (m2) and resolution for +#' `mulde_area`. +#' @param height_bounds,height_tol Search range (mm) and resolution for +#' `mulde_height`. +#' @param storage_spec Storage search space per type, see +#' [default_storage_spec()]: discrete `levels` (infiltration box) or +#' continuous `bounds` + `tol` (gravel trench). +#' @param fixed Named list of parameters passed unchanged to `run_fn` +#' (connected area, filter geometry, kf at maximum, ...). Must contain +#' `filter_height` for the cost model. +#' @param prior_results Optional data.frame with prior (grid) results in +#' the workflow CSV schema, used as warm start (narrows the first area +#' bracket to one grid step). +#' @param max_total_depth Optional analytic depth constraint in mm: +#' `mulde_height + filter_height + storage_height <= max_total_depth` +#' (e.g. from DWA-A 138 groundwater clearance or cover requirements). +#' Enforced without any simulation runs. +#' @param cost_rates Unit costs, see [default_cost_rates()]. +#' @param verbose Print one progress line per solved cell. +#' +#' @return Tibble with one row per (storage type, x): the optimal design +#' (`mulde_area`, `mulde_height`, `storage_height`), its metrics +#' (`n_overflows`, `overflow_volume_m3`, `et_pct`), cost columns from +#' [compute_costs()], a `status` (`"ok"` or `"infeasible_within_bounds"`), +#' `monotonicity_warning` (volume referee) and `n_runs_new` (fresh engine +#' runs spent on this cell). All evaluated designs are attached as +#' attribute `"evaluations"`. +#' +#' @seealso [find_min_feasible()], [make_swale_runner()], +#' [default_storage_spec()] +#' @export +optimise_swale_design <- function(run_fn, + x_targets = 0:5, + area_bounds = c(25, 200), + area_tol = 2, + height_bounds = c(100, 300), + height_tol = 10, + storage_spec = default_storage_spec(), + fixed = list( + connected_area = 1000, + filter_height = 300, + filter_hydraulicconductivity = 360, + bottom_hydraulicconductivity = 12 + ), + prior_results = NULL, + max_total_depth = NULL, + cost_rates = default_cost_rates(), + verbose = TRUE) { + + stopifnot(is.function(run_fn), !is.null(fixed$filter_height)) + filter_height <- fixed$filter_height + + # --- shared evaluation cache (one engine run per distinct design) ------- + cache <- new.env(parent = emptyenv()) + runs_executed <- 0L + + eval_design <- function(type, area, h_m, h_s) { + key <- paste(type, format(area, digits = 10), format(h_m, digits = 10), + format(h_s, digits = 10), sep = "|") + hit <- cache[[key]] + if (!is.null(hit)) return(hit) + params <- c(list(mulde_area = area, mulde_height = h_m, + storage_type = type, storage_height = h_s), fixed) + res <- as.list(run_fn(params)) + if (!"n_overflows" %in% names(res)) { + stop("optimise_swale_design(): run_fn() must return 'n_overflows'") + } + vol <- res[["overflow_volume_m3"]] + if (is.null(vol) && !is.null(res[["sum_overflows"]])) { + vol <- res[["sum_overflows"]] * area / 1000 # mm x m2 / 1000 = m3 + } + et <- res[["element.WB_Evapotranspiration_"]] + out <- list(storage_type = type, mulde_area = area, mulde_height = h_m, + storage_height = h_s, + n_overflows = as.numeric(res$n_overflows), + overflow_volume_m3 = if (is.null(vol)) NA_real_ else as.numeric(vol), + et_pct = if (is.null(et)) NA_real_ else as.numeric(et)) + runs_executed <<- runs_executed + 1L + assign(key, out, envir = cache) + out + } + + # --- analytic depth constraint ------------------------------------------ + hm_upper <- function(h_s) { + up <- rep(height_bounds[2], length(h_s)) + if (!is.null(max_total_depth)) { + up <- pmin(up, max_total_depth - filter_height - h_s) + } + up + } + + # area search with warm-start bracket; widens the bracket when the + # optimum turns out to lie below it + search_area <- function(eval_a, x, bracket) { + res <- find_min_feasible(eval_a, x_max = x, + lower = bracket[1], upper = bracket[2], + tol = area_tol) + if (identical(res$status, "at_lower_bound") && + bracket[1] > area_bounds[1]) { + res <- find_min_feasible(eval_a, x_max = x, + lower = area_bounds[1], upper = bracket[1], + tol = area_tol) + } + if (identical(res$status, "infeasible") && + bracket[2] < area_bounds[2]) { + # warm start was too optimistic -> retry up to the full upper bound + res <- find_min_feasible(eval_a, x_max = x, + lower = bracket[1], upper = area_bounds[2], + tol = area_tol) + } + res + } + + # --- solve one (storage type, x) cell ------------------------------------ + solve_cell <- function(type, x) { + runs_before <- runs_executed + spec <- storage_spec[[type]] + if (is.null(spec)) { + stop("optimise_swale_design(): storage_spec has no entry '", type, "'") + } + discrete <- !is.null(spec$levels) + mono_warn <- FALSE + + infeasible_row <- function() tibble::tibble( + x = x, storage_type = type, status = "infeasible_within_bounds", + mulde_area = NA_real_, mulde_height = NA_real_, + storage_height = NA_real_, n_overflows = NA_real_, + overflow_volume_m3 = NA_real_, et_pct = NA_real_, + monotonicity_warning = mono_warn, + n_runs_new = runs_executed - runs_before + ) + + if (discrete) { + levels_all <- sort(spec$levels) + levels_all <- levels_all[hm_upper(levels_all) >= height_bounds[1]] + if (length(levels_all) == 0) return(infeasible_row()) + h_s <- levels_all[1] + } else { + gb <- spec$bounds + if (!is.null(max_total_depth)) { + gb[2] <- min(gb[2], max_total_depth - filter_height - height_bounds[1]) + } + if (gb[2] <= gb[1]) return(infeasible_row()) + gravel_tol <- if (is.null(spec$tol)) 25 else spec$tol + h_s <- gb[1] + } + + a_star <- NA_real_ + repeat { + h_m_up <- hm_upper(h_s) + eval_a <- function(a) eval_design(type, a, h_m_up, h_s) + bracket <- area_bracket_from_prior(prior_results, type, h_s, h_m_up, + x, area_bounds) + res_a <- search_area(eval_a, x, bracket) + mono_warn <- mono_warn || res_a$monotonicity_violation + if (!identical(res_a$status, "infeasible")) { + a_star <- res_a$value + break + } + # area stuck at the upper bound -> escalate the storage layer + eval_s <- function(h) eval_design(type, area_bounds[2], hm_upper(h), h) + if (discrete) { + rest <- levels_all[levels_all > h_s] + if (length(rest) == 0) return(infeasible_row()) + res_s <- find_min_feasible(eval_s, x_max = x, levels = rest) + } else { + if (h_s >= gb[2]) return(infeasible_row()) + res_s <- find_min_feasible(eval_s, x_max = x, + lower = h_s, upper = gb[2], + tol = gravel_tol) + } + mono_warn <- mono_warn || res_s$monotonicity_violation + if (identical(res_s$status, "infeasible")) return(infeasible_row()) + h_s <- res_s$value + } + + # shrink the cheap lever last: mulde_height at fixed (a*, h_s). + # A second area pass is provably redundant: a smaller mulde_height + # only weakens the hydraulics, so the minimal feasible area cannot + # decrease any further. + h_m_up <- hm_upper(h_s) + h_m_star <- h_m_up + if (h_m_up > height_bounds[1]) { + res_h <- find_min_feasible( + function(h) eval_design(type, a_star, h, h_s), + x_max = x, lower = height_bounds[1], upper = h_m_up, + tol = height_tol + ) + mono_warn <- mono_warn || res_h$monotonicity_violation + if (!identical(res_h$status, "infeasible")) h_m_star <- res_h$value + } + + final <- eval_design(type, a_star, h_m_star, h_s) + if (isTRUE(verbose)) { + message(sprintf( + "[%s | x = %d] area %s m2, height %s mm, storage %s mm (%d neue Laeufe)", + type, x, format(a_star), format(h_m_star), format(h_s), + runs_executed - runs_before + )) + } + tibble::tibble( + x = x, storage_type = type, status = "ok", + mulde_area = a_star, mulde_height = h_m_star, storage_height = h_s, + n_overflows = final$n_overflows, + overflow_volume_m3 = final$overflow_volume_m3, + et_pct = final$et_pct, + monotonicity_warning = mono_warn, + n_runs_new = runs_executed - runs_before + ) + } + + # --- sweep all cells (shared cache makes repeats cheap) ------------------ + cells <- expand.grid(type = names(storage_spec), + x = sort(unique(as.integer(x_targets))), + stringsAsFactors = FALSE) + out <- dplyr::bind_rows( + lapply(seq_len(nrow(cells)), + function(i) solve_cell(cells$type[i], cells$x[i])) + ) + + out$filter_height <- filter_height + out <- compute_costs(out, cost_rates = cost_rates) + out <- dplyr::arrange(out, .data$storage_type, .data$x) + + evaluations <- dplyr::bind_rows( + lapply(ls(cache), function(k) tibble::as_tibble(get(k, envir = cache))) + ) + attr(out, "evaluations") <- dplyr::arrange( + evaluations, .data$storage_type, .data$mulde_area + ) + attr(out, "n_runs_total") <- runs_executed + out +} diff --git a/R/read_site_timeseries.R b/R/read_site_timeseries.R new file mode 100644 index 0000000..266abf2 --- /dev/null +++ b/R/read_site_timeseries.R @@ -0,0 +1,83 @@ +#' Read and prepare site rain/ET0 time series for the engine (mm/h) +#' +#' Factors the time-series preparation duplicated in the Wien and Bad +#' Aussee workflow vignettes into one helper: reads the shipped GeoSphere +#' rain series (`rain.csv.gz`: columns `time` (datetime), `rr` (mm per +#' interval), `station`, further columns tolerated) and reference ET0 +#' series (`et.csv`: +#' `date;value` with `dd.mm.yyyy`, mm per day), converts both to hours +#' since series start, aligns the series ends (the shorter series is +#' extended to the longer one's end, repeating its last value) and +#' converts the values to the engine's **mm/h** rate convention (rain: +#' mm per interval / interval hours; ET0: mm per day / 24). +#' +#' @param path_rain Path to the rain CSV (may be gzipped). +#' @param path_et Path to the ET0 CSV (semicolon separated). +#' @param verbose Print alignment messages (default TRUE). +#' +#' @return List with data.frames `rain` and `et` (columns `time` = hours +#' since start, `value` = mm/h) ready for +#' `make_swale_runner(timeseries_rain = , timeseries_et = )`. +#' +#' @seealso [make_swale_runner()] +#' @export +read_site_timeseries <- function(path_rain, path_et, verbose = TRUE) { + + if (!requireNamespace("readr", quietly = TRUE)) { + stop("read_site_timeseries() requires the 'readr' package") + } + + timeseries_et <- readr::read_delim(path_et, delim = ";", + col_types = "cd") %>% + dplyr::mutate( + date = lubridate::dmy(.data$date), + time = as.integer(difftime(.data$date, min(.data$date), + units = "hours")) + ) %>% + dplyr::select(-"date") %>% + dplyr::filter(!is.na(.data$value)) %>% + dplyr::relocate("time", .before = "value") + timeseries_et$time[nrow(timeseries_et)] <- + ceiling(timeseries_et$time[nrow(timeseries_et)]) + + timeseries_rain <- readr::read_csv(path_rain, show_col_types = FALSE) %>% + dplyr::rename(datetime = "time", value = "rr") %>% + dplyr::mutate( + time = as.double(difftime(.data$datetime, min(.data$datetime), + units = "secs")) / 3600 + ) %>% + dplyr::filter(!is.na(.data$value)) %>% + # robust gegen zusaetzliche Spalten (Bad Aussee hat z.B. "substation"): + # die Engine erwartet exakt time + value + dplyr::select("time", "value") + timeseries_rain$time[nrow(timeseries_rain)] <- + ceiling(timeseries_rain$time[nrow(timeseries_rain)]) + + # Serien-Enden angleichen: die kuerzere Serie wird mit ihrem letzten + # Wert bis zum Ende der laengeren verlaengert (wie in den Vignetten). + extend_to <- function(df, t_end, label) { + if (t_end <= max(df$time)) return(df) + if (isTRUE(verbose)) { + message(sprintf( + "%s series extended by %.1f hours to %.0f h (last value %.4f)", + label, t_end - max(df$time), t_end, df$value[nrow(df)] + )) + } + dplyr::bind_rows(df, tibble::tibble(time = t_end, + value = df$value[nrow(df)])) + } + t_end <- max(max(timeseries_rain$time), max(timeseries_et$time)) + timeseries_et <- extend_to(timeseries_et, t_end, "ET0") + timeseries_rain <- extend_to(timeseries_rain, t_end, "Rain") + + # mm je Intervall -> mm/h (Engine liest beide Kurven als mm/h-Rate; + # ET0-Tageswerte ohne /24 wuerden 24x zu hoch integriert) + period_rain <- c(diff(timeseries_rain$time), + mean(diff(timeseries_rain$time))) + timeseries_rain$value <- timeseries_rain$value / period_rain + period_et <- c(diff(timeseries_et$time), mean(diff(timeseries_et$time))) + timeseries_et$value <- timeseries_et$value / period_et + + list(rain = as.data.frame(timeseries_rain), + et = as.data.frame(timeseries_et)) +} diff --git a/R/stack_levels.R b/R/stack_levels.R new file mode 100644 index 0000000..b13562a --- /dev/null +++ b/R/stack_levels.R @@ -0,0 +1,115 @@ +#' Achievable storage-layer stack heights from module heights +#' +#' Enumerates all storage-layer heights that can be built by stacking +#' (and mixing) the given module heights, e.g. full blocks combined with +#' at most one half block. +#' +#' @param modules Numeric vector of module heights in mm (e.g. `c(660, 350)` +#' for a full block plus a half block). +#' @param max_count Integer vector (recycled to `length(modules)`): maximum +#' number of modules of each type in one stack. Defaults to 7 for every +#' module (cf. GRAF EcoBloc smart, stackable up to 7 layers). +#' @param max_height Maximum total stack height in mm (default 2600). +#' +#' @return Sorted numeric vector of achievable stack heights in mm. +#' +#' @examples +#' stack_levels(360) # 360, 720, ..., 2520 +#' stack_levels(c(660, 350), max_count = c(7, 1)) # Rigofill full + half block +#' +#' @export +stack_levels <- function(modules, + max_count = rep(7L, length(modules)), + max_height = 2600) { + stopifnot(is.numeric(modules), all(modules > 0)) + max_count <- rep_len(as.integer(max_count), length(modules)) + counts <- Map(function(m, k) 0:min(k, floor(max_height / m)), + modules, max_count) + grid <- do.call(expand.grid, counts) + h <- as.vector(as.matrix(grid) %*% modules) + sort(unique(h[h > 0 & h <= max_height])) +} + +#' Sickerbox storage-height presets (brute force default + manufacturers) +#' +#' Named list of storage-height level vectors (mm) for the infiltration-box +#' storage layer. `brute_force` is the default used by the workflow +#' vignettes (300/600/900/1200 mm -- itself a combination of several box +#' types). The manufacturer presets are generated with [stack_levels()] +#' from typical module heights of commercial block systems; verify against +#' the current data sheets before productive optimisation runs. +#' +#' @param max_height Maximum total stack height in mm passed to +#' [stack_levels()] (default 2600). +#' +#' @return Named list of sorted numeric vectors (mm). +#' +#' @export +sickerbox_level_presets <- function(max_height = 2600) { + list( + brute_force = c(300, 600, 900, 1200), + graf_ecobloc_smart = stack_levels(360, max_height = max_height), + graf_ecobloc_420 = stack_levels(660, max_height = max_height), + fraenkische_rigofill = stack_levels(c(660, 350), max_count = c(7L, 1L), + max_height = max_height), + aco_stormbrixx_hd = stack_levels(614, max_height = max_height), + aco_stormbrixx_sd = stack_levels(342, max_height = max_height), + wavin_aquacell = stack_levels(400, max_height = max_height) + ) +} + +#' Default storage specification for the swale-design optimiser +#' +#' Storage-layer search space per storage type: the infiltration box uses +#' discrete stack levels (default: the brute-force grid levels), the gravel +#' trench is continuous with bounds coupled to the box level range by +#' `coupling_factor` (default 3, approximating the usable-porosity ratio +#' 0.95 / 0.3). +#' +#' @param levels Numeric vector of infiltration-box stack heights in mm. +#' @param coupling_factor Factor between gravel-trench bounds and the box +#' level range. +#' @param gravel_tol Bisection tolerance for the continuous gravel-trench +#' height in mm. +#' +#' @return Named list with entries `infiltration_box` (with `levels`) and +#' `gravel_trench` (with `bounds` and `tol`). +#' +#' @export +default_storage_spec <- function(levels = sickerbox_level_presets()$brute_force, + coupling_factor = 3, + gravel_tol = 25) { + list( + infiltration_box = list(levels = sort(unique(levels))), + gravel_trench = list(bounds = coupling_factor * range(levels), + tol = gravel_tol) + ) +} + +#' Default storage-type soil presets (Speicher layer) +#' +#' Soil parameters of the storage (2nd Bodenschichtung) layer per storage +#' type, as used by the workflow vignettes: infiltration box ("Sickerbox", +#' thetaS 0.95) and gravel trench ("Schotterrigol", thetaS 0.3). +#' +#' @return Named list (per storage type) of lists with +#' `Startwerte_theta_ActualSoilMoisture`, `thetaWP_MoistureAtWiltingPoint`, +#' `thetaFC_MoistureAtFieldCapacity`, `thetaS_MoistureAtSaturation`. +#' +#' @export +default_storage_types <- function() { + list( + infiltration_box = list( + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.95 + ), + gravel_trench = list( + Startwerte_theta_ActualSoilMoisture = 0, + thetaWP_MoistureAtWiltingPoint = 0, + thetaFC_MoistureAtFieldCapacity = 0, + thetaS_MoistureAtSaturation = 0.3 + ) + ) +} diff --git a/man/default_storage_spec.Rd b/man/default_storage_spec.Rd new file mode 100644 index 0000000..6e7347a --- /dev/null +++ b/man/default_storage_spec.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stack_levels.R +\name{default_storage_spec} +\alias{default_storage_spec} +\title{Default storage specification for the swale-design optimiser} +\usage{ +default_storage_spec( + levels = sickerbox_level_presets()$brute_force, + coupling_factor = 3, + gravel_tol = 25 +) +} +\arguments{ +\item{levels}{Numeric vector of infiltration-box stack heights in mm.} + +\item{coupling_factor}{Factor between gravel-trench bounds and the box +level range.} + +\item{gravel_tol}{Bisection tolerance for the continuous gravel-trench +height in mm.} +} +\value{ +Named list with entries \code{infiltration_box} (with \code{levels}) and +\code{gravel_trench} (with \code{bounds} and \code{tol}). +} +\description{ +Storage-layer search space per storage type: the infiltration box uses +discrete stack levels (default: the brute-force grid levels), the gravel +trench is continuous with bounds coupled to the box level range by +\code{coupling_factor} (default 3, approximating the usable-porosity ratio +0.95 / 0.3). +} diff --git a/man/default_storage_types.Rd b/man/default_storage_types.Rd new file mode 100644 index 0000000..7e951c0 --- /dev/null +++ b/man/default_storage_types.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stack_levels.R +\name{default_storage_types} +\alias{default_storage_types} +\title{Default storage-type soil presets (Speicher layer)} +\usage{ +default_storage_types() +} +\value{ +Named list (per storage type) of lists with +\code{Startwerte_theta_ActualSoilMoisture}, \code{thetaWP_MoistureAtWiltingPoint}, +\code{thetaFC_MoistureAtFieldCapacity}, \code{thetaS_MoistureAtSaturation}. +} +\description{ +Soil parameters of the storage (2nd Bodenschichtung) layer per storage +type, as used by the workflow vignettes: infiltration box ("Sickerbox", +thetaS 0.95) and gravel trench ("Schotterrigol", thetaS 0.3). +} diff --git a/man/find_min_feasible.Rd b/man/find_min_feasible.Rd new file mode 100644 index 0000000..b903494 --- /dev/null +++ b/man/find_min_feasible.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/find_min_feasible.R +\name{find_min_feasible} +\alias{find_min_feasible} +\title{Smallest feasible parameter value via bisection (monotone threshold search)} +\usage{ +find_min_feasible( + evaluate, + x_max, + lower = NULL, + upper = NULL, + tol = 1, + levels = NULL, + wobble = 1L, + volume_column = "overflow_volume_m3", + verbose = FALSE +) +} +\arguments{ +\item{evaluate}{\verb{function(value)} returning a list / one-row data.frame +with at least \code{n_overflows}; if it also contains \code{volume_column}, the +volume referee is active. Evaluations are memoised per value.} + +\item{x_max}{Feasibility target: feasible iff \code{n_overflows <= x_max}.} + +\item{lower, upper}{Numeric search bounds (continuous mode).} + +\item{tol}{Resolution of the continuous search (same unit as the value).} + +\item{levels}{Sorted numeric vector of discrete candidate values +(discrete mode, e.g. Sickerbox stack heights). If given, \code{lower}, +\code{upper} and \code{tol} are ignored and a binary search over the levels is +performed.} + +\item{wobble}{Maximum counting-artefact size tolerated by the edge guard +(default 1, matching the observed +1 flips).} + +\item{volume_column}{Name of the volume element in the \code{evaluate} result +used by the volume referee (default \code{"overflow_volume_m3"}).} + +\item{verbose}{Print one line per evaluation.} +} +\value{ +List with +\describe{ +\item{value}{smallest feasible value, or \code{NA} if infeasible} +\item{n_overflows}{overflow count at \code{value}} +\item{status}{\code{"ok"}, \code{"at_lower_bound"} (already feasible at the lower +end -- caller may widen the bracket) or \code{"infeasible"}} +\item{evaluations}{tibble of all evaluated values (value, n_overflows, +volume), sorted by value} +\item{n_evaluations}{number of distinct evaluations} +\item{monotonicity_violation}{\code{TRUE} if the volume referee fired} +} +} +\description{ +Core building block of the swale-design optimiser: finds the smallest +value of one design parameter for which the overflow target is met +(\code{n_overflows <= x_max}), assuming quasi-monotone feasibility (larger +value = never more overflows; verified for the RAINDROP model in the +\code{monotonicity_analysis} vignette). Each evaluation halves the search +interval, so \code{ceiling(log2(range / tol))} evaluations suffice. +} +\details{ +Two safety rules from the monotonicity analysis are built in: +\itemize{ +\item \strong{Edge guard}: if the upper bound is infeasible by no more +than \code{wobble} events (the +1 counting artefact of the 4-h event +separation), a descending ladder below the edge searches for a +feasible anchor before the branch is declared infeasible. +\item \strong{Volume referee}: whenever \code{n_overflows} increases with +the parameter (a counting flip), the overflow volume must have +decreased; if the volume increased as well, a warning is emitted and +\code{monotonicity_violation} is set (real non-monotonicity -- never +observed at the three validation sites). +} +} +\examples{ +# synthetic monotone step function: feasible from 137.4 m2 on +f <- function(v) list(n_overflows = if (v >= 137.4) 0L else 10L) +find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2)$value + +} diff --git a/man/make_swale_runner.Rd b/man/make_swale_runner.Rd new file mode 100644 index 0000000..b9e346d --- /dev/null +++ b/man/make_swale_runner.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/make_swale_runner.R +\name{make_swale_runner} +\alias{make_swale_runner} +\title{Create a site-specific single-scenario runner for the optimiser} +\usage{ +make_swale_runner( + path_list, + timestep_hours = 0.1, + timeseries_rain = NULL, + timeseries_et = NULL, + storage_types = default_storage_types(), + event_separation_hours = 4, + scenario_prefix = "o", + debug = FALSE +) +} +\arguments{ +\item{path_list}{Path definition list as used by the workflow vignettes +(resolvable with \code{kwb.utils::resolve()}, must contain \code{path_base}, +\code{path_exe}, \code{dir_input}, \code{dir_output}, \code{dir_target_output}, +\code{path_target_input}, \code{path_results_hdf5_element}, +\code{path_results_hdf5_flaeche}, \code{file_target}).} + +\item{timestep_hours}{Engine time step in hours (default 0.1).} + +\item{timeseries_rain}{Optional data.frame \code{time}/\code{value} (mm/h) written +to \verb{//Kurven/Regen}; when given, \verb{//Kurven/Growth_1} and +\verb{//Kurven/Shading_1} end times are extended to the rain series end and +\code{rain_factor} is ignored.} + +\item{timeseries_et}{Optional data.frame \code{time}/\code{value} (mm/h) written +to \verb{//Kurven/ET0}.} + +\item{storage_types}{Soil presets of the storage layer per storage type, +see \code{\link[=default_storage_types]{default_storage_types()}}.} + +\item{event_separation_hours}{Event separation for overflow counting +(default 4, as in the vignettes and the monotonicity analysis).} + +\item{scenario_prefix}{Prefix for generated scenario names (default +\code{"o"} -> \code{o00001}, \code{o00002}, ... -- distinct from the grid runs +\code{s00001} ...).} + +\item{debug}{Passed on to the engine/reader helpers.} +} +\value{ +\verb{function(params)} where \code{params} is a named list (or one-row +data.frame) with \code{mulde_area}, \code{mulde_height} (mm), \code{storage_type}, +\code{storage_height} (mm), \code{connected_area} (m2), \code{filter_height} (mm), +\code{filter_hydraulicconductivity} (mm/h), \code{bottom_hydraulicconductivity} +(mm/h) and optionally \code{rain_factor} (default 1) and \code{lai} +(default 3.9). It returns a one-row tibble with the parameters, the +scenario name and the optimisation metrics (\code{n_overflows}, +\code{sum_overflows} in mm, \code{overflow_volume_m3}, water-balance shares). +} +\description{ +Factors the \code{run_one()} function that was duplicated across the three +workflow vignettes (Eisenstadt 2005, Wien, Bad Aussee) into one +package-level closure factory. The returned function runs the RAINDROP +engine for one parameter set and returns the thinned one-row +optimisation result (overflow events + water balance), augmented with +the input parameters and the overflow volume in m3. +} +\details{ +Site differences are covered by the arguments: Eisenstadt scales the +rain curve shipped in \code{base.h5} by \code{rain_factor} (leave +\code{timeseries_rain} = \code{NULL}), Wien and Bad Aussee replace the rain and +ET0 curves entirely (\code{timeseries_rain} / \code{timeseries_et}, values in +mm/h as written by the vignettes). +} +\seealso{ +\code{\link[=optimise_swale_design]{optimise_swale_design()}}, \code{\link[=find_min_feasible]{find_min_feasible()}} +} diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd new file mode 100644 index 0000000..690f6f4 --- /dev/null +++ b/man/optimise_swale_design.Rd @@ -0,0 +1,83 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/optimise_swale_design.R +\name{optimise_swale_design} +\alias{optimise_swale_design} +\title{Find the cost-optimal swale design per overflow target} +\usage{ +optimise_swale_design( + run_fn, + x_targets = 0:5, + area_bounds = c(25, 200), + area_tol = 2, + height_bounds = c(100, 300), + height_tol = 10, + storage_spec = default_storage_spec(), + fixed = list(connected_area = 1000, filter_height = 300, filter_hydraulicconductivity = + 360, bottom_hydraulicconductivity = 12), + prior_results = NULL, + max_total_depth = NULL, + cost_rates = default_cost_rates(), + verbose = TRUE +) +} +\arguments{ +\item{run_fn}{\verb{function(params)} running one scenario and returning at +least \code{n_overflows} plus \code{sum_overflows} (mm) or \code{overflow_volume_m3}; +typically created with \code{\link[=make_swale_runner]{make_swale_runner()}}. \code{params} is a named list +of \code{mulde_area}, \code{mulde_height}, \code{storage_type}, \code{storage_height} plus +everything in \code{fixed}.} + +\item{x_targets}{Integer vector of overflow targets (feasible :<=> +\code{n_overflows <= x}), default \code{0:5}.} + +\item{area_bounds, area_tol}{Search range (m2) and resolution for +\code{mulde_area}.} + +\item{height_bounds, height_tol}{Search range (mm) and resolution for +\code{mulde_height}.} + +\item{storage_spec}{Storage search space per type, see +\code{\link[=default_storage_spec]{default_storage_spec()}}: discrete \code{levels} (infiltration box) or +continuous \code{bounds} + \code{tol} (gravel trench).} + +\item{fixed}{Named list of parameters passed unchanged to \code{run_fn} +(connected area, filter geometry, kf at maximum, ...). Must contain +\code{filter_height} for the cost model.} + +\item{prior_results}{Optional data.frame with prior (grid) results in +the workflow CSV schema, used as warm start (narrows the first area +bracket to one grid step).} + +\item{max_total_depth}{Optional analytic depth constraint in mm: +\code{mulde_height + filter_height + storage_height <= max_total_depth} +(e.g. from DWA-A 138 groundwater clearance or cover requirements). +Enforced without any simulation runs.} + +\item{cost_rates}{Unit costs, see \code{\link[=default_cost_rates]{default_cost_rates()}}.} + +\item{verbose}{Print one progress line per solved cell.} +} +\value{ +Tibble with one row per (storage type, x): the optimal design +(\code{mulde_area}, \code{mulde_height}, \code{storage_height}), its metrics +(\code{n_overflows}, \code{overflow_volume_m3}, \code{et_pct}), cost columns from +\code{\link[=compute_costs]{compute_costs()}}, a \code{status} (\code{"ok"} or \code{"infeasible_within_bounds"}), +\code{monotonicity_warning} (volume referee) and \code{n_runs_new} (fresh engine +runs spent on this cell). All evaluated designs are attached as +attribute \code{"evaluations"}. +} +\description{ +Coordinate-descent optimiser built from a single primitive +(\code{\link[=find_min_feasible]{find_min_feasible()}}, bisection over one parameter): shrink the +expensive lever first (\code{mulde_area}), then the cheap one +(\code{mulde_height}); the storage layer starts at its smallest level and is +only escalated when the area is stuck at its upper bound. The filter +conductivity is expected to be fixed at the maximum via \code{fixed} (it is +cost-free and dominant, see the \code{monotonicity_analysis} vignette). Every +engine run is cached, so the sweep over all \code{x_targets} and both storage +types shares evaluations. +} +\seealso{ +\code{\link[=find_min_feasible]{find_min_feasible()}}, \code{\link[=make_swale_runner]{make_swale_runner()}}, +\code{\link[=default_storage_spec]{default_storage_spec()}} +} diff --git a/man/read_site_timeseries.Rd b/man/read_site_timeseries.Rd new file mode 100644 index 0000000..d80aebb --- /dev/null +++ b/man/read_site_timeseries.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_site_timeseries.R +\name{read_site_timeseries} +\alias{read_site_timeseries} +\title{Read and prepare site rain/ET0 time series for the engine (mm/h)} +\usage{ +read_site_timeseries(path_rain, path_et, verbose = TRUE) +} +\arguments{ +\item{path_rain}{Path to the rain CSV (may be gzipped).} + +\item{path_et}{Path to the ET0 CSV (semicolon separated).} + +\item{verbose}{Print alignment messages (default TRUE).} +} +\value{ +List with data.frames \code{rain} and \code{et} (columns \code{time} = hours +since start, \code{value} = mm/h) ready for +\code{make_swale_runner(timeseries_rain = , timeseries_et = )}. +} +\description{ +Factors the time-series preparation duplicated in the Wien and Bad +Aussee workflow vignettes into one helper: reads the shipped GeoSphere +rain series (\code{rain.csv.gz}: columns \code{time} (datetime), \code{rr} (mm per +interval), \code{station}, further columns tolerated) and reference ET0 +series (\code{et.csv}: +\verb{date;value} with \code{dd.mm.yyyy}, mm per day), converts both to hours +since series start, aligns the series ends (the shorter series is +extended to the longer one's end, repeating its last value) and +converts the values to the engine's \strong{mm/h} rate convention (rain: +mm per interval / interval hours; ET0: mm per day / 24). +} +\seealso{ +\code{\link[=make_swale_runner]{make_swale_runner()}} +} diff --git a/man/sickerbox_level_presets.Rd b/man/sickerbox_level_presets.Rd new file mode 100644 index 0000000..43eafdb --- /dev/null +++ b/man/sickerbox_level_presets.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stack_levels.R +\name{sickerbox_level_presets} +\alias{sickerbox_level_presets} +\title{Sickerbox storage-height presets (brute force default + manufacturers)} +\usage{ +sickerbox_level_presets(max_height = 2600) +} +\arguments{ +\item{max_height}{Maximum total stack height in mm passed to +\code{\link[=stack_levels]{stack_levels()}} (default 2600).} +} +\value{ +Named list of sorted numeric vectors (mm). +} +\description{ +Named list of storage-height level vectors (mm) for the infiltration-box +storage layer. \code{brute_force} is the default used by the workflow +vignettes (300/600/900/1200 mm -- itself a combination of several box +types). The manufacturer presets are generated with \code{\link[=stack_levels]{stack_levels()}} +from typical module heights of commercial block systems; verify against +the current data sheets before productive optimisation runs. +} diff --git a/man/stack_levels.Rd b/man/stack_levels.Rd new file mode 100644 index 0000000..82c00fa --- /dev/null +++ b/man/stack_levels.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stack_levels.R +\name{stack_levels} +\alias{stack_levels} +\title{Achievable storage-layer stack heights from module heights} +\usage{ +stack_levels(modules, max_count = rep(7L, length(modules)), max_height = 2600) +} +\arguments{ +\item{modules}{Numeric vector of module heights in mm (e.g. \code{c(660, 350)} +for a full block plus a half block).} + +\item{max_count}{Integer vector (recycled to \code{length(modules)}): maximum +number of modules of each type in one stack. Defaults to 7 for every +module (cf. GRAF EcoBloc smart, stackable up to 7 layers).} + +\item{max_height}{Maximum total stack height in mm (default 2600).} +} +\value{ +Sorted numeric vector of achievable stack heights in mm. +} +\description{ +Enumerates all storage-layer heights that can be built by stacking +(and mixing) the given module heights, e.g. full blocks combined with +at most one half block. +} +\examples{ +stack_levels(360) # 360, 720, ..., 2520 +stack_levels(c(660, 350), max_count = c(7, 1)) # Rigofill full + half block + +} diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..3dc1a40 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(kwb.raindrop) + +test_check("kwb.raindrop") diff --git a/tests/testthat/test-find_min_feasible.R b/tests/testthat/test-find_min_feasible.R new file mode 100644 index 0000000..1dde70e --- /dev/null +++ b/tests/testthat/test-find_min_feasible.R @@ -0,0 +1,87 @@ +test_that("kontinuierliche Bisektion findet die Schwelle innerhalb der Toleranz", { + calls <- 0L + f <- function(v) { + calls <<- calls + 1L + list(n_overflows = if (v >= 137.4) 0L else 10L) + } + res <- find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2) + expect_identical(res$status, "ok") + expect_gte(res$value, 137.4) + expect_lte(res$value, 137.4 + 2) + # log2(175 / 2) ~ 6.5 -> hoechstens ~9 Laeufe inkl. Randtests + expect_lte(res$n_evaluations, 9) + # Memoisierung: jede Stelle nur einmal evaluiert + expect_equal(calls, res$n_evaluations) + expect_false(res$monotonicity_violation) +}) + +test_that("unterer Rand zulaessig -> at_lower_bound", { + f <- function(v) list(n_overflows = if (v >= 10) 0L else 10L) + res <- find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2) + expect_identical(res$status, "at_lower_bound") + expect_equal(res$value, 25) +}) + +test_that("tief unzulaessiger Rand -> sofort infeasible (1 Lauf)", { + f <- function(v) list(n_overflows = 99L) + res <- find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2) + expect_identical(res$status, "infeasible") + expect_true(is.na(res$value)) + expect_equal(res$n_evaluations, 1L) +}) + +test_that("Rand-Guard: +1-Zaehl-Wobble am oberen Rand frisst keine Loesung", { + # zulaessig in [100, 180), am oberen Rand springt der Zaehler auf x+1 + n_fun <- function(v) if (v >= 180) 2L else if (v >= 100) 1L else 50L + f <- function(v) list(n_overflows = n_fun(v)) + res <- find_min_feasible(f, x_max = 1, lower = 25, upper = 200, tol = 2) + expect_identical(res$status, "ok") + expect_gte(res$value, 100) + expect_lte(res$value, 102) +}) + +test_that("Volumen-Schiedsrichter: Warnung nur bei echter Nicht-Monotonie", { + # Zaehler springt bei 150 von 1 auf 2 -- Volumen steigt MIT: echte Verletzung + f_bad <- function(v) list( + n_overflows = if (v >= 150) 2L else if (v >= 100) 1L else 9L, + overflow_volume_m3 = if (v >= 150) 200 else if (v >= 100) 100 else 5000 + ) + expect_warning( + res_bad <- find_min_feasible(f_bad, x_max = 1, lower = 25, upper = 200, + tol = 2), + "non-monotonicity" + ) + expect_true(res_bad$monotonicity_violation) + + # gleicher Zaehler-Sprung, aber Volumen faellt weiter: harmloser Wobble + f_ok <- function(v) list( + n_overflows = if (v >= 150) 2L else if (v >= 100) 1L else 9L, + overflow_volume_m3 = 5000 - 20 * v + ) + expect_no_warning( + res_ok <- find_min_feasible(f_ok, x_max = 1, lower = 25, upper = 200, + tol = 2) + ) + expect_false(res_ok$monotonicity_violation) +}) + +test_that("diskrete Levels: Binaersuche ueber Stufen", { + lv <- c(300, 600, 900, 1200) + f <- function(v) list(n_overflows = if (v >= 900) 0L else 7L) + res <- find_min_feasible(f, x_max = 0, levels = lv) + expect_identical(res$status, "ok") + expect_equal(res$value, 900) + expect_lte(res$n_evaluations, 3) + + # schon die kleinste Stufe reicht + f2 <- function(v) list(n_overflows = 0L) + res2 <- find_min_feasible(f2, x_max = 0, levels = lv) + expect_identical(res2$status, "at_lower_bound") + expect_equal(res2$value, 300) + + # keine Stufe reicht (tief unzulaessig) + f3 <- function(v) list(n_overflows = 9L) + res3 <- find_min_feasible(f3, x_max = 0, levels = lv) + expect_identical(res3$status, "infeasible") + expect_equal(res3$n_evaluations, 1L) +}) diff --git a/tests/testthat/test-optimise_swale_design.R b/tests/testthat/test-optimise_swale_design.R new file mode 100644 index 0000000..f40cc23 --- /dev/null +++ b/tests/testthat/test-optimise_swale_design.R @@ -0,0 +1,129 @@ +# Synthetisches, monotones Hydraulikmodell: Ueberlaeufe fallen mit der +# Rueckhaltekapazitaet cap = Flaeche x (Muldentiefe + Porositaet x +# Speicherhoehe). Kein Engine-Aufruf noetig -> der Optimierer laesst sich +# gegen eine Brute-Force-Referenz auf feinem Raster verifizieren. +synthetic_run_factory <- function(demand) { + porosity <- c(infiltration_box = 0.95, gravel_trench = 0.3) + function(params) { + cap <- params$mulde_area * + (params$mulde_height + + porosity[[params$storage_type]] * params$storage_height) + ratio <- demand / cap + list( + n_overflows = max(0, floor(ratio) - 3), + sum_overflows = 800 * max(0, ratio - 3), + element.WB_Evapotranspiration_ = 0.1 * params$mulde_area + ) + } +} + +test_fixed <- list(connected_area = 1000, filter_height = 300, + filter_hydraulicconductivity = 360, + bottom_hydraulicconductivity = 12) + +# Brute-Force-Referenz: guenstigstes zulaessiges Design auf feinem Raster +reference_optimum <- function(run, type, x, storage_values) { + grid <- expand.grid( + mulde_area = seq(25, 200, by = 0.5), + mulde_height = seq(100, 300, by = 5), + storage_height = storage_values, + stringsAsFactors = FALSE + ) + grid$storage_type <- type + porosity <- c(infiltration_box = 0.95, gravel_trench = 0.3) + cap <- grid$mulde_area * + (grid$mulde_height + porosity[[type]] * grid$storage_height) + grid$n <- pmax(0, floor(environment(run)$demand / cap) - 3) + grid <- grid[grid$n <= x, , drop = FALSE] + if (nrow(grid) == 0) return(NULL) + grid$filter_height <- 300 + costs <- compute_costs(grid) + costs[which.min(costs$cost_total), , drop = FALSE] +} + +test_that("Optimierer findet das Kostenminimum (Vergleich mit Brute-Force)", { + run <- synthetic_run_factory(demand = 3.6e5) + out <- optimise_swale_design(run, x_targets = 0:3, + fixed = test_fixed, verbose = FALSE) + + expect_true(all(out$status == "ok")) + expect_false(any(out$monotonicity_warning)) + # Zulaessigkeit: Ueberlaufziel eingehalten + expect_true(all(out$n_overflows <= out$x)) + + for (i in seq_len(nrow(out))) { + type <- out$storage_type[i] + stor <- if (type == "infiltration_box") c(300, 600, 900, 1200) + else seq(900, 3600, by = 25) + ref <- reference_optimum(run, type, out$x[i], stor) + expect_false(is.null(ref)) + # innerhalb 5 % des (quasi-kontinuierlichen) Brute-Force-Optimums + expect_lte(out$cost_total[i], ref$cost_total * 1.05) + } + + # Kosten-Wirksamkeits-Kurve: lockereres Ziel ist nie teurer + for (type in unique(out$storage_type)) { + cc <- out$cost_total[out$storage_type == type][order(out$x[out$storage_type == type])] + expect_true(all(diff(cc) <= 1e-9)) + } + + # Laufbudget: alle 8 Zellen zusammen deutlich unter Brute-Force-Groesse + expect_lte(attr(out, "n_runs_total"), 200) +}) + +test_that("Speicher-Eskalation greift, wenn die Flaeche am Anschlag klemmt", { + run <- synthetic_run_factory(demand = 8e5) + out <- optimise_swale_design(run, x_targets = 0, + fixed = test_fixed, verbose = FALSE) + box <- out[out$storage_type == "infiltration_box", ] + expect_identical(box$status, "ok") + # bei Minimal-Speicher 300 ist selbst 200 m2 unzulaessig -> Eskalation + expect_gt(box$storage_height, 300) + expect_lte(box$n_overflows, 0) +}) + +test_that("unloesbar innerhalb der Bounds ist ein regulaeres Ergebnis", { + run <- synthetic_run_factory(demand = 5e6) + out <- optimise_swale_design(run, x_targets = 0, + fixed = test_fixed, verbose = FALSE) + expect_true(all(out$status == "infeasible_within_bounds")) + expect_true(all(is.na(out$mulde_area))) + expect_true(all(is.na(out$cost_total))) +}) + +test_that("Warmstart aus Rasterergebnissen spart Laeufe", { + run <- synthetic_run_factory(demand = 3.6e5) + + # Prior im CSV-Schema der Workflows (kf = 360, h_m = 300, Rasterschritt 25) + prior <- expand.grid( + mulde_area = seq(25, 200, by = 25), + mulde_height = 300, + storage_type = c("infiltration_box", "gravel_trench"), + stringsAsFactors = FALSE + ) + prior$storage_height <- ifelse(prior$storage_type == "infiltration_box", + 300, 900) + prior$filter_hydraulicconductivity <- 360 + prior$n_overflows <- vapply(seq_len(nrow(prior)), function(i) { + as.numeric(run(c(as.list(prior[i, ]), test_fixed))$n_overflows) + }, numeric(1)) + + cold <- optimise_swale_design(run, x_targets = 0:3, + fixed = test_fixed, verbose = FALSE) + warm <- optimise_swale_design(run, x_targets = 0:3, + fixed = test_fixed, prior_results = prior, + verbose = FALSE) + + # identisches Ergebnis, weniger Laeufe + expect_equal(warm$cost_total, cold$cost_total, tolerance = 0.02) + expect_lt(attr(warm, "n_runs_total"), attr(cold, "n_runs_total")) +}) + +test_that("max_total_depth wirkt als analytische Nebenbedingung", { + run <- synthetic_run_factory(demand = 3.6e5) + out <- optimise_swale_design(run, x_targets = 0, fixed = test_fixed, + max_total_depth = 1200, verbose = FALSE) + ok <- out[out$status == "ok", ] + expect_true(all(ok$mulde_height + ok$filter_height + ok$storage_height + <= 1200 + 1e-9)) +}) diff --git a/tests/testthat/test-stack_levels.R b/tests/testthat/test-stack_levels.R new file mode 100644 index 0000000..8ebdd63 --- /dev/null +++ b/tests/testthat/test-stack_levels.R @@ -0,0 +1,22 @@ +test_that("stack_levels: Vielfache einer Modulhoehe bis zur Obergrenze", { + expect_equal(stack_levels(360), seq(360, 2520, by = 360)) + expect_equal(stack_levels(614), c(614, 1228, 1842, 2456)) + expect_true(all(stack_levels(400) <= 2600)) +}) + +test_that("stack_levels: Mischkombination Vollblock + max. 1 Halbblock", { + expect_equal( + stack_levels(c(660, 350), max_count = c(7L, 1L)), + c(350, 660, 1010, 1320, 1670, 1980, 2330) + ) +}) + +test_that("Presets und Default-Spezifikation", { + presets <- sickerbox_level_presets() + expect_equal(presets$brute_force, c(300, 600, 900, 1200)) + expect_true(all(vapply(presets, function(p) all(diff(p) > 0), logical(1)))) + + spec <- default_storage_spec() + expect_equal(spec$infiltration_box$levels, c(300, 600, 900, 1200)) + expect_equal(spec$gravel_trench$bounds, c(900, 3600)) +}) diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd new file mode 100644 index 0000000..6c184d3 --- /dev/null +++ b/vignettes/workflow_optimisation.Rmd @@ -0,0 +1,293 @@ +--- +title: "Workflow Optimierung (Eisenstadt · Wien · Bad Aussee)" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Workflow Optimierung (Eisenstadt · Wien · Bad Aussee)} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE, eval = TRUE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.width = 7.5, + fig.height = 3.2 +) +is_ghactions <- tolower(Sys.getenv("GITHUB_ACTIONS")) == "true" || + tolower(Sys.getenv("CI")) %in% c("true", "1", "yes") + +# extdata robust aufloesen: zuerst installiertes Paket, sonst Quellbaum +# (Knit direkt im Repo, auch ohne installiertes kwb.raindrop) +extdata_path <- function(...) { + p <- system.file("extdata", ..., package = "kwb.raindrop") + if (nzchar(p)) return(p) + src <- file.path("..", "inst", "extdata", ...) + if (file.exists(src)) normalizePath(src) else "" +} + +path_base <- extdata_path("models", "eisenstadt-2005", "base.h5") +data_available <- nzchar(path_base) && file.exists(path_base) +is_windows <- Sys.info()[["sysname"]] == "Windows" +can_run <- data_available && is_windows && !is_ghactions +``` + +## Ziel + +Dieser Workflow findet für **alle drei Standorte** (Eisenstadt 2005, +Wien, Bad Aussee) die **günstigste Muldenkonfiguration je Überlaufziel** +x = 0…5 — pro Speichertyp (Sickerbox / Schotterrigol) — mit +`optimise_swale_design()` statt eines Brute-Force-Rasters. Das Verfahren +ist reine Bisektion ("Zahlenraten"): Fläche schrumpfen, dann Muldentiefe, +Speicher nur erhöhen, wenn die Fläche am Anschlag klemmt. Voraussetzung +ist die in der Vignette `monotonicity_analysis` belegte Monotonie +("größer = nie mehr Überläufe"); die dort abgeleiteten Absicherungen +(Rand-Guard, Volumen-Schiedsrichter) sind in `find_min_feasible()` +eingebaut. + +Die Filterdurchlässigkeit wird fest auf das Maximum gesetzt (kostenfrei +dominant: gleiche Verdunstung, nie mehr Überläufe), Fläche und +Muldentiefe werden stufenlos gesucht, die Sickerbox in den +Default-Stufen 300/600/900/1200 mm (`sickerbox_level_presets()` bietet +Hersteller-Alternativen), der Schotterrigol stufenlos im 3-fachen +Box-Bereich. + +**Laufzeit:** Ein Engine-Lauf dauert ~2 s (Eisenstadt, 1 Jahr) bzw. +~15 s (Wien / Bad Aussee, 15-Jahres-Serien); der komplette Workflow +liegt damit bei ca. 30–40 Minuten. + +```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} +cat(sprintf(paste0( + "> **Hinweis:** Die Rechen-Chunks wurden übersprungen. Prüfungen: ", + "Windows: %s · CI/GitHub Actions: %s · base.h5 gefunden: %s (%s). ", + "Auf einem lokalen Windows-Rechner sollten alle drei Bedingungen ", + "erfüllt sein — falls base.h5 fehlt: Vignette aus dem Paket-Repo ", + "heraus rendern oder das Paket installieren.\n"), + is_windows, is_ghactions, data_available, + if (nzchar(path_base)) path_base else "weder installiert noch ../inst/extdata" +)) +``` + +## Standort-Konfiguration + +Die Standorte unterscheiden sich nur in zwei Punkten: dem +Modell-Template (`base.h5`) und der Frage, ob eigene Regen-/ET0-Zeitreihen +in die Engine geschrieben werden (Wien und Bad Aussee) oder die Kurven +aus `base.h5` verwendet werden (Eisenstadt). Beides kapselt +`make_swale_runner()`; die Zeitreihen-Aufbereitung (mm/h-Konvention, +Serien-Angleichung) übernimmt `read_site_timeseries()`. + +```{r site_config, eval = can_run} +# Im Quellbaum die Entwicklungsversion laden (immer aktuell, auch wenn +# das installierte Paket aelter ist); ausserhalb: installiertes Paket. +if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) +} else { + library(kwb.raindrop) +} + +sites <- list( + Eisenstadt_2005 = list(dir = "eisenstadt-2005", timeseries = FALSE, + prior = "simulation_results_optimisation_Eisenstadt_2005.csv"), + Wien = list(dir = "wien", timeseries = TRUE, + prior = "simulation_results_optimisation_Wien.csv"), + BadAussee = list(dir = "badaussee", timeseries = TRUE, + prior = "simulation_results_optimisation_BadAussee.csv") +) + +fixed <- list(connected_area = 1000, + filter_height = 300, + filter_hydraulicconductivity = 360, # Rastermaximum, gratis + bottom_hydraulicconductivity = 12) + +make_path_list <- function(modelname, model_dir) { + list( + modelname = modelname, + root_path = file.path(tempdir(), paste0("raindrop_opt_", model_dir)), + dir_input = "/models//input", + dir_output = "/models//output", + dir_target_output = "/", + file_errors_hdf5 = "Fehlerprotokoll.h5", + file_results_hdf5_element = "Mulde_Rigole.h5", + file_results_hdf5_flaeche = "Dach.h5", + file_results_hdf5_verschaltungen = "_Verschaltungen.h5", + file_results_txt = "Mulde_Rigole_RAINDROP.txt", + file_results_txt_multilayer = "Mulde_Rigole_RAINDROP_multi_layer.txt", + file_target = ".h5", + path_base = extdata_path("models", model_dir, "base.h5"), + path_exe = download_engine(), + path_errors_hdf5 = "/", + path_results_hdf5_element = "/", + path_results_hdf5_flaeche = "/", + path_results_hdf5_verschaltungen = "/", + path_results_txt = "/", + path_results_txt_multilayer = "/", + path_target_input = "/" + ) +} +``` + +## Suchraum und Kostensätze + +Die Suchbereiche der variablen Parameter sind die Default-Argumente von +`optimise_swale_design()` — bewusst identisch mit den min/max-Bereichen +des Brute-Force-Rasters, denn nur dort ist die Monotonie geprüft. Hier +stehen sie explizit, damit sie sichtbar und anpassbar sind: + +```{r search_space, eval = can_run} +area_bounds <- c(25, 200) # Muldenflaeche [m2], stufenlos +area_tol <- 2 # Aufloesung der Flaechensuche [m2] +height_bounds <- c(100, 300) # Muldentiefe [mm], stufenlos +height_tol <- 10 # Aufloesung der Tiefensuche [mm] +storage_spec <- default_storage_spec() +# Alternativ Hersteller-Stufen, z. B.: +# storage_spec <- default_storage_spec( +# levels = sickerbox_level_presets()$graf_ecobloc_smart) + +knitr::kable(tibble::tibble( + Parameter = c("mulde_area [m2]", "mulde_height [mm]", + "storage_height Sickerbox [mm]", + "storage_height Schotterrigol [mm]", + "filter_hydraulicconductivity [mm/h]", + "filter_height [mm]"), + Suchraum = c( + sprintf("stufenlos %g bis %g (Toleranz %g)", + area_bounds[1], area_bounds[2], area_tol), + sprintf("stufenlos %g bis %g (Toleranz %g)", + height_bounds[1], height_bounds[2], height_tol), + paste("Stufen:", + paste(storage_spec$infiltration_box$levels, collapse = " / ")), + sprintf("stufenlos %g bis %g (Toleranz %g)", + storage_spec$gravel_trench$bounds[1], + storage_spec$gravel_trench$bounds[2], + storage_spec$gravel_trench$tol), + "fix = 360 (Rastermaximum; kostenfrei dominant)", + "fix = 300" + ) +)) +``` + +Die Kostensätze sind die Defaults nach Leimgruber (2026-03-27, +`default_cost_rates()`); einzelne Sätze lassen sich hier überschreiben — +gerechnet wird zunächst mit den Defaults: + +```{r cost_rates, eval = can_run} +cost_rates <- default_cost_rates() +# Beispiel fuer eine Anpassung (auskommentiert): +# cost_rates$excavation_eur_per_m3 <- 85 +# cost_rates$infiltration_box_eur_per_m3 <- 400 + +knitr::kable( + tibble::tibble(Kostensatz = names(cost_rates), + `EUR je m2/m3` = unlist(cost_rates)), + caption = "Kostensaetze (inkl. Einbau)" +) +``` + +## Optimierung aller Standorte + +Liegen die Rasterergebnisse der Workflow-Vignetten als CSV neben dieser +Vignette, verengen sie als Warmstart die erste Flächensuche auf einen +25-m²-Rasterschritt. + +```{r optimise_all, eval = can_run} +opt_all <- purrr::map_dfr(names(sites), function(site) { + cfg <- sites[[site]] + message("=== ", site, " ===") + + ts <- if (cfg$timeseries) { + read_site_timeseries( + extdata_path("models", cfg$dir, "rain.csv.gz"), + extdata_path("models", cfg$dir, "et.csv") + ) + } else { + NULL + } + + run_fn <- make_swale_runner(make_path_list(site, cfg$dir), + timeseries_rain = ts$rain, + timeseries_et = ts$et) + + prior <- if (file.exists(cfg$prior)) { + readr::read_csv(cfg$prior, show_col_types = FALSE) + } else { + NULL + } + + t0 <- Sys.time() + opt <- optimise_swale_design(run_fn, x_targets = 0:5, + area_bounds = area_bounds, + area_tol = area_tol, + height_bounds = height_bounds, + height_tol = height_tol, + storage_spec = storage_spec, + fixed = fixed, + prior_results = prior, + cost_rates = cost_rates, + verbose = TRUE) + opt$site <- site + opt$n_runs_site <- attr(opt, "n_runs_total") + opt$minutes_site <- round(as.numeric( + difftime(Sys.time(), t0, units = "mins")), 1) + message(sprintf("%s fertig: %d Engine-Laeufe in %.1f min", + site, opt$n_runs_site[1], opt$minutes_site[1])) + opt +}) +``` + +## Ergebnis: günstigstes Design je Standort und Überlaufziel + +```{r results_table, eval = can_run} +knitr::kable( + opt_all[, c("site", "x", "storage_type", "status", "mulde_area", + "mulde_height", "storage_height", "n_overflows", + "overflow_volume_m3", "et_pct", "cost_total")], + digits = c(NA, 0, NA, NA, 1, 0, 0, 0, 1, 1, 0) +) +``` + +```{r cost_curves, eval = can_run, fig.height = 3.4} +library(ggplot2) + +ok <- opt_all[opt_all$status == "ok", ] +ggplot(ok, aes(x, cost_total / 1000, colour = storage_type)) + + geom_line() + + geom_point(size = 2) + + facet_wrap(~ site, scales = "free_y") + + scale_x_continuous(breaks = 0:5) + + labs(title = "Kosten-Wirksamkeits-Kurven: Was kostet ein Ueberlauf weniger?", + x = "Ueberlaufziel x (zulaessige Ereignisse)", + y = "Kosten Optimum [Tsd. EUR]", + colour = "Speichertyp", + caption = cost_rates_caption("de", cost_rates)) + + theme_bw() +``` + +```{r export, eval = can_run} +readr::write_csv(opt_all, "optimisation_results_all_sites.csv") +for (site in unique(opt_all$site)) { + readr::write_csv(opt_all[opt_all$site == site, ], + sprintf("optimisation_results_%s.csv", site)) +} + +knitr::kable(unique(opt_all[, c("site", "n_runs_site", "minutes_site")]), + col.names = c("Standort", "Engine-Laeufe", "Minuten")) +``` + +## Einordnung + +- **Plausibilität:** Die Optima müssen auf oder knapp unter den + günstigsten zulässigen Rasterzellen liegen (Warmstart-Tabelle der + Monotonie-Analyse); die Kostenkurven müssen monoton fallen. + `monotonicity_warning = TRUE` in einer Zeile hieße: Zähler *und* + Volumen sind gemeinsam gestiegen — dann Branch prüfen. +- **Wien x = 0** ist der Stresstest: Im Raster war das Ziel mit + minimalem Speicher teils unerreichbar — hier greift die + Speicher-Eskalation automatisch; "infeasible_within_bounds" wäre ein + reguläres Ergebnis, kein Fehler. +- **Bad Aussee x = 1** trägt den bekannten +1-Zählwobble am Rasterrand; + der Rand-Guard in `find_min_feasible()` deckt ihn ab. +- **Nebenbedingung Tiefe:** `max_total_depth` (mm) begrenzt + Muldentiefe + Filter + Speicher analytisch (DWA-A 138 / Überdeckung), + ohne zusätzliche Läufe. From 1ae3085c0ca6f7a7cdd1494736681aa8334b0b82 Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 4 Aug 2026 08:27:33 +0100 Subject: [PATCH 16/34] Final tweaks --- .Rbuildignore | 1 + .gitignore | 4 + NEWS.md | 31 ++- R/find_min_feasible.R | 22 +- R/optimise_swale_design.R | 19 +- man/find_min_feasible.Rd | 8 + man/optimise_swale_design.Rd | 6 + tests/testthat/test-find_min_feasible.R | 21 ++ tests/testthat/test-optimise_swale_design.R | 16 ++ vignettes/workflow_optimisation.Rmd | 225 ++++++++++++++++++-- 10 files changed, 328 insertions(+), 25 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index b2336fa..7e8b18a 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -10,5 +10,6 @@ ^README\.md$ ^vignettes/index\.Rmd$ ^vignettes/monotonicity_analysis$ +^vignettes/optimiser_vs_bruteforce$ ^\.positai$ ^\.claude$ diff --git a/.gitignore b/.gitignore index 4024089..e07bfe6 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,7 @@ Rplots.pdf # Das betrifft auch den handgeschriebenen Ergebnisbericht index.html # (liegt lokal, als claude.ai-Artefakt und deployt auf dem Server). vignettes/monotonicity_analysis/ + +# Deploy-Ordner der Vergleichs-Praesentation Optimierer vs. Brute-Force +# (handgeschriebenes index.html, liegt auch als claude.ai-Artefakt vor) +vignettes/optimiser_vs_bruteforce/ diff --git a/NEWS.md b/NEWS.md index fd71f28..f1e1021 100644 --- a/NEWS.md +++ b/NEWS.md @@ -17,7 +17,9 @@ cannot eat a solution) and a **volume referee** that warns — and flags the result — iff the overflow count *and* the overflow volume increase together (real non-monotonicity; never observed in the - 5 112 validation comparisons). + 5 112 validation comparisons). An optional `split_jitter` randomises + the bisection split point — a Monte-Carlo of the search path + (repeated runs with different seeds must agree within `tol`). - `optimise_swale_design()` — coordinate descent in cost order: shrink `mulde_area` (the expensive lever) first, then `mulde_height` (the cheap one); the storage layer starts at its smallest level and is @@ -58,6 +60,33 @@ report `index.html` and the exported `mono_*` detail tables as CSV + interactive HTML). +* New conditional vignette `workflow_optimisation` — runs the optimiser + for all three sites (Eisenstadt 2005, Wien, Bad Aussee), **parallelised + over site × storage type** (6 independent tasks via + `future`/`future.apply`; wall time = longest single task, ~15–20 min + instead of ~65 min sequential — bisection within a search is inherently + sequential and the x-targets of one storage type share the evaluation + cache, but box and trench never share a single engine run). Exposes the + search space and the cost rates as explicit, adjustable code (defaults + used), warm-starts from the grid CSVs, renders the combined optimum + table, per-site cost-effectiveness curves, total-runtime reporting + (per task, per section and for the whole document) and a + **Monte-Carlo section** (`n_mc = 10`) evaluating the robustness of the + *search itself*: every bisection split point is randomly displaced + (`split_jitter = 0.3`) while rain, cost rates and all other inputs + stay fixed; the repetitions with different seeds must agree on the + storage level, keep the area within 2 × `area_tol` and the cost within + a few percent — the swale depth may scatter somewhat more because it + is hydraulically coupled to the found area (x = 1; the full pool of + 3 sites × 2 storage types × 10 repetitions runs as 60 parallel tasks, + one full re-optimisation each). + +* New exported helper `read_site_timeseries()` — the rain/ET0 time-series + preparation previously duplicated in the Wien and Bad Aussee vignettes + (hours since start, series-end alignment, engine mm/h convention); + selects strictly `time` + `value`, tolerating extra raw-data columns + (Bad Aussee ships a `substation` column that Wien does not have). + * **testthat suite added** (edition 3; `tests/testthat/`): unit tests for the bisection primitive (threshold accuracy, run counts, wobble guard, volume referee, discrete levels) and end-to-end optimiser tests diff --git a/R/find_min_feasible.R b/R/find_min_feasible.R index ef6c228..69a76ec 100644 --- a/R/find_min_feasible.R +++ b/R/find_min_feasible.R @@ -32,6 +32,12 @@ #' performed. #' @param wobble Maximum counting-artefact size tolerated by the edge guard #' (default 1, matching the observed +1 flips). +#' @param split_jitter Numeric in `[0, 0.45]`, default 0. With 0 the +#' interval is split exactly in half (deterministic). A positive value +#' draws the split fraction uniformly from `0.5 +- split_jitter` -- +#' a Monte-Carlo of the *search path*: repeated runs with different +#' seeds take different routes to the threshold and must agree within +#' `tol` if the result is a property of the problem, not of the path. #' @param volume_column Name of the volume element in the `evaluate` result #' used by the volume referee (default `"overflow_volume_m3"`). #' @param verbose Print one line per evaluation. @@ -61,9 +67,12 @@ find_min_feasible <- function(evaluate, tol = 1, levels = NULL, wobble = 1L, + split_jitter = 0, volume_column = "overflow_volume_m3", verbose = FALSE) { + stopifnot(split_jitter >= 0, split_jitter <= 0.45) + discrete <- !is.null(levels) if (discrete) { grid <- sort(unique(levels)) @@ -146,8 +155,17 @@ find_min_feasible <- function(evaluate, hi <- lo # optimum at (or below) the lower end } while ((hi - lo) > axis_tol) { - mid <- (lo + hi) / 2 - if (discrete) mid <- floor(mid) + frac <- if (split_jitter > 0) { + stats::runif(1, 0.5 - split_jitter, 0.5 + split_jitter) + } else { + 0.5 + } + mid <- lo + frac * (hi - lo) + if (discrete) { + mid <- floor(mid) + if (mid <= lo) mid <- lo + 1 + if (mid >= hi) mid <- hi - 1 + } if (mid <= lo || mid >= hi) break if (feasible(mid)) hi <- mid else lo <- mid } diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index a5ae954..8a48323 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -60,6 +60,10 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' @param prior_results Optional data.frame with prior (grid) results in #' the workflow CSV schema, used as warm start (narrows the first area #' bracket to one grid step). +#' @param split_jitter Passed to [find_min_feasible()]: 0 (default) = +#' deterministic halving; > 0 randomises every bisection split point +#' (Monte-Carlo of the search path -- repeated runs with different +#' seeds must agree within the search tolerances). #' @param max_total_depth Optional analytic depth constraint in mm: #' `mulde_height + filter_height + storage_height <= max_total_depth` #' (e.g. from DWA-A 138 groundwater clearance or cover requirements). @@ -92,6 +96,7 @@ optimise_swale_design <- function(run_fn, bottom_hydraulicconductivity = 12 ), prior_results = NULL, + split_jitter = 0, max_total_depth = NULL, cost_rates = default_cost_rates(), verbose = TRUE) { @@ -143,19 +148,19 @@ optimise_swale_design <- function(run_fn, search_area <- function(eval_a, x, bracket) { res <- find_min_feasible(eval_a, x_max = x, lower = bracket[1], upper = bracket[2], - tol = area_tol) + tol = area_tol, split_jitter = split_jitter) if (identical(res$status, "at_lower_bound") && bracket[1] > area_bounds[1]) { res <- find_min_feasible(eval_a, x_max = x, lower = area_bounds[1], upper = bracket[1], - tol = area_tol) + tol = area_tol, split_jitter = split_jitter) } if (identical(res$status, "infeasible") && bracket[2] < area_bounds[2]) { # warm start was too optimistic -> retry up to the full upper bound res <- find_min_feasible(eval_a, x_max = x, lower = bracket[1], upper = area_bounds[2], - tol = area_tol) + tol = area_tol, split_jitter = split_jitter) } res } @@ -211,12 +216,14 @@ optimise_swale_design <- function(run_fn, if (discrete) { rest <- levels_all[levels_all > h_s] if (length(rest) == 0) return(infeasible_row()) - res_s <- find_min_feasible(eval_s, x_max = x, levels = rest) + res_s <- find_min_feasible(eval_s, x_max = x, levels = rest, + split_jitter = split_jitter) } else { if (h_s >= gb[2]) return(infeasible_row()) res_s <- find_min_feasible(eval_s, x_max = x, lower = h_s, upper = gb[2], - tol = gravel_tol) + tol = gravel_tol, + split_jitter = split_jitter) } mono_warn <- mono_warn || res_s$monotonicity_violation if (identical(res_s$status, "infeasible")) return(infeasible_row()) @@ -233,7 +240,7 @@ optimise_swale_design <- function(run_fn, res_h <- find_min_feasible( function(h) eval_design(type, a_star, h, h_s), x_max = x, lower = height_bounds[1], upper = h_m_up, - tol = height_tol + tol = height_tol, split_jitter = split_jitter ) mono_warn <- mono_warn || res_h$monotonicity_violation if (!identical(res_h$status, "infeasible")) h_m_star <- res_h$value diff --git a/man/find_min_feasible.Rd b/man/find_min_feasible.Rd index b903494..4137642 100644 --- a/man/find_min_feasible.Rd +++ b/man/find_min_feasible.Rd @@ -12,6 +12,7 @@ find_min_feasible( tol = 1, levels = NULL, wobble = 1L, + split_jitter = 0, volume_column = "overflow_volume_m3", verbose = FALSE ) @@ -35,6 +36,13 @@ performed.} \item{wobble}{Maximum counting-artefact size tolerated by the edge guard (default 1, matching the observed +1 flips).} +\item{split_jitter}{Numeric in \verb{[0, 0.45]}, default 0. With 0 the +interval is split exactly in half (deterministic). A positive value +draws the split fraction uniformly from \code{0.5 +- split_jitter} -- +a Monte-Carlo of the \emph{search path}: repeated runs with different +seeds take different routes to the threshold and must agree within +\code{tol} if the result is a property of the problem, not of the path.} + \item{volume_column}{Name of the volume element in the \code{evaluate} result used by the volume referee (default \code{"overflow_volume_m3"}).} diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index 690f6f4..0a1969d 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -15,6 +15,7 @@ optimise_swale_design( fixed = list(connected_area = 1000, filter_height = 300, filter_hydraulicconductivity = 360, bottom_hydraulicconductivity = 12), prior_results = NULL, + split_jitter = 0, max_total_depth = NULL, cost_rates = default_cost_rates(), verbose = TRUE @@ -48,6 +49,11 @@ continuous \code{bounds} + \code{tol} (gravel trench).} the workflow CSV schema, used as warm start (narrows the first area bracket to one grid step).} +\item{split_jitter}{Passed to \code{\link[=find_min_feasible]{find_min_feasible()}}: 0 (default) = +deterministic halving; > 0 randomises every bisection split point +(Monte-Carlo of the search path -- repeated runs with different +seeds must agree within the search tolerances).} + \item{max_total_depth}{Optional analytic depth constraint in mm: \code{mulde_height + filter_height + storage_height <= max_total_depth} (e.g. from DWA-A 138 groundwater clearance or cover requirements). diff --git a/tests/testthat/test-find_min_feasible.R b/tests/testthat/test-find_min_feasible.R index 1dde70e..e2d3a79 100644 --- a/tests/testthat/test-find_min_feasible.R +++ b/tests/testthat/test-find_min_feasible.R @@ -65,6 +65,27 @@ test_that("Volumen-Schiedsrichter: Warnung nur bei echter Nicht-Monotonie", { expect_false(res_ok$monotonicity_violation) }) +test_that("split_jitter: zufaellige Suchpfade treffen dieselbe Schwelle", { + f <- function(v) list(n_overflows = if (v >= 137.4) 0L else 10L) + vals <- vapply(1:5, function(s) { + set.seed(s) + find_min_feasible(f, x_max = 0, lower = 25, upper = 200, tol = 2, + split_jitter = 0.3)$value + }, numeric(1)) + expect_true(all(vals >= 137.4 & vals <= 137.4 + 2)) + # verschiedene Seeds -> verschiedene Pfade (fast sicher versch. Werte) + expect_gt(length(unique(round(vals, 6))), 1) + + # diskrete Levels mit Jitter: identisches Ergebnis wie deterministisch + lv <- c(300, 600, 900, 1200) + g <- function(v) list(n_overflows = if (v >= 900) 0L else 7L) + set.seed(99) + expect_equal( + find_min_feasible(g, x_max = 0, levels = lv, split_jitter = 0.3)$value, + 900 + ) +}) + test_that("diskrete Levels: Binaersuche ueber Stufen", { lv <- c(300, 600, 900, 1200) f <- function(v) list(n_overflows = if (v >= 900) 0L else 7L) diff --git a/tests/testthat/test-optimise_swale_design.R b/tests/testthat/test-optimise_swale_design.R index f40cc23..76e7944 100644 --- a/tests/testthat/test-optimise_swale_design.R +++ b/tests/testthat/test-optimise_swale_design.R @@ -119,6 +119,22 @@ test_that("Warmstart aus Rasterergebnissen spart Laeufe", { expect_lt(attr(warm, "n_runs_total"), attr(cold, "n_runs_total")) }) +test_that("Such-MC: gejitterte Pfade treffen das deterministische Optimum", { + run <- synthetic_run_factory(demand = 3.6e5) + det <- optimise_swale_design(run, x_targets = 1, fixed = test_fixed, + verbose = FALSE) + for (s in 1:3) { + set.seed(s) + jit <- optimise_swale_design(run, x_targets = 1, fixed = test_fixed, + split_jitter = 0.3, verbose = FALSE) + expect_equal(jit$storage_height, det$storage_height) + expect_lte(max(abs(jit$mulde_area - det$mulde_area)), 2) # area_tol + expect_lte(max(abs(jit$mulde_height - det$mulde_height)), 10) # height_tol + expect_lte(max(abs(jit$cost_total - det$cost_total) / det$cost_total), + 0.03) + } +}) + test_that("max_total_depth wirkt als analytische Nebenbedingung", { run <- synthetic_run_factory(demand = 3.6e5) out <- optimise_swale_design(run, x_targets = 0, fixed = test_fixed, diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index 6c184d3..ffe058d 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -30,6 +30,8 @@ path_base <- extdata_path("models", "eisenstadt-2005", "base.h5") data_available <- nzchar(path_base) && file.exists(path_base) is_windows <- Sys.info()[["sysname"]] == "Windows" can_run <- data_available && is_windows && !is_ghactions + +t_vignette_start <- Sys.time() ``` ## Ziel @@ -53,8 +55,9 @@ Hersteller-Alternativen), der Schotterrigol stufenlos im 3-fachen Box-Bereich. **Laufzeit:** Ein Engine-Lauf dauert ~2 s (Eisenstadt, 1 Jahr) bzw. -~15 s (Wien / Bad Aussee, 15-Jahres-Serien); der komplette Workflow -liegt damit bei ca. 30–40 Minuten. +~15 s (Wien / Bad Aussee, 15-Jahres-Serien). Die 6 Tasks +(Standort × Speichertyp) laufen parallel; die Gesamtdauer entspricht +dem längsten Einzeltask — ca. 15–20 Minuten. ```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} cat(sprintf(paste0( @@ -185,21 +188,49 @@ knitr::kable( ) ``` -## Optimierung aller Standorte +## Optimierung aller Standorte (parallel) + +Parallelisiert wird über **Standort × Speichertyp = 6 unabhängige +Tasks**: Die Bisektion innerhalb einer Suche ist prinzipbedingt +sequentiell, und die x-Ziele eines Speichertyps teilen sich den +Evaluations-Cache — aber Box- und Rigol-Läufe teilen keinen einzigen +Engine-Lauf (der Cache-Schlüssel enthält den Typ). Jeder Worker ist ein +eigener R-Prozess mit eigenem `tempdir()`, Kollisionen sind damit +ausgeschlossen. Die Wall-Time entspricht dem längsten Einzeltask +(Wien/Rigol, ~15–20 min) statt der Summe aller Tasks (~65 min). Liegen die Rasterergebnisse der Workflow-Vignetten als CSV neben dieser Vignette, verengen sie als Warmstart die erste Flächensuche auf einen 25-m²-Rasterschritt. ```{r optimise_all, eval = can_run} -opt_all <- purrr::map_dfr(names(sites), function(site) { - cfg <- sites[[site]] - message("=== ", site, " ===") +t_opt_start <- Sys.time() + +tasks <- expand.grid(site = names(sites), type = names(storage_spec), + stringsAsFactors = FALSE) + +future::plan(future::multisession, + workers = min(nrow(tasks), + max(1, parallel::detectCores() - 1))) + +opt_list <- future.apply::future_lapply(seq_len(nrow(tasks)), function(i) { + site <- tasks$site[i] + type <- tasks$type[i] + + # Worker = eigener Prozess: Paket dort genauso laden wie im Hauptprozess + if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) + } else { + library(kwb.raindrop) + } + cfg <- sites[[site]] ts <- if (cfg$timeseries) { read_site_timeseries( extdata_path("models", cfg$dir, "rain.csv.gz"), - extdata_path("models", cfg$dir, "et.csv") + extdata_path("models", cfg$dir, "et.csv"), + verbose = FALSE ) } else { NULL @@ -221,19 +252,22 @@ opt_all <- purrr::map_dfr(names(sites), function(site) { area_tol = area_tol, height_bounds = height_bounds, height_tol = height_tol, - storage_spec = storage_spec, + storage_spec = storage_spec[type], fixed = fixed, prior_results = prior, cost_rates = cost_rates, - verbose = TRUE) + verbose = FALSE) opt$site <- site - opt$n_runs_site <- attr(opt, "n_runs_total") - opt$minutes_site <- round(as.numeric( + opt$n_runs_task <- attr(opt, "n_runs_total") + opt$minutes_task <- round(as.numeric( difftime(Sys.time(), t0, units = "mins")), 1) - message(sprintf("%s fertig: %d Engine-Laeufe in %.1f min", - site, opt$n_runs_site[1], opt$minutes_site[1])) opt -}) +}, future.seed = TRUE) + +future::plan(future::sequential) +opt_all <- dplyr::bind_rows(opt_list) + +t_opt_end <- Sys.time() ``` ## Ergebnis: günstigstes Design je Standort und Überlaufziel @@ -271,8 +305,155 @@ for (site in unique(opt_all$site)) { sprintf("optimisation_results_%s.csv", site)) } -knitr::kable(unique(opt_all[, c("site", "n_runs_site", "minutes_site")]), - col.names = c("Standort", "Engine-Laeufe", "Minuten")) +task_stats <- unique(opt_all[, c("site", "storage_type", "n_runs_task", + "minutes_task")]) +knitr::kable( + task_stats, + col.names = c("Standort", "Speichertyp", "Engine-Laeufe", "Minuten") +) +``` + +```{r runtime_total, echo = FALSE, results = 'asis', eval = can_run} +opt_wall_min <- as.numeric(difftime(t_opt_end, t_opt_start, units = "mins")) +cat(sprintf(paste0( + "**Gesamtlaufzeit Optimierung:** %d Engine-Läufe · Summe der ", + "Task-Zeiten %.1f min · tatsächliche Laufzeit %.1f min ", + "(paralleler Speedup %.1f×).\n"), + sum(task_stats$n_runs_task), sum(task_stats$minutes_task), + opt_wall_min, sum(task_stats$minutes_task) / max(opt_wall_min, 0.1) +)) +``` + +## Monte-Carlo-Analyse: Wie robust ist die Suche selbst? + +Die Bisektion ist deterministisch: gleiche Eingaben, gleicher Pfad, +gleiches Ergebnis. Die Monte-Carlo-Frage lautet deshalb: **Hängt das +gefundene Optimum vom Suchpfad ab?** Dazu wird der Teilungspunkt jeder +Bisektion zufällig verschoben (`split_jitter = 0.3`: Teilung zufällig +zwischen 20 % und 80 % des Intervalls statt exakt mittig) und die +Optimierung `n_mc`-mal mit unterschiedlichen Seeds wiederholt — **Regen, +Kostensätze und alle übrigen Eingaben bleiben unverändert** (x = 1, ohne +Warmstart, damit jede Wiederholung den vollen Suchraum durchläuft). +Gerechnet wird der volle Pool **3 Standorte × 2 Speichertypen × +`n_mc` Wiederholungen = 60 unabhängige Tasks**, alle parallel (je Task +eine komplette Neu-Optimierung mit ~15 Engine-Läufen; Wall-Time je nach +Kernzahl ~20–35 min). Erwartung, wenn das Optimum eine +Eigenschaft des Problems ist — und nicht des Wegs, den die Suche +genommen hat: **identische Speicherstufe, Flächen-Spanne ≤ +2 × `area_tol`, Kostenspanne von wenigen Prozent**. Die Muldentiefe +darf etwas weiter streuen als 2 × `height_tol`: Sie ist über die +Hydraulik an die gefundene Fläche gekoppelt (eine um `area_tol` größere +Fläche erlaubt eine entsprechend geringere Tiefe), sodass sich dort die +Toleranzen beider Suchen addieren. + +```{r mc_config, eval = can_run} +n_mc <- 10 +mc_seeds <- 1:n_mc +``` + +```{r mc_search, eval = can_run} +t_mc_start <- Sys.time() + +mc_tasks <- expand.grid(site = names(sites), type = names(storage_spec), + rep = seq_len(n_mc), stringsAsFactors = FALSE) + +future::plan(future::multisession, + workers = min(nrow(mc_tasks), + max(1, parallel::detectCores() - 1))) + +mc_search <- future.apply::future_lapply(seq_len(nrow(mc_tasks)), function(i) { + site <- mc_tasks$site[i] + type <- mc_tasks$type[i] + rep <- mc_tasks$rep[i] + + if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) + } else { + library(kwb.raindrop) + } + set.seed(mc_seeds[rep]) + + cfg <- sites[[site]] + ts <- if (cfg$timeseries) { + read_site_timeseries( + extdata_path("models", cfg$dir, "rain.csv.gz"), + extdata_path("models", cfg$dir, "et.csv"), + verbose = FALSE + ) + } else { + NULL + } + run_fn <- make_swale_runner(make_path_list(paste0(site, "_MC"), cfg$dir), + timeseries_rain = ts$rain, + timeseries_et = ts$et) + + opt <- optimise_swale_design( + run_fn, x_targets = 1, + area_bounds = area_bounds, area_tol = area_tol, + height_bounds = height_bounds, height_tol = height_tol, + storage_spec = storage_spec[type], + fixed = fixed, + split_jitter = 0.3, + cost_rates = cost_rates, verbose = FALSE + ) + opt$site <- site + opt$rep <- rep + opt$n_runs_rep <- attr(opt, "n_runs_total") + opt +}, future.seed = TRUE) + +future::plan(future::sequential) +mc_search <- dplyr::bind_rows(mc_search) + +t_mc_end <- Sys.time() +``` + +```{r mc_search_summary, eval = can_run, fig.height = 3.4} +ok_mc <- mc_search[mc_search$status == "ok", ] + +ggplot(ok_mc, aes(rep, cost_total / 1000, colour = storage_type)) + + geom_point(size = 2) + + facet_wrap(~ site, scales = "free_y") + + scale_x_continuous(breaks = seq_len(n_mc)) + + labs(title = sprintf( + "Such-Monte-Carlo (x = 1, %d zufaellige Suchpfade je Standort und Typ)", + n_mc), + x = "Wiederholung (Seed)", + y = "Kosten Optimum [Tsd. EUR]", + colour = "Speichertyp") + + theme_bw() + +knitr::kable( + ok_mc %>% + dplyr::group_by(site, storage_type) %>% + dplyr::summarise( + flaeche_spanne_m2 = max(mulde_area) - min(mulde_area), + tiefe_spanne_mm = max(mulde_height) - min(mulde_height), + speicher_identisch = dplyr::n_distinct(storage_height) == 1, + kosten_min = min(cost_total), + kosten_max = max(cost_total), + kosten_spanne_pct = round(100 * (max(cost_total) - min(cost_total)) / + min(cost_total), 2), + .groups = "drop" + ), + digits = 1, + caption = paste("Streuung ueber die Suchpfade -- erwartet: identische", + "Speicherstufe, Flaechen-Spanne <= 2 x area_tol,", + "Kostenspanne wenige Prozent; die Tiefe streut wegen", + "der Flaechen-Kopplung weiter") +) +``` + +```{r mc_runtime, echo = FALSE, results = 'asis', eval = can_run} +cat(sprintf(paste0( + "**Laufzeit Such-Monte-Carlo:** %d Engine-Läufe in %.1f min ", + "(parallel über %d Tasks: %d Standorte × %d Speichertypen × ", + "%d Wiederholungen).\n"), + sum(mc_search$n_runs_rep), + as.numeric(difftime(t_mc_end, t_mc_start, units = "mins")), + nrow(mc_tasks), length(sites), length(storage_spec), n_mc +)) ``` ## Einordnung @@ -291,3 +472,15 @@ knitr::kable(unique(opt_all[, c("site", "n_runs_site", "minutes_site")]), - **Nebenbedingung Tiefe:** `max_total_depth` (mm) begrenzt Muldentiefe + Filter + Speicher analytisch (DWA-A 138 / Überdeckung), ohne zusätzliche Läufe. + +```{r vignette_runtime, echo = FALSE, results = 'asis', eval = can_run} +cat(sprintf(paste0( + "---\n\n**Gesamtlaufzeit dieser Vignette:** %.1f Minuten ", + "(Optimierung %.1f min · Such-Monte-Carlo %.1f min · ", + "Rest: Setup und Rendern).\n"), + as.numeric(difftime(Sys.time(), t_vignette_start, units = "mins")), + opt_wall_min, + as.numeric(difftime(t_mc_end, t_mc_start, units = "mins")) +)) +``` + From 7423796c96224e9c8d27f60ba2f501e90be52822 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 09:59:46 +0000 Subject: [PATCH 17/34] Add simultaneous all-parameter optimiser as alternative to bisection New optimise_swale_design_simultaneous(): penalised Nelder-Mead search (stats::optim, no new dependency) over mulde_area, mulde_height and storage_height at once, instead of per-parameter bisection. Infeasible designs are graded-penalised rather than excluded, so the simplex can trade parameters against each other and the method does not rely on the per-parameter monotonicity assumption. Engine runs stay bounded via tolerance snapping (shared evaluation cache across all x targets), a deterministic multistart (prior warm start, previous-target optimum, one anchor start per storage level, space-filling points; equal budget slices per start) and a final lattice polish. Same interface and result schema as optimise_swale_design(); a pairwise dominance check replaces the bisection's volume referee. - tests mirroring the bisection suite (brute-force reference, implicit storage escalation, infeasibility, warm start, max_total_depth) plus a mutual cross-check between both optimisers - workflow_optimisation vignette: new section running the simultaneous search for all sites and tabulating cost deltas vs. bisection - NEWS entry, docs and cross-references Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NAMESPACE | 1 + NEWS.md | 27 + R/optimise_swale_design.R | 6 +- R/optimise_swale_design_simultaneous.R | 518 ++++++++++++++++++ man/optimise_swale_design.Rd | 6 +- man/optimise_swale_design_simultaneous.Rd | 161 ++++++ .../test-optimise_swale_design_simultaneous.R | 158 ++++++ vignettes/workflow_optimisation.Rmd | 146 ++++- 8 files changed, 1014 insertions(+), 9 deletions(-) create mode 100644 R/optimise_swale_design_simultaneous.R create mode 100644 man/optimise_swale_design_simultaneous.Rd create mode 100644 tests/testthat/test-optimise_swale_design_simultaneous.R diff --git a/NAMESPACE b/NAMESPACE index 08ebe14..88d18a0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(h5_write_values) export(list_h5_datasets) export(make_swale_runner) export(optimise_swale_design) +export(optimise_swale_design_simultaneous) export(plot_cost_overflow_boxplot) export(plot_cost_vs_evaporation) export(plot_cost_vs_overflow_volume) diff --git a/NEWS.md b/NEWS.md index f1e1021..2c9d2f4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -32,6 +32,33 @@ simulation runs, and "infeasible within bounds" is a regular result status, not an error. Costs are attached via `compute_costs()`; all evaluated designs ship as attribute `"evaluations"`. + - `optimise_swale_design_simultaneous()` — alternative optimiser that + searches **all design parameters at once** (`mulde_area`, + `mulde_height`, `storage_height`) with a penalised Nelder-Mead + simplex (`stats::optim()`, no new dependency) instead of + per-parameter bisection: infeasible designs are not excluded but + penalised (any infeasible design is worse than any feasible one; + excess overflow events grade the penalty and steer the simplex back), + so the search can trade the parameters against each other in a + single step and does not rely on the per-parameter monotonicity the + bisection exploits. Engine runs are kept in check by snapping every + candidate to the search tolerances (the shared cache absorbs + repeats across all `x_targets`), a deterministic multistart (prior + warm start, previous-target optimum, one anchor start per storage + level — the flat cost valley along the feasibility boundary makes + the cheapest storage level easy to miss from a single start — then + space-filling points; every start gets an equal slice of the + `max_evals` run budget) and a final lattice polish that makes the + result locally optimal on the tolerance lattice. Same interface and + result schema as `optimise_swale_design()` (incl. `max_total_depth`, + warm start and the `"evaluations"` attribute); a pairwise dominance + check per cell (a strictly larger design with more overflows *and* + more overflow volume) replaces the bisection's volume referee. + Needs more engine runs per cell (typically 30–80 instead of ~15) + but serves as an independent cross-check that coordinate descent + did not miss a cheaper corner of the design space; the + `workflow_optimisation` vignette gained a section running both + optimisers for all three sites and tabulating the cost deltas. - `make_swale_runner()` — package-level refactoring of the `run_one()` function previously duplicated across the three case-study vignettes: one closure factory covering both variants (Eisenstadt: diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index 8a48323..e441903 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -79,8 +79,10 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' runs spent on this cell). All evaluated designs are attached as #' attribute `"evaluations"`. #' -#' @seealso [find_min_feasible()], [make_swale_runner()], -#' [default_storage_spec()] +#' @seealso [optimise_swale_design_simultaneous()] (alternative: all +#' parameters at once via penalised Nelder-Mead, as an independent +#' cross-check of the coordinate descent), [find_min_feasible()], +#' [make_swale_runner()], [default_storage_spec()] #' @export optimise_swale_design <- function(run_fn, x_targets = 0:5, diff --git a/R/optimise_swale_design_simultaneous.R b/R/optimise_swale_design_simultaneous.R new file mode 100644 index 0000000..084c772 --- /dev/null +++ b/R/optimise_swale_design_simultaneous.R @@ -0,0 +1,518 @@ +#' Cheapest feasible prior design as warm start for the simultaneous search +#' +#' Picks the cheapest feasible grid cell of the matching branch from prior +#' (brute-force) results in the workflow CSV schema. Returns a one-row +#' data.frame with `mulde_area`, `mulde_height`, `storage_height`, or +#' `NULL` if the prior does not contain a feasible cell for this branch. +#' +#' @keywords internal +#' @noRd +prior_start_design <- function(prior, type, x, filter_height, cost_rates) { + needed <- c("storage_type", "storage_height", "mulde_height", "mulde_area", + "n_overflows", "filter_hydraulicconductivity") + if (is.null(prior) || !all(needed %in% names(prior))) return(NULL) + kf_max <- suppressWarnings( + max(prior$filter_hydraulicconductivity, na.rm = TRUE) + ) + d <- prior[prior$storage_type == type & + prior$filter_hydraulicconductivity == kf_max & + !is.na(prior$n_overflows) & prior$n_overflows <= x, , + drop = FALSE] + if (nrow(d) == 0) return(NULL) + if (!"filter_height" %in% names(d)) d$filter_height <- filter_height + d <- compute_costs(d, cost_rates = cost_rates) + d[which.min(d$cost_total), + c("mulde_area", "mulde_height", "storage_height"), drop = FALSE] +} + +#' Find the cost-optimal swale design by simultaneous parameter search +#' +#' Alternative to the coordinate-descent optimiser +#' ([optimise_swale_design()], bisection per parameter): all design +#' parameters -- `mulde_area`, `mulde_height` and `storage_height` -- are +#' optimised **simultaneously** with a penalised Nelder-Mead search +#' (`stats::optim()`). Infeasible designs (`n_overflows > x`) are not +#' excluded but penalised (any infeasible design is worse than any feasible +#' one; the number of excess events grades the penalty, steering the +#' simplex back towards feasibility), so the search moves freely through +#' the full parameter space and can trade the parameters against each +#' other in a single step -- it does not rely on the per-parameter +#' monotonicity that the bisection exploits. +#' +#' Three ingredients keep the number of engine runs in check: +#' \itemize{ +#' \item \strong{Snapping}: every candidate is snapped to the search +#' tolerances (`area_tol`, `height_tol`, storage `tol` / discrete +#' `levels`) before evaluation, so the shared cache absorbs repeated +#' visits and the sweep over all `x_targets` reuses runs. +#' \item \strong{Multistart}: `n_starts` deterministic starting points +#' (prior warm start and the optimum of the previous overflow target +#' first, then a *storage ladder* -- one anchor start per storage +#' level, smallest level first -- then fixed space-filling points) +#' guard against the simplex stalling on the plateaus that the +#' snapping and the integer overflow count create, and make sure every +#' storage level competes: along the feasibility boundary the cost +#' valley is flat, so the cheapest (usually smallest) storage level is +#' easily missed from a single start. Different starts take different +#' search paths -- the counterpart of `split_jitter` in the bisection +#' optimiser. Every start receives an equal slice of the remaining +#' `max_evals` budget (unused runs roll over). +#' \item \strong{Lattice polish}: from the best feasible design found, +#' single tolerance steps downwards (cheaper by construction) are +#' tested until no parameter can be reduced any further -- the result +#' is locally optimal on the tolerance lattice. +#' } +#' +#' The discrete infiltration-box levels are mapped onto a continuous +#' latent axis (each level owns an equal share of `[0, 1]`), the gravel +#' trench is searched continuously. The filter conductivity is expected to +#' be fixed at the maximum via `fixed` (cost-free and dominant, see the +#' `monotonicity_analysis` vignette). `max_total_depth` is enforced by +#' construction (the `mulde_height` axis is compressed to the remaining +#' depth), so no simulation runs are spent on depth-invalid designs. +#' +#' Compared to [optimise_swale_design()] this needs more engine runs per +#' cell (typically 30-60 instead of ~15) but serves as an independent +#' cross-check: it can discover cheaper corners of the design space that +#' coordinate descent would miss if the parameter interaction were +#' stronger than the monotonicity analysis suggests. +#' +#' @param run_fn `function(params)` running one scenario and returning at +#' least `n_overflows` plus `sum_overflows` (mm) or `overflow_volume_m3`; +#' typically created with [make_swale_runner()]. `params` is a named list +#' of `mulde_area`, `mulde_height`, `storage_type`, `storage_height` plus +#' everything in `fixed`. +#' @param x_targets Integer vector of overflow targets (feasible :<=> +#' `n_overflows <= x`), default `0:5`. +#' @param area_bounds,area_tol Search range (m2) and resolution for +#' `mulde_area`. +#' @param height_bounds,height_tol Search range (mm) and resolution for +#' `mulde_height`. +#' @param storage_spec Storage search space per type, see +#' [default_storage_spec()]: discrete `levels` (infiltration box) or +#' continuous `bounds` + `tol` (gravel trench). +#' @param fixed Named list of parameters passed unchanged to `run_fn` +#' (connected area, filter geometry, kf at maximum, ...). Must contain +#' `filter_height` for the cost model. +#' @param prior_results Optional data.frame with prior (grid) results in +#' the workflow CSV schema, used as warm start (the cheapest feasible +#' grid cell of the branch becomes the first Nelder-Mead start). +#' @param n_starts Number of Nelder-Mead starts per (storage type, x) +#' cell (default 4). Warm starts (prior, previous target) count towards +#' this number, then the storage-ladder anchors, then the space-filling +#' points. +#' @param max_evals Soft cap on fresh engine runs per cell: once reached, +#' the Nelder-Mead phase winds down (already cached designs remain +#' free); the final lattice polish may add a few runs beyond the cap. +#' Default 80 -- thanks to the shared cache the later `x_targets` of a +#' storage type stay far below this. +#' @param wobble Maximum counting-artefact size tolerated at the upper +#' corner (default 1, matching the +1 event-counting wobble): only if +#' the maximal design overflows by more than `wobble` events is the +#' cell declared infeasible without a search. +#' @param max_total_depth Optional analytic depth constraint in mm: +#' `mulde_height + filter_height + storage_height <= max_total_depth` +#' (e.g. from DWA-A 138 groundwater clearance or cover requirements). +#' Enforced without any simulation runs. +#' @param cost_rates Unit costs, see [default_cost_rates()]. +#' @param verbose Print one progress line per solved cell. +#' +#' @return Tibble with one row per (storage type, x), same schema as +#' [optimise_swale_design()]: the optimal design (`mulde_area`, +#' `mulde_height`, `storage_height`), its metrics (`n_overflows`, +#' `overflow_volume_m3`, `et_pct`), cost columns from [compute_costs()], +#' a `status` (`"ok"` or `"infeasible_within_bounds"`), +#' `monotonicity_warning` (`TRUE` if a strictly larger design produced +#' more overflows *and* more overflow volume among the cell's +#' evaluations) and `n_runs_new` (fresh engine runs spent on this cell). +#' All evaluated designs are attached as attribute `"evaluations"`. +#' +#' @examples +#' # synthetic monotone model: overflows fall with retention capacity +#' run <- function(params) { +#' cap <- params$mulde_area * +#' (params$mulde_height + 0.95 * params$storage_height) +#' list(n_overflows = max(0, floor(3.6e5 / cap) - 3), +#' sum_overflows = 800 * max(0, 3.6e5 / cap - 3)) +#' } +#' opt <- optimise_swale_design_simultaneous( +#' run, x_targets = 1, +#' storage_spec = default_storage_spec()["infiltration_box"], +#' verbose = FALSE +#' ) +#' opt[, c("x", "mulde_area", "mulde_height", "storage_height", "cost_total")] +#' +#' @seealso [optimise_swale_design()] (coordinate descent / bisection), +#' [make_swale_runner()], [default_storage_spec()] +#' @export +optimise_swale_design_simultaneous <- function(run_fn, + x_targets = 0:5, + area_bounds = c(25, 200), + area_tol = 2, + height_bounds = c(100, 300), + height_tol = 10, + storage_spec = default_storage_spec(), + fixed = list( + connected_area = 1000, + filter_height = 300, + filter_hydraulicconductivity = 360, + bottom_hydraulicconductivity = 12 + ), + prior_results = NULL, + n_starts = 4, + max_evals = 80, + wobble = 1L, + max_total_depth = NULL, + cost_rates = default_cost_rates(), + verbose = TRUE) { + + stopifnot(is.function(run_fn), !is.null(fixed$filter_height), + n_starts >= 1, max_evals >= 10) + filter_height <- fixed$filter_height + + # --- shared evaluation cache (one engine run per distinct design) ------- + cache <- new.env(parent = emptyenv()) + runs_executed <- 0L + + cache_key <- function(type, area, h_m, h_s) { + paste(type, format(area, digits = 10), format(h_m, digits = 10), + format(h_s, digits = 10), sep = "|") + } + + eval_design <- function(type, area, h_m, h_s) { + key <- cache_key(type, area, h_m, h_s) + hit <- cache[[key]] + if (!is.null(hit)) return(hit) + params <- c(list(mulde_area = area, mulde_height = h_m, + storage_type = type, storage_height = h_s), fixed) + res <- as.list(run_fn(params)) + if (!"n_overflows" %in% names(res)) { + stop("optimise_swale_design_simultaneous(): ", + "run_fn() must return 'n_overflows'") + } + vol <- res[["overflow_volume_m3"]] + if (is.null(vol) && !is.null(res[["sum_overflows"]])) { + vol <- res[["sum_overflows"]] * area / 1000 # mm x m2 / 1000 = m3 + } + et <- res[["element.WB_Evapotranspiration_"]] + out <- list(storage_type = type, mulde_area = area, mulde_height = h_m, + storage_height = h_s, + n_overflows = as.numeric(res$n_overflows), + overflow_volume_m3 = if (is.null(vol)) NA_real_ else as.numeric(vol), + et_pct = if (is.null(et)) NA_real_ else as.numeric(et)) + runs_executed <<- runs_executed + 1L + assign(key, out, envir = cache) + out + } + + cost_total_of <- function(type, area, h_m, h_s) { + compute_costs( + tibble::tibble(mulde_area = area, mulde_height = h_m, + filter_height = filter_height, storage_height = h_s, + storage_type = type), + cost_rates = cost_rates + )$cost_total + } + + # --- analytic depth constraint ------------------------------------------ + hm_upper <- function(h_s) { + up <- rep(height_bounds[2], length(h_s)) + if (!is.null(max_total_depth)) { + up <- pmin(up, max_total_depth - filter_height - h_s) + } + up + } + + snap_to <- function(v, origin, step) { + origin + round((v - origin) / step) * step + } + + # fixed space-filling starts in the unit cube (area, height, storage); + # deterministic on purpose -- repeated calls give identical results + default_starts <- list( + c(0.70, 0.85, 0.25), c(0.35, 0.50, 0.65), c(0.15, 0.95, 0.85), + c(0.55, 0.25, 0.45), c(0.80, 0.35, 0.75), c(0.25, 0.70, 0.15) + ) + + # --- pairwise dominance check over the evaluations of one cell ---------- + # violation :<=> a strictly larger design (all three parameters >=, at + # least one >) has MORE overflows AND MORE overflow volume -- the + # simultaneous analogue of the bisection's volume referee + dominance_violation <- function(evs) { + if (length(evs) < 2) return(FALSE) + m <- do.call(rbind, lapply(evs, function(e) { + c(e$area, e$h_m, e$h_s, e$n, e$vol) + })) + for (i in seq_len(nrow(m) - 1)) { + for (j in (i + 1):nrow(m)) { + if (any(is.na(m[i, 4:5])) || any(is.na(m[j, 4:5]))) next + d <- m[i, 1:3] - m[j, 1:3] + big <- if (all(d >= 0) && any(d > 0)) i + else if (all(d <= 0) && any(d < 0)) j + else next + small <- if (big == i) j else i + if (m[big, 4] > m[small, 4] && m[big, 5] > m[small, 5] + 1e-9) { + return(TRUE) + } + } + } + FALSE + } + + # --- solve one (storage type, x) cell ------------------------------------ + # returns list(row = tibble, best_u = unit-cube position of the optimum, + # used as warm start for the next overflow target of the same type) + solve_cell <- function(type, x, extra_start = NULL) { + runs_before <- runs_executed + spec <- storage_spec[[type]] + if (is.null(spec)) { + stop("optimise_swale_design_simultaneous(): ", + "storage_spec has no entry '", type, "'") + } + discrete <- !is.null(spec$levels) + mono_warn <- FALSE + cell_evals <- list() + + infeasible_row <- function() list( + row = tibble::tibble( + x = x, storage_type = type, status = "infeasible_within_bounds", + mulde_area = NA_real_, mulde_height = NA_real_, + storage_height = NA_real_, n_overflows = NA_real_, + overflow_volume_m3 = NA_real_, et_pct = NA_real_, + monotonicity_warning = mono_warn, + n_runs_new = runs_executed - runs_before + ), + best_u = NULL + ) + + if (discrete) { + levels_all <- sort(spec$levels) + levels_all <- levels_all[hm_upper(levels_all) >= height_bounds[1]] + if (length(levels_all) == 0) return(infeasible_row()) + hs_max <- levels_all[length(levels_all)] + } else { + gb <- spec$bounds + if (!is.null(max_total_depth)) { + gb[2] <- min(gb[2], max_total_depth - filter_height - height_bounds[1]) + } + if (gb[2] <= gb[1]) return(infeasible_row()) + s_tol <- if (is.null(spec$tol)) 25 else spec$tol + hs_max <- gb[2] + } + + # unit cube [0,1]^3 -> snapped physical design (depth-valid by + # construction: the mulde_height axis is compressed to hm_upper(h_s)) + decode <- function(u) { + u <- pmin(1, pmax(0, u)) + a <- snap_to(area_bounds[1] + u[1] * diff(area_bounds), + area_bounds[1], area_tol) + a <- min(max(a, area_bounds[1]), area_bounds[2]) + h_s <- if (discrete) { + levels_all[min(length(levels_all), + 1L + as.integer(floor(u[3] * length(levels_all))))] + } else { + s <- snap_to(gb[1] + u[3] * (gb[2] - gb[1]), gb[1], s_tol) + min(max(s, gb[1]), gb[2]) + } + up <- hm_upper(h_s) + h_m <- snap_to(height_bounds[1] + u[2] * (up - height_bounds[1]), + height_bounds[1], height_tol) + h_m <- min(max(h_m, height_bounds[1]), up) + list(area = a, h_m = h_m, h_s = h_s) + } + + encode <- function(area, h_m, h_s) { + u3 <- if (discrete) { + i <- which.min(abs(levels_all - h_s)) + (i - 0.5) / length(levels_all) + } else { + (h_s - gb[1]) / (gb[2] - gb[1]) + } + up <- hm_upper(h_s) + u2 <- if (up > height_bounds[1]) { + (h_m - height_bounds[1]) / (up - height_bounds[1]) + } else { + 0 + } + u1 <- (area - area_bounds[1]) / diff(area_bounds) + pmin(1, pmax(0, c(u1, u2, u3))) + } + + # any infeasible design must be worse than any feasible one + cost_cap <- cost_total_of(type, area_bounds[2], height_bounds[2], hs_max) + best <- NULL + + consider <- function(area, h_m, h_s) { + ev <- eval_design(type, area, h_m, h_s) + cell_evals[[cache_key(type, area, h_m, h_s)]] <<- list( + area = area, h_m = h_m, h_s = h_s, + n = ev$n_overflows, vol = ev$overflow_volume_m3 + ) + cost <- cost_total_of(type, area, h_m, h_s) + feasible <- !is.na(ev$n_overflows) && ev$n_overflows <= x + if (feasible && (is.null(best) || cost < best$cost)) { + best <<- list(area = area, h_m = h_m, h_s = h_s, cost = cost) + } + list(ev = ev, cost = cost, feasible = feasible) + } + + # fast path: if even the maximal design is infeasible beyond the + # counting wobble, the whole cell is (monotonicity) -- no search + top <- consider(area_bounds[2], hm_upper(hs_max), hs_max) + if (!top$feasible && + (is.na(top$ev$n_overflows) || top$ev$n_overflows > x + wobble)) { + mono_warn <- dominance_violation(cell_evals) + return(infeasible_row()) + } + + start_cap <- max_evals + budget_hit <- function() runs_executed - runs_before >= start_cap + + objective <- function(u) { + p <- decode(u) + if (budget_hit() && + is.null(cache[[cache_key(type, p$area, p$h_m, p$h_s)]])) { + return(4 * cost_cap) # budget spent: only cached designs are free + } + r <- consider(p$area, p$h_m, p$h_s) + n <- r$ev$n_overflows + if (is.na(n)) return(4 * cost_cap) + if (n <= x) { + r$cost + } else { + cost_cap + r$cost + 0.05 * cost_cap * (n - x) + } + } + + # --- starts: prior warm start / previous target first, then one + # anchor per storage level (min storage first -- the storage ladder + # guards the flat cost valley along the feasibility boundary), then + # fixed space-filling points -------------------------------------------- + starts <- list() + ps <- prior_start_design(prior_results, type, x, filter_height, + cost_rates) + if (!is.null(ps)) { + starts <- c(starts, list(encode(ps$mulde_area, ps$mulde_height, + ps$storage_height))) + } + if (!is.null(extra_start)) starts <- c(starts, list(extra_start)) + ladder_u3 <- if (discrete) { + (seq_along(levels_all) - 0.5) / length(levels_all) + } else { + c(0.02, 0.30, 0.60, 0.90) + } + ladder <- lapply(seq_along(ladder_u3), function(i) { + c(if (i %% 2 == 1) 0.85 else 0.45, 0.90, ladder_u3[[i]]) + }) + starts <- c(starts, ladder, default_starts) + starts <- starts[seq_len(min(length(starts), n_starts))] + + # every start gets a slice of the remaining run budget, unused runs + # roll over to the following starts + for (si in seq_along(starts)) { + used <- runs_executed - runs_before + if (max_evals - used <= 2) break + start_cap <- used + ceiling((max_evals - used) / + (length(starts) - si + 1)) + stats::optim(starts[[si]], objective, method = "Nelder-Mead", + control = list(maxit = 200, reltol = 1e-4, + warn.1d.NelderMead = FALSE)) + } + + if (is.null(best)) { + mono_warn <- dominance_violation(cell_evals) + return(infeasible_row()) + } + + # --- lattice polish: single tolerance steps downwards ---------------- + # (any reduction is cheaper by construction; stop when none is + # feasible any more -> locally optimal on the tolerance lattice) + for (polish_round in seq_len(20)) { + b <- best + candidates <- list() + if (b$area - area_tol >= area_bounds[1] - 1e-9) { + candidates <- c(candidates, list( + list(area = b$area - area_tol, h_m = b$h_m, h_s = b$h_s) + )) + } + if (b$h_m - height_tol >= height_bounds[1] - 1e-9) { + candidates <- c(candidates, list( + list(area = b$area, h_m = b$h_m - height_tol, h_s = b$h_s) + )) + } + h_s_down <- if (discrete) { + lower <- levels_all[levels_all < b$h_s] + if (length(lower)) max(lower) else NA_real_ + } else { + if (b$h_s - s_tol >= gb[1] - 1e-9) b$h_s - s_tol else NA_real_ + } + if (!is.na(h_s_down)) { + candidates <- c(candidates, list( + list(area = b$area, h_m = b$h_m, h_s = h_s_down) + )) + } + for (p in candidates) consider(p$area, p$h_m, p$h_s) + if (best$cost >= b$cost - 1e-9) break + } + + mono_warn <- dominance_violation(cell_evals) + if (mono_warn) { + warning(sprintf( + paste0("optimise_swale_design_simultaneous(): a larger design ", + "produced more overflows AND more overflow volume ", + "(%s, x = %d) -- real non-monotonicity, result may be ", + "unreliable for this cell."), + type, x + ), call. = FALSE) + } + + final <- eval_design(type, best$area, best$h_m, best$h_s) + if (isTRUE(verbose)) { + message(sprintf( + "[%s | x = %d] area %s m2, height %s mm, storage %s mm (%d neue Laeufe)", + type, x, format(best$area), format(best$h_m), format(best$h_s), + runs_executed - runs_before + )) + } + list( + row = tibble::tibble( + x = x, storage_type = type, status = "ok", + mulde_area = best$area, mulde_height = best$h_m, + storage_height = best$h_s, + n_overflows = final$n_overflows, + overflow_volume_m3 = final$overflow_volume_m3, + et_pct = final$et_pct, + monotonicity_warning = mono_warn, + n_runs_new = runs_executed - runs_before + ), + best_u = encode(best$area, best$h_m, best$h_s) + ) + } + + # --- sweep: per storage type in ascending x (the optimum of x - 1 is + # feasible for x too and seeds the next search) -------------------------- + xs <- sort(unique(as.integer(x_targets))) + rows <- list() + for (type in names(storage_spec)) { + last_u <- NULL + for (x in xs) { + solved <- solve_cell(type, x, extra_start = last_u) + rows[[length(rows) + 1L]] <- solved$row + if (!is.null(solved$best_u)) last_u <- solved$best_u + } + } + out <- dplyr::bind_rows(rows) + + out$filter_height <- filter_height + out <- compute_costs(out, cost_rates = cost_rates) + out <- dplyr::arrange(out, .data$storage_type, .data$x) + + evaluations <- dplyr::bind_rows( + lapply(ls(cache), function(k) tibble::as_tibble(get(k, envir = cache))) + ) + attr(out, "evaluations") <- dplyr::arrange( + evaluations, .data$storage_type, .data$mulde_area + ) + attr(out, "n_runs_total") <- runs_executed + out +} diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index 0a1969d..20b877b 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -84,6 +84,8 @@ engine run is cached, so the sweep over all \code{x_targets} and both storage types shares evaluations. } \seealso{ -\code{\link[=find_min_feasible]{find_min_feasible()}}, \code{\link[=make_swale_runner]{make_swale_runner()}}, -\code{\link[=default_storage_spec]{default_storage_spec()}} +\code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}} (alternative: all +parameters at once via penalised Nelder-Mead, as an independent +cross-check of the coordinate descent), \code{\link[=find_min_feasible]{find_min_feasible()}}, +\code{\link[=make_swale_runner]{make_swale_runner()}}, \code{\link[=default_storage_spec]{default_storage_spec()}} } diff --git a/man/optimise_swale_design_simultaneous.Rd b/man/optimise_swale_design_simultaneous.Rd new file mode 100644 index 0000000..7e88d68 --- /dev/null +++ b/man/optimise_swale_design_simultaneous.Rd @@ -0,0 +1,161 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/optimise_swale_design_simultaneous.R +\name{optimise_swale_design_simultaneous} +\alias{optimise_swale_design_simultaneous} +\title{Find the cost-optimal swale design by simultaneous parameter search} +\usage{ +optimise_swale_design_simultaneous( + run_fn, + x_targets = 0:5, + area_bounds = c(25, 200), + area_tol = 2, + height_bounds = c(100, 300), + height_tol = 10, + storage_spec = default_storage_spec(), + fixed = list(connected_area = 1000, filter_height = 300, filter_hydraulicconductivity = + 360, bottom_hydraulicconductivity = 12), + prior_results = NULL, + n_starts = 4, + max_evals = 80, + wobble = 1L, + max_total_depth = NULL, + cost_rates = default_cost_rates(), + verbose = TRUE +) +} +\arguments{ +\item{run_fn}{\verb{function(params)} running one scenario and returning at +least \code{n_overflows} plus \code{sum_overflows} (mm) or \code{overflow_volume_m3}; +typically created with \code{\link[=make_swale_runner]{make_swale_runner()}}. \code{params} is a named list +of \code{mulde_area}, \code{mulde_height}, \code{storage_type}, \code{storage_height} plus +everything in \code{fixed}.} + +\item{x_targets}{Integer vector of overflow targets (feasible :<=> +\code{n_overflows <= x}), default \code{0:5}.} + +\item{area_bounds, area_tol}{Search range (m2) and resolution for +\code{mulde_area}.} + +\item{height_bounds, height_tol}{Search range (mm) and resolution for +\code{mulde_height}.} + +\item{storage_spec}{Storage search space per type, see +\code{\link[=default_storage_spec]{default_storage_spec()}}: discrete \code{levels} (infiltration box) or +continuous \code{bounds} + \code{tol} (gravel trench).} + +\item{fixed}{Named list of parameters passed unchanged to \code{run_fn} +(connected area, filter geometry, kf at maximum, ...). Must contain +\code{filter_height} for the cost model.} + +\item{prior_results}{Optional data.frame with prior (grid) results in +the workflow CSV schema, used as warm start (the cheapest feasible +grid cell of the branch becomes the first Nelder-Mead start).} + +\item{n_starts}{Number of Nelder-Mead starts per (storage type, x) +cell (default 4). Warm starts (prior, previous target) count towards +this number, then the storage-ladder anchors, then the space-filling +points.} + +\item{max_evals}{Soft cap on fresh engine runs per cell: once reached, +the Nelder-Mead phase winds down (already cached designs remain +free); the final lattice polish may add a few runs beyond the cap. +Default 80 -- thanks to the shared cache the later \code{x_targets} of a +storage type stay far below this.} + +\item{wobble}{Maximum counting-artefact size tolerated at the upper +corner (default 1, matching the +1 event-counting wobble): only if +the maximal design overflows by more than \code{wobble} events is the +cell declared infeasible without a search.} + +\item{max_total_depth}{Optional analytic depth constraint in mm: +\code{mulde_height + filter_height + storage_height <= max_total_depth} +(e.g. from DWA-A 138 groundwater clearance or cover requirements). +Enforced without any simulation runs.} + +\item{cost_rates}{Unit costs, see \code{\link[=default_cost_rates]{default_cost_rates()}}.} + +\item{verbose}{Print one progress line per solved cell.} +} +\value{ +Tibble with one row per (storage type, x), same schema as +\code{\link[=optimise_swale_design]{optimise_swale_design()}}: the optimal design (\code{mulde_area}, +\code{mulde_height}, \code{storage_height}), its metrics (\code{n_overflows}, +\code{overflow_volume_m3}, \code{et_pct}), cost columns from \code{\link[=compute_costs]{compute_costs()}}, +a \code{status} (\code{"ok"} or \code{"infeasible_within_bounds"}), +\code{monotonicity_warning} (\code{TRUE} if a strictly larger design produced +more overflows \emph{and} more overflow volume among the cell's +evaluations) and \code{n_runs_new} (fresh engine runs spent on this cell). +All evaluated designs are attached as attribute \code{"evaluations"}. +} +\description{ +Alternative to the coordinate-descent optimiser +(\code{\link[=optimise_swale_design]{optimise_swale_design()}}, bisection per parameter): all design +parameters -- \code{mulde_area}, \code{mulde_height} and \code{storage_height} -- are +optimised \strong{simultaneously} with a penalised Nelder-Mead search +(\code{stats::optim()}). Infeasible designs (\code{n_overflows > x}) are not +excluded but penalised (any infeasible design is worse than any feasible +one; the number of excess events grades the penalty, steering the +simplex back towards feasibility), so the search moves freely through +the full parameter space and can trade the parameters against each +other in a single step -- it does not rely on the per-parameter +monotonicity that the bisection exploits. +} +\details{ +Three ingredients keep the number of engine runs in check: +\itemize{ +\item \strong{Snapping}: every candidate is snapped to the search +tolerances (\code{area_tol}, \code{height_tol}, storage \code{tol} / discrete +\code{levels}) before evaluation, so the shared cache absorbs repeated +visits and the sweep over all \code{x_targets} reuses runs. +\item \strong{Multistart}: \code{n_starts} deterministic starting points +(prior warm start and the optimum of the previous overflow target +first, then a \emph{storage ladder} -- one anchor start per storage +level, smallest level first -- then fixed space-filling points) +guard against the simplex stalling on the plateaus that the +snapping and the integer overflow count create, and make sure every +storage level competes: along the feasibility boundary the cost +valley is flat, so the cheapest (usually smallest) storage level is +easily missed from a single start. Different starts take different +search paths -- the counterpart of \code{split_jitter} in the bisection +optimiser. Every start receives an equal slice of the remaining +\code{max_evals} budget (unused runs roll over). +\item \strong{Lattice polish}: from the best feasible design found, +single tolerance steps downwards (cheaper by construction) are +tested until no parameter can be reduced any further -- the result +is locally optimal on the tolerance lattice. +} + +The discrete infiltration-box levels are mapped onto a continuous +latent axis (each level owns an equal share of \verb{[0, 1]}), the gravel +trench is searched continuously. The filter conductivity is expected to +be fixed at the maximum via \code{fixed} (cost-free and dominant, see the +\code{monotonicity_analysis} vignette). \code{max_total_depth} is enforced by +construction (the \code{mulde_height} axis is compressed to the remaining +depth), so no simulation runs are spent on depth-invalid designs. + +Compared to \code{\link[=optimise_swale_design]{optimise_swale_design()}} this needs more engine runs per +cell (typically 30-60 instead of ~15) but serves as an independent +cross-check: it can discover cheaper corners of the design space that +coordinate descent would miss if the parameter interaction were +stronger than the monotonicity analysis suggests. +} +\examples{ +# synthetic monotone model: overflows fall with retention capacity +run <- function(params) { + cap <- params$mulde_area * + (params$mulde_height + 0.95 * params$storage_height) + list(n_overflows = max(0, floor(3.6e5 / cap) - 3), + sum_overflows = 800 * max(0, 3.6e5 / cap - 3)) +} +opt <- optimise_swale_design_simultaneous( + run, x_targets = 1, + storage_spec = default_storage_spec()["infiltration_box"], + verbose = FALSE +) +opt[, c("x", "mulde_area", "mulde_height", "storage_height", "cost_total")] + +} +\seealso{ +\code{\link[=optimise_swale_design]{optimise_swale_design()}} (coordinate descent / bisection), +\code{\link[=make_swale_runner]{make_swale_runner()}}, \code{\link[=default_storage_spec]{default_storage_spec()}} +} diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R new file mode 100644 index 0000000..cd04cb0 --- /dev/null +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -0,0 +1,158 @@ +# Gleiches synthetisches, monotones Hydraulikmodell wie in +# test-optimise_swale_design.R: Ueberlaeufe fallen mit der +# Rueckhaltekapazitaet cap = Flaeche x (Muldentiefe + Porositaet x +# Speicherhoehe). Kein Engine-Aufruf noetig -> die simultane Suche laesst +# sich gegen eine Brute-Force-Referenz und gegen die Bisektion verifizieren. +sim_run_factory <- function(demand) { + porosity <- c(infiltration_box = 0.95, gravel_trench = 0.3) + function(params) { + cap <- params$mulde_area * + (params$mulde_height + + porosity[[params$storage_type]] * params$storage_height) + ratio <- demand / cap + list( + n_overflows = max(0, floor(ratio) - 3), + sum_overflows = 800 * max(0, ratio - 3), + element.WB_Evapotranspiration_ = 0.1 * params$mulde_area + ) + } +} + +sim_fixed <- list(connected_area = 1000, filter_height = 300, + filter_hydraulicconductivity = 360, + bottom_hydraulicconductivity = 12) + +# Brute-Force-Referenz: guenstigstes zulaessiges Design auf feinem Raster +sim_reference_optimum <- function(run, type, x, storage_values) { + grid <- expand.grid( + mulde_area = seq(25, 200, by = 0.5), + mulde_height = seq(100, 300, by = 5), + storage_height = storage_values, + stringsAsFactors = FALSE + ) + grid$storage_type <- type + porosity <- c(infiltration_box = 0.95, gravel_trench = 0.3) + cap <- grid$mulde_area * + (grid$mulde_height + porosity[[type]] * grid$storage_height) + grid$n <- pmax(0, floor(environment(run)$demand / cap) - 3) + grid <- grid[grid$n <= x, , drop = FALSE] + if (nrow(grid) == 0) return(NULL) + grid$filter_height <- 300 + costs <- compute_costs(grid) + costs[which.min(costs$cost_total), , drop = FALSE] +} + +test_that("Simultane Suche findet das Kostenminimum (Vergleich mit Brute-Force)", { + run <- sim_run_factory(demand = 3.6e5) + out <- optimise_swale_design_simultaneous(run, x_targets = 0:3, + fixed = sim_fixed, + verbose = FALSE) + + expect_true(all(out$status == "ok")) + expect_false(any(out$monotonicity_warning)) + # Zulaessigkeit: Ueberlaufziel eingehalten + expect_true(all(out$n_overflows <= out$x)) + + for (i in seq_len(nrow(out))) { + type <- out$storage_type[i] + stor <- if (type == "infiltration_box") c(300, 600, 900, 1200) + else seq(900, 3600, by = 25) + ref <- sim_reference_optimum(run, type, out$x[i], stor) + expect_false(is.null(ref)) + # innerhalb 5 % des (quasi-kontinuierlichen) Brute-Force-Optimums + expect_lte(out$cost_total[i], ref$cost_total * 1.05) + } + + # Kosten-Wirksamkeits-Kurve: lockereres Ziel ist nie teurer + for (type in unique(out$storage_type)) { + cc <- out$cost_total[out$storage_type == type][order(out$x[out$storage_type == type])] + expect_true(all(diff(cc) <= 1e-9)) + } +}) + +test_that("Bisektion und simultane Suche bestaetigen sich gegenseitig", { + run <- sim_run_factory(demand = 3.6e5) + cd <- optimise_swale_design(run, x_targets = 0:2, + fixed = sim_fixed, verbose = FALSE) + nm <- optimise_swale_design_simultaneous(run, x_targets = 0:2, + fixed = sim_fixed, + verbose = FALSE) + # gleiche Zellen, gleicher Status, Kosten innerhalb 5 % voneinander + expect_identical(nm$status, cd$status) + expect_true(all(abs(nm$cost_total - cd$cost_total) <= + 0.05 * pmin(nm$cost_total, cd$cost_total))) +}) + +test_that("hoher Bedarf erzwingt implizit einen groesseren Speicher", { + run <- sim_run_factory(demand = 8e5) + out <- optimise_swale_design_simultaneous(run, x_targets = 0, + fixed = sim_fixed, + verbose = FALSE) + box <- out[out$storage_type == "infiltration_box", ] + expect_identical(box$status, "ok") + # bei Minimal-Speicher 300 ist selbst 200 m2 unzulaessig + expect_gt(box$storage_height, 300) + expect_lte(box$n_overflows, 0) +}) + +test_that("unloesbar innerhalb der Bounds ist ein regulaeres Ergebnis", { + run <- sim_run_factory(demand = 5e6) + out <- optimise_swale_design_simultaneous(run, x_targets = 0, + fixed = sim_fixed, + verbose = FALSE) + expect_true(all(out$status == "infeasible_within_bounds")) + expect_true(all(is.na(out$mulde_area))) + expect_true(all(is.na(out$cost_total))) +}) + +test_that("Warmstart aus Rasterergebnissen liefert dasselbe Optimum", { + run <- sim_run_factory(demand = 3.6e5) + + # Prior im CSV-Schema der Workflows (kf = 360, h_m = 300, Rasterschritt 25) + prior <- expand.grid( + mulde_area = seq(25, 200, by = 25), + mulde_height = 300, + storage_type = c("infiltration_box", "gravel_trench"), + stringsAsFactors = FALSE + ) + prior$storage_height <- ifelse(prior$storage_type == "infiltration_box", + 300, 900) + prior$filter_hydraulicconductivity <- 360 + prior$n_overflows <- vapply(seq_len(nrow(prior)), function(i) { + as.numeric(run(c(as.list(prior[i, ]), sim_fixed))$n_overflows) + }, numeric(1)) + + cold <- optimise_swale_design_simultaneous(run, x_targets = 0:2, + fixed = sim_fixed, + verbose = FALSE) + warm <- optimise_swale_design_simultaneous(run, x_targets = 0:2, + fixed = sim_fixed, + prior_results = prior, + verbose = FALSE) + + # gleiches Optimum (innerhalb der Suchtoleranzen) + expect_equal(warm$cost_total, cold$cost_total, tolerance = 0.05) +}) + +test_that("max_total_depth wirkt als analytische Nebenbedingung", { + run <- sim_run_factory(demand = 3.6e5) + out <- optimise_swale_design_simultaneous(run, x_targets = 0, + fixed = sim_fixed, + max_total_depth = 1200, + verbose = FALSE) + ok <- out[out$status == "ok", ] + expect_true(all(ok$mulde_height + ok$filter_height + ok$storage_height + <= 1200 + 1e-9)) +}) + +test_that("mehr Starts finden nie ein schlechteres Optimum", { + run <- sim_run_factory(demand = 3.6e5) + few <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, n_starts = 1, + verbose = FALSE) + many <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, n_starts = 5, + max_evals = 120, + verbose = FALSE) + expect_true(all(many$cost_total <= few$cost_total * 1.001)) +}) diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index ffe058d..cfef202 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -45,7 +45,10 @@ Speicher nur erhöhen, wenn die Fläche am Anschlag klemmt. Voraussetzung ist die in der Vignette `monotonicity_analysis` belegte Monotonie ("größer = nie mehr Überläufe"); die dort abgeleiteten Absicherungen (Rand-Guard, Volumen-Schiedsrichter) sind in `find_min_feasible()` -eingebaut. +eingebaut. Als Gegenprobe optimiert der Abschnitt *Alternative* weiter +unten **alle Parameter gleichzeitig** +(`optimise_swale_design_simultaneous()`, Nelder-Mead mit Straffunktion) +— ohne die Monotonie-Annahme. Die Filterdurchlässigkeit wird fest auf das Maximum gesetzt (kostenfrei dominant: gleiche Verdunstung, nie mehr Überläufe), Fläche und @@ -57,7 +60,10 @@ Box-Bereich. **Laufzeit:** Ein Engine-Lauf dauert ~2 s (Eisenstadt, 1 Jahr) bzw. ~15 s (Wien / Bad Aussee, 15-Jahres-Serien). Die 6 Tasks (Standort × Speichertyp) laufen parallel; die Gesamtdauer entspricht -dem längsten Einzeltask — ca. 15–20 Minuten. +dem längsten Einzeltask — ca. 15–20 Minuten. Die simultane Gegenprobe +(Abschnitt *Alternative*) braucht je Zelle mehr Läufe (typisch 30–80 +statt ~15); ihr längster Einzeltask (Wien / Rigol) kann entsprechend +~1–1.5 h dauern. ```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} cat(sprintf(paste0( @@ -324,6 +330,136 @@ cat(sprintf(paste0( )) ``` +## Alternative: Simultane Optimierung aller Parameter (Nelder-Mead) + +Die Bisektion optimiert die Parameter *nacheinander* und stützt sich +dabei auf die Monotonie je Parameter. Als unabhängige Gegenprobe +optimiert `optimise_swale_design_simultaneous()` **alle Parameter +gleichzeitig**: Ein Nelder-Mead-Simplex (`stats::optim()`) wandert frei +durch den Raum (Fläche × Muldentiefe × Speicherhöhe) und kann die +Parameter in einem einzigen Schritt gegeneinander tauschen — unzulässige +Designs werden dabei nicht ausgeschlossen, sondern bestraft (jedes +unzulässige Design ist teurer als jedes zulässige; überzählige +Überlaufereignisse staffeln die Strafe und lenken den Simplex zurück). +Drei Zutaten halten die Zahl der Engine-Läufe im Rahmen: Kandidaten +werden auf die Suchtoleranzen gerastert (der Evaluations-Cache füllt +sich über die x-Ziele hinweg), ein deterministischer Multistart — +Warmstart, Optimum des vorigen x-Ziels, je ein Anker-Start pro +Speicherstufe (das Kostental entlang der Zulässigkeitsgrenze ist flach, +die günstigste Speicherstufe wird von einem einzelnen Start leicht +verfehlt), Raumfüller — mit je einem gleichen Anteil am Laufbudget +(`max_evals`), und ein abschließender Gitter-Feinschliff (einzelne +Toleranzschritte abwärts, bis kein Parameter mehr sinken kann). Der +Preis: mehr Engine-Läufe je Zelle (typisch 30–80 statt ~15). + +```{r optimise_simultaneous, eval = can_run} +t_nm_start <- Sys.time() + +future::plan(future::multisession, + workers = min(nrow(tasks), + max(1, parallel::detectCores() - 1))) + +nm_list <- future.apply::future_lapply(seq_len(nrow(tasks)), function(i) { + site <- tasks$site[i] + type <- tasks$type[i] + + if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) + } else { + library(kwb.raindrop) + } + + cfg <- sites[[site]] + ts <- if (cfg$timeseries) { + read_site_timeseries( + extdata_path("models", cfg$dir, "rain.csv.gz"), + extdata_path("models", cfg$dir, "et.csv"), + verbose = FALSE + ) + } else { + NULL + } + + run_fn <- make_swale_runner(make_path_list(paste0(site, "_NM"), cfg$dir), + timeseries_rain = ts$rain, + timeseries_et = ts$et) + + prior <- if (file.exists(cfg$prior)) { + readr::read_csv(cfg$prior, show_col_types = FALSE) + } else { + NULL + } + + t0 <- Sys.time() + opt <- optimise_swale_design_simultaneous( + run_fn, x_targets = 0:5, + area_bounds = area_bounds, area_tol = area_tol, + height_bounds = height_bounds, height_tol = height_tol, + storage_spec = storage_spec[type], + fixed = fixed, + prior_results = prior, + cost_rates = cost_rates, + verbose = FALSE + ) + opt$site <- site + opt$n_runs_task <- attr(opt, "n_runs_total") + opt$minutes_task <- round(as.numeric( + difftime(Sys.time(), t0, units = "mins")), 1) + opt +}, future.seed = TRUE) + +future::plan(future::sequential) +nm_all <- dplyr::bind_rows(nm_list) + +t_nm_end <- Sys.time() +``` + +Beide Verfahren müssen — bis auf die Suchtoleranzen, also wenige +Prozent — auf dieselben Kosten kommen. Fände die simultane Suche +*systematisch günstigere* Designs, wäre das ein Hinweis auf +Parameter-Wechselwirkungen, die die Koordinatensuche nicht sieht (und +ein Fall für die Monotonie-Analyse); fände sie nur teurere, hat der +Simplex sein Laufbudget nicht ausgeschöpft oder klemmt in einem lokalen +Tal (`n_starts` / `max_evals` erhöhen). + +```{r compare_methods, eval = can_run} +vergleich <- dplyr::full_join( + dplyr::select(opt_all, site, storage_type, x, + status_bisektion = status, kosten_bisektion = cost_total), + dplyr::select(nm_all, site, storage_type, x, + status_simultan = status, kosten_simultan = cost_total), + by = c("site", "storage_type", "x") +) %>% + dplyr::mutate( + delta_pct = round(100 * (kosten_simultan - kosten_bisektion) / + kosten_bisektion, 1) + ) %>% + dplyr::arrange(site, storage_type, x) + +knitr::kable( + vergleich, digits = 0, + caption = paste("Gegenprobe Bisektion vs. simultane Suche:", + "delta_pct < 0 heisst, die simultane Suche hat ein", + "guenstigeres Design gefunden") +) + +readr::write_csv(nm_all, "optimisation_results_simultaneous_all_sites.csv") +``` + +```{r nm_runtime, echo = FALSE, results = 'asis', eval = can_run} +nm_stats <- unique(nm_all[, c("site", "storage_type", "n_runs_task", + "minutes_task")]) +nm_wall_min <- as.numeric(difftime(t_nm_end, t_nm_start, units = "mins")) +cat(sprintf(paste0( + "**Laufzeit simultane Optimierung:** %d Engine-Läufe · Summe der ", + "Task-Zeiten %.1f min · tatsächliche Laufzeit %.1f min (Bisektion ", + "zum Vergleich: %d Läufe).\n"), + sum(nm_stats$n_runs_task), sum(nm_stats$minutes_task), nm_wall_min, + sum(task_stats$n_runs_task) +)) +``` + ## Monte-Carlo-Analyse: Wie robust ist die Suche selbst? Die Bisektion ist deterministisch: gleiche Eingaben, gleicher Pfad, @@ -476,10 +612,10 @@ cat(sprintf(paste0( ```{r vignette_runtime, echo = FALSE, results = 'asis', eval = can_run} cat(sprintf(paste0( "---\n\n**Gesamtlaufzeit dieser Vignette:** %.1f Minuten ", - "(Optimierung %.1f min · Such-Monte-Carlo %.1f min · ", - "Rest: Setup und Rendern).\n"), + "(Optimierung %.1f min · simultane Gegenprobe %.1f min · ", + "Such-Monte-Carlo %.1f min · Rest: Setup und Rendern).\n"), as.numeric(difftime(Sys.time(), t_vignette_start, units = "mins")), - opt_wall_min, + opt_wall_min, nm_wall_min, as.numeric(difftime(t_mc_end, t_mc_start, units = "mins")) )) ``` From a51dc3870d09568726c9d63b7b22e8ddd8e988b9 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 10:25:39 +0000 Subject: [PATCH 18/34] Split vignettes and add alternative search methods for comparison Separate the two optimisation workflows: workflow_optimisation.Rmd is restored to bisection-only (plus a pointer paragraph), the simultaneous search moves into the new vignette workflow_optimisation_simultaneous.Rmd (Nelder-Mead sweep for all sites, cell-by-cell comparison against the bisection CSV export when present, and a method benchmark at x = 1). optimise_swale_design_simultaneous() gains a method argument with two alternative optimisers for comparison purposes: - diff_evolution: compact DE/rand/1/bin, deterministic via an internal Park-Miller generator (seed argument); R's global RNG stays untouched - halton_search: quasi-random space-filling baseline (Halton sequence) All methods share the penalised objective, the evaluation cache, the tolerance snapping and a new multi-valley lattice polish (accelerated 8/4/2/1-tolerance pattern descent from the cheapest feasible design of every storage level visited - the storage axis separates cost valleys that single coordinate steps cannot cross). Results carry a method column. Tests: per-method brute-force reference comparison, DE determinism and .Random.seed invariance, start-configuration agreement within search tolerances; 137 tests green. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 64 +-- R/optimise_swale_design_simultaneous.R | 321 +++++++++---- man/optimise_swale_design_simultaneous.Rd | 97 ++-- .../test-optimise_swale_design_simultaneous.R | 60 ++- tests/testthat/testthat-problems.rds | Bin 0 -> 25670 bytes vignettes/workflow_optimisation.Rmd | 150 +------ .../workflow_optimisation_simultaneous.Rmd | 425 ++++++++++++++++++ 7 files changed, 834 insertions(+), 283 deletions(-) create mode 100644 tests/testthat/testthat-problems.rds create mode 100644 vignettes/workflow_optimisation_simultaneous.Rmd diff --git a/NEWS.md b/NEWS.md index 2c9d2f4..4a5910f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -34,31 +34,45 @@ evaluated designs ship as attribute `"evaluations"`. - `optimise_swale_design_simultaneous()` — alternative optimiser that searches **all design parameters at once** (`mulde_area`, - `mulde_height`, `storage_height`) with a penalised Nelder-Mead - simplex (`stats::optim()`, no new dependency) instead of - per-parameter bisection: infeasible designs are not excluded but - penalised (any infeasible design is worse than any feasible one; - excess overflow events grade the penalty and steer the simplex back), - so the search can trade the parameters against each other in a - single step and does not rely on the per-parameter monotonicity the - bisection exploits. Engine runs are kept in check by snapping every - candidate to the search tolerances (the shared cache absorbs - repeats across all `x_targets`), a deterministic multistart (prior - warm start, previous-target optimum, one anchor start per storage - level — the flat cost valley along the feasibility boundary makes - the cheapest storage level easy to miss from a single start — then - space-filling points; every start gets an equal slice of the - `max_evals` run budget) and a final lattice polish that makes the - result locally optimal on the tolerance lattice. Same interface and - result schema as `optimise_swale_design()` (incl. `max_total_depth`, - warm start and the `"evaluations"` attribute); a pairwise dominance - check per cell (a strictly larger design with more overflows *and* - more overflow volume) replaces the bisection's volume referee. - Needs more engine runs per cell (typically 30–80 instead of ~15) - but serves as an independent cross-check that coordinate descent - did not miss a cheaper corner of the design space; the - `workflow_optimisation` vignette gained a section running both - optimisers for all three sites and tabulating the cost deltas. + `mulde_height`, `storage_height`) instead of per-parameter + bisection: infeasible designs are not excluded but penalised (any + infeasible design is worse than any feasible one; excess overflow + events grade the penalty and steer the search back towards the + feasibility boundary, where the optimum lives), so the search can + trade the parameters against each other in a single step and does + not rely on the per-parameter monotonicity the bisection exploits. + Three search `method`s share this penalised objective, the + tolerance snapping (the shared cache absorbs repeats across all + `x_targets`) and a final **multi-valley lattice polish** + (accelerated 8/4/2/1-tolerance pattern descent from the cheapest + feasible design of every storage level visited — the storage axis + separates cost valleys that single coordinate steps cannot cross): + `"nelder_mead"` (default; deterministic multistart via + `stats::optim()` — prior warm start, previous-target optimum, one + anchor start per storage level, space-filling points; every start + gets an equal slice of the `max_evals` run budget), + `"diff_evolution"` (compact DE/rand/1/bin for comparison; + deterministic via an internal Park-Miller generator seeded with + `seed` — R's global RNG stays untouched) and `"halton_search"` + (quasi-random space-filling baseline). Same interface and result + schema as `optimise_swale_design()` (incl. `max_total_depth`, warm + start and the `"evaluations"` attribute) plus a `method` column; a + pairwise dominance check per cell (a strictly larger design with + more overflows *and* more overflow volume) replaces the bisection's + volume referee. Needs considerably more engine runs per cell + (typically 60–120 instead of ~15) but serves as an independent + cross-check that coordinate descent did not miss a cheaper corner + of the design space. + +* New conditional vignette `workflow_optimisation_simultaneous` — the + simultaneous counterpart of `workflow_optimisation` (which stays + bisection-only and now points here): runs the Nelder-Mead sweep for + all three sites in parallel (site × storage type), compares the + optima cell by cell against the bisection CSV export when present + (`delta_pct` table), and benchmarks the three search methods + (Nelder-Mead / differential evolution / Halton baseline) on the same + x = 1 cell across all sites and storage types — 12 parallel tasks — + to show what the structured searches contribute over naive sampling. - `make_swale_runner()` — package-level refactoring of the `run_one()` function previously duplicated across the three case-study vignettes: one closure factory covering both variants (Eisenstadt: diff --git a/R/optimise_swale_design_simultaneous.R b/R/optimise_swale_design_simultaneous.R index 084c772..f29f487 100644 --- a/R/optimise_swale_design_simultaneous.R +++ b/R/optimise_swale_design_simultaneous.R @@ -25,20 +25,73 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { c("mulde_area", "mulde_height", "storage_height"), drop = FALSE] } +#' Radical-inverse (van der Corput) sequence element +#' @keywords internal +#' @noRd +halton_1d <- function(i, base) { + f <- 1 + r <- 0 + while (i > 0) { + f <- f / base + r <- r + f * (i %% base) + i <- i %/% base + } + r +} + +#' i-th point of the 3-dimensional Halton sequence (bases 2, 3, 5) +#' @keywords internal +#' @noRd +halton_point <- function(i) { + c(halton_1d(i, 2), halton_1d(i, 3), halton_1d(i, 5)) +} + +#' Minimal deterministic uniform generator (Park-Miller LCG) +#' +#' Self-contained pseudo-random stream for the differential-evolution +#' method: fully reproducible from `seed` and independent of R's global +#' RNG (`.Random.seed` is neither read nor written). +#' +#' @keywords internal +#' @noRd +make_lcg <- function(seed) { + state <- (abs(as.double(seed)) %% 2147483646) + 1 + function() { + # 16807 * state < 2^53, exact in double arithmetic + state <<- (16807 * state) %% 2147483647 + state / 2147483647 + } +} + #' Find the cost-optimal swale design by simultaneous parameter search #' #' Alternative to the coordinate-descent optimiser #' ([optimise_swale_design()], bisection per parameter): all design #' parameters -- `mulde_area`, `mulde_height` and `storage_height` -- are -#' optimised **simultaneously** with a penalised Nelder-Mead search -#' (`stats::optim()`). Infeasible designs (`n_overflows > x`) are not -#' excluded but penalised (any infeasible design is worse than any feasible -#' one; the number of excess events grades the penalty, steering the -#' simplex back towards feasibility), so the search moves freely through -#' the full parameter space and can trade the parameters against each -#' other in a single step -- it does not rely on the per-parameter +#' optimised **simultaneously**. Infeasible designs (`n_overflows > x`) +#' are not excluded but penalised (any infeasible design is worse than any +#' feasible one; the number of excess events grades the penalty, steering +#' the search back towards feasibility), so the search moves freely +#' through the full parameter space and can trade the parameters against +#' each other in a single step -- it does not rely on the per-parameter #' monotonicity that the bisection exploits. #' +#' Three search `method`s share this penalised objective (plus cache, +#' tolerance snapping and final lattice polish) and differ only in how +#' they propose candidates: +#' \itemize{ +#' \item `"nelder_mead"` (default): multistart Nelder-Mead simplex via +#' `stats::optim()` -- the recommended method. +#' \item `"diff_evolution"`: a compact differential evolution +#' (DE/rand/1/bin, population 12, F = 0.7, CR = 0.9), included for +#' comparison. Deterministic: it draws from an internal Park-Miller +#' generator seeded with `seed` and leaves R's global RNG +#' (`.Random.seed`) untouched. +#' \item `"halton_search"`: quasi-random space-filling sampling +#' (Halton sequence, bases 2/3/5) -- a deliberately simple baseline +#' showing what the structured searches must beat. +#' } +#' #' Three ingredients keep the number of engine runs in check: #' \itemize{ #' \item \strong{Snapping}: every candidate is snapped to the search @@ -57,10 +110,13 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { #' search paths -- the counterpart of `split_jitter` in the bisection #' optimiser. Every start receives an equal slice of the remaining #' `max_evals` budget (unused runs roll over). -#' \item \strong{Lattice polish}: from the best feasible design found, -#' single tolerance steps downwards (cheaper by construction) are -#' tested until no parameter can be reduced any further -- the result -#' is locally optimal on the tolerance lattice. +#' \item \strong{Lattice polish}: an accelerated pattern descent +#' (steps of 8/4/2/1 tolerances downwards, cheaper by construction) +#' runs from the cheapest feasible design of *every storage level +#' visited* -- the storage axis separates cost valleys that single +#' coordinate steps cannot cross -- until no parameter can be reduced +#' any further: the result is locally optimal on the tolerance +#' lattice, whatever the search method delivered. #' } #' #' The discrete infiltration-box levels are mapped onto a continuous @@ -71,11 +127,12 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { #' construction (the `mulde_height` axis is compressed to the remaining #' depth), so no simulation runs are spent on depth-invalid designs. #' -#' Compared to [optimise_swale_design()] this needs more engine runs per -#' cell (typically 30-60 instead of ~15) but serves as an independent -#' cross-check: it can discover cheaper corners of the design space that -#' coordinate descent would miss if the parameter interaction were -#' stronger than the monotonicity analysis suggests. +#' Compared to [optimise_swale_design()] this needs considerably more +#' engine runs per cell (typically 60-120 instead of ~15; search phase +#' plus multi-valley polish) but serves as an independent cross-check: it +#' can discover cheaper corners of the design space that coordinate +#' descent would miss if the parameter interaction were stronger than the +#' monotonicity analysis suggests. #' #' @param run_fn `function(params)` running one scenario and returning at #' least `n_overflows` plus `sum_overflows` (mm) or `overflow_volume_m3`; @@ -96,16 +153,23 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { #' `filter_height` for the cost model. #' @param prior_results Optional data.frame with prior (grid) results in #' the workflow CSV schema, used as warm start (the cheapest feasible -#' grid cell of the branch becomes the first Nelder-Mead start). +#' grid cell of the branch becomes the first start / seeds the +#' population). +#' @param method Search method, see Details: `"nelder_mead"` (default), +#' `"diff_evolution"` or `"halton_search"` (the latter two mainly for +#' comparison). #' @param n_starts Number of Nelder-Mead starts per (storage type, x) -#' cell (default 4). Warm starts (prior, previous target) count towards -#' this number, then the storage-ladder anchors, then the space-filling -#' points. -#' @param max_evals Soft cap on fresh engine runs per cell: once reached, -#' the Nelder-Mead phase winds down (already cached designs remain -#' free); the final lattice polish may add a few runs beyond the cap. -#' Default 80 -- thanks to the shared cache the later `x_targets` of a -#' storage type stay far below this. +#' cell (default 4; only used by `method = "nelder_mead"`). Warm starts +#' (prior, previous target) count towards this number, then the +#' storage-ladder anchors, then the space-filling points. +#' @param seed Integer seed of the internal deterministic generator used +#' by `method = "diff_evolution"` (ignored by the other methods). R's +#' global RNG state is not touched. +#' @param max_evals Soft cap on fresh engine runs per cell for the search +#' phase: once reached, the search winds down (already cached designs +#' remain free). The final multi-valley lattice polish adds its own +#' runs on top (typically 20-50 per cell). Default 80 -- thanks to the +#' shared cache the later `x_targets` of a storage type stay cheaper. #' @param wobble Maximum counting-artefact size tolerated at the upper #' corner (default 1, matching the +1 event-counting wobble): only if #' the maximal design overflows by more than `wobble` events is the @@ -118,14 +182,15 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { #' @param verbose Print one progress line per solved cell. #' #' @return Tibble with one row per (storage type, x), same schema as -#' [optimise_swale_design()]: the optimal design (`mulde_area`, -#' `mulde_height`, `storage_height`), its metrics (`n_overflows`, -#' `overflow_volume_m3`, `et_pct`), cost columns from [compute_costs()], -#' a `status` (`"ok"` or `"infeasible_within_bounds"`), -#' `monotonicity_warning` (`TRUE` if a strictly larger design produced -#' more overflows *and* more overflow volume among the cell's -#' evaluations) and `n_runs_new` (fresh engine runs spent on this cell). -#' All evaluated designs are attached as attribute `"evaluations"`. +#' [optimise_swale_design()] plus a `method` column: the optimal design +#' (`mulde_area`, `mulde_height`, `storage_height`), its metrics +#' (`n_overflows`, `overflow_volume_m3`, `et_pct`), cost columns from +#' [compute_costs()], a `status` (`"ok"` or +#' `"infeasible_within_bounds"`), `monotonicity_warning` (`TRUE` if a +#' strictly larger design produced more overflows *and* more overflow +#' volume among the cell's evaluations) and `n_runs_new` (fresh engine +#' runs spent on this cell). All evaluated designs are attached as +#' attribute `"evaluations"`. #' #' @examples #' # synthetic monotone model: overflows fall with retention capacity @@ -159,13 +224,18 @@ optimise_swale_design_simultaneous <- function(run_fn, bottom_hydraulicconductivity = 12 ), prior_results = NULL, + method = c("nelder_mead", + "diff_evolution", + "halton_search"), n_starts = 4, max_evals = 80, + seed = 1, wobble = 1L, max_total_depth = NULL, cost_rates = default_cost_rates(), verbose = TRUE) { + method <- match.arg(method) stopifnot(is.function(run_fn), !is.null(fixed$filter_height), n_starts >= 1, max_evals >= 10) filter_height <- fixed$filter_height @@ -275,7 +345,8 @@ optimise_swale_design_simultaneous <- function(run_fn, infeasible_row <- function() list( row = tibble::tibble( - x = x, storage_type = type, status = "infeasible_within_bounds", + x = x, storage_type = type, method = method, + status = "infeasible_within_bounds", mulde_area = NA_real_, mulde_height = NA_real_, storage_height = NA_real_, n_overflows = NA_real_, overflow_volume_m3 = NA_real_, et_pct = NA_real_, @@ -388,14 +459,14 @@ optimise_swale_design_simultaneous <- function(run_fn, # anchor per storage level (min storage first -- the storage ladder # guards the flat cost valley along the feasibility boundary), then # fixed space-filling points -------------------------------------------- - starts <- list() + starts_all <- list() ps <- prior_start_design(prior_results, type, x, filter_height, cost_rates) if (!is.null(ps)) { - starts <- c(starts, list(encode(ps$mulde_area, ps$mulde_height, - ps$storage_height))) + starts_all <- c(starts_all, list(encode(ps$mulde_area, ps$mulde_height, + ps$storage_height))) } - if (!is.null(extra_start)) starts <- c(starts, list(extra_start)) + if (!is.null(extra_start)) starts_all <- c(starts_all, list(extra_start)) ladder_u3 <- if (discrete) { (seq_along(levels_all) - 0.5) / length(levels_all) } else { @@ -404,19 +475,71 @@ optimise_swale_design_simultaneous <- function(run_fn, ladder <- lapply(seq_along(ladder_u3), function(i) { c(if (i %% 2 == 1) 0.85 else 0.45, 0.90, ladder_u3[[i]]) }) - starts <- c(starts, ladder, default_starts) - starts <- starts[seq_len(min(length(starts), n_starts))] - - # every start gets a slice of the remaining run budget, unused runs - # roll over to the following starts - for (si in seq_along(starts)) { - used <- runs_executed - runs_before - if (max_evals - used <= 2) break - start_cap <- used + ceiling((max_evals - used) / - (length(starts) - si + 1)) - stats::optim(starts[[si]], objective, method = "Nelder-Mead", - control = list(maxit = 200, reltol = 1e-4, - warn.1d.NelderMead = FALSE)) + starts_all <- c(starts_all, ladder, default_starts) + + if (method == "nelder_mead") { + # every start gets a slice of the remaining run budget, unused + # runs roll over to the following starts + starts <- starts_all[seq_len(min(length(starts_all), n_starts))] + for (si in seq_along(starts)) { + used <- runs_executed - runs_before + if (max_evals - used <= 2) break + start_cap <- used + ceiling((max_evals - used) / + (length(starts) - si + 1)) + stats::optim(starts[[si]], objective, method = "Nelder-Mead", + control = list(maxit = 200, reltol = 1e-4, + warn.1d.NelderMead = FALSE)) + } + } else if (method == "diff_evolution") { + # DE/rand/1/bin on the unit cube; deterministic via internal LCG + start_cap <- max_evals + rng <- make_lcg(seed) + n_pop <- 12 + pop <- lapply(seq_len(n_pop), function(i) { + if (i <= length(starts_all)) starts_all[[i]] else halton_point(i) + }) + fit <- vapply(pop, objective, numeric(1)) + pick_other <- function(i) { + repeat { + r <- 1L + as.integer(floor(rng() * n_pop)) + if (r != i && r <= n_pop) return(r) + } + } + gen <- 0 + while (!budget_hit() && gen < 60) { + gen <- gen + 1 + for (i in seq_len(n_pop)) { + if (budget_hit()) break + r1 <- pick_other(i) + r2 <- pick_other(i) + r3 <- pick_other(i) + mutant <- pop[[r1]] + 0.7 * (pop[[r2]] - pop[[r3]]) + trial <- pop[[i]] + j_rand <- 1L + as.integer(floor(rng() * 3)) + for (j in 1:3) { + if (j == j_rand || rng() < 0.9) trial[j] <- mutant[j] + } + trial <- pmin(1, pmax(0, trial)) + f_trial <- objective(trial) + if (f_trial <= fit[i]) { + pop[[i]] <- trial + fit[i] <- f_trial + } + } + } + } else { # halton_search + # quasi-random space-filling baseline: warm starts first, then the + # Halton sequence until the run budget is spent + start_cap <- max_evals + for (u0 in starts_all) { + if (budget_hit()) break + objective(u0) + } + i <- 0 + while (!budget_hit() && i < 50 * max_evals) { + i <- i + 1 + objective(halton_point(i)) + } } if (is.null(best)) { @@ -424,36 +547,70 @@ optimise_swale_design_simultaneous <- function(run_fn, return(infeasible_row()) } - # --- lattice polish: single tolerance steps downwards ---------------- - # (any reduction is cheaper by construction; stop when none is - # feasible any more -> locally optimal on the tolerance lattice) - for (polish_round in seq_len(20)) { - b <- best - candidates <- list() - if (b$area - area_tol >= area_bounds[1] - 1e-9) { - candidates <- c(candidates, list( - list(area = b$area - area_tol, h_m = b$h_m, h_s = b$h_s) - )) - } - if (b$h_m - height_tol >= height_bounds[1] - 1e-9) { - candidates <- c(candidates, list( - list(area = b$area, h_m = b$h_m - height_tol, h_s = b$h_s) - )) - } - h_s_down <- if (discrete) { - lower <- levels_all[levels_all < b$h_s] - if (length(lower)) max(lower) else NA_real_ - } else { - if (b$h_s - s_tol >= gb[1] - 1e-9) b$h_s - s_tol else NA_real_ + # --- lattice polish: accelerated pattern descent --------------------- + # (any reduction is cheaper by construction; step 8/4/2/1 tolerances + # downwards, halving the step whenever nothing improves -> locally + # optimal on the tolerance lattice, whatever the search delivered) + polish_from <- function(b0) { + cur <- b0 + scale <- 8 + rounds <- 0 + while (scale >= 1 && rounds < 80) { + rounds <- rounds + 1 + candidates <- list() + a_down <- max(area_bounds[1], cur$area - scale * area_tol) + if (a_down < cur$area - 1e-9) { + candidates <- c(candidates, list( + list(area = a_down, h_m = cur$h_m, h_s = cur$h_s) + )) + } + hm_down <- max(height_bounds[1], cur$h_m - scale * height_tol) + if (hm_down < cur$h_m - 1e-9) { + candidates <- c(candidates, list( + list(area = cur$area, h_m = hm_down, h_s = cur$h_s) + )) + } + h_s_down <- if (discrete) { + lower <- levels_all[levels_all < cur$h_s] + if (length(lower)) max(lower) else NA_real_ + } else { + s_down <- max(gb[1], cur$h_s - scale * s_tol) + if (s_down < cur$h_s - 1e-9) s_down else NA_real_ + } + if (!is.na(h_s_down)) { + candidates <- c(candidates, list( + list(area = cur$area, h_m = cur$h_m, h_s = h_s_down) + )) + } + improved <- FALSE + for (p in candidates) { + r <- consider(p$area, p$h_m, p$h_s) + if (r$feasible && r$cost < cur$cost - 1e-9) { + cur <- list(area = p$area, h_m = p$h_m, h_s = p$h_s, + cost = r$cost) + improved <- TRUE + } + } + if (!improved) scale <- scale / 2 } - if (!is.na(h_s_down)) { - candidates <- c(candidates, list( - list(area = b$area, h_m = b$h_m, h_s = h_s_down) - )) + } + + # the storage axis separates cost valleys that single coordinate + # steps cannot cross (dropping the storage level breaks feasibility + # on the boundary) -> polish the cheapest feasible design of every + # storage level visited, not only the single global best + seeds <- list() + for (e in cell_evals) { + if (is.na(e$n) || e$n > x) next + key <- format(e$h_s, digits = 10) + cost <- cost_total_of(type, e$area, e$h_m, e$h_s) + if (is.null(seeds[[key]]) || cost < seeds[[key]]$cost) { + seeds[[key]] <- list(area = e$area, h_m = e$h_m, h_s = e$h_s, + cost = cost) } - for (p in candidates) consider(p$area, p$h_m, p$h_s) - if (best$cost >= b$cost - 1e-9) break } + seeds <- seeds[order(vapply(seeds, function(s) s$cost, numeric(1)))] + for (s in seeds[seq_len(min(length(seeds), 6))]) polish_from(s) mono_warn <- dominance_violation(cell_evals) if (mono_warn) { @@ -469,14 +626,14 @@ optimise_swale_design_simultaneous <- function(run_fn, final <- eval_design(type, best$area, best$h_m, best$h_s) if (isTRUE(verbose)) { message(sprintf( - "[%s | x = %d] area %s m2, height %s mm, storage %s mm (%d neue Laeufe)", - type, x, format(best$area), format(best$h_m), format(best$h_s), - runs_executed - runs_before + "[%s | x = %d | %s] area %s m2, height %s mm, storage %s mm (%d neue Laeufe)", + type, x, method, format(best$area), format(best$h_m), + format(best$h_s), runs_executed - runs_before )) } list( row = tibble::tibble( - x = x, storage_type = type, status = "ok", + x = x, storage_type = type, method = method, status = "ok", mulde_area = best$area, mulde_height = best$h_m, storage_height = best$h_s, n_overflows = final$n_overflows, diff --git a/man/optimise_swale_design_simultaneous.Rd b/man/optimise_swale_design_simultaneous.Rd index 7e88d68..318f274 100644 --- a/man/optimise_swale_design_simultaneous.Rd +++ b/man/optimise_swale_design_simultaneous.Rd @@ -15,8 +15,10 @@ optimise_swale_design_simultaneous( fixed = list(connected_area = 1000, filter_height = 300, filter_hydraulicconductivity = 360, bottom_hydraulicconductivity = 12), prior_results = NULL, + method = c("nelder_mead", "diff_evolution", "halton_search"), n_starts = 4, max_evals = 80, + seed = 1, wobble = 1L, max_total_depth = NULL, cost_rates = default_cost_rates(), @@ -49,18 +51,27 @@ continuous \code{bounds} + \code{tol} (gravel trench).} \item{prior_results}{Optional data.frame with prior (grid) results in the workflow CSV schema, used as warm start (the cheapest feasible -grid cell of the branch becomes the first Nelder-Mead start).} +grid cell of the branch becomes the first start / seeds the +population).} + +\item{method}{Search method, see Details: \code{"nelder_mead"} (default), +\code{"diff_evolution"} or \code{"halton_search"} (the latter two mainly for +comparison).} \item{n_starts}{Number of Nelder-Mead starts per (storage type, x) -cell (default 4). Warm starts (prior, previous target) count towards -this number, then the storage-ladder anchors, then the space-filling -points.} +cell (default 4; only used by \code{method = "nelder_mead"}). Warm starts +(prior, previous target) count towards this number, then the +storage-ladder anchors, then the space-filling points.} + +\item{max_evals}{Soft cap on fresh engine runs per cell for the search +phase: once reached, the search winds down (already cached designs +remain free). The final multi-valley lattice polish adds its own +runs on top (typically 20-50 per cell). Default 80 -- thanks to the +shared cache the later \code{x_targets} of a storage type stay cheaper.} -\item{max_evals}{Soft cap on fresh engine runs per cell: once reached, -the Nelder-Mead phase winds down (already cached designs remain -free); the final lattice polish may add a few runs beyond the cap. -Default 80 -- thanks to the shared cache the later \code{x_targets} of a -storage type stay far below this.} +\item{seed}{Integer seed of the internal deterministic generator used +by \code{method = "diff_evolution"} (ignored by the other methods). R's +global RNG state is not touched.} \item{wobble}{Maximum counting-artefact size tolerated at the upper corner (default 1, matching the +1 event-counting wobble): only if @@ -78,29 +89,45 @@ Enforced without any simulation runs.} } \value{ Tibble with one row per (storage type, x), same schema as -\code{\link[=optimise_swale_design]{optimise_swale_design()}}: the optimal design (\code{mulde_area}, -\code{mulde_height}, \code{storage_height}), its metrics (\code{n_overflows}, -\code{overflow_volume_m3}, \code{et_pct}), cost columns from \code{\link[=compute_costs]{compute_costs()}}, -a \code{status} (\code{"ok"} or \code{"infeasible_within_bounds"}), -\code{monotonicity_warning} (\code{TRUE} if a strictly larger design produced -more overflows \emph{and} more overflow volume among the cell's -evaluations) and \code{n_runs_new} (fresh engine runs spent on this cell). -All evaluated designs are attached as attribute \code{"evaluations"}. +\code{\link[=optimise_swale_design]{optimise_swale_design()}} plus a \code{method} column: the optimal design +(\code{mulde_area}, \code{mulde_height}, \code{storage_height}), its metrics +(\code{n_overflows}, \code{overflow_volume_m3}, \code{et_pct}), cost columns from +\code{\link[=compute_costs]{compute_costs()}}, a \code{status} (\code{"ok"} or +\code{"infeasible_within_bounds"}), \code{monotonicity_warning} (\code{TRUE} if a +strictly larger design produced more overflows \emph{and} more overflow +volume among the cell's evaluations) and \code{n_runs_new} (fresh engine +runs spent on this cell). All evaluated designs are attached as +attribute \code{"evaluations"}. } \description{ Alternative to the coordinate-descent optimiser (\code{\link[=optimise_swale_design]{optimise_swale_design()}}, bisection per parameter): all design parameters -- \code{mulde_area}, \code{mulde_height} and \code{storage_height} -- are -optimised \strong{simultaneously} with a penalised Nelder-Mead search -(\code{stats::optim()}). Infeasible designs (\code{n_overflows > x}) are not -excluded but penalised (any infeasible design is worse than any feasible -one; the number of excess events grades the penalty, steering the -simplex back towards feasibility), so the search moves freely through -the full parameter space and can trade the parameters against each -other in a single step -- it does not rely on the per-parameter +optimised \strong{simultaneously}. Infeasible designs (\code{n_overflows > x}) +are not excluded but penalised (any infeasible design is worse than any +feasible one; the number of excess events grades the penalty, steering +the search back towards feasibility), so the search moves freely +through the full parameter space and can trade the parameters against +each other in a single step -- it does not rely on the per-parameter monotonicity that the bisection exploits. } \details{ +Three search \code{method}s share this penalised objective (plus cache, +tolerance snapping and final lattice polish) and differ only in how +they propose candidates: +\itemize{ +\item \code{"nelder_mead"} (default): multistart Nelder-Mead simplex via +\code{stats::optim()} -- the recommended method. +\item \code{"diff_evolution"}: a compact differential evolution +(DE/rand/1/bin, population 12, F = 0.7, CR = 0.9), included for +comparison. Deterministic: it draws from an internal Park-Miller +generator seeded with \code{seed} and leaves R's global RNG +(\code{.Random.seed}) untouched. +\item \code{"halton_search"}: quasi-random space-filling sampling +(Halton sequence, bases 2/3/5) -- a deliberately simple baseline +showing what the structured searches must beat. +} + Three ingredients keep the number of engine runs in check: \itemize{ \item \strong{Snapping}: every candidate is snapped to the search @@ -119,10 +146,13 @@ easily missed from a single start. Different starts take different search paths -- the counterpart of \code{split_jitter} in the bisection optimiser. Every start receives an equal slice of the remaining \code{max_evals} budget (unused runs roll over). -\item \strong{Lattice polish}: from the best feasible design found, -single tolerance steps downwards (cheaper by construction) are -tested until no parameter can be reduced any further -- the result -is locally optimal on the tolerance lattice. +\item \strong{Lattice polish}: an accelerated pattern descent +(steps of 8/4/2/1 tolerances downwards, cheaper by construction) +runs from the cheapest feasible design of \emph{every storage level +visited} -- the storage axis separates cost valleys that single +coordinate steps cannot cross -- until no parameter can be reduced +any further: the result is locally optimal on the tolerance +lattice, whatever the search method delivered. } The discrete infiltration-box levels are mapped onto a continuous @@ -133,11 +163,12 @@ be fixed at the maximum via \code{fixed} (cost-free and dominant, see the construction (the \code{mulde_height} axis is compressed to the remaining depth), so no simulation runs are spent on depth-invalid designs. -Compared to \code{\link[=optimise_swale_design]{optimise_swale_design()}} this needs more engine runs per -cell (typically 30-60 instead of ~15) but serves as an independent -cross-check: it can discover cheaper corners of the design space that -coordinate descent would miss if the parameter interaction were -stronger than the monotonicity analysis suggests. +Compared to \code{\link[=optimise_swale_design]{optimise_swale_design()}} this needs considerably more +engine runs per cell (typically 60-120 instead of ~15; search phase +plus multi-valley polish) but serves as an independent cross-check: it +can discover cheaper corners of the design space that coordinate +descent would miss if the parameter interaction were stronger than the +monotonicity analysis suggests. } \examples{ # synthetic monotone model: overflows fall with retention capacity diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R index cd04cb0..d4ba5cf 100644 --- a/tests/testthat/test-optimise_swale_design_simultaneous.R +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -145,7 +145,58 @@ test_that("max_total_depth wirkt als analytische Nebenbedingung", { <= 1200 + 1e-9)) }) -test_that("mehr Starts finden nie ein schlechteres Optimum", { +test_that("alle Suchverfahren treffen das Brute-Force-Optimum", { + run <- sim_run_factory(demand = 3.6e5) + # NM ist am praezisesten, DE nah dran, Halton ist die naive Baseline + slack <- c(nelder_mead = 1.05, diff_evolution = 1.08, halton_search = 1.12) + for (m in names(slack)) { + out <- optimise_swale_design_simultaneous(run, x_targets = c(0, 2), + fixed = sim_fixed, method = m, + verbose = FALSE) + expect_true(all(out$status == "ok"), info = m) + expect_true(all(out$method == m), info = m) + expect_true(all(out$n_overflows <= out$x), info = m) + for (i in seq_len(nrow(out))) { + type <- out$storage_type[i] + stor <- if (type == "infiltration_box") c(300, 600, 900, 1200) + else seq(900, 3600, by = 25) + ref <- sim_reference_optimum(run, type, out$x[i], stor) + expect_lte(out$cost_total[i], ref$cost_total * slack[[m]]) + } + } +}) + +test_that("Differential Evolution ist deterministisch und laesst Rs RNG in Ruhe", { + run <- sim_run_factory(demand = 3.6e5) + + set.seed(4711) + rng_before <- .Random.seed + de1 <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, + method = "diff_evolution", + verbose = FALSE) + # .Random.seed unveraendert: der interne LCG ersetzt Rs Zufallsstrom + expect_identical(.Random.seed, rng_before) + + de2 <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, + method = "diff_evolution", + verbose = FALSE) + expect_identical(de1$cost_total, de2$cost_total) + expect_identical(de1$mulde_area, de2$mulde_area) + + # anderer Seed = anderer Suchpfad, aber gleiches Optimum (Toleranzen) + de3 <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, + method = "diff_evolution", + seed = 99, verbose = FALSE) + expect_equal(de3$cost_total, de1$cost_total, tolerance = 0.05) +}) + +test_that("verschiedene Start-Konfigurationen treffen dasselbe Optimum", { + # verschiedene Suchpfade besuchen verschiedene Gitterpunkte -- die + # Optima muessen innerhalb der Suchtoleranzen uebereinstimmen + # (analog zur split_jitter-Erwartung der Bisektion) run <- sim_run_factory(demand = 3.6e5) few <- optimise_swale_design_simultaneous(run, x_targets = 1, fixed = sim_fixed, n_starts = 1, @@ -154,5 +205,10 @@ test_that("mehr Starts finden nie ein schlechteres Optimum", { fixed = sim_fixed, n_starts = 5, max_evals = 120, verbose = FALSE) - expect_true(all(many$cost_total <= few$cost_total * 1.001)) + # Sickerbox: identische Stufe; Schotterrigol (stufenlos): eine + # Toleranzstufe (25 mm) Spielraum + tol_hs <- ifelse(many$storage_type == "infiltration_box", 0, 25) + expect_true(all(abs(many$storage_height - few$storage_height) <= tol_hs)) + expect_true(all(abs(many$cost_total - few$cost_total) <= + 0.03 * few$cost_total)) }) diff --git a/tests/testthat/testthat-problems.rds b/tests/testthat/testthat-problems.rds new file mode 100644 index 0000000000000000000000000000000000000000..6870cc70d294783d47a0339c12025cbd2fd85934 GIT binary patch literal 25670 zcmX_ndpuMBAHSLV{gNcK$`E1|lEMhNRnt`=>rNy^LS{o3qNqu7ov0{@$|aFaDoI&F za;eRA!ffuFUC!@)KHuN(*B?D-l^hRH~fBe}9ndIC(FYMoRLTF zbgaPWT<+sNKhdE-t^fUfT_x@N>w$(*Ywqds(?;KZD&O04W#3Vk75BSwh|E2w)q7o~ z)m^%<6vfoiWQF9!A~`6+i1p3RGJ;{{cdo5ROiVJirRPP^-!Ba;#2M>xuGIPed-?6Q zlFwBc(fDdt@>uwpO=mM!xRU6XN7bh%W_eM2RBs@ia7lj#&c*K7-h7zfTJY=Q$Kf4y zA7*7gJgEJ?nDoAU4Mj`k2zxQDE4_b5J^NSXpDW?6)%~GIgB!p29yxI8d-=0VEm)^_ z@2>vZ=Xhg$qbJ+D(|{58vE=aq}?HTve=PU$_2l}eZC^8Jr4ZdhhqEHR#9V%k^>{p&9AE%#ZN zR{vT)9~M%g|9WS=aB%OADdm~4%)>tMzLt(gzt+|FB^D&p>&wl4oD~p$sZ@l_*g*VQBRY(h;U4L!9lBz!+Gv!_%S{+Mp=nspGX+E5*ze3f_ zv;2;FeWYJWi*`+I%scz~_b1ZzYkckh94@ZDx!YuINXel_hoRKP@;wD-{oG^{6TIoh zQ7I+PUgdlKbo5E>Kwc?1wl7rwLagXlFiE!ieQ?ZU`&H*k(2qQ?967Y-uh=7^Vlp*T`D_3AuiP4i zNh|)v;xmy;U6#vrzrrghKTY)Jxh1)Nk~^N=2!5{p%g0yWiGHQONAD?l!|`A3g1%)MMD=^2OyFzcDw8pC1yid)o>(#8X|Fx0db=qvX!fsG=OTpQ;zz2TIID@~h zT^%Y6HZ_#>|9#h;bH?yrtlhb{n!nwuZt5Mxr5=gc=FWFqL!z;iZ?w7Y>pt+3YU`-{ zcUo~uZXfb;%#{Z{2Yu&5)*e|C>2u=H(FilsPo?i#HmvyPxyjElg0|6m`j%vQ&ea#^ zDSup_9f=!A8SC!1|AUxNCzbY_i8MmRebM&A=Fd;viwlag+&Foezj+Vo;yEbdbyaLs zU+BQfj_tKFLh<-WSEuWp!=ZbWdoq50Pzf%vn$3H%xyR20n(y55+OPGT-}No0cNnkM zvH5tL^<;Ie)Q3UGtl~?d$6WWD2l?mR{Jy@-;H1FWYL&CqjU)929j{pILW+-TiE5j3 zb9H{wv8?J2XVg!VQ!$s77T%t#&Ml6>JvKXm?vN|1+BRrfo}c;PY~Pi1%t`0v^y(mH zbnzXp2nR!7Yv_5*q4w$oMyv8Tv(gx$K zTd)2Z_~xCMJ+d-?dwlmTq*2Q6Z+F!qh8lisu%2~eJ-WyLbho)6!uDFEkJ7K+F@!%1s9eVQ1Z8myu zE*uLlHdfhXni{3{O1{?Gu`ROd6Y|&}tBpCuDQg%r`?L>T=B#6@QH;Ma)awnMeH zdUCM@t-Ui(cdyTlPPi~u?iADd^zrD+{2H~Y#G06$zXnJ877y&}cy*BYLVqgxf^t!t z^=(E9`Ri}qBlVr^?~xw9-KPzQ>mI*rdf9WeW4(H^i{Hn$_@K1%&k63OfpVPlDzSZD-yV!-P;nt>8mi0xR~do%5HVm*XvGdPYN^oakt1)|~IWn67ik_wcjoqb04O zH8y(v0j_=LvId9EJ(KkRxbug%KCQf1{&*y?yFF#ZRO>*ebmHNWlawp@3za0+UF1Qo~4w}3})s03;nyeIQ#3D!rmF*`rs2c9-aA#!}Y$T z5p)=Bb8E2t${#yX^W1ZZSHv^db|$ax>ffAvG~A;4Q0_4LT#ojn>9FQ`=udEFVI_tmyX7nFXeP8%t--(i~qm|W(=|TrqD4tR4|CzlL zGJYYR8qf>e_*^UhWYS3kTbF9zUW`qL%G1u1$tOpmi>RvSkmr`@H$>;$S$5m68o$US zOvuR+uKXBg>|b7WKHn(>po+@Q$ll+SpA`+Xu`}j7`r@O(QUCy7Gg6@9ZV~msy^D<1u?&+6(0?sqC;<{XvPhc(M@+eHDi}#3y^govn9qEN+Gy zc<&BNnSn#2)#H{(EHCp<9-XJTnjFOCGp|FB=Av^K-n~)@AXW zj$7r&VtwywV{yv13+(*ZYGQ?Mg~x@V8h`RUj8{u>#M z2Ym_bALqkVdFwlJua#a!gc=pK=Q`IIuX^uVQJ#i1%|`o}9wShOmM-@`nhjcaG3oUK z-B>k)qD)TPT`^HXJS76j9WR~pxrcHmG*s?z6WaIH{pPGz=}VcV?pMi z7)>>8Ar?-*x*nT4QYO2XJpRX=LtzJHd?G#(xkc3{z5CU6X_e zJ&P@Vr6q>i7E^4*&JWM7=a@fh4v~#EvQ;|EXLp$CRP5-4VG^wQ5JZb{OZ4(_H6v44%JkK9y&C0VRON{C-$zV>5KuW9!m3Xy__!Lb8Hqle2?ey+ppW|b9~9gK57 zw3+rP<>ZChD5dRXg6bz$=QliCJKZEjao!AV95%=%^%PFlHez2*JxW|a*1Ix`pS;hf z4|E*pxf|fRaqI4yo7xx5l*76|T$As-_OdkVy4$g-54;y4H73V%RL6e)+SDo+nB28= z%<{0n@7OKOkFg&Y7i6#Sj*Z!ze)Im3wLNFzU2)$U5Ane@hHBVF_QcaIH#ff$k}6`( zv$36&J;cG9Za2%c>vvzS(~J4|)Hyw@d-(E|d7tPrJu{I^f8w2osy96%pI;;jwyrBL zv&m8Xmx`9!zv}y_@}f!{3C*?e^oIc;IUP@bCxTU=nI?YRw_l ztb&h$3Y2wr!wSrZ>+}@`Gv3TU9|Gm+Z&i3Z2jAQX)UzO@Sqa=b($(}#8vHI}bf@?X z_1UANZi;&~Vu`Qv7;+?!`3yv_Pu=egSl3FIsS?dJMB|FP?3nAfrHL|Y=SuF~Hs&kW z7FUJtZHOpdplq1o(xnq`c#~dwmAFXgXGoM-Y-*RgmO+^ z!mL*M*DQ%G*o?|mynl&jJ_NP~dMP(Nz$+|{#_N%ufIE6sB8JRliHO3_J_zCZCPOup zATN|@-Pn7aAy>-ZcP@yrt1{4{j&v_DZO+&yde?W9xUOIXy5)fK7Stkml1=I_qlt7` zBD(N1Rf5+MpTih1!W!S&+n#6(eh}ejeJj9qILhnTdzsjBk|tL=(SQc+Cyy4PS!G)ha?$Ws#gteP^uW*?DXL{a!M8ZrGs<1afU{g2)_#Tv~n>S^qrp;P=O zC$htiVwJonqvTo#Wn%AeyqQUgd!?Wxohjo)`-spYiW2<06`BtCx5CHbUdQmq<8BIH zYw!J3cyilZCe|EsXM(AhfZXn#*ATflhN1!F5SOuJP;8~%$FlPId1-ue#R=bQN_ETh1N)K3TO+HA--g8;gViA z5p{mYu5BER-%hQ1dvz8ynZ9_wjGq<4?DwCU$v}!T1NXKBCL{!^uqdYs>L{t956m27 zgG6y?BKO$ZqB%e9)+=EBmXO%p7gz99@8+2}BZGz7WdGpGo>`1!ql+4=CDp@1Jx-@Ejf2|(X3$G%bXc5TXXc7Wd=Zzq zTOf&B3u`!|XrEQl3nb~^K9a#gicJ-!5C6}T4S6!NJB80ByTtXr(F3s|#PA*dvcgr4 z-x-q$DC1;)B(n96Ou+D|X<`QsjCs_ESt7SL;?vw@85*zoUb>XOfJHB@o~jmBAn;11 zGo<{Hv&f1?n`?3M;Fjhzoc8?%n;a@*eciG7Hxky=3kLieut-#Wo~Pp-NQJyZxuK6C zzj!DgX;)ORI z{o#;)*Djb@O&BZCh%+o4W1XV;D7Hs_5-eRJ8@pgty_c{IWBwy>HQWafs%YmWAF!(2)Ouz05 zHVL$vyFF=AoFEv+p-C%6?vDA4fD#lqA>9xq0c99eH#E$`(6S^ZcziSNRn(0o7Z>6+@V+_RVRYlATQg72Ao0izGnZ6ac-x)w zsT&*`hdtUXxvTMOe$$cn`8Qe|cM?r27MsbR-L~M-*tUZ8DHoyKtz*rqQ2$^G$HVw@ zoa^MS*wLz6MJVG90#?xZ5sWAm9A?sbuIW20v*yuz&*ei!7{vXV?5#Sy{Z4h1Q9(tO z3A}9Ld<8-s^L%A(e1+6O!AWKrqPuYg&o(|7tIzXoGODD=3->#+p)JfTA`%(_$1)^2(5na^5Wrf2Ny4+D%^2#>dvlM5V&dZV^s>FlJRCc&`$#Hjd2L zQ%)yOz=p;jgfK?g2FEsUz{CC`}T8@~zGk`VL)25bpS$a>ZHD%ulO30v(nJ7S+gO56uRe zj>z^@=z?nCOFfW)GAm^_&xPGZZ(RNt?@RpB6fmr+h}|=kD>E8FsEzchz&3b z3g%YN$|EaANjs-(jkicti?IJZ^B9>vu|pcavQCQ+ye4X;7O3}B%z0R>h*K%dgMM19 zt@{l?4kP8@qc$DbX|d&Zv&bys97R*K$|)2dfW;~cqnkXKkOrB)I(h**T1nr;rDQCc zs5>lwTO-8pEg~eWwIl7VPaHW6P#3b}M#~n@F*4CUx4;UrsF=G0=fTqYAh0`sgnyb_ zN~IMCiHY){mTn{Y?+L$?&@)?s0JES^!pjgJtj(kReEDB3jY4u$r3QufuNbuM0WelC zKc$O^B*b<9Xyg*I>+XwP#fMud`v-O2tR*$NhS!^kl_>i-OSU9{Q%{-#L=2S%KeYnV z(?3q(S>s8F3EumRkqcmaR7Kuk;&2mGtGqbeRPeS6|8^))_ES}Xc&{Lh+xa9QC5N#@ zw!8hF1z^$z7F>SfsU`?16FY!c%Ua9>;2+L!SR$$MZY6$V zLhHzG{xh#E|7hWoSBDU93(xSf@3xGXkDX1 zrLhIOq==$iDuU45Loa!P4XdF8Xk2RJN&s~&X!H~c#|ySy07Y>}IoGX&KOMoAY?7$RTeEPsdaNisw-Q;ADo zDh^A&U{tuw5_CiE*%~=mjz&Ju7Ae&Y}5niHn0aBe;?F->^u0b9$V(LvX zUX7LQ)e|V2D$#p$?9KdTW|o8}agJiMmu|(Kz-odW^o02D=uP1+!TDz1HIaJ6tC{>0 zOvTgU91}Z(Z}@*z#vZ73%l=Mp@m`qq&$fbstWKM(_h_bJ?<~xB6rohUEHHNJfq#2~ z6+|f$?yb!u{e1TQXUi?3RpCg~cDD6T<5i$UY-6@aJcnjv1e=f3ms$?ER$Lkvr`6q} z4eM8cnHV-HqDXC+!!MsM#e&fvppot+P!tvqNOY6rxt&rA!Vgikoe30`4XmVj9aMV?JGq*y)r>req^2)>Jdei_GM3tVh zR1zLOM^P9w^Oxt4N+`R3u3xru(x>WCl0L!%F^8W}*v{|vJef+AEF8n@-lBt%gffla z4MjDqChhPjfyXV5+y-vE*O`AHVM%8qy#e1B^?>_^+_!X)e0Mwo5gDgSCj0`w=S*YC zr^PQSXPgI9;~2`2Yt07y0MMX)i8&NKK!lDJp;SwU1C3kH!JjLF#*e3;x6BBwY~c@D zC0DEfhgkFG@}TgdQ5EB|<1q$Zl4w*o%aX)Tr;r#fJv0^~nH4^K0# z#i=ynn!=Zmw(hL#U)AFlIh1#S-luKz-?rW8VYPoPv%mC;)v2j$cS)Wji=M;Zr!3^x znfef*Z+yNMdD4X=(l6~u)BCG-!kPKLIk^whYqPHMo zF61MFJrNVQ*4cYnyO%=p&^oT45fyV2Tp-` zW=Il?m{vY^)G%b@D(^YL6{eT;px8n5A2obHGX9-~oZvOKsbTG)Qx;D|cd5ALz%*_I zd6|VE%eqnwl0|d& z@g!7xJG3nMF((n$joJwm%-dCcONQhu(EdSNeq#__GXl^3M6-%TlKX0Wt1x5>k)=Q{ zrBkAX!pxC99jeH#nFX2bGcak)rKxIv6m|Qd!%_jIScY=#ruWwPKw(I%ry2(*-aDHH zh|q+10)>X)ZZ0YwWxP#CNDZk>VnN@YP%+ET61PKh{6#!XTX8}pQ&GXWCv3@#uC+xj zLkw?HRnIJh6uas0mXz6wOD*3%Er%Hu-lyC#YXEK2v00 z8?o!25YHmByCFGdbzU!%^tfrwFU;7#sJJrIb@_Y3hR2@D{zNVM zafthb3m#EA(|PsYW^nFDdk|PfZxP-4KUVXKcNQ5e?$+%?v2~S1NyDeqN8Ahxm+|Mn zVDwO4h9qq{da1y#K=-gFwk4BSt2Hl9jR;Y0J>0BXZsrubIf5djW)P+(4DNzkFKix*!BH^|(d3;pczF{07@ zeuMAB`zYg#s^q`sa`YZcJ9NqFDQodcrlNGxHR!O0-@I%5c5%P^c5tK^GQ{g^7sKkC z)(Fzy-i{wHkqGAx)a27}(g&dcGU)JSzASbv>Xd8)$GblsBNaP}yt(KqKKPI7`T^rP zLEY4PrK4W@6|^3$3fHqM;2x2Xi|GEVYk&}8B)ewnGOI;wff7@Kz&d%eNPX0^gv5~ynAi-nE+?ykO=GM)YCw|t?Sq&QMs95_altE>vLjSl zvy=e{9H3419;26Z;dNN#yg+8R*sihyd4DeOGoMD+JTC!hXAt@TrN>%M|3%VLjl%f8CsNP>qZ~<04>o;K-Q@dV8Za$BgQXL6*`|~XDixxAu9@A zebGXpNQN;7<_#nw30%>zEZj>QaSfzr2y-i2`->@=s|?@tM;DWD@`mYoC=E}-SY^|Jf{=A5SAd4 zbksp*f4aHoB+zgcTSyR}-cCP*)&X?3eQWlc>pciKom^OedSF!Xb01MsM#HENgl_0Ph9jeNm@BrFX;f zt9W0Ba@p(~Rj>9?g(%5$Ad|l$QSdN~r z>)vkjJ4EOvLBSl66Q`rWAWp>hVcqWO!Tr2$0?K0B8ete{DVM+bpDi0VmY5L6DRDKW zPl(#>9*ji83(re8=sgcMQ@Ski`Eh9;w&^$?vH0=K)>L9mp#y%fE=G~tomffzZg+14 z4JLYG`Hj{@`l7GcgGnk%2$K;IxD|GnvRNr$6W5S*xpPuyh-vMptsY6^+L9B(j=kYe zK@-N2Al_qY1X1>q54ZqTRy1ii1D9nJnhoFxpem_m?R0&Lo=AsFcTk z^JWNZv4qDDa2}$N72#4mZ1-`J6ev1%&hu{a7cPIAvy^H`>l~($9-girPnYcy-gXpq z1hg?!#92B#{o_@c8K`lF5Wm^lzo?)3%>MCJY6<`O}GA5@r8n!TM8c3 zIYZLdM`_<9_`)#mU}4110cV7?8o(@eQZs;2-0LX0zi8&xxluhoIm>Jni&TZlfy}c~q+1deop!oJk4B(1bRUqK!;ITFzRhQ`Bo>ZY`sbsOOfAr_w z;}izD0Sy#@_tY_Q%)O~On4=mpwHAoi`=K*r#x0_0;UeAaGzDhCR3tH{um;-#nYN-_ z@RER}#=;XW3sj~F@k0R=3DmM`2vQ;_gK~g(7sImW&=$tZIPD*xG$!!9tF(C4T(2POl_!aZ(K0;!L4x?D4EbKz&) zT<|Y2I}fNTJdLI;TE43HdPflZ~qPTvYBOQODoFacT@rGiyPo!v-iiHUY6XEn>#J zzz7^W+|hO9O2B+Ro;kK2RFZS{?0Z@W;_Jc!&NiqfV`>HLCDdITISEgMChugEMi6ui zU2>}tbiPqGt^Z(HTFvb|Hp6-Q9Kx-dDx--nCs(ZYX7%7C@dif}#dIV7{qaeFJ`wKi zaKA~BB)(ibjcT|4JuGJ0C0D3>&&?5>A*Oihlt5|vL#qd^u<7Iu^im2y=Ng7RIvwWG z?`gOd*9B!S1o0S|F43HbmZdPk&u1|>WV_?QJCLOTWniplNol58go!X=Ckape#I`7s z2>T&Br&;F?mfT557(b#6&Lgyrd!ecK2bMqua|gG~1!#UM%pj!+nQI3~r$rA(jEgD| zT|#0X_!N=?rhz?l5yHv}HGoo2K`^9%+Gy8Ghg;bQpedHlKs$MwXyRwzWR4GwF5Sf= zDihup7SQWNMCaL}@mz^&A!9qJ^cV%|(V>1NpgUJc;#Es$L~D5b#H&;qyJabrWX1Ir zqnbcpo<`{*&w9mFLtgud#&cm`c)jcG4ALmnd%|O2rnV9P8VUU2r`Q3WLXr!qlA~Pl zau0vaMf}=vngTNijwE(>rJQh1G#p!mLX-+L8%aXo5sIj?LiZ*UCd815eM>oOvAkVz zvP9nZBt6QFgT${d<$s#&CwVxm5ZM76OtnxP1cY!oanh67Z=a@gC3>;>-(OoQvsD?Y zCoG;o_vo3z?fZC|$K;o^d#j8BwNr>I3cpc$yLx&LfP+X?1FZ4Xuqb0sWV?liXq)3d z=zL$snRK{6U(ak&+zADyZ~E;FS!$<-nHJ9D7dJ4?o$T@9{Rdw3YPw+cy+4x{qh*1? zlK4o(Q$)n%w8{7tfaRf=~v$r zV1op#b`y*9a7VxxM#DU}V@-e`(n>e~VEKW+F_*0mR2A;jK}wv;oqnsj=Z?-P;E35fj1BRpk1LJItgZPR1AkAO`%ASr&B6zyx@+%0lWuU?8u)rM_%hf3q$Ugki-(8d zli_~~z(NS^zY~Qq9?hB!CdI)g%H}KYpBgA|&}m4uwZ|2h`E!C0wCZYrF+DKnmINnf zpd2IwO2vHQv;&x3sumC|xrEKR99E+tXcXR&n1Z@~xbgO*rE7i^H3JenfK|(is~s;< zm=Jo+U0T$KwI<%k0(&nRs8*Xn;X3x8(nM8;m8N=Sb}By#HP6s+G>3@J&?%z*27b2* zp~P%6b&X++|9mr;6uy{U3)9tY+-B*`)JEJavLjvUAcVWya2!l4R)Tn+xs3}slZ{=0 zeJ6sFM`FNGNg6!)#0>u#;nkFpa~(J!Wr{YpTEbsr#XSJGE|gVMm*V1NhRlG7MEd1T z-BL+f(^sMA%_dz4g2F3Fh~-*IZ#L9(7o~L^@@vIbaBn{(Rorbbg?kec)qqa}1s*R= ze7kmx!SN7pSiT25I#o0WMt&43FM-)tMhC*vOc>-VS7!q%2D||3>(O)zQ_!{u%~s4^S zG55Nvr&wwo_ARjm353VVC`sV-T2t$Y|9K5}!W4g}BfEHeS2&<&ZjguOB)~PpAqdci zjYXN=GKZxj#^np&<$(-G)CGR@c4%g~c_}I%_E5vSvRTU_1ck7_rlbDXb>e~tZaOBq=YpK=MFol|sUR>Y&GH7%-_ zY=Mo^Q1}AsSon96X)N#iGFnW^8L=z^>_bSsK5`Z?Hb@6}(RckkrH)*IC0FsluJ95tV+<8S0rN7Kl+?7QKkIE?tPA#lH!ErlJ_>j&Ri-{jCtV;HdCc=3*Tup_Xo$Ra>x7Wo#f*I@XN0R2rd4O&uKET$E_ z9q{c)2ce$Se%3lr%_juXc2v9Fv!%crnh?&(_0oY`#!m;)fr~Oc(ruT1AgC{s^8N!T z$bow%@eK{qL}OR{C%PfYfiQDVf_+Oz0e~@+jvmPgUhGdWcI=rA)RnxzLSiHUnWN5v zt_0EC4>2&9#C%)s0_eArX02G#LnXfZevQbL&I>DYD-9s#6?VaS@>hR9~UZw|Y~ zia@X}iv-%c?6H^ln0pQDmj}U=ww=a;W`#Ycz;y)zmv=kIorqc92X1ueH3n`m7)b1D zfU5~3)*b1HgAfTV(1X!T8En>!CWzuL-neW6u8t%x!Anl30d-(blLh+JziM$NYXz(~ z&3F&-IRMpR5`fT%s2;O69drrMyu% zh7L*u3n6J@&DtqSxO{{qoa^~Y-xF1tHQT$@kTiy%Ao)iD!bT|bkEt$x9G!R@B5{Ag zyjBhH$+kzt=6H-G@F0?A>Lk5~&9>a;XdTD;j;T5npO$!SpKl-DqF6DPHXDrHH)i}R zP|_0`-Rqfy&0v?v(Lv)LjWx|$oUMBTcn^rPc%3qgdH}`?av)0Hi#BxwvX)8>eRK)I zAaKMjl}A-&1xLN9>m92p`Bhl&05*#zHfW~xd=*bz9>isBvm$Ni3D-_`@bTtUoFip; z*=F^h1T&%-PuG5NUHs_HmFbfmJ^=ZD9Nn>W8q6+UiBNr9`6DhQ^g_mX2*R4WS|2bt zO>Ttrf(Vh*67D0xklVl#3}n&(MGzi!eceY3;eQ+j+TNLXJ#6jw)gVUm9I8eq!I>|) z-xUC-ZM)R4eJCTL@e|Ri$-=la3E&OZ(C^Vet0ulF;A|l8DS|0{=w$$yTjfbNKSs&i zr_boC5|D+T0j4QRMM9t1_1ULWLD-@;KF**pjiH$_>lagvwLM2LoHO4-1gT5)mWn+; zVfR~)%0}a12S$ZCCw)nHg`Bs3+0;>=8bB_CcliotnRLinG0ea!fGe|P3$C~tW2sXYnkosT7^DNMH zM_`ezF;#C0{B;BCHngK9a~qYQ!jo~l!`TmzYDgHa(>e-hAXN`ekPz$EpA!Od>SK5Z zIxY6vLd`R?E1ssra4wf~S@Lu_R?C2{`vncrMaO*91$4|8K*||Xz~~>Kj}S9QLW)qz zrGjB-U0p9In^YO$Dkq-Uak@u&kt;%g#(xh86V*xcPC9KPjS^uH1BZndW>D7&e~pT8 zcatp>Qn@D5tE6fUl>zCKBiXoDt%YGv!+=(;QJZJvl*gDhsAB*JVd19uu|_772wur1~5Xv9=(;?2+;s-Fo)!Qh6Fla%S0Kob2os{u-wLnHnv9m*Us`x z;_QOJR;43=b-7#EX=}O^h{kG*!X4QR7TA;!JpnHd1l|W<;u4|*C>Zi$;PoYJIG;FS z103M{g5GiQHBN~b7H3Jw2EU7TRVW7jJ$hL_zK@6@3qj&hj0Yw#P>F(wR3*Y@K#a}c zmR7Wlwe(+9#1~j7VA=T#vChJaP?Nu>U>y|rkCJ+Wy6qY1@7fqIz)yZ-!^k2l7?l*G zYu7eVC;}TYHMLR0Tfho^O@U7uNw(2bja5s!+hDf58ca!)9vFH(P`-wQi(w$*5ez}H zJR_hxHBy!R-@s-z}d-pyB7UcfpnXGTPj2Y3v(MCN2wae{CzaH3D?~mOs7`vnkB=s_orh|PwQjWpw zSvW|w=oT|@GZQ9(ia-(u8Km>qL`N!Fde5~)(N0J4Jbp}o77+F$p)aS>+ofWxfyGzK zx0QvJa-uR1W5umLj#v63uGR1f3xZBoQo_bbBif$CxV=1joyK2Ad$Iqw5Dn2L$85%2 z&1P%8jrHA}n2lUC2gw7J5zEXLp*>=(mH<1Uu-0A!UlQm!Eafm2M5*X%D?-!Nsi zC;(@+TPF5AerR@UGRR=Ju?GAVg-W2^Lvz%~%`Sjq%%D79w}S(Lk^!kgJ1*&M)0%>? zP1>my2=8G$F8us{Q3nwTKudckUzlC&LX`u=4Bcu3wg^^%_bD+c9=anVaHbJ6K1MzJ zNH66#M=Whd8yj}3veUH+*q=f7(lps}3EiR#YtdnVup@#61rov)PKrQl>xI(*D=Ps5 zTKMOpgI$H{3)}OYw1u?)C+{Hiwe|}y5aeGUFmeFuS1jsp!5%Z(niAgF)(?`Uejq|R zRK(K#Re}uW6McsGK;TgQO7{V-HmklNA6@Utk?G=xXqzX&4HrY1&{#N)iHUn;dF1au z7@sHGjNzU8kA{)GKX>f!(T@=VQUH*U+Ers%ck|4EuDuOA5|=U(4rm$4f_uSf8)LL1 z#(^XGKdwG^ezlFA;qdAn8FW(=(c6%1K50q&nb!D2qU(K>({(-85K=IOaU7)u9dS z{J89qHQ+fQ1#YvHHTEs^QX0gW7a5T>9FQGY;`)LS836DMiA9*k=_X**yXH(Xmub0KwTbl<8ZQq55khd*Msu7bg+c z5NFFgbhVP&a+mZ4B!J^Gxwp4tXL@H4Lw+t45CB=SC!c5ANF5{=c0D_Gl(qyMb90rI9$2}l(kc7nK~e{)3@ zGF@W6PA>}%*UZuA>RmJ6XXZrzFs^vn(&0I6SR2R!rgfLVcny^*31op5PDKLP_`o%8 zO)Ua|xB!{A;*~(iB$WorJAd%MOi3SAX%Q%SaRCUTH86URttcRsLk7QL6)*0)H`V$$ zq#Z~73fUmwlyf@qYogB)1LKr)_ zxF?>Bn$CMXQ_;}JGX9QjB|Q2T)&pV^OMX_31FmQTS3D5->3c#F>fxw^nDd-aJB|?)?8t?eG?F!@Zai6 zZvEBh677h{i0`>NE|O=du=xWA;Kl?F3M0J>%7P2me<ac9oh1+_T!!ZG9T z($mF&`%)1ARUblDK5u~v2z)lY<7+tlr7elwr8Y-WZ`J64-97y7pQk}V@&b{xWIiLP zvPEdz{(k@bgSBIzT>=INw1uoyL;)%sRqwyCD!^l{u&Tl|P-*@zptBOeVw5Byo4L`) z4(dVR4U1<@w3bbhXRozePKUVQ z*Ou~~C=s18w74>m@ukXuAsNuH<;K$?aM@!SuU4I&gxe!uV9cC^0s<>r#0KqgZ@~RQ z_P1t0qCvV;9ERpUA5TT}7W6#G)dLBE3Q4TqR3^3eN8=ZUsVM3_x5s#aQR{v|J1$}E zA|n*dfu%Y&2!(Cbh~2rQkLDx;^h%@e0I(&;F@DQ|Erns}K@oDP)&maV5u%V-5APmh z2Z)d~5&-%QU{=TuIfHUg@rW?OK?=aWC)qpB7LJDi>7&tY)(cD)h$Z_v9i#H5Ahp(J z@Uja^Mi3MK&cQ*FaE%F6_c*e#Qo}Mya!OnBImnSvkEn4l1?%~*fS!Vt5g0kbdRv>6 z5767lb|8=gMI5Ipc+U+7-V`4Nukzj(vjR6ZOB+I+K?UJd3E-uDCry(Y8A1^02e0^W zMPvQ&t3ozF&*)mnn1uYu+Te{5s@!4*7$BgHDTUHvydnQRxEobga1z{276b?vM3??j z-UFsgv+AXYbimsp3d!jl8z>kkIMhVZM$lf^D1l7PaP0}9stuQehBGzwTS$xzcEt{O z7JtT`3?)0@y(!pPp(t!W4rWr21a`OgUu^OiLx4sBP6A>z)YEvFS)wE=Mrnc_)2g>{ zn&2gzd8|)s5Jud)6)?aLd;`kzHvHr}TJFo(h# zD4MCQFfpf}mcH1J1O#WyrySe}56qNGpGHI<2&vA6IB+ec+SWSs9T>4m0q?N%XN8-Po&gar zOe$cmP(^41j8NjkI^hBc34zzc7#L(g{|R*-e(&r3^QqF2Lhiup#F2~OTfyCTIWFL0 zvxU}0a5mGA4UTA!1kf|ss+J#XS4^oUEn`45lG^@*8btlON&Emox_>*&q4*5qHHm05 zwQ6v||3yO|N|wdih@>8!4ivX^&k=7HEi+6T8np`>`ZTp;No$*Fn%Z&DaLCYseWLyk zbNU~`ncW3%#|2?8aI#&C?8}CYl#+%%!3Zn&Mqrmno*w5!t{ndpza4ussDAb#px#Ld zbZxtzT05wtZtho-#Ty*;p?NN_FEft?A|R2J^9U%pp( z0ccO?Ncf$Pia8*s3gZ69(A*({GcWAz(30+eL)Jb2b;|@0vu*Qu38x*+;xTG^Dht4@ z%LGTbLP`L?p{T7is+}O}-cJovfcE%&fbg3rWBI~KSFq8ChlTZNBV{mCvWIC883`E#)@kl1oNzxz1fk%YBHEu&~@WY_s#8?>Ue2`2G3& zw|yQS?X&m$b$QepkG^IvMnzN zvrR3T2CcjQ5Rz80d%^vhM(plinP{}pYASfMSWdbuP}(rg$g>iy=#HnN@%MMQL`VU= z=sblf<^sc!4~SG=2eaCym#)MmT>(nyj=38$F!ryR6e_9sVlIU(Zv%8TlcvQcd;eXQ zeOA`Q@|3}`_t7z$DSNW>H()OBO!2$pYoEKdZmqFrE?vWebA*7es0eVZ@O*$mnj@g& z>g2YK0G^AEMS@ENcuT;`e#eGDHyYR#8oe_OE(M7PZ2z;S4)gZ_D=Xs2R|S8O z0*(uw6EN?0Syg+%9U114Ts8*%*DrPxkSa?&^qi-nXuVAy*&QDHmka3Q0HhFg+_xDF zp5H=w=IwIs5(k~yBBA1rx;Bf8+nPHxB@$WvYmJj+inLj80WjK^h~Ez2JF`>( z@?5j?7=?cRTeBC#F|ft7jT2+Tgqm!R@Ltxi*kayOCjUX8a;5-1VAZ}GjjZ8o-a<$K z?g8A{4h)_Q#KEfC)rMHIwIS0i?q$_y+bF@gB}$_b=w9`lo3hVTSXb6)CULa~ z>e>T@iJ*rtn3X5cZ$p{&aahc&=#zW|d%^uU+BVxB(Mw0~?&*Tnhq0z$mB(}vFnoml z1Sl`+@@fLR6X>SL@@A1N90#aV*AVH=)8H+jxq(Pj^&pg{ zUkxz#3UoL4wrCB2xmU1=mF$6p0>G&x@OsSOKlcR$J(OoL3H%>bo1u!}+ira-fv`J| zBPY06nk*msZ4;rhN5T70M6+uvP=d@ni_{B=Zj=P*mFiwR@T_C*$=`hdpg~tBJZMCY zXBnp1Ow_MeET%{djDMLA)ZdCmrNehQR&Lw#39168X(l@jU`65-17L{fi^K6ahroTy z{NM)0HYy!#-HbUo@(|3p(d?(z2)WrS`CtS}V*B{yzB1N|faaNH6L_-oI$OfF)?yiF z&Th>z;Er`MA6&qvT-OFL$LYDU=J@Nj;1d!jW1s#P?3qXBfbBurw{)`$knv+raRj_4JS~lpy&FB{?SoYhMu3@FNUV}b?6=3gj zKcKs^3NZe&2vQnjp#Kr}p*{nXAo^_+iko=EDlitbh3XIoI+&cmhD$S-nPZpNX=u`K z4mKnPS+;n_KgkLSLvj)w_pJ1Qg}nX;dqa)QWX*D#-kloEas-;ssM)Ay0xv6dUF$=- zX%MO*;kODWZs(-}BaSS`@q|(KqE;O2kmi}lVySAgb)ckSLQS6}f~J5!9C)LIgMr=^ zAY18&l!1@%r>FTq{D9*#s)Xw#&O{VH@3`gZigE(9pCYR!d+Q1)lGkT(*q5OCV8(HL zINHDeRUhHq>Qhy7cquZ$iar*M`nFiw`TB3q`O&%yl&g9Ami?7FG==MuodP_SBRg*t zg8y89gi&*wIkYg0oA6mb$VjgL6TYDkV=afD!P(W%l4oa9)Ff))VINf}Y2*4^8Ua1$ z#4I65@}Vx*gv6vyOiM810#4)J^!ChxTAS{z+d}k}^3S0O8nzNQdV3U-aCS+yy2)SK z?)RTlC~qA!Y=Q-e#n_PQR$uU^#Hby2OR#v$AC2WTe?+g*I08+*tu}u2{;$Zxo~ngs zR7dr-(kPSe>)r9+tL%}7Jr$7i`iq&A?#uI$^f1LY+MY|%viC48$Tv44oqw-;saN87CU;cE zcd*dqi{iEdt!3YCy-sH?9AD{8)y_@PQe83dO$}~vl+Xz8NIfCeX1CqG_&bX1l5Ty^PZaul;e}u+;rR8?=N0>}Oh( zbWg*`+Lqe)G&rj!S{?$DT6Qu*xAUEkLB0nJly6HsI+ z0V&BId1ur2as80}mD~)ku)A>Xabvr0ZB%D1?a7?>FBp^gNn%J@q-qH4Ce8r)Sp72g zyp{h(jd39jTkx0C_5?pRae!2=17(i@ZAc<}3gvG!`qVgpUk!xPhc74v&( z+nNo->b`X5VVy~1M#fO^{)c!`YkGmIc;7>egKo0?hIBRdb($zQwC7^^tR89Zc+K=| z6JK_i@HP4j7vQut4+gtKiE#qsl}{ucrYKPng`>6n>KQqH%1SAJm)>8vVAaJFu#aar z*&&|x)LNa24^Rz8936-pR;9LAKO~-Zz!J!&}BC&=e;%h zxu9h{)Imw|QEF3xU@-?`>+L;9t2vkL%LvI3g11sGOHU{QNli>duIEG|gJ(wzm#~Y2 zZy}R6Nc4~KwEjF_M0$7x8RxuMWvsUE)6cw=qmkpGEn-WE`NYfxvM$mkAB{NUViAd| zhLAUwJEktsSJ0>6B}uxk97dIDg3&e75}KxnIUk>8YlKgh$mKqYRg-uKV=$>_vVlYr z7{T5?9-f!Em_zhD$|OE&=Md?F$&07X&;}tcP~7*uw7g2)RpD*A@1#Ulzy@t_6u)$~ zh86|ot8f&*E%4%bz-erUz!wbE+gRfxtX<+!2WDMs8i6YnM6HAb+N(Te6u3AOj zT;g1Ecfh{Ig%N^4%$dIv^xy=m!Llr%VEquOL{i+FPCp;Ysnx+E)OVE9c36J&srJpu zMZb*i|MDQbp_J;dg)YMy32i9|YjF+@ab4=T5RM3KWpR2vAWn$DWp`L^!ilz?$jYjU zegT_I`yHP=32MYq+mEF>ZHKPpwRl|kO?pQP_?nSGI*d@_W}m7A0(UpuM$Z= zIpa=Os9jwg@=Aj^5+`Q=P#38YI&h-LhM!&Zkf=(|)1oxXt?d^$c3P`iP_mbV$bRli zI@q7`=>m!sYW{|vM-~qd)8JPs{J&5(>97N1)RJU)+pJb40U z)hbNg^zt+h@6P;nDYN9_T`Qvy&%8nBfLp}hU6q#mq@8O$jHQSkR$kfHo>ii&j;&O6 zx)Eo1JtDlEVT~}as;~+8lD87Nz&1o6?{G@kA+&F8o~ro%zkPS^n#n?|_xX-V?^wd6 z@p*}!!4)I+>BJ*d<-E+P3#yBM-9_Do-9L5eCd#jFkJUH${Al4)ui97c-Y=>e#m*^} zt1V2Baed8XIt@1cjkQ2nO#@81^(7sP2Txyj{q%Ehc@4{e($Ri#JDmm+Tj)Hd{ z^u@Eu#6pZ+Z(VS0o|axe20B1Vy#7@=dO$$=143jnrZ;`U@zObr+%|m4#Lib!bq>)( zbpEs#Px9s;^E&Pman0^$W#8l-UfouI*g5DK#phq?_s(OS4E z`=P6X$ZL^*-;tmFoX#Eej`6;K(mn<``$fg|M^^gJ{qL2}btJfJ#jBRShu3xpm!=6< zeT&H$)<{`(?>9XEP&MSVY`&SHUfp>EYQD*XKmIYEsH25cXE*qCg}oEm!>j?Nr!A9wnxTK-tJZH2igaKK5rJYvPaF3g z87>)TngcOsW^9Kt;nYYN6YQwoH|yVF|IAY6v9Q<&e|5h1l^qdcjT1ix+7VyL2?yrg zXsx-O30Ha^lafY+4z${4(yl9NxVX#&kC{g#L5~xs1|t8dc;ZpN-frz`)+ax5O6y^y zbW?(kUXk_=)IlJ-$}IWkm-rhJ5)oI7&lRd3yQan+I`~>r%$ig5#?8)> zI*GK2q3`o&aV`t8qj}$|zo|uXI%8m_^+!oh`1Su%f?5c|&OK8mnCUy8bMKq?`J2}c zlO9BVQZxOknOfjV&$kJryC+I|@@QpQ`SvcT5LYb|E=HGc%3cfUGNSlI@_kHjiWm4@ z+MaAT?zHsS^k|AUXKaa!jBNXjmRVxrU8!I1Fu6VOB1yPfq)wB7R_bS8BZ=Xt^~eMb zwGmGt$jm*6xj>LST*L1Y?4R((1o-0c*%%ttPbj;`q!s??2!=5CwT*tlRnIlDIo+oy z-`uU`TU=vhoDLV+I*j9G-S{-$#^D;$IY9&;vizqR!p_}lU^hecdl07V(&u~Z6jegh z*dy3QxVwZqiBf?KSs8OS#O0~ZQ6B^x_bxC?8k-Prefvx2fdy}DZ+eZD(VEAfQW34l z7>6F+v7oI5FU9sBbaCr~lkig!im>^k{dQU#!H62!YHAE3);eb-%|$9#g6}Fs%*#Xh zv&@!XdB-_&NZ&l=TT1T_zN#PZyNgs)8Sw_)<O zq>R5PTGp$!WO;>JpgdZStXg{UZMHa|TW`dlht959$^7Jk^!A_E^sLF@y#S-Ro}KT| z_1zPVG4930-IH4fp{u%X71JjEkMkE*3S-u|tDbAy*Nr|e5WwuK8jCvPnBgxr6Zj?> zab5{Aaf`T$@KShW_^foyte-blIkrvc<>Ctx!b7QhTF-5^L5cs*C(RR7m^0acAb25| zXt4pei0}Jg>uo7@9Q|Yhr{`dp#+>%_+d`o<1p z#YQ?BanTtEVL1o$%knqPAZ{BT0cJ%w-jW7u*e1(|VfMbE`B-52MdP zWF*WVd?duk6N;(0GM5_Cmiy3--#!u{<*{r2pzjG6yA&@JCf^J#Xq%EHM>evtkEbe) zaiTQ!`}Vvr{&_{EH0Z<9`HEn1x01l&jgKEQgmKE*gS3OwK3cMNd_Mmno2!l$d7^lrt?p8f>&?FF=vf~-wr=s7LZ2@Zda z#IaX3yfo?B>IO)Fm(JWz2&UW5btj8RFrCy+caW zt|)5lo$Qva&Id}sb#G3ZaLBz@e9Q6sRQ=_?ZsbG8)^|wQ@#IhN)};?YMIf+MwjtUL zzsIZIpx1j!I3^6v6Tpqlw(39by@D{H2Udc}R)Ozu1C23CH;>AZpqetB6EMDwMgiED z{%&80+hn6;|A9(fn~-Bp&WAqZyFk(I>CvD_$x|48@newBclP7}y^uFCX zeOc?ABs%frapd;5sFz-yT=SuRiavq){`Y@~W&Bg!ZCm|^SYTX!6&{oozxp_IvXWfj zoCx!*68%)oubOD-<}1vyHh@wuT>DsYp3L8`X^XpZ-@nYDV_xDQ&W1WAa!r!-d2yyQ z*4V`{|TAj?4EM5n?*PO?IaoF{e(Yi10C?Vq!taiM+KVgDz#8Yd^0n0B6 z>Ev(W)J4X7eKMu`rX|7~5~Mp+aoE^Q_UG2WYZElha} zLSq&_hdIpgG?n~wBj{yc@4u1aG^)k()~-|7rC*2gisa;%tTieP=NpQbyb3yd$FAQa zDEM^gJ`prdd%LQbs7oT=ujCH-UNuf{f-v-|%X)t5+hwrE_-&3$r1ba+2*WxejY^|Gx+AEB2n1bfLSc&z`fH9PR_L3Aa?`kT}xg?6`$<`|uFDYu!;Q&t~ zkfj+(oj|*jp++7hdAV42Y z8ABQ8Za?VwimGcXv2rU4l4T@GW%cXAzG|m2oL+nnq)-^@N3~D%d)o8#g;W#_jF#vI zODz8RToVRCs2iIy9)9Vwtr%TJXew%Q^(sXMhD<$$ZtL%KA3|XQYP~)!hd;s&<22Ha ztp?eqb>yxU>yTjPhj~(JADJ5Yzg~)OYv}m8)N^5M45XH&>-~U-#(O!tl^gY(7&~&4 zX$g5xWu`Q=C&jwdRufx@XYhI5@YJazwm3<*2x}9HqXK5lz2$MxwQ*Zb$Y<`F5Z8c_ zsqcEPoQukIBLbG0bhFEk%KmIr@ua4>WA9wZTryLrnIj8?+oBR23y$AEFU}B%Ky6M2 zC};g_T5@7YG6mW@{_q`mSxZa+!5Ua0^Wtz?prN?*HY2%0`rOkG-;(1j%I#+B4j^=N zJuChuBh)t3(m1vh>NCm5fC`P0j#qZ`I$$HFUQ|(s@^s1W*L@?PUVTFAuEgi*v8IF^ zw+Y6mjsvPTY$s+`C`CwXF7ZP~u=Eu%a&w6s zVdbb_Mq5M10A(K^*}`d|w02 zLFEVit}F8>+c@K=Y(cdxSZ8u|ZGM&b+NQNW>*UZblI)X4a-KK;f<$w9_~##Ep4tn& zFcnHX&Qk3g9U1@YURbWJxb8VGo%F#RQgZ9&c7ULO!2W)RLvrcFA-Hpw#QcwmR@$FZ zVZZS`JOroq3DokB!qWSQ^%+H+G3W3sY;s?VMI;ZoZs^b-4VR66t7Fxu< zS7~5Hc!BYfVGDaVg#Y^jZAYvuDA?4r;#8!_54!kYStKI@>UHSlCmDHikCa&QEycye z6_j_r#dpl={|tk51!1s%GinSO5<0k(3srkv!b0#P7ax?5X^Bg39lxnwee`UeGxU{c z*06ZZFEn(9W!% - dplyr::mutate( - delta_pct = round(100 * (kosten_simultan - kosten_bisektion) / - kosten_bisektion, 1) - ) %>% - dplyr::arrange(site, storage_type, x) - -knitr::kable( - vergleich, digits = 0, - caption = paste("Gegenprobe Bisektion vs. simultane Suche:", - "delta_pct < 0 heisst, die simultane Suche hat ein", - "guenstigeres Design gefunden") -) - -readr::write_csv(nm_all, "optimisation_results_simultaneous_all_sites.csv") -``` - -```{r nm_runtime, echo = FALSE, results = 'asis', eval = can_run} -nm_stats <- unique(nm_all[, c("site", "storage_type", "n_runs_task", - "minutes_task")]) -nm_wall_min <- as.numeric(difftime(t_nm_end, t_nm_start, units = "mins")) -cat(sprintf(paste0( - "**Laufzeit simultane Optimierung:** %d Engine-Läufe · Summe der ", - "Task-Zeiten %.1f min · tatsächliche Laufzeit %.1f min (Bisektion ", - "zum Vergleich: %d Läufe).\n"), - sum(nm_stats$n_runs_task), sum(nm_stats$minutes_task), nm_wall_min, - sum(task_stats$n_runs_task) -)) -``` - ## Monte-Carlo-Analyse: Wie robust ist die Suche selbst? Die Bisektion ist deterministisch: gleiche Eingaben, gleicher Pfad, @@ -612,10 +480,10 @@ cat(sprintf(paste0( ```{r vignette_runtime, echo = FALSE, results = 'asis', eval = can_run} cat(sprintf(paste0( "---\n\n**Gesamtlaufzeit dieser Vignette:** %.1f Minuten ", - "(Optimierung %.1f min · simultane Gegenprobe %.1f min · ", - "Such-Monte-Carlo %.1f min · Rest: Setup und Rendern).\n"), + "(Optimierung %.1f min · Such-Monte-Carlo %.1f min · ", + "Rest: Setup und Rendern).\n"), as.numeric(difftime(Sys.time(), t_vignette_start, units = "mins")), - opt_wall_min, nm_wall_min, + opt_wall_min, as.numeric(difftime(t_mc_end, t_mc_start, units = "mins")) )) ``` diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd new file mode 100644 index 0000000..83e0deb --- /dev/null +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -0,0 +1,425 @@ +--- +title: "Workflow Optimierung — Simultane Suche (alle Parameter gleichzeitig)" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Workflow Optimierung — Simultane Suche (alle Parameter gleichzeitig)} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE, eval = TRUE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>", + fig.width = 7.5, + fig.height = 3.2 +) +is_ghactions <- tolower(Sys.getenv("GITHUB_ACTIONS")) == "true" || + tolower(Sys.getenv("CI")) %in% c("true", "1", "yes") + +# extdata robust aufloesen: zuerst installiertes Paket, sonst Quellbaum +# (Knit direkt im Repo, auch ohne installiertes kwb.raindrop) +extdata_path <- function(...) { + p <- system.file("extdata", ..., package = "kwb.raindrop") + if (nzchar(p)) return(p) + src <- file.path("..", "inst", "extdata", ...) + if (file.exists(src)) normalizePath(src) else "" +} + +path_base <- extdata_path("models", "eisenstadt-2005", "base.h5") +data_available <- nzchar(path_base) && file.exists(path_base) +is_windows <- Sys.info()[["sysname"]] == "Windows" +can_run <- data_available && is_windows && !is_ghactions + +t_vignette_start <- Sys.time() +``` + +## Ziel + +Die Vignette `workflow_optimisation` findet die günstigste +Muldenkonfiguration je Überlaufziel per **Bisektion**: Parameter +nacheinander, gestützt auf die Monotonie je Parameter +(`monotonicity_analysis`). Diese Vignette ist die **unabhängige +Gegenprobe**: `optimise_swale_design_simultaneous()` optimiert **alle +Parameter gleichzeitig** — Fläche, Muldentiefe und Speicherhöhe in einem +Zug — und kommt dabei *ohne* die Monotonie-Annahme aus. + +Warum das funktioniert: Unzulässige Designs (`n_overflows > x`) werden +nicht ausgeschlossen, sondern **bestraft** — jedes unzulässige Design ist +teurer als jedes zulässige, und überzählige Überlaufereignisse staffeln +die Strafe. Das Optimum liegt (Kosten steigen monoton mit jedem +Parameter) genau *auf* der Zulässigkeitsgrenze; die Straffunktion erlaubt +der Suche, diese Grenze zu überqueren, auf beiden Seiten Information zu +sammeln und die Parameter in einem einzigen Schritt gegeneinander zu +tauschen (z. B. weniger Fläche gegen mehr Speicher). Ein Ausschluss +unzulässiger Punkte würde der Suche jenseits der Grenze jede +Richtungsinformation nehmen — sie würde blind an der Grenze abprallen, +statt an ihr entlangzuwandern. + +Drei Suchverfahren teilen sich dieselbe Infrastruktur (Straf-Ziel, +Evaluations-Cache, Toleranz-Rasterung, Multi-Tal-Feinschliff) und +unterscheiden sich nur darin, wie sie Kandidaten vorschlagen +(`method`-Argument): + +* **`nelder_mead`** (Default, Empfehlung): Multistart-Simplex + (`stats::optim()`) — Warmstart, Optimum des vorigen x-Ziels, je ein + Anker-Start pro Speicherstufe, Raumfüller; jeder Start erhält einen + gleichen Anteil am Laufbudget (`max_evals`). +* **`diff_evolution`**: kompakte Differential Evolution (DE/rand/1/bin) + — Vergleichsverfahren; deterministisch über einen internen + Park-Miller-Generator (`seed`-Argument), Rs globaler Zufallsstrom + (`.Random.seed`) bleibt unangetastet. +* **`halton_search`**: quasi-zufällige, raumfüllende Halton-Stichprobe — + bewusst naive Baseline, die zeigt, was die strukturierten Verfahren + schlagen müssen. + +**Laufzeit:** Die simultane Suche braucht je (Speichertyp, x)-Zelle mehr +Engine-Läufe als die Bisektion (typisch 60–120 statt ~15; Suchphase plus +Feinschliff). Bei ~15 s je Lauf (Wien / Bad Aussee) kann der längste +Einzeltask des Nelder-Mead-Sweeps ~1.5–2.5 h dauern; Eisenstadt (~2 s je +Lauf) bleibt bei Minuten. Der Methodenvergleich am Ende rechnet deshalb +nur eine Zelle (x = 1) je Standort und Speichertyp. + +```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} +cat(sprintf(paste0( + "> **Hinweis:** Die Rechen-Chunks wurden übersprungen. Prüfungen: ", + "Windows: %s · CI/GitHub Actions: %s · base.h5 gefunden: %s (%s). ", + "Auf einem lokalen Windows-Rechner sollten alle drei Bedingungen ", + "erfüllt sein — falls base.h5 fehlt: Vignette aus dem Paket-Repo ", + "heraus rendern oder das Paket installieren.\n"), + is_windows, is_ghactions, data_available, + if (nzchar(path_base)) path_base else "weder installiert noch ../inst/extdata" +)) +``` + +## Standort-Konfiguration + +Identisch mit der Vignette `workflow_optimisation` (gleiche Standorte, +gleiche Suchräume, gleiche Kostensätze — nur so ist der Vergleich +aussagekräftig): + +```{r site_config, eval = can_run} +# Im Quellbaum die Entwicklungsversion laden (immer aktuell, auch wenn +# das installierte Paket aelter ist); ausserhalb: installiertes Paket. +if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) +} else { + library(kwb.raindrop) +} + +sites <- list( + Eisenstadt_2005 = list(dir = "eisenstadt-2005", timeseries = FALSE, + prior = "simulation_results_optimisation_Eisenstadt_2005.csv"), + Wien = list(dir = "wien", timeseries = TRUE, + prior = "simulation_results_optimisation_Wien.csv"), + BadAussee = list(dir = "badaussee", timeseries = TRUE, + prior = "simulation_results_optimisation_BadAussee.csv") +) + +fixed <- list(connected_area = 1000, + filter_height = 300, + filter_hydraulicconductivity = 360, # Rastermaximum, gratis + bottom_hydraulicconductivity = 12) + +area_bounds <- c(25, 200) # Muldenflaeche [m2], stufenlos +area_tol <- 2 # Aufloesung der Flaechensuche [m2] +height_bounds <- c(100, 300) # Muldentiefe [mm], stufenlos +height_tol <- 10 # Aufloesung der Tiefensuche [mm] +storage_spec <- default_storage_spec() +cost_rates <- default_cost_rates() + +make_path_list <- function(modelname, model_dir) { + list( + modelname = modelname, + root_path = file.path(tempdir(), paste0("raindrop_sim_", model_dir)), + dir_input = "/models//input", + dir_output = "/models//output", + dir_target_output = "/", + file_errors_hdf5 = "Fehlerprotokoll.h5", + file_results_hdf5_element = "Mulde_Rigole.h5", + file_results_hdf5_flaeche = "Dach.h5", + file_results_hdf5_verschaltungen = "_Verschaltungen.h5", + file_results_txt = "Mulde_Rigole_RAINDROP.txt", + file_results_txt_multilayer = "Mulde_Rigole_RAINDROP_multi_layer.txt", + file_target = ".h5", + path_base = extdata_path("models", model_dir, "base.h5"), + path_exe = download_engine(), + path_errors_hdf5 = "/", + path_results_hdf5_element = "/", + path_results_hdf5_flaeche = "/", + path_results_hdf5_verschaltungen = "/", + path_results_txt = "/", + path_results_txt_multilayer = "/", + path_target_input = "/" + ) +} + +# Ein Task = eine komplette Optimierung (Standort x Speichertyp x +# Methode); gekapselt, damit Haupt-Sweep und Methodenvergleich denselben +# Code nutzen +run_simultaneous_task <- function(site, type, method, x_targets, + model_suffix) { + if (file.exists("../DESCRIPTION") && + requireNamespace("pkgload", quietly = TRUE)) { + pkgload::load_all("..", quiet = TRUE) + } else { + library(kwb.raindrop) + } + + cfg <- sites[[site]] + ts <- if (cfg$timeseries) { + read_site_timeseries( + extdata_path("models", cfg$dir, "rain.csv.gz"), + extdata_path("models", cfg$dir, "et.csv"), + verbose = FALSE + ) + } else { + NULL + } + + run_fn <- make_swale_runner( + make_path_list(paste0(site, "_", model_suffix), cfg$dir), + timeseries_rain = ts$rain, + timeseries_et = ts$et + ) + + prior <- if (file.exists(cfg$prior)) { + readr::read_csv(cfg$prior, show_col_types = FALSE) + } else { + NULL + } + + t0 <- Sys.time() + opt <- optimise_swale_design_simultaneous( + run_fn, x_targets = x_targets, + area_bounds = area_bounds, area_tol = area_tol, + height_bounds = height_bounds, height_tol = height_tol, + storage_spec = storage_spec[type], + fixed = fixed, + prior_results = prior, + method = method, + cost_rates = cost_rates, + verbose = FALSE + ) + opt$site <- site + opt$n_runs_task <- attr(opt, "n_runs_total") + opt$minutes_task <- round(as.numeric( + difftime(Sys.time(), t0, units = "mins")), 1) + opt +} +``` + +## Simultane Optimierung aller Standorte (Nelder-Mead, parallel) + +Wie im Bisektions-Workflow laufen **Standort × Speichertyp = 6 +unabhängige Tasks** parallel; innerhalb eines Tasks teilen sich die +x-Ziele den Evaluations-Cache. + +```{r optimise_all, eval = can_run} +t_nm_start <- Sys.time() + +tasks <- expand.grid(site = names(sites), type = names(storage_spec), + stringsAsFactors = FALSE) + +future::plan(future::multisession, + workers = min(nrow(tasks), + max(1, parallel::detectCores() - 1))) + +nm_list <- future.apply::future_lapply(seq_len(nrow(tasks)), function(i) { + run_simultaneous_task(tasks$site[i], tasks$type[i], + method = "nelder_mead", x_targets = 0:5, + model_suffix = "NM") +}, future.seed = TRUE) + +future::plan(future::sequential) +nm_all <- dplyr::bind_rows(nm_list) + +t_nm_end <- Sys.time() +``` + +## Ergebnis: günstigstes Design je Standort und Überlaufziel + +```{r results_table, eval = can_run} +knitr::kable( + nm_all[, c("site", "x", "storage_type", "status", "mulde_area", + "mulde_height", "storage_height", "n_overflows", + "overflow_volume_m3", "et_pct", "cost_total")], + digits = c(NA, 0, NA, NA, 1, 0, 0, 0, 1, 1, 0) +) +``` + +```{r cost_curves, eval = can_run, fig.height = 3.4} +library(ggplot2) + +ok <- nm_all[nm_all$status == "ok", ] +ggplot(ok, aes(x, cost_total / 1000, colour = storage_type)) + + geom_line() + + geom_point(size = 2) + + facet_wrap(~ site, scales = "free_y") + + scale_x_continuous(breaks = 0:5) + + labs(title = "Kosten-Wirksamkeits-Kurven (simultane Suche, Nelder-Mead)", + x = "Ueberlaufziel x (zulaessige Ereignisse)", + y = "Kosten Optimum [Tsd. EUR]", + colour = "Speichertyp", + caption = cost_rates_caption("de", cost_rates)) + + theme_bw() +``` + +```{r export, eval = can_run} +readr::write_csv(nm_all, "optimisation_results_simultaneous_all_sites.csv") + +nm_stats <- unique(nm_all[, c("site", "storage_type", "n_runs_task", + "minutes_task")]) +knitr::kable( + nm_stats, + col.names = c("Standort", "Speichertyp", "Engine-Laeufe", "Minuten") +) +``` + +## Gegenprobe: Vergleich mit der Bisektion + +Liegt der Export der Bisektions-Vignette +(`optimisation_results_all_sites.csv`) neben dieser Vignette, werden +beide Optima Zelle für Zelle verglichen. Beide Verfahren müssen — bis +auf die Suchtoleranzen, also wenige Prozent — auf dieselben Kosten +kommen. Fände die simultane Suche *systematisch günstigere* Designs, +wäre das ein Hinweis auf Parameter-Wechselwirkungen, die die +Koordinatensuche nicht sieht (und ein Fall für die Monotonie-Analyse); +fände sie nur teurere, hat der Simplex sein Laufbudget nicht +ausgeschöpft oder klemmt in einem lokalen Tal (`n_starts` / `max_evals` +erhöhen). + +```{r bisection_available, echo = FALSE, eval = can_run} +has_bisection <- file.exists("optimisation_results_all_sites.csv") +``` + +```{r bisection_note, echo = FALSE, results = 'asis', eval = can_run && !has_bisection} +cat(paste0( + "> **Hinweis:** `optimisation_results_all_sites.csv` nicht gefunden — ", + "zuerst die Vignette `workflow_optimisation` rendern, dann liefert ", + "dieser Abschnitt den Zellenvergleich.\n" +)) +``` + +```{r compare_bisection, eval = can_run && has_bisection} +bisect_all <- readr::read_csv("optimisation_results_all_sites.csv", + show_col_types = FALSE) + +vergleich <- dplyr::full_join( + dplyr::select(bisect_all, site, storage_type, x, + status_bisektion = status, kosten_bisektion = cost_total), + dplyr::select(nm_all, site, storage_type, x, + status_simultan = status, kosten_simultan = cost_total), + by = c("site", "storage_type", "x") +) %>% + dplyr::mutate( + delta_pct = round(100 * (kosten_simultan - kosten_bisektion) / + kosten_bisektion, 1) + ) %>% + dplyr::arrange(site, storage_type, x) + +knitr::kable( + vergleich, digits = 0, + caption = paste("Gegenprobe Bisektion vs. simultane Suche:", + "delta_pct < 0 heisst, die simultane Suche hat ein", + "guenstigeres Design gefunden") +) +``` + +## Alternative Optimierer im Vergleich + +Dieselbe Zelle (x = 1, beide Speichertypen, alle Standorte), drei +Suchverfahren: Nelder-Mead (aus dem Haupt-Sweep oben), Differential +Evolution und die Halton-Baseline. Erwartung: Nelder-Mead und DE liegen +innerhalb weniger Prozent beieinander; die naive Halton-Stichprobe +bleibt trotz des gemeinsamen Feinschliffs messbar dahinter — der +Abstand zeigt, wie viel die strukturierte Suche beiträgt. Parallelisiert +über **Standort × Speichertyp × Methode = 12 Tasks**. + +```{r compare_methods_run, eval = can_run} +t_cmp_start <- Sys.time() + +method_tasks <- expand.grid(site = names(sites), + type = names(storage_spec), + method = c("diff_evolution", "halton_search"), + stringsAsFactors = FALSE) + +future::plan(future::multisession, + workers = min(nrow(method_tasks), + max(1, parallel::detectCores() - 1))) + +cmp_list <- future.apply::future_lapply(seq_len(nrow(method_tasks)), + function(i) { + run_simultaneous_task(method_tasks$site[i], method_tasks$type[i], + method = method_tasks$method[i], x_targets = 1, + model_suffix = toupper(substr( + method_tasks$method[i], 1, 2))) +}, future.seed = TRUE) + +future::plan(future::sequential) + +methoden <- dplyr::bind_rows( + dplyr::filter(nm_all, x == 1), + dplyr::bind_rows(cmp_list) +) + +t_cmp_end <- Sys.time() +``` + +```{r compare_methods_table, eval = can_run} +methoden_breit <- methoden %>% + dplyr::select(site, storage_type, method, cost_total, n_runs_new) %>% + tidyr::pivot_wider(names_from = method, + values_from = c(cost_total, n_runs_new)) + +knitr::kable( + methoden_breit, digits = 0, + caption = paste("Methodenvergleich bei x = 1: Kosten des Optimums und", + "frische Engine-Laeufe der Zelle je Suchverfahren.", + "Der Nelder-Mead-Wert stammt aus dem Haupt-Sweep", + "(profitiert dort vom Cache der uebrigen x-Ziele).") +) +``` + +```{r compare_methods_plot, eval = can_run, fig.height = 3.4} +ggplot(methoden[methoden$status == "ok", ], + aes(method, cost_total / 1000, fill = storage_type)) + + geom_col(position = "dodge") + + facet_wrap(~ site, scales = "free_y") + + labs(title = "Kosten des gefundenen Optimums je Suchverfahren (x = 1)", + x = "Suchverfahren", + y = "Kosten Optimum [Tsd. EUR]", + fill = "Speichertyp", + caption = cost_rates_caption("de", cost_rates)) + + theme_bw() + + theme(axis.text.x = element_text(angle = 20, hjust = 1)) +``` + +## Einordnung + +- **Konsistenz:** Bisektion und simultane Suche bestätigen sich + gegenseitig, wenn ihre Kosten je Zelle nur um wenige Prozent + differieren — dann ist das Optimum eine Eigenschaft des Problems, + nicht des Suchwegs. +- **`monotonicity_warning = TRUE`** heißt hier: Unter den Evaluationen + der Zelle liegt ein *strikt größeres* Design mit mehr Überläufen + *und* mehr Überlaufvolumen — echte Nicht-Monotonie; dann verdient die + Zelle einen Blick in das `"evaluations"`-Attribut. +- **Methodenwahl:** `nelder_mead` bleibt die Empfehlung (beste + Präzision je Engine-Lauf). `diff_evolution` ist die Absicherung gegen + Simplex-Artefakte, `halton_search` die Messlatte von unten. +- **Budget:** `max_evals` begrenzt die Suchphase je Zelle; der + Feinschliff (Multi-Tal-Musterabstieg) kommt obendrauf. Wer Laufzeit + sparen muss, reduziert zuerst `x_targets`, dann `max_evals`. + +```{r vignette_runtime, echo = FALSE, results = 'asis', eval = can_run} +cat(sprintf(paste0( + "---\n\n**Gesamtlaufzeit dieser Vignette:** %.1f Minuten ", + "(Nelder-Mead-Sweep %.1f min · Methodenvergleich %.1f min · ", + "Rest: Setup und Rendern).\n"), + as.numeric(difftime(Sys.time(), t_vignette_start, units = "mins")), + as.numeric(difftime(t_nm_end, t_nm_start, units = "mins")), + as.numeric(difftime(t_cmp_end, t_cmp_start, units = "mins")) +)) +``` From 99dd686af9048a2d0a1c0c8c0dd6387532ee2633 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 10:26:00 +0000 Subject: [PATCH 19/34] Remove accidentally committed testthat run artifact Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- .gitignore | 1 + tests/testthat/testthat-problems.rds | Bin 25670 -> 0 bytes 2 files changed, 1 insertion(+) delete mode 100644 tests/testthat/testthat-problems.rds diff --git a/.gitignore b/.gitignore index e07bfe6..da55509 100644 --- a/.gitignore +++ b/.gitignore @@ -23,3 +23,4 @@ vignettes/monotonicity_analysis/ # Deploy-Ordner der Vergleichs-Praesentation Optimierer vs. Brute-Force # (handgeschriebenes index.html, liegt auch als claude.ai-Artefakt vor) vignettes/optimiser_vs_bruteforce/ +tests/testthat/testthat-problems.rds diff --git a/tests/testthat/testthat-problems.rds b/tests/testthat/testthat-problems.rds deleted file mode 100644 index 6870cc70d294783d47a0339c12025cbd2fd85934..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 25670 zcmX_ndpuMBAHSLV{gNcK$`E1|lEMhNRnt`=>rNy^LS{o3qNqu7ov0{@$|aFaDoI&F za;eRA!ffuFUC!@)KHuN(*B?D-l^hRH~fBe}9ndIC(FYMoRLTF zbgaPWT<+sNKhdE-t^fUfT_x@N>w$(*Ywqds(?;KZD&O04W#3Vk75BSwh|E2w)q7o~ z)m^%<6vfoiWQF9!A~`6+i1p3RGJ;{{cdo5ROiVJirRPP^-!Ba;#2M>xuGIPed-?6Q zlFwBc(fDdt@>uwpO=mM!xRU6XN7bh%W_eM2RBs@ia7lj#&c*K7-h7zfTJY=Q$Kf4y zA7*7gJgEJ?nDoAU4Mj`k2zxQDE4_b5J^NSXpDW?6)%~GIgB!p29yxI8d-=0VEm)^_ z@2>vZ=Xhg$qbJ+D(|{58vE=aq}?HTve=PU$_2l}eZC^8Jr4ZdhhqEHR#9V%k^>{p&9AE%#ZN zR{vT)9~M%g|9WS=aB%OADdm~4%)>tMzLt(gzt+|FB^D&p>&wl4oD~p$sZ@l_*g*VQBRY(h;U4L!9lBz!+Gv!_%S{+Mp=nspGX+E5*ze3f_ zv;2;FeWYJWi*`+I%scz~_b1ZzYkckh94@ZDx!YuINXel_hoRKP@;wD-{oG^{6TIoh zQ7I+PUgdlKbo5E>Kwc?1wl7rwLagXlFiE!ieQ?ZU`&H*k(2qQ?967Y-uh=7^Vlp*T`D_3AuiP4i zNh|)v;xmy;U6#vrzrrghKTY)Jxh1)Nk~^N=2!5{p%g0yWiGHQONAD?l!|`A3g1%)MMD=^2OyFzcDw8pC1yid)o>(#8X|Fx0db=qvX!fsG=OTpQ;zz2TIID@~h zT^%Y6HZ_#>|9#h;bH?yrtlhb{n!nwuZt5Mxr5=gc=FWFqL!z;iZ?w7Y>pt+3YU`-{ zcUo~uZXfb;%#{Z{2Yu&5)*e|C>2u=H(FilsPo?i#HmvyPxyjElg0|6m`j%vQ&ea#^ zDSup_9f=!A8SC!1|AUxNCzbY_i8MmRebM&A=Fd;viwlag+&Foezj+Vo;yEbdbyaLs zU+BQfj_tKFLh<-WSEuWp!=ZbWdoq50Pzf%vn$3H%xyR20n(y55+OPGT-}No0cNnkM zvH5tL^<;Ie)Q3UGtl~?d$6WWD2l?mR{Jy@-;H1FWYL&CqjU)929j{pILW+-TiE5j3 zb9H{wv8?J2XVg!VQ!$s77T%t#&Ml6>JvKXm?vN|1+BRrfo}c;PY~Pi1%t`0v^y(mH zbnzXp2nR!7Yv_5*q4w$oMyv8Tv(gx$K zTd)2Z_~xCMJ+d-?dwlmTq*2Q6Z+F!qh8lisu%2~eJ-WyLbho)6!uDFEkJ7K+F@!%1s9eVQ1Z8myu zE*uLlHdfhXni{3{O1{?Gu`ROd6Y|&}tBpCuDQg%r`?L>T=B#6@QH;Ma)awnMeH zdUCM@t-Ui(cdyTlPPi~u?iADd^zrD+{2H~Y#G06$zXnJ877y&}cy*BYLVqgxf^t!t z^=(E9`Ri}qBlVr^?~xw9-KPzQ>mI*rdf9WeW4(H^i{Hn$_@K1%&k63OfpVPlDzSZD-yV!-P;nt>8mi0xR~do%5HVm*XvGdPYN^oakt1)|~IWn67ik_wcjoqb04O zH8y(v0j_=LvId9EJ(KkRxbug%KCQf1{&*y?yFF#ZRO>*ebmHNWlawp@3za0+UF1Qo~4w}3})s03;nyeIQ#3D!rmF*`rs2c9-aA#!}Y$T z5p)=Bb8E2t${#yX^W1ZZSHv^db|$ax>ffAvG~A;4Q0_4LT#ojn>9FQ`=udEFVI_tmyX7nFXeP8%t--(i~qm|W(=|TrqD4tR4|CzlL zGJYYR8qf>e_*^UhWYS3kTbF9zUW`qL%G1u1$tOpmi>RvSkmr`@H$>;$S$5m68o$US zOvuR+uKXBg>|b7WKHn(>po+@Q$ll+SpA`+Xu`}j7`r@O(QUCy7Gg6@9ZV~msy^D<1u?&+6(0?sqC;<{XvPhc(M@+eHDi}#3y^govn9qEN+Gy zc<&BNnSn#2)#H{(EHCp<9-XJTnjFOCGp|FB=Av^K-n~)@AXW zj$7r&VtwywV{yv13+(*ZYGQ?Mg~x@V8h`RUj8{u>#M z2Ym_bALqkVdFwlJua#a!gc=pK=Q`IIuX^uVQJ#i1%|`o}9wShOmM-@`nhjcaG3oUK z-B>k)qD)TPT`^HXJS76j9WR~pxrcHmG*s?z6WaIH{pPGz=}VcV?pMi z7)>>8Ar?-*x*nT4QYO2XJpRX=LtzJHd?G#(xkc3{z5CU6X_e zJ&P@Vr6q>i7E^4*&JWM7=a@fh4v~#EvQ;|EXLp$CRP5-4VG^wQ5JZb{OZ4(_H6v44%JkK9y&C0VRON{C-$zV>5KuW9!m3Xy__!Lb8Hqle2?ey+ppW|b9~9gK57 zw3+rP<>ZChD5dRXg6bz$=QliCJKZEjao!AV95%=%^%PFlHez2*JxW|a*1Ix`pS;hf z4|E*pxf|fRaqI4yo7xx5l*76|T$As-_OdkVy4$g-54;y4H73V%RL6e)+SDo+nB28= z%<{0n@7OKOkFg&Y7i6#Sj*Z!ze)Im3wLNFzU2)$U5Ane@hHBVF_QcaIH#ff$k}6`( zv$36&J;cG9Za2%c>vvzS(~J4|)Hyw@d-(E|d7tPrJu{I^f8w2osy96%pI;;jwyrBL zv&m8Xmx`9!zv}y_@}f!{3C*?e^oIc;IUP@bCxTU=nI?YRw_l ztb&h$3Y2wr!wSrZ>+}@`Gv3TU9|Gm+Z&i3Z2jAQX)UzO@Sqa=b($(}#8vHI}bf@?X z_1UANZi;&~Vu`Qv7;+?!`3yv_Pu=egSl3FIsS?dJMB|FP?3nAfrHL|Y=SuF~Hs&kW z7FUJtZHOpdplq1o(xnq`c#~dwmAFXgXGoM-Y-*RgmO+^ z!mL*M*DQ%G*o?|mynl&jJ_NP~dMP(Nz$+|{#_N%ufIE6sB8JRliHO3_J_zCZCPOup zATN|@-Pn7aAy>-ZcP@yrt1{4{j&v_DZO+&yde?W9xUOIXy5)fK7Stkml1=I_qlt7` zBD(N1Rf5+MpTih1!W!S&+n#6(eh}ejeJj9qILhnTdzsjBk|tL=(SQc+Cyy4PS!G)ha?$Ws#gteP^uW*?DXL{a!M8ZrGs<1afU{g2)_#Tv~n>S^qrp;P=O zC$htiVwJonqvTo#Wn%AeyqQUgd!?Wxohjo)`-spYiW2<06`BtCx5CHbUdQmq<8BIH zYw!J3cyilZCe|EsXM(AhfZXn#*ATflhN1!F5SOuJP;8~%$FlPId1-ue#R=bQN_ETh1N)K3TO+HA--g8;gViA z5p{mYu5BER-%hQ1dvz8ynZ9_wjGq<4?DwCU$v}!T1NXKBCL{!^uqdYs>L{t956m27 zgG6y?BKO$ZqB%e9)+=EBmXO%p7gz99@8+2}BZGz7WdGpGo>`1!ql+4=CDp@1Jx-@Ejf2|(X3$G%bXc5TXXc7Wd=Zzq zTOf&B3u`!|XrEQl3nb~^K9a#gicJ-!5C6}T4S6!NJB80ByTtXr(F3s|#PA*dvcgr4 z-x-q$DC1;)B(n96Ou+D|X<`QsjCs_ESt7SL;?vw@85*zoUb>XOfJHB@o~jmBAn;11 zGo<{Hv&f1?n`?3M;Fjhzoc8?%n;a@*eciG7Hxky=3kLieut-#Wo~Pp-NQJyZxuK6C zzj!DgX;)ORI z{o#;)*Djb@O&BZCh%+o4W1XV;D7Hs_5-eRJ8@pgty_c{IWBwy>HQWafs%YmWAF!(2)Ouz05 zHVL$vyFF=AoFEv+p-C%6?vDA4fD#lqA>9xq0c99eH#E$`(6S^ZcziSNRn(0o7Z>6+@V+_RVRYlATQg72Ao0izGnZ6ac-x)w zsT&*`hdtUXxvTMOe$$cn`8Qe|cM?r27MsbR-L~M-*tUZ8DHoyKtz*rqQ2$^G$HVw@ zoa^MS*wLz6MJVG90#?xZ5sWAm9A?sbuIW20v*yuz&*ei!7{vXV?5#Sy{Z4h1Q9(tO z3A}9Ld<8-s^L%A(e1+6O!AWKrqPuYg&o(|7tIzXoGODD=3->#+p)JfTA`%(_$1)^2(5na^5Wrf2Ny4+D%^2#>dvlM5V&dZV^s>FlJRCc&`$#Hjd2L zQ%)yOz=p;jgfK?g2FEsUz{CC`}T8@~zGk`VL)25bpS$a>ZHD%ulO30v(nJ7S+gO56uRe zj>z^@=z?nCOFfW)GAm^_&xPGZZ(RNt?@RpB6fmr+h}|=kD>E8FsEzchz&3b z3g%YN$|EaANjs-(jkicti?IJZ^B9>vu|pcavQCQ+ye4X;7O3}B%z0R>h*K%dgMM19 zt@{l?4kP8@qc$DbX|d&Zv&bys97R*K$|)2dfW;~cqnkXKkOrB)I(h**T1nr;rDQCc zs5>lwTO-8pEg~eWwIl7VPaHW6P#3b}M#~n@F*4CUx4;UrsF=G0=fTqYAh0`sgnyb_ zN~IMCiHY){mTn{Y?+L$?&@)?s0JES^!pjgJtj(kReEDB3jY4u$r3QufuNbuM0WelC zKc$O^B*b<9Xyg*I>+XwP#fMud`v-O2tR*$NhS!^kl_>i-OSU9{Q%{-#L=2S%KeYnV z(?3q(S>s8F3EumRkqcmaR7Kuk;&2mGtGqbeRPeS6|8^))_ES}Xc&{Lh+xa9QC5N#@ zw!8hF1z^$z7F>SfsU`?16FY!c%Ua9>;2+L!SR$$MZY6$V zLhHzG{xh#E|7hWoSBDU93(xSf@3xGXkDX1 zrLhIOq==$iDuU45Loa!P4XdF8Xk2RJN&s~&X!H~c#|ySy07Y>}IoGX&KOMoAY?7$RTeEPsdaNisw-Q;ADo zDh^A&U{tuw5_CiE*%~=mjz&Ju7Ae&Y}5niHn0aBe;?F->^u0b9$V(LvX zUX7LQ)e|V2D$#p$?9KdTW|o8}agJiMmu|(Kz-odW^o02D=uP1+!TDz1HIaJ6tC{>0 zOvTgU91}Z(Z}@*z#vZ73%l=Mp@m`qq&$fbstWKM(_h_bJ?<~xB6rohUEHHNJfq#2~ z6+|f$?yb!u{e1TQXUi?3RpCg~cDD6T<5i$UY-6@aJcnjv1e=f3ms$?ER$Lkvr`6q} z4eM8cnHV-HqDXC+!!MsM#e&fvppot+P!tvqNOY6rxt&rA!Vgikoe30`4XmVj9aMV?JGq*y)r>req^2)>Jdei_GM3tVh zR1zLOM^P9w^Oxt4N+`R3u3xru(x>WCl0L!%F^8W}*v{|vJef+AEF8n@-lBt%gffla z4MjDqChhPjfyXV5+y-vE*O`AHVM%8qy#e1B^?>_^+_!X)e0Mwo5gDgSCj0`w=S*YC zr^PQSXPgI9;~2`2Yt07y0MMX)i8&NKK!lDJp;SwU1C3kH!JjLF#*e3;x6BBwY~c@D zC0DEfhgkFG@}TgdQ5EB|<1q$Zl4w*o%aX)Tr;r#fJv0^~nH4^K0# z#i=ynn!=Zmw(hL#U)AFlIh1#S-luKz-?rW8VYPoPv%mC;)v2j$cS)Wji=M;Zr!3^x znfef*Z+yNMdD4X=(l6~u)BCG-!kPKLIk^whYqPHMo zF61MFJrNVQ*4cYnyO%=p&^oT45fyV2Tp-` zW=Il?m{vY^)G%b@D(^YL6{eT;px8n5A2obHGX9-~oZvOKsbTG)Qx;D|cd5ALz%*_I zd6|VE%eqnwl0|d& z@g!7xJG3nMF((n$joJwm%-dCcONQhu(EdSNeq#__GXl^3M6-%TlKX0Wt1x5>k)=Q{ zrBkAX!pxC99jeH#nFX2bGcak)rKxIv6m|Qd!%_jIScY=#ruWwPKw(I%ry2(*-aDHH zh|q+10)>X)ZZ0YwWxP#CNDZk>VnN@YP%+ET61PKh{6#!XTX8}pQ&GXWCv3@#uC+xj zLkw?HRnIJh6uas0mXz6wOD*3%Er%Hu-lyC#YXEK2v00 z8?o!25YHmByCFGdbzU!%^tfrwFU;7#sJJrIb@_Y3hR2@D{zNVM zafthb3m#EA(|PsYW^nFDdk|PfZxP-4KUVXKcNQ5e?$+%?v2~S1NyDeqN8Ahxm+|Mn zVDwO4h9qq{da1y#K=-gFwk4BSt2Hl9jR;Y0J>0BXZsrubIf5djW)P+(4DNzkFKix*!BH^|(d3;pczF{07@ zeuMAB`zYg#s^q`sa`YZcJ9NqFDQodcrlNGxHR!O0-@I%5c5%P^c5tK^GQ{g^7sKkC z)(Fzy-i{wHkqGAx)a27}(g&dcGU)JSzASbv>Xd8)$GblsBNaP}yt(KqKKPI7`T^rP zLEY4PrK4W@6|^3$3fHqM;2x2Xi|GEVYk&}8B)ewnGOI;wff7@Kz&d%eNPX0^gv5~ynAi-nE+?ykO=GM)YCw|t?Sq&QMs95_altE>vLjSl zvy=e{9H3419;26Z;dNN#yg+8R*sihyd4DeOGoMD+JTC!hXAt@TrN>%M|3%VLjl%f8CsNP>qZ~<04>o;K-Q@dV8Za$BgQXL6*`|~XDixxAu9@A zebGXpNQN;7<_#nw30%>zEZj>QaSfzr2y-i2`->@=s|?@tM;DWD@`mYoC=E}-SY^|Jf{=A5SAd4 zbksp*f4aHoB+zgcTSyR}-cCP*)&X?3eQWlc>pciKom^OedSF!Xb01MsM#HENgl_0Ph9jeNm@BrFX;f zt9W0Ba@p(~Rj>9?g(%5$Ad|l$QSdN~r z>)vkjJ4EOvLBSl66Q`rWAWp>hVcqWO!Tr2$0?K0B8ete{DVM+bpDi0VmY5L6DRDKW zPl(#>9*ji83(re8=sgcMQ@Ski`Eh9;w&^$?vH0=K)>L9mp#y%fE=G~tomffzZg+14 z4JLYG`Hj{@`l7GcgGnk%2$K;IxD|GnvRNr$6W5S*xpPuyh-vMptsY6^+L9B(j=kYe zK@-N2Al_qY1X1>q54ZqTRy1ii1D9nJnhoFxpem_m?R0&Lo=AsFcTk z^JWNZv4qDDa2}$N72#4mZ1-`J6ev1%&hu{a7cPIAvy^H`>l~($9-girPnYcy-gXpq z1hg?!#92B#{o_@c8K`lF5Wm^lzo?)3%>MCJY6<`O}GA5@r8n!TM8c3 zIYZLdM`_<9_`)#mU}4110cV7?8o(@eQZs;2-0LX0zi8&xxluhoIm>Jni&TZlfy}c~q+1deop!oJk4B(1bRUqK!;ITFzRhQ`Bo>ZY`sbsOOfAr_w z;}izD0Sy#@_tY_Q%)O~On4=mpwHAoi`=K*r#x0_0;UeAaGzDhCR3tH{um;-#nYN-_ z@RER}#=;XW3sj~F@k0R=3DmM`2vQ;_gK~g(7sImW&=$tZIPD*xG$!!9tF(C4T(2POl_!aZ(K0;!L4x?D4EbKz&) zT<|Y2I}fNTJdLI;TE43HdPflZ~qPTvYBOQODoFacT@rGiyPo!v-iiHUY6XEn>#J zzz7^W+|hO9O2B+Ro;kK2RFZS{?0Z@W;_Jc!&NiqfV`>HLCDdITISEgMChugEMi6ui zU2>}tbiPqGt^Z(HTFvb|Hp6-Q9Kx-dDx--nCs(ZYX7%7C@dif}#dIV7{qaeFJ`wKi zaKA~BB)(ibjcT|4JuGJ0C0D3>&&?5>A*Oihlt5|vL#qd^u<7Iu^im2y=Ng7RIvwWG z?`gOd*9B!S1o0S|F43HbmZdPk&u1|>WV_?QJCLOTWniplNol58go!X=Ckape#I`7s z2>T&Br&;F?mfT557(b#6&Lgyrd!ecK2bMqua|gG~1!#UM%pj!+nQI3~r$rA(jEgD| zT|#0X_!N=?rhz?l5yHv}HGoo2K`^9%+Gy8Ghg;bQpedHlKs$MwXyRwzWR4GwF5Sf= zDihup7SQWNMCaL}@mz^&A!9qJ^cV%|(V>1NpgUJc;#Es$L~D5b#H&;qyJabrWX1Ir zqnbcpo<`{*&w9mFLtgud#&cm`c)jcG4ALmnd%|O2rnV9P8VUU2r`Q3WLXr!qlA~Pl zau0vaMf}=vngTNijwE(>rJQh1G#p!mLX-+L8%aXo5sIj?LiZ*UCd815eM>oOvAkVz zvP9nZBt6QFgT${d<$s#&CwVxm5ZM76OtnxP1cY!oanh67Z=a@gC3>;>-(OoQvsD?Y zCoG;o_vo3z?fZC|$K;o^d#j8BwNr>I3cpc$yLx&LfP+X?1FZ4Xuqb0sWV?liXq)3d z=zL$snRK{6U(ak&+zADyZ~E;FS!$<-nHJ9D7dJ4?o$T@9{Rdw3YPw+cy+4x{qh*1? zlK4o(Q$)n%w8{7tfaRf=~v$r zV1op#b`y*9a7VxxM#DU}V@-e`(n>e~VEKW+F_*0mR2A;jK}wv;oqnsj=Z?-P;E35fj1BRpk1LJItgZPR1AkAO`%ASr&B6zyx@+%0lWuU?8u)rM_%hf3q$Ugki-(8d zli_~~z(NS^zY~Qq9?hB!CdI)g%H}KYpBgA|&}m4uwZ|2h`E!C0wCZYrF+DKnmINnf zpd2IwO2vHQv;&x3sumC|xrEKR99E+tXcXR&n1Z@~xbgO*rE7i^H3JenfK|(is~s;< zm=Jo+U0T$KwI<%k0(&nRs8*Xn;X3x8(nM8;m8N=Sb}By#HP6s+G>3@J&?%z*27b2* zp~P%6b&X++|9mr;6uy{U3)9tY+-B*`)JEJavLjvUAcVWya2!l4R)Tn+xs3}slZ{=0 zeJ6sFM`FNGNg6!)#0>u#;nkFpa~(J!Wr{YpTEbsr#XSJGE|gVMm*V1NhRlG7MEd1T z-BL+f(^sMA%_dz4g2F3Fh~-*IZ#L9(7o~L^@@vIbaBn{(Rorbbg?kec)qqa}1s*R= ze7kmx!SN7pSiT25I#o0WMt&43FM-)tMhC*vOc>-VS7!q%2D||3>(O)zQ_!{u%~s4^S zG55Nvr&wwo_ARjm353VVC`sV-T2t$Y|9K5}!W4g}BfEHeS2&<&ZjguOB)~PpAqdci zjYXN=GKZxj#^np&<$(-G)CGR@c4%g~c_}I%_E5vSvRTU_1ck7_rlbDXb>e~tZaOBq=YpK=MFol|sUR>Y&GH7%-_ zY=Mo^Q1}AsSon96X)N#iGFnW^8L=z^>_bSsK5`Z?Hb@6}(RckkrH)*IC0FsluJ95tV+<8S0rN7Kl+?7QKkIE?tPA#lH!ErlJ_>j&Ri-{jCtV;HdCc=3*Tup_Xo$Ra>x7Wo#f*I@XN0R2rd4O&uKET$E_ z9q{c)2ce$Se%3lr%_juXc2v9Fv!%crnh?&(_0oY`#!m;)fr~Oc(ruT1AgC{s^8N!T z$bow%@eK{qL}OR{C%PfYfiQDVf_+Oz0e~@+jvmPgUhGdWcI=rA)RnxzLSiHUnWN5v zt_0EC4>2&9#C%)s0_eArX02G#LnXfZevQbL&I>DYD-9s#6?VaS@>hR9~UZw|Y~ zia@X}iv-%c?6H^ln0pQDmj}U=ww=a;W`#Ycz;y)zmv=kIorqc92X1ueH3n`m7)b1D zfU5~3)*b1HgAfTV(1X!T8En>!CWzuL-neW6u8t%x!Anl30d-(blLh+JziM$NYXz(~ z&3F&-IRMpR5`fT%s2;O69drrMyu% zh7L*u3n6J@&DtqSxO{{qoa^~Y-xF1tHQT$@kTiy%Ao)iD!bT|bkEt$x9G!R@B5{Ag zyjBhH$+kzt=6H-G@F0?A>Lk5~&9>a;XdTD;j;T5npO$!SpKl-DqF6DPHXDrHH)i}R zP|_0`-Rqfy&0v?v(Lv)LjWx|$oUMBTcn^rPc%3qgdH}`?av)0Hi#BxwvX)8>eRK)I zAaKMjl}A-&1xLN9>m92p`Bhl&05*#zHfW~xd=*bz9>isBvm$Ni3D-_`@bTtUoFip; z*=F^h1T&%-PuG5NUHs_HmFbfmJ^=ZD9Nn>W8q6+UiBNr9`6DhQ^g_mX2*R4WS|2bt zO>Ttrf(Vh*67D0xklVl#3}n&(MGzi!eceY3;eQ+j+TNLXJ#6jw)gVUm9I8eq!I>|) z-xUC-ZM)R4eJCTL@e|Ri$-=la3E&OZ(C^Vet0ulF;A|l8DS|0{=w$$yTjfbNKSs&i zr_boC5|D+T0j4QRMM9t1_1ULWLD-@;KF**pjiH$_>lagvwLM2LoHO4-1gT5)mWn+; zVfR~)%0}a12S$ZCCw)nHg`Bs3+0;>=8bB_CcliotnRLinG0ea!fGe|P3$C~tW2sXYnkosT7^DNMH zM_`ezF;#C0{B;BCHngK9a~qYQ!jo~l!`TmzYDgHa(>e-hAXN`ekPz$EpA!Od>SK5Z zIxY6vLd`R?E1ssra4wf~S@Lu_R?C2{`vncrMaO*91$4|8K*||Xz~~>Kj}S9QLW)qz zrGjB-U0p9In^YO$Dkq-Uak@u&kt;%g#(xh86V*xcPC9KPjS^uH1BZndW>D7&e~pT8 zcatp>Qn@D5tE6fUl>zCKBiXoDt%YGv!+=(;QJZJvl*gDhsAB*JVd19uu|_772wur1~5Xv9=(;?2+;s-Fo)!Qh6Fla%S0Kob2os{u-wLnHnv9m*Us`x z;_QOJR;43=b-7#EX=}O^h{kG*!X4QR7TA;!JpnHd1l|W<;u4|*C>Zi$;PoYJIG;FS z103M{g5GiQHBN~b7H3Jw2EU7TRVW7jJ$hL_zK@6@3qj&hj0Yw#P>F(wR3*Y@K#a}c zmR7Wlwe(+9#1~j7VA=T#vChJaP?Nu>U>y|rkCJ+Wy6qY1@7fqIz)yZ-!^k2l7?l*G zYu7eVC;}TYHMLR0Tfho^O@U7uNw(2bja5s!+hDf58ca!)9vFH(P`-wQi(w$*5ez}H zJR_hxHBy!R-@s-z}d-pyB7UcfpnXGTPj2Y3v(MCN2wae{CzaH3D?~mOs7`vnkB=s_orh|PwQjWpw zSvW|w=oT|@GZQ9(ia-(u8Km>qL`N!Fde5~)(N0J4Jbp}o77+F$p)aS>+ofWxfyGzK zx0QvJa-uR1W5umLj#v63uGR1f3xZBoQo_bbBif$CxV=1joyK2Ad$Iqw5Dn2L$85%2 z&1P%8jrHA}n2lUC2gw7J5zEXLp*>=(mH<1Uu-0A!UlQm!Eafm2M5*X%D?-!Nsi zC;(@+TPF5AerR@UGRR=Ju?GAVg-W2^Lvz%~%`Sjq%%D79w}S(Lk^!kgJ1*&M)0%>? zP1>my2=8G$F8us{Q3nwTKudckUzlC&LX`u=4Bcu3wg^^%_bD+c9=anVaHbJ6K1MzJ zNH66#M=Whd8yj}3veUH+*q=f7(lps}3EiR#YtdnVup@#61rov)PKrQl>xI(*D=Ps5 zTKMOpgI$H{3)}OYw1u?)C+{Hiwe|}y5aeGUFmeFuS1jsp!5%Z(niAgF)(?`Uejq|R zRK(K#Re}uW6McsGK;TgQO7{V-HmklNA6@Utk?G=xXqzX&4HrY1&{#N)iHUn;dF1au z7@sHGjNzU8kA{)GKX>f!(T@=VQUH*U+Ers%ck|4EuDuOA5|=U(4rm$4f_uSf8)LL1 z#(^XGKdwG^ezlFA;qdAn8FW(=(c6%1K50q&nb!D2qU(K>({(-85K=IOaU7)u9dS z{J89qHQ+fQ1#YvHHTEs^QX0gW7a5T>9FQGY;`)LS836DMiA9*k=_X**yXH(Xmub0KwTbl<8ZQq55khd*Msu7bg+c z5NFFgbhVP&a+mZ4B!J^Gxwp4tXL@H4Lw+t45CB=SC!c5ANF5{=c0D_Gl(qyMb90rI9$2}l(kc7nK~e{)3@ zGF@W6PA>}%*UZuA>RmJ6XXZrzFs^vn(&0I6SR2R!rgfLVcny^*31op5PDKLP_`o%8 zO)Ua|xB!{A;*~(iB$WorJAd%MOi3SAX%Q%SaRCUTH86URttcRsLk7QL6)*0)H`V$$ zq#Z~73fUmwlyf@qYogB)1LKr)_ zxF?>Bn$CMXQ_;}JGX9QjB|Q2T)&pV^OMX_31FmQTS3D5->3c#F>fxw^nDd-aJB|?)?8t?eG?F!@Zai6 zZvEBh677h{i0`>NE|O=du=xWA;Kl?F3M0J>%7P2me<ac9oh1+_T!!ZG9T z($mF&`%)1ARUblDK5u~v2z)lY<7+tlr7elwr8Y-WZ`J64-97y7pQk}V@&b{xWIiLP zvPEdz{(k@bgSBIzT>=INw1uoyL;)%sRqwyCD!^l{u&Tl|P-*@zptBOeVw5Byo4L`) z4(dVR4U1<@w3bbhXRozePKUVQ z*Ou~~C=s18w74>m@ukXuAsNuH<;K$?aM@!SuU4I&gxe!uV9cC^0s<>r#0KqgZ@~RQ z_P1t0qCvV;9ERpUA5TT}7W6#G)dLBE3Q4TqR3^3eN8=ZUsVM3_x5s#aQR{v|J1$}E zA|n*dfu%Y&2!(Cbh~2rQkLDx;^h%@e0I(&;F@DQ|Erns}K@oDP)&maV5u%V-5APmh z2Z)d~5&-%QU{=TuIfHUg@rW?OK?=aWC)qpB7LJDi>7&tY)(cD)h$Z_v9i#H5Ahp(J z@Uja^Mi3MK&cQ*FaE%F6_c*e#Qo}Mya!OnBImnSvkEn4l1?%~*fS!Vt5g0kbdRv>6 z5767lb|8=gMI5Ipc+U+7-V`4Nukzj(vjR6ZOB+I+K?UJd3E-uDCry(Y8A1^02e0^W zMPvQ&t3ozF&*)mnn1uYu+Te{5s@!4*7$BgHDTUHvydnQRxEobga1z{276b?vM3??j z-UFsgv+AXYbimsp3d!jl8z>kkIMhVZM$lf^D1l7PaP0}9stuQehBGzwTS$xzcEt{O z7JtT`3?)0@y(!pPp(t!W4rWr21a`OgUu^OiLx4sBP6A>z)YEvFS)wE=Mrnc_)2g>{ zn&2gzd8|)s5Jud)6)?aLd;`kzHvHr}TJFo(h# zD4MCQFfpf}mcH1J1O#WyrySe}56qNGpGHI<2&vA6IB+ec+SWSs9T>4m0q?N%XN8-Po&gar zOe$cmP(^41j8NjkI^hBc34zzc7#L(g{|R*-e(&r3^QqF2Lhiup#F2~OTfyCTIWFL0 zvxU}0a5mGA4UTA!1kf|ss+J#XS4^oUEn`45lG^@*8btlON&Emox_>*&q4*5qHHm05 zwQ6v||3yO|N|wdih@>8!4ivX^&k=7HEi+6T8np`>`ZTp;No$*Fn%Z&DaLCYseWLyk zbNU~`ncW3%#|2?8aI#&C?8}CYl#+%%!3Zn&Mqrmno*w5!t{ndpza4ussDAb#px#Ld zbZxtzT05wtZtho-#Ty*;p?NN_FEft?A|R2J^9U%pp( z0ccO?Ncf$Pia8*s3gZ69(A*({GcWAz(30+eL)Jb2b;|@0vu*Qu38x*+;xTG^Dht4@ z%LGTbLP`L?p{T7is+}O}-cJovfcE%&fbg3rWBI~KSFq8ChlTZNBV{mCvWIC883`E#)@kl1oNzxz1fk%YBHEu&~@WY_s#8?>Ue2`2G3& zw|yQS?X&m$b$QepkG^IvMnzN zvrR3T2CcjQ5Rz80d%^vhM(plinP{}pYASfMSWdbuP}(rg$g>iy=#HnN@%MMQL`VU= z=sblf<^sc!4~SG=2eaCym#)MmT>(nyj=38$F!ryR6e_9sVlIU(Zv%8TlcvQcd;eXQ zeOA`Q@|3}`_t7z$DSNW>H()OBO!2$pYoEKdZmqFrE?vWebA*7es0eVZ@O*$mnj@g& z>g2YK0G^AEMS@ENcuT;`e#eGDHyYR#8oe_OE(M7PZ2z;S4)gZ_D=Xs2R|S8O z0*(uw6EN?0Syg+%9U114Ts8*%*DrPxkSa?&^qi-nXuVAy*&QDHmka3Q0HhFg+_xDF zp5H=w=IwIs5(k~yBBA1rx;Bf8+nPHxB@$WvYmJj+inLj80WjK^h~Ez2JF`>( z@?5j?7=?cRTeBC#F|ft7jT2+Tgqm!R@Ltxi*kayOCjUX8a;5-1VAZ}GjjZ8o-a<$K z?g8A{4h)_Q#KEfC)rMHIwIS0i?q$_y+bF@gB}$_b=w9`lo3hVTSXb6)CULa~ z>e>T@iJ*rtn3X5cZ$p{&aahc&=#zW|d%^uU+BVxB(Mw0~?&*Tnhq0z$mB(}vFnoml z1Sl`+@@fLR6X>SL@@A1N90#aV*AVH=)8H+jxq(Pj^&pg{ zUkxz#3UoL4wrCB2xmU1=mF$6p0>G&x@OsSOKlcR$J(OoL3H%>bo1u!}+ira-fv`J| zBPY06nk*msZ4;rhN5T70M6+uvP=d@ni_{B=Zj=P*mFiwR@T_C*$=`hdpg~tBJZMCY zXBnp1Ow_MeET%{djDMLA)ZdCmrNehQR&Lw#39168X(l@jU`65-17L{fi^K6ahroTy z{NM)0HYy!#-HbUo@(|3p(d?(z2)WrS`CtS}V*B{yzB1N|faaNH6L_-oI$OfF)?yiF z&Th>z;Er`MA6&qvT-OFL$LYDU=J@Nj;1d!jW1s#P?3qXBfbBurw{)`$knv+raRj_4JS~lpy&FB{?SoYhMu3@FNUV}b?6=3gj zKcKs^3NZe&2vQnjp#Kr}p*{nXAo^_+iko=EDlitbh3XIoI+&cmhD$S-nPZpNX=u`K z4mKnPS+;n_KgkLSLvj)w_pJ1Qg}nX;dqa)QWX*D#-kloEas-;ssM)Ay0xv6dUF$=- zX%MO*;kODWZs(-}BaSS`@q|(KqE;O2kmi}lVySAgb)ckSLQS6}f~J5!9C)LIgMr=^ zAY18&l!1@%r>FTq{D9*#s)Xw#&O{VH@3`gZigE(9pCYR!d+Q1)lGkT(*q5OCV8(HL zINHDeRUhHq>Qhy7cquZ$iar*M`nFiw`TB3q`O&%yl&g9Ami?7FG==MuodP_SBRg*t zg8y89gi&*wIkYg0oA6mb$VjgL6TYDkV=afD!P(W%l4oa9)Ff))VINf}Y2*4^8Ua1$ z#4I65@}Vx*gv6vyOiM810#4)J^!ChxTAS{z+d}k}^3S0O8nzNQdV3U-aCS+yy2)SK z?)RTlC~qA!Y=Q-e#n_PQR$uU^#Hby2OR#v$AC2WTe?+g*I08+*tu}u2{;$Zxo~ngs zR7dr-(kPSe>)r9+tL%}7Jr$7i`iq&A?#uI$^f1LY+MY|%viC48$Tv44oqw-;saN87CU;cE zcd*dqi{iEdt!3YCy-sH?9AD{8)y_@PQe83dO$}~vl+Xz8NIfCeX1CqG_&bX1l5Ty^PZaul;e}u+;rR8?=N0>}Oh( zbWg*`+Lqe)G&rj!S{?$DT6Qu*xAUEkLB0nJly6HsI+ z0V&BId1ur2as80}mD~)ku)A>Xabvr0ZB%D1?a7?>FBp^gNn%J@q-qH4Ce8r)Sp72g zyp{h(jd39jTkx0C_5?pRae!2=17(i@ZAc<}3gvG!`qVgpUk!xPhc74v&( z+nNo->b`X5VVy~1M#fO^{)c!`YkGmIc;7>egKo0?hIBRdb($zQwC7^^tR89Zc+K=| z6JK_i@HP4j7vQut4+gtKiE#qsl}{ucrYKPng`>6n>KQqH%1SAJm)>8vVAaJFu#aar z*&&|x)LNa24^Rz8936-pR;9LAKO~-Zz!J!&}BC&=e;%h zxu9h{)Imw|QEF3xU@-?`>+L;9t2vkL%LvI3g11sGOHU{QNli>duIEG|gJ(wzm#~Y2 zZy}R6Nc4~KwEjF_M0$7x8RxuMWvsUE)6cw=qmkpGEn-WE`NYfxvM$mkAB{NUViAd| zhLAUwJEktsSJ0>6B}uxk97dIDg3&e75}KxnIUk>8YlKgh$mKqYRg-uKV=$>_vVlYr z7{T5?9-f!Em_zhD$|OE&=Md?F$&07X&;}tcP~7*uw7g2)RpD*A@1#Ulzy@t_6u)$~ zh86|ot8f&*E%4%bz-erUz!wbE+gRfxtX<+!2WDMs8i6YnM6HAb+N(Te6u3AOj zT;g1Ecfh{Ig%N^4%$dIv^xy=m!Llr%VEquOL{i+FPCp;Ysnx+E)OVE9c36J&srJpu zMZb*i|MDQbp_J;dg)YMy32i9|YjF+@ab4=T5RM3KWpR2vAWn$DWp`L^!ilz?$jYjU zegT_I`yHP=32MYq+mEF>ZHKPpwRl|kO?pQP_?nSGI*d@_W}m7A0(UpuM$Z= zIpa=Os9jwg@=Aj^5+`Q=P#38YI&h-LhM!&Zkf=(|)1oxXt?d^$c3P`iP_mbV$bRli zI@q7`=>m!sYW{|vM-~qd)8JPs{J&5(>97N1)RJU)+pJb40U z)hbNg^zt+h@6P;nDYN9_T`Qvy&%8nBfLp}hU6q#mq@8O$jHQSkR$kfHo>ii&j;&O6 zx)Eo1JtDlEVT~}as;~+8lD87Nz&1o6?{G@kA+&F8o~ro%zkPS^n#n?|_xX-V?^wd6 z@p*}!!4)I+>BJ*d<-E+P3#yBM-9_Do-9L5eCd#jFkJUH${Al4)ui97c-Y=>e#m*^} zt1V2Baed8XIt@1cjkQ2nO#@81^(7sP2Txyj{q%Ehc@4{e($Ri#JDmm+Tj)Hd{ z^u@Eu#6pZ+Z(VS0o|axe20B1Vy#7@=dO$$=143jnrZ;`U@zObr+%|m4#Lib!bq>)( zbpEs#Px9s;^E&Pman0^$W#8l-UfouI*g5DK#phq?_s(OS4E z`=P6X$ZL^*-;tmFoX#Eej`6;K(mn<``$fg|M^^gJ{qL2}btJfJ#jBRShu3xpm!=6< zeT&H$)<{`(?>9XEP&MSVY`&SHUfp>EYQD*XKmIYEsH25cXE*qCg}oEm!>j?Nr!A9wnxTK-tJZH2igaKK5rJYvPaF3g z87>)TngcOsW^9Kt;nYYN6YQwoH|yVF|IAY6v9Q<&e|5h1l^qdcjT1ix+7VyL2?yrg zXsx-O30Ha^lafY+4z${4(yl9NxVX#&kC{g#L5~xs1|t8dc;ZpN-frz`)+ax5O6y^y zbW?(kUXk_=)IlJ-$}IWkm-rhJ5)oI7&lRd3yQan+I`~>r%$ig5#?8)> zI*GK2q3`o&aV`t8qj}$|zo|uXI%8m_^+!oh`1Su%f?5c|&OK8mnCUy8bMKq?`J2}c zlO9BVQZxOknOfjV&$kJryC+I|@@QpQ`SvcT5LYb|E=HGc%3cfUGNSlI@_kHjiWm4@ z+MaAT?zHsS^k|AUXKaa!jBNXjmRVxrU8!I1Fu6VOB1yPfq)wB7R_bS8BZ=Xt^~eMb zwGmGt$jm*6xj>LST*L1Y?4R((1o-0c*%%ttPbj;`q!s??2!=5CwT*tlRnIlDIo+oy z-`uU`TU=vhoDLV+I*j9G-S{-$#^D;$IY9&;vizqR!p_}lU^hecdl07V(&u~Z6jegh z*dy3QxVwZqiBf?KSs8OS#O0~ZQ6B^x_bxC?8k-Prefvx2fdy}DZ+eZD(VEAfQW34l z7>6F+v7oI5FU9sBbaCr~lkig!im>^k{dQU#!H62!YHAE3);eb-%|$9#g6}Fs%*#Xh zv&@!XdB-_&NZ&l=TT1T_zN#PZyNgs)8Sw_)<O zq>R5PTGp$!WO;>JpgdZStXg{UZMHa|TW`dlht959$^7Jk^!A_E^sLF@y#S-Ro}KT| z_1zPVG4930-IH4fp{u%X71JjEkMkE*3S-u|tDbAy*Nr|e5WwuK8jCvPnBgxr6Zj?> zab5{Aaf`T$@KShW_^foyte-blIkrvc<>Ctx!b7QhTF-5^L5cs*C(RR7m^0acAb25| zXt4pei0}Jg>uo7@9Q|Yhr{`dp#+>%_+d`o<1p z#YQ?BanTtEVL1o$%knqPAZ{BT0cJ%w-jW7u*e1(|VfMbE`B-52MdP zWF*WVd?duk6N;(0GM5_Cmiy3--#!u{<*{r2pzjG6yA&@JCf^J#Xq%EHM>evtkEbe) zaiTQ!`}Vvr{&_{EH0Z<9`HEn1x01l&jgKEQgmKE*gS3OwK3cMNd_Mmno2!l$d7^lrt?p8f>&?FF=vf~-wr=s7LZ2@Zda z#IaX3yfo?B>IO)Fm(JWz2&UW5btj8RFrCy+caW zt|)5lo$Qva&Id}sb#G3ZaLBz@e9Q6sRQ=_?ZsbG8)^|wQ@#IhN)};?YMIf+MwjtUL zzsIZIpx1j!I3^6v6Tpqlw(39by@D{H2Udc}R)Ozu1C23CH;>AZpqetB6EMDwMgiED z{%&80+hn6;|A9(fn~-Bp&WAqZyFk(I>CvD_$x|48@newBclP7}y^uFCX zeOc?ABs%frapd;5sFz-yT=SuRiavq){`Y@~W&Bg!ZCm|^SYTX!6&{oozxp_IvXWfj zoCx!*68%)oubOD-<}1vyHh@wuT>DsYp3L8`X^XpZ-@nYDV_xDQ&W1WAa!r!-d2yyQ z*4V`{|TAj?4EM5n?*PO?IaoF{e(Yi10C?Vq!taiM+KVgDz#8Yd^0n0B6 z>Ev(W)J4X7eKMu`rX|7~5~Mp+aoE^Q_UG2WYZElha} zLSq&_hdIpgG?n~wBj{yc@4u1aG^)k()~-|7rC*2gisa;%tTieP=NpQbyb3yd$FAQa zDEM^gJ`prdd%LQbs7oT=ujCH-UNuf{f-v-|%X)t5+hwrE_-&3$r1ba+2*WxejY^|Gx+AEB2n1bfLSc&z`fH9PR_L3Aa?`kT}xg?6`$<`|uFDYu!;Q&t~ zkfj+(oj|*jp++7hdAV42Y z8ABQ8Za?VwimGcXv2rU4l4T@GW%cXAzG|m2oL+nnq)-^@N3~D%d)o8#g;W#_jF#vI zODz8RToVRCs2iIy9)9Vwtr%TJXew%Q^(sXMhD<$$ZtL%KA3|XQYP~)!hd;s&<22Ha ztp?eqb>yxU>yTjPhj~(JADJ5Yzg~)OYv}m8)N^5M45XH&>-~U-#(O!tl^gY(7&~&4 zX$g5xWu`Q=C&jwdRufx@XYhI5@YJazwm3<*2x}9HqXK5lz2$MxwQ*Zb$Y<`F5Z8c_ zsqcEPoQukIBLbG0bhFEk%KmIr@ua4>WA9wZTryLrnIj8?+oBR23y$AEFU}B%Ky6M2 zC};g_T5@7YG6mW@{_q`mSxZa+!5Ua0^Wtz?prN?*HY2%0`rOkG-;(1j%I#+B4j^=N zJuChuBh)t3(m1vh>NCm5fC`P0j#qZ`I$$HFUQ|(s@^s1W*L@?PUVTFAuEgi*v8IF^ zw+Y6mjsvPTY$s+`C`CwXF7ZP~u=Eu%a&w6s zVdbb_Mq5M10A(K^*}`d|w02 zLFEVit}F8>+c@K=Y(cdxSZ8u|ZGM&b+NQNW>*UZblI)X4a-KK;f<$w9_~##Ep4tn& zFcnHX&Qk3g9U1@YURbWJxb8VGo%F#RQgZ9&c7ULO!2W)RLvrcFA-Hpw#QcwmR@$FZ zVZZS`JOroq3DokB!qWSQ^%+H+G3W3sY;s?VMI;ZoZs^b-4VR66t7Fxu< zS7~5Hc!BYfVGDaVg#Y^jZAYvuDA?4r;#8!_54!kYStKI@>UHSlCmDHikCa&QEycye z6_j_r#dpl={|tk51!1s%GinSO5<0k(3srkv!b0#P7ax?5X^Bg39lxnwee`UeGxU{c z*06ZZFEn(9W! Date: Wed, 5 Aug 2026 11:16:00 +0000 Subject: [PATCH 20/34] Fix defects found by adversarial review of the simultaneous optimiser Confirmed findings from a multi-lens review (algorithms, R semantics, doc consistency, test quality), all reproduced before fixing: - both optimisers crashed in the final arrange() when every cell was analytically infeasible (e.g. a strict max_total_depth): the empty evaluation cache produced a 0-column tibble; now they return the documented infeasible_within_bounds rows with a 0-row evaluations attribute - a max_total_depth that compresses the gravel-trench bounds to a single admissible storage height (gb[2] == gb[1]) was misreported as infeasible without any evaluation; the degenerate axis is now solved (encode() guards the 0/0 division) in both optimisers - prior_start_design(): NA rows in prior results injected all-NA rows via NA logical indexing and crashed compute_costs(); all filter conditions are NA-guarded now, and an all-NA-cost selection returns NULL instead of a 0-row frame that broke encode() - DE mutation indices r1/r2/r3 could coincide (P ~ 1/11 for a zero difference vector); now pairwise distinct as DE/rand/1/bin requires - NEWS: the simultaneous-vignette bullet had split the optimiser sub-bullet list, re-parenting make_swale_runner()/stack_levels() under the wrong bullet; docs now also state the 6-seed cap of the multi-valley polish instead of claiming "every storage level" New tests: empty search space (both optimisers), degenerate gravel axis, NA-containing prior, max_evals budget effect, seed-effect canary on the search path, result attributes, single-type storage_spec for all three methods. 160 tests green. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 23 ++--- R/optimise_swale_design.R | 14 ++- R/optimise_swale_design_simultaneous.R | 64 ++++++++----- man/optimise_swale_design_simultaneous.Rd | 12 ++- .../test-optimise_swale_design_simultaneous.R | 92 +++++++++++++++++++ 5 files changed, 162 insertions(+), 43 deletions(-) diff --git a/NEWS.md b/NEWS.md index 4a5910f..04a797d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -45,7 +45,8 @@ tolerance snapping (the shared cache absorbs repeats across all `x_targets`) and a final **multi-valley lattice polish** (accelerated 8/4/2/1-tolerance pattern descent from the cheapest - feasible design of every storage level visited — the storage axis + feasible design of every storage level visited, capped at the 6 + cheapest levels for the continuous gravel trench — the storage axis separates cost valleys that single coordinate steps cannot cross): `"nelder_mead"` (default; deterministic multistart via `stats::optim()` — prior warm start, previous-target optimum, one @@ -63,16 +64,6 @@ (typically 60–120 instead of ~15) but serves as an independent cross-check that coordinate descent did not miss a cheaper corner of the design space. - -* New conditional vignette `workflow_optimisation_simultaneous` — the - simultaneous counterpart of `workflow_optimisation` (which stays - bisection-only and now points here): runs the Nelder-Mead sweep for - all three sites in parallel (site × storage type), compares the - optima cell by cell against the bisection CSV export when present - (`delta_pct` table), and benchmarks the three search methods - (Nelder-Mead / differential evolution / Halton baseline) on the same - x = 1 cell across all sites and storage types — 12 parallel tasks — - to show what the structured searches contribute over naive sampling. - `make_swale_runner()` — package-level refactoring of the `run_one()` function previously duplicated across the three case-study vignettes: one closure factory covering both variants (Eisenstadt: @@ -122,6 +113,16 @@ 3 sites × 2 storage types × 10 repetitions runs as 60 parallel tasks, one full re-optimisation each). +* New conditional vignette `workflow_optimisation_simultaneous` — the + simultaneous counterpart of `workflow_optimisation` (which stays + bisection-only and now points here): runs the Nelder-Mead sweep for + all three sites in parallel (site × storage type), compares the + optima cell by cell against the bisection CSV export when present + (`delta_pct` table), and benchmarks the three search methods + (Nelder-Mead / differential evolution / Halton baseline) on the same + x = 1 cell across all sites and storage types — 12 parallel tasks — + to show what the structured searches contribute over naive sampling. + * New exported helper `read_site_timeseries()` — the rain/ET0 time-series preparation previously duplicated in the Wien and Bad Aussee vignettes (hours since start, series-end alignment, engine mm/h convention); diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index e441903..f5722a0 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -196,7 +196,9 @@ optimise_swale_design <- function(run_fn, if (!is.null(max_total_depth)) { gb[2] <- min(gb[2], max_total_depth - filter_height - height_bounds[1]) } - if (gb[2] <= gb[1]) return(infeasible_row()) + # gb[2] == gb[1] is a degenerate but valid axis (exactly one + # admissible storage height), only gb[2] < gb[1] is infeasible + if (gb[2] < gb[1]) return(infeasible_row()) gravel_tol <- if (is.null(spec$tol)) 25 else spec$tol h_s <- gb[1] } @@ -283,9 +285,13 @@ optimise_swale_design <- function(run_fn, evaluations <- dplyr::bind_rows( lapply(ls(cache), function(k) tibble::as_tibble(get(k, envir = cache))) ) - attr(out, "evaluations") <- dplyr::arrange( - evaluations, .data$storage_type, .data$mulde_area - ) + if (nrow(evaluations) > 0) { + # empty when every cell is analytically infeasible (no engine run) + evaluations <- dplyr::arrange( + evaluations, .data$storage_type, .data$mulde_area + ) + } + attr(out, "evaluations") <- evaluations attr(out, "n_runs_total") <- runs_executed out } diff --git a/R/optimise_swale_design_simultaneous.R b/R/optimise_swale_design_simultaneous.R index f29f487..837e002 100644 --- a/R/optimise_swale_design_simultaneous.R +++ b/R/optimise_swale_design_simultaneous.R @@ -14,15 +14,20 @@ prior_start_design <- function(prior, type, x, filter_height, cost_rates) { kf_max <- suppressWarnings( max(prior$filter_hydraulicconductivity, na.rm = TRUE) ) - d <- prior[prior$storage_type == type & - prior$filter_hydraulicconductivity == kf_max & - !is.na(prior$n_overflows) & prior$n_overflows <= x, , - drop = FALSE] + keep <- !is.na(prior$storage_type) & prior$storage_type == type & + !is.na(prior$filter_hydraulicconductivity) & + prior$filter_hydraulicconductivity == kf_max & + !is.na(prior$n_overflows) & prior$n_overflows <= x + d <- prior[keep, , drop = FALSE] if (nrow(d) == 0) return(NULL) if (!"filter_height" %in% names(d)) d$filter_height <- filter_height d <- compute_costs(d, cost_rates = cost_rates) - d[which.min(d$cost_total), - c("mulde_area", "mulde_height", "storage_height"), drop = FALSE] + best_i <- which.min(d$cost_total) # integer(0) if all costs are NA + if (length(best_i) == 0) return(NULL) + out <- d[best_i, c("mulde_area", "mulde_height", "storage_height"), + drop = FALSE] + if (anyNA(out)) return(NULL) + out } #' Radical-inverse (van der Corput) sequence element @@ -112,11 +117,13 @@ make_lcg <- function(seed) { #' `max_evals` budget (unused runs roll over). #' \item \strong{Lattice polish}: an accelerated pattern descent #' (steps of 8/4/2/1 tolerances downwards, cheaper by construction) -#' runs from the cheapest feasible design of *every storage level -#' visited* -- the storage axis separates cost valleys that single -#' coordinate steps cannot cross -- until no parameter can be reduced -#' any further: the result is locally optimal on the tolerance -#' lattice, whatever the search method delivered. +#' runs from the cheapest feasible design of every storage level +#' visited -- capped at the 6 cheapest levels, which only bites for +#' the continuous gravel trench (the discrete box has at most a +#' handful) -- because the storage axis separates cost valleys that +#' single coordinate steps cannot cross. It stops when no parameter +#' can be reduced any further: the result is locally optimal on the +#' tolerance lattice, whatever the search method delivered. #' } #' #' The discrete infiltration-box levels are mapped onto a continuous @@ -366,7 +373,9 @@ optimise_swale_design_simultaneous <- function(run_fn, if (!is.null(max_total_depth)) { gb[2] <- min(gb[2], max_total_depth - filter_height - height_bounds[1]) } - if (gb[2] <= gb[1]) return(infeasible_row()) + # gb[2] == gb[1] is a degenerate but valid axis (exactly one + # admissible storage height), only gb[2] < gb[1] is infeasible + if (gb[2] < gb[1]) return(infeasible_row()) s_tol <- if (is.null(spec$tol)) 25 else spec$tol hs_max <- gb[2] } @@ -396,8 +405,10 @@ optimise_swale_design_simultaneous <- function(run_fn, u3 <- if (discrete) { i <- which.min(abs(levels_all - h_s)) (i - 0.5) / length(levels_all) - } else { + } else if (gb[2] > gb[1]) { (h_s - gb[1]) / (gb[2] - gb[1]) + } else { + 0 # degenerate axis: exactly one admissible storage height } up <- hm_upper(h_s) u2 <- if (up > height_bounds[1]) { @@ -499,21 +510,24 @@ optimise_swale_design_simultaneous <- function(run_fn, if (i <= length(starts_all)) starts_all[[i]] else halton_point(i) }) fit <- vapply(pop, objective, numeric(1)) - pick_other <- function(i) { - repeat { + # i, r1, r2, r3 pairwise distinct, as DE/rand/1/bin requires + pick_distinct <- function(i) { + chosen <- integer(0) + while (length(chosen) < 3) { r <- 1L + as.integer(floor(rng() * n_pop)) - if (r != i && r <= n_pop) return(r) + if (r != i && r <= n_pop && !(r %in% chosen)) { + chosen <- c(chosen, r) + } } + chosen } gen <- 0 while (!budget_hit() && gen < 60) { gen <- gen + 1 for (i in seq_len(n_pop)) { if (budget_hit()) break - r1 <- pick_other(i) - r2 <- pick_other(i) - r3 <- pick_other(i) - mutant <- pop[[r1]] + 0.7 * (pop[[r2]] - pop[[r3]]) + r <- pick_distinct(i) + mutant <- pop[[r[1]]] + 0.7 * (pop[[r[2]]] - pop[[r[3]]]) trial <- pop[[i]] j_rand <- 1L + as.integer(floor(rng() * 3)) for (j in 1:3) { @@ -667,9 +681,13 @@ optimise_swale_design_simultaneous <- function(run_fn, evaluations <- dplyr::bind_rows( lapply(ls(cache), function(k) tibble::as_tibble(get(k, envir = cache))) ) - attr(out, "evaluations") <- dplyr::arrange( - evaluations, .data$storage_type, .data$mulde_area - ) + if (nrow(evaluations) > 0) { + # empty when every cell is analytically infeasible (no engine run) + evaluations <- dplyr::arrange( + evaluations, .data$storage_type, .data$mulde_area + ) + } + attr(out, "evaluations") <- evaluations attr(out, "n_runs_total") <- runs_executed out } diff --git a/man/optimise_swale_design_simultaneous.Rd b/man/optimise_swale_design_simultaneous.Rd index 318f274..88cc6fc 100644 --- a/man/optimise_swale_design_simultaneous.Rd +++ b/man/optimise_swale_design_simultaneous.Rd @@ -148,11 +148,13 @@ optimiser. Every start receives an equal slice of the remaining \code{max_evals} budget (unused runs roll over). \item \strong{Lattice polish}: an accelerated pattern descent (steps of 8/4/2/1 tolerances downwards, cheaper by construction) -runs from the cheapest feasible design of \emph{every storage level -visited} -- the storage axis separates cost valleys that single -coordinate steps cannot cross -- until no parameter can be reduced -any further: the result is locally optimal on the tolerance -lattice, whatever the search method delivered. +runs from the cheapest feasible design of every storage level +visited -- capped at the 6 cheapest levels, which only bites for +the continuous gravel trench (the discrete box has at most a +handful) -- because the storage axis separates cost valleys that +single coordinate steps cannot cross. It stops when no parameter +can be reduced any further: the result is locally optimal on the +tolerance lattice, whatever the search method delivered. } The discrete infiltration-box levels are mapped onto a continuous diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R index d4ba5cf..67c82c6 100644 --- a/tests/testthat/test-optimise_swale_design_simultaneous.R +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -145,6 +145,94 @@ test_that("max_total_depth wirkt als analytische Nebenbedingung", { <= 1200 + 1e-9)) }) +test_that("leerer Suchraum (Tiefe verbietet alles) liefert Zeilen statt Fehler", { + # max_total_depth = 500 laesst mit filter_height 300 und Muldentiefe + # >= 100 keine einzige Speicherhoehe zu -> kein Engine-Lauf, aber ein + # regulaeres Ergebnis (kein Absturz beim Zusammenbau der Attribute) + run <- sim_run_factory(demand = 3.6e5) + for (f in list(optimise_swale_design, optimise_swale_design_simultaneous)) { + out <- f(run, x_targets = 0:1, fixed = sim_fixed, + max_total_depth = 500, verbose = FALSE) + expect_true(all(out$status == "infeasible_within_bounds")) + expect_identical(attr(out, "n_runs_total"), 0L) + expect_identical(nrow(attr(out, "evaluations")), 0L) + } +}) + +test_that("degenerierte Rigol-Achse (genau eine zulaessige Hoehe) ist loesbar", { + # max_total_depth = 1300: gb[2] wird auf gb[1] = 900 gedrueckt -- + # genau ein zulaessiger Speicherwert bleibt, die Zelle ist loesbar + run <- sim_run_factory(demand = 3.6e5) + out <- optimise_swale_design_simultaneous( + run, x_targets = 5, fixed = sim_fixed, + storage_spec = default_storage_spec()["gravel_trench"], + max_total_depth = 1300, verbose = FALSE + ) + expect_identical(out$status, "ok") + expect_identical(out$storage_height, 900) + expect_identical(out$mulde_height, 100) +}) + +test_that("NA-Zeilen im Prior stuerzen den Warmstart nicht ab", { + run <- sim_run_factory(demand = 3.6e5) + prior <- data.frame( + mulde_area = c(150, NA), mulde_height = c(300, NA), + storage_type = c("infiltration_box", NA), + storage_height = c(300, NA), + filter_hydraulicconductivity = c(360, NA), + n_overflows = c(0, NA) + ) + out <- optimise_swale_design_simultaneous( + run, x_targets = 0, fixed = sim_fixed, + storage_spec = default_storage_spec()["infiltration_box"], + prior_results = prior, verbose = FALSE + ) + expect_identical(out$status, "ok") +}) + +test_that("max_evals begrenzt die Suchphase messbar", { + run <- sim_run_factory(demand = 3.6e5) + small <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, + max_evals = 15, + verbose = FALSE) + large <- optimise_swale_design_simultaneous(run, x_targets = 1, + fixed = sim_fixed, + max_evals = 200, + verbose = FALSE) + expect_lt(attr(small, "n_runs_total"), attr(large, "n_runs_total")) + # das Optimum leidet nicht wesentlich unter dem kleinen Budget + expect_true(all(small$cost_total <= large$cost_total * 1.10)) +}) + +test_that("Ergebnis traegt die Attribute evaluations und n_runs_total", { + run <- sim_run_factory(demand = 3.6e5) + out <- optimise_swale_design_simultaneous( + run, x_targets = 1, fixed = sim_fixed, + storage_spec = default_storage_spec()["infiltration_box"], + verbose = FALSE + ) + ev <- attr(out, "evaluations") + expect_s3_class(ev, "tbl_df") + expect_gt(nrow(ev), 0) + expect_true(all(c("storage_type", "mulde_area", "mulde_height", + "storage_height", "n_overflows") %in% names(ev))) + expect_identical(attr(out, "n_runs_total"), nrow(ev)) +}) + +test_that("alle Methoden funktionieren mit Ein-Typ-storage_spec", { + run <- sim_run_factory(demand = 3.6e5) + for (m in c("nelder_mead", "diff_evolution", "halton_search")) { + out <- optimise_swale_design_simultaneous( + run, x_targets = 1, fixed = sim_fixed, + storage_spec = default_storage_spec()["infiltration_box"], + method = m, verbose = FALSE + ) + expect_identical(out$status, "ok") + expect_identical(out$method, m) + } +}) + test_that("alle Suchverfahren treffen das Brute-Force-Optimum", { run <- sim_run_factory(demand = 3.6e5) # NM ist am praezisesten, DE nah dran, Halton ist die naive Baseline @@ -191,6 +279,10 @@ test_that("Differential Evolution ist deterministisch und laesst Rs RNG in Ruhe" method = "diff_evolution", seed = 99, verbose = FALSE) expect_equal(de3$cost_total, de1$cost_total, tolerance = 0.05) + # Kanarienvogel gegen ein ignoriertes seed-Argument: die besuchten + # Designs (Suchpfade) muessen sich unterscheiden, auch wenn die + # Optima uebereinstimmen duerfen + expect_false(identical(attr(de3, "evaluations"), attr(de1, "evaluations"))) }) test_that("verschiedene Start-Konfigurationen treffen dasselbe Optimum", { From a9a8fcc3e283672bc42bee5779ea42381a172403 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 12:38:54 +0000 Subject: [PATCH 21/34] make_swale_runner(): delete scenario files after reading the result The optimisation vignettes died on the user's machine with HDF5 errno = 28 ("No space left on device"): every engine run creates its own scenario directory (a copy of base.h5 as input plus all output HDF5s) under tempdir() and nothing was ever removed. The bisection's ~15 runs per cell masked this; the simultaneous search (60-120 runs per cell, ~124 scenarios per task across 6 parallel tasks with the 15-year Wien/Bad Aussee models) fills the temp drive mid-sweep. The runner only ever uses the thinned one-row result, so it now deletes the scenario's input copy and output directory right after that row has been read (new argument cleanup = TRUE; failed runs keep their files for debugging). Both optimisation vignettes document the disk behaviour and the recovery step after an aborted run. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 6 ++++++ R/make_swale_runner.R | 18 ++++++++++++++++++ man/make_swale_runner.Rd | 10 ++++++++++ vignettes/workflow_optimisation.Rmd | 5 ++++- .../workflow_optimisation_simultaneous.Rmd | 9 +++++++++ 5 files changed, 47 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 04a797d..6187801 100644 --- a/NEWS.md +++ b/NEWS.md @@ -71,6 +71,12 @@ rain + ET0 series in mm/h incl. the Growth/Shading end-time fix). Returns the thinned one-row optimisation result augmented with `overflow_volume_m3` (= `sum_overflows` [mm] × `mulde_area` / 1000). + Deletes each scenario's input copy and output directory right after + that row has been read (`cleanup = TRUE`, the default; failed runs + keep their files) — without this, long searches (hundreds of engine + runs per task, each with its own `base.h5` copy plus output HDF5s) + fill the temp drive and the engine dies with HDF5 `errno = 28` + ("No space left on device"). - `stack_levels()`, `sickerbox_level_presets()`, `default_storage_spec()`, `default_storage_types()` — storage-layer search spaces: achievable stack heights from module heights (incl. diff --git a/R/make_swale_runner.R b/R/make_swale_runner.R index ab766aa..bb0335a 100644 --- a/R/make_swale_runner.R +++ b/R/make_swale_runner.R @@ -45,6 +45,14 @@ psi_s_mm <- function(kf_mmh) { #' @param scenario_prefix Prefix for generated scenario names (default #' `"o"` -> `o00001`, `o00002`, ... -- distinct from the grid runs #' `s00001` ...). +#' @param cleanup Delete each scenario's copied input file and output +#' directory right after the thinned one-row result has been read +#' (default `TRUE`). The optimisers only need that row; without the +#' cleanup an optimisation run (hundreds of engine runs per task, each +#' with its own copy of `base.h5` plus all output HDF5s) fills the +#' temp drive and the engine aborts with HDF5 `errno = 28` ("No space +#' left on device"). Set `FALSE` to keep all scenario files for +#' debugging. Files of a *failed* run are always kept. #' @param debug Passed on to the engine/reader helpers. #' #' @return `function(params)` where `params` is a named list (or one-row @@ -65,6 +73,7 @@ make_swale_runner <- function(path_list, storage_types = default_storage_types(), event_separation_hours = 4, scenario_prefix = "o", + cleanup = TRUE, debug = FALSE) { counter <- 0L @@ -175,6 +184,15 @@ make_swale_runner <- function(path_list, canonical_variables = default_canonical_wb_variables() ) + # the thinned row is all the optimiser needs -- drop the scenario's + # input copy and output directory so long searches (hundreds of + # engine runs) do not fill the temp drive. Reached only on success: + # a failed run errors above and keeps its files for debugging. + if (isTRUE(cleanup)) { + try(fs::file_delete(paths$path_target_input), silent = TRUE) + try(fs::dir_delete(paths$dir_target_output), silent = TRUE) + } + dplyr::bind_cols( tibble::as_tibble(params[required]), tibble::tibble(rain_factor = rain_factor, lai = lai), diff --git a/man/make_swale_runner.Rd b/man/make_swale_runner.Rd index b9e346d..4f1d88e 100644 --- a/man/make_swale_runner.Rd +++ b/man/make_swale_runner.Rd @@ -12,6 +12,7 @@ make_swale_runner( storage_types = default_storage_types(), event_separation_hours = 4, scenario_prefix = "o", + cleanup = TRUE, debug = FALSE ) } @@ -42,6 +43,15 @@ see \code{\link[=default_storage_types]{default_storage_types()}}.} \code{"o"} -> \code{o00001}, \code{o00002}, ... -- distinct from the grid runs \code{s00001} ...).} +\item{cleanup}{Delete each scenario's copied input file and output +directory right after the thinned one-row result has been read +(default \code{TRUE}). The optimisers only need that row; without the +cleanup an optimisation run (hundreds of engine runs per task, each +with its own copy of \code{base.h5} plus all output HDF5s) fills the +temp drive and the engine aborts with HDF5 \code{errno = 28} ("No space +left on device"). Set \code{FALSE} to keep all scenario files for +debugging. Files of a \emph{failed} run are always kept.} + \item{debug}{Passed on to the engine/reader helpers.} } \value{ diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index b9d2c25..63c3285 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -61,7 +61,10 @@ Box-Bereich. **Laufzeit:** Ein Engine-Lauf dauert ~2 s (Eisenstadt, 1 Jahr) bzw. ~15 s (Wien / Bad Aussee, 15-Jahres-Serien). Die 6 Tasks (Standort × Speichertyp) laufen parallel; die Gesamtdauer entspricht -dem längsten Einzeltask — ca. 15–20 Minuten. +dem längsten Einzeltask — ca. 15–20 Minuten. `make_swale_runner()` +löscht die Szenario-Dateien jedes Laufs standardmäßig direkt nach dem +Einlesen (`cleanup = TRUE`), damit lange Suchen das Temp-Laufwerk nicht +füllen. ```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} cat(sprintf(paste0( diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index 83e0deb..b44b287 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -80,6 +80,15 @@ Einzeltask des Nelder-Mead-Sweeps ~1.5–2.5 h dauern; Eisenstadt (~2 s je Lauf) bleibt bei Minuten. Der Methodenvergleich am Ende rechnet deshalb nur eine Zelle (x = 1) je Standort und Speichertyp. +**Plattenplatz:** Jeder Engine-Lauf legt ein eigenes Szenario an (Kopie +der `base.h5` plus Output-HDF5s). `make_swale_runner()` löscht diese +Dateien standardmäßig direkt nach dem Einlesen der dünnen Ergebniszeile +(`cleanup = TRUE`) — ohne dieses Aufräumen füllen mehrere hundert Läufe +je Task das Temp-Laufwerk und die Engine bricht mit `No space left on +device` ab. Vor einem Neustart nach einem solchen Abbruch die +`raindrop_sim_*`-Verzeichnisse unter `tempdir()` bzw. +`%LOCALAPPDATA%\Temp` (`Rtmp*`) löschen. + ```{r availability_note, echo = FALSE, results = 'asis', eval = !can_run} cat(sprintf(paste0( "> **Hinweis:** Die Rechen-Chunks wurden übersprungen. Prüfungen: ", From 8231342b95d53679833d58937591fbd502591257 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 15:18:17 +0000 Subject: [PATCH 22/34] Simultaneous vignette: live progress, honest runtime, quick-test switch A full Nelder-Mead sweep is ~400-700 engine runs per task (2-3 h per task at 15 s/run for the Wien / Bad Aussee models, more wall time when fewer cores than tasks are free) and ran completely silent inside the future workers - indistinguishable from a hang. Both compute chunks now show a progressr bar ticking once per engine run across the worker boundary (per-task quota topped up on completion so the bar ends at exactly 100%). The runtime paragraph states the real expectation (2-5 h), the site list gains a commented quick-test switch (Eisenstadt only, minutes instead of hours) and max_evals is exposed in the search-space chunk as the runtime lever. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 4 + .../workflow_optimisation_simultaneous.Rmd | 94 +++++++++++++++---- 2 files changed, 78 insertions(+), 20 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6187801..c1ad2b0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -128,6 +128,10 @@ (Nelder-Mead / differential evolution / Halton baseline) on the same x = 1 cell across all sites and storage types — 12 parallel tasks — to show what the structured searches contribute over naive sampling. + Both compute chunks report live progress across the worker boundary + (one \pkg{progressr} tick per engine run — a multi-hour sweep no + longer looks frozen), the site list has a quick-test switch + (Eisenstadt only) and `max_evals` is exposed as the runtime lever. * New exported helper `read_site_timeseries()` — the rain/ET0 time-series preparation previously duplicated in the Wien and Bad Aussee vignettes diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index b44b287..f7a5bb2 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -75,10 +75,19 @@ unterscheiden sich nur darin, wie sie Kandidaten vorschlagen **Laufzeit:** Die simultane Suche braucht je (Speichertyp, x)-Zelle mehr Engine-Läufe als die Bisektion (typisch 60–120 statt ~15; Suchphase plus -Feinschliff). Bei ~15 s je Lauf (Wien / Bad Aussee) kann der längste -Einzeltask des Nelder-Mead-Sweeps ~1.5–2.5 h dauern; Eisenstadt (~2 s je -Lauf) bleibt bei Minuten. Der Methodenvergleich am Ende rechnet deshalb -nur eine Zelle (x = 1) je Standort und Speichertyp. +Feinschliff). Über 6 Überlaufziele summiert sich das auf ~400–700 +Engine-Läufe **je Task**; bei ~15 s je Lauf (Wien / Bad Aussee) sind das +**2–3 h je Task** — und wenn weniger freie Kerne als 6 Tasks verfügbar +sind, entsprechend mehr Wandzeit (realistisch **2–5 h** für den +Nelder-Mead-Sweep). Eisenstadt (~2 s je Lauf) bleibt bei Minuten. Beide +Rechen-Chunks zeigen deshalb einen **Live-Fortschrittsbalken** (ein Tick +je Engine-Lauf, über `progressr` aus den Worker-Prozessen heraus) — ein +über Minuten stehender Balken wäre ein echter Hänger, ein langsam +wandernder ist Normalbetrieb. Der Methodenvergleich am Ende rechnet nur +eine Zelle (x = 1) je Standort und Speichertyp. Wer zuerst einen +schnellen Funktionstest will, rechnet nur Eisenstadt (Kommentar im +Chunk `site_config`); der Laufzeit-Hebel für den vollen Sweep ist +`max_evals` (Kommentar im selben Chunk). **Plattenplatz:** Jeder Engine-Lauf legt ein eigenes Szenario an (Kopie der `base.h5` plus Output-HDF5s). `make_swale_runner()` löscht diese @@ -125,6 +134,9 @@ sites <- list( BadAussee = list(dir = "badaussee", timeseries = TRUE, prior = "simulation_results_optimisation_BadAussee.csv") ) +# Schneller Funktionstest (~10-15 min statt Stunden): nur Eisenstadt -- +# 1-Jahres-Modell, ~2 s je Engine-Lauf: +# sites <- sites["Eisenstadt_2005"] fixed <- list(connected_area = 1000, filter_height = 300, @@ -137,6 +149,9 @@ height_bounds <- c(100, 300) # Muldentiefe [mm], stufenlos height_tol <- 10 # Aufloesung der Tiefensuche [mm] storage_spec <- default_storage_spec() cost_rates <- default_cost_rates() +max_evals <- 80 # Laufzeit-Hebel: Budget an frischen + # Engine-Laeufen je Zelle (Suchphase; + # der Feinschliff kommt obendrauf) make_path_list <- function(modelname, model_dir) { list( @@ -166,9 +181,13 @@ make_path_list <- function(modelname, model_dir) { # Ein Task = eine komplette Optimierung (Standort x Speichertyp x # Methode); gekapselt, damit Haupt-Sweep und Methodenvergleich denselben -# Code nutzen +# Code nutzen. tick/tick_cap: progressr-Fortschritt ueber die +# Worker-Grenze hinweg -- ein Tick je Engine-Lauf, am Task-Ende wird +# der Rest des Task-Kontingents aufgefuellt, damit der Balken exakt +# bei 100 % endet. run_simultaneous_task <- function(site, type, method, x_targets, - model_suffix) { + model_suffix, + tick = NULL, tick_cap = Inf) { if (file.exists("../DESCRIPTION") && requireNamespace("pkgload", quietly = TRUE)) { pkgload::load_all("..", quiet = TRUE) @@ -193,6 +212,18 @@ run_simultaneous_task <- function(site, type, method, x_targets, timeseries_et = ts$et ) + ticks_sent <- 0L + if (!is.null(tick)) { + inner_fn <- run_fn + run_fn <- function(params) { + if (ticks_sent < tick_cap) { + ticks_sent <<- ticks_sent + 1L + tick(sprintf("%s | %s | Lauf %d", site, type, ticks_sent)) + } + inner_fn(params) + } + } + prior <- if (file.exists(cfg$prior)) { readr::read_csv(cfg$prior, show_col_types = FALSE) } else { @@ -208,6 +239,7 @@ run_simultaneous_task <- function(site, type, method, x_targets, fixed = fixed, prior_results = prior, method = method, + max_evals = max_evals, cost_rates = cost_rates, verbose = FALSE ) @@ -215,6 +247,11 @@ run_simultaneous_task <- function(site, type, method, x_targets, opt$n_runs_task <- attr(opt, "n_runs_total") opt$minutes_task <- round(as.numeric( difftime(Sys.time(), t0, units = "mins")), 1) + if (!is.null(tick) && is.finite(tick_cap) && tick_cap > ticks_sent) { + tick(sprintf("%s | %s fertig (%d Laeufe, %.1f min)", + site, type, opt$n_runs_task[1], opt$minutes_task[1]), + amount = tick_cap - ticks_sent) + } opt } ``` @@ -235,14 +272,24 @@ future::plan(future::multisession, workers = min(nrow(tasks), max(1, parallel::detectCores() - 1))) -nm_list <- future.apply::future_lapply(seq_len(nrow(tasks)), function(i) { - run_simultaneous_task(tasks$site[i], tasks$type[i], - method = "nelder_mead", x_targets = 0:5, - model_suffix = "NM") -}, future.seed = TRUE) +# Live-Fortschritt ueber die Worker hinweg: 1 Tick = 1 Engine-Lauf +# (tick_cap = grosszuegiges Kontingent je Task; der Rest wird am +# Task-Ende aufgefuellt, der Balken endet also exakt bei 100 %) +progressr::handlers(progressr::handler_txtprogressbar()) +tick_cap_nm <- 1000 + +nm_all <- progressr::with_progress({ + p <- progressr::progressor(steps = nrow(tasks) * tick_cap_nm) + nm_list <- future.apply::future_lapply(seq_len(nrow(tasks)), function(i) { + run_simultaneous_task(tasks$site[i], tasks$type[i], + method = "nelder_mead", x_targets = 0:5, + model_suffix = "NM", + tick = p, tick_cap = tick_cap_nm) + }, future.seed = TRUE) + dplyr::bind_rows(nm_list) +}) future::plan(future::sequential) -nm_all <- dplyr::bind_rows(nm_list) t_nm_end <- Sys.time() ``` @@ -358,19 +405,26 @@ future::plan(future::multisession, workers = min(nrow(method_tasks), max(1, parallel::detectCores() - 1))) -cmp_list <- future.apply::future_lapply(seq_len(nrow(method_tasks)), - function(i) { - run_simultaneous_task(method_tasks$site[i], method_tasks$type[i], - method = method_tasks$method[i], x_targets = 1, - model_suffix = toupper(substr( - method_tasks$method[i], 1, 2))) -}, future.seed = TRUE) +tick_cap_cmp <- 300 # eine Zelle je Task + +cmp_all <- progressr::with_progress({ + p <- progressr::progressor(steps = nrow(method_tasks) * tick_cap_cmp) + cmp_list <- future.apply::future_lapply(seq_len(nrow(method_tasks)), + function(i) { + run_simultaneous_task(method_tasks$site[i], method_tasks$type[i], + method = method_tasks$method[i], x_targets = 1, + model_suffix = toupper(substr( + method_tasks$method[i], 1, 2)), + tick = p, tick_cap = tick_cap_cmp) + }, future.seed = TRUE) + dplyr::bind_rows(cmp_list) +}) future::plan(future::sequential) methoden <- dplyr::bind_rows( dplyr::filter(nm_all, x == 1), - dplyr::bind_rows(cmp_list) + cmp_all ) t_cmp_end <- Sys.time() From d079fb327782e51d61f1cbb33929d609083fb4db Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 16:21:38 +0000 Subject: [PATCH 23/34] make_swale_runner(): one-time site master instead of full HDF5 round trip per run An Eisenstadt-only quick test still took close to an hour: the ~2 s engine time per run was dwarfed by per-run overhead - every single run copied base.h5, read ALL datasets via h5_read_values(), rewrote ALL of them via h5_write_values() (for Wien / Bad Aussee including the 15-year rain series), and spawned a new process, with Windows virus scanning on top of each new file. The runner now prepares a site master file once on first call (base.h5 + calculation settings + ET/rain time series + Growth/Shading end-time fix) and each run copies that master and writes only its ~15 small parameter datasets (geometry, storage soil preset, kf/Psi, LAI, result path; the base.h5 rain curve is cached once and rescaled only when rain_factor != 1). Written file contents are identical to before; untouched datasets now stay bit-identical to base.h5 instead of going through a read/write round trip. rain_factor stays ignored when own rain series are provided, as documented. The vignette's quick-test note states realistic timing and points to max_evals and a virus-scanner exclusion for the temp folder as the remaining levers. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 8 +- R/make_swale_runner.R | 137 ++++++++++++------ man/make_swale_runner.Rd | 9 ++ .../workflow_optimisation_simultaneous.Rmd | 7 +- 4 files changed, 114 insertions(+), 47 deletions(-) diff --git a/NEWS.md b/NEWS.md index c1ad2b0..1608afe 100644 --- a/NEWS.md +++ b/NEWS.md @@ -76,7 +76,13 @@ keep their files) — without this, long searches (hundreds of engine runs per task, each with its own `base.h5` copy plus output HDF5s) fill the temp drive and the engine dies with HDF5 `errno = 28` - ("No space left on device"). + ("No space left on device"). Prepares a **site master file** once + (base.h5 + calculation settings + ET/rain series) and writes only + the ~15 small parameter datasets per run instead of reading and + rewriting *every* dataset each time — that full HDF5 round trip + (plus process spawn and virus-scanner latency on new files) was the + dominant per-run cost of the optimisation searches, several times + the ~2 s engine time of the Eisenstadt model. - `stack_levels()`, `sickerbox_level_presets()`, `default_storage_spec()`, `default_storage_types()` — storage-layer search spaces: achievable stack heights from module heights (incl. diff --git a/R/make_swale_runner.R b/R/make_swale_runner.R index bb0335a..7a3690f 100644 --- a/R/make_swale_runner.R +++ b/R/make_swale_runner.R @@ -26,6 +26,15 @@ psi_s_mm <- function(kf_mmh) { #' ET0 curves entirely (`timeseries_rain` / `timeseries_et`, values in #' mm/h as written by the vignettes). #' +#' On the first call the runner prepares a **site master file** once: +#' `base.h5` plus everything identical for every run (calculation +#' settings, ET/rain time series). Each run then copies the master and +#' writes only its ~15 small parameter datasets. Compared to the +#' previous full read/rewrite of *all* datasets per run this removes +#' the dominant per-run overhead of the optimisation searches +#' (hundreds of runs; for Wien / Bad Aussee it skips rewriting the +#' 15-year rain series on every single engine run). +#' #' @param path_list Path definition list as used by the workflow vignettes #' (resolvable with `kwb.utils::resolve()`, must contain `path_base`, #' `path_exe`, `dir_input`, `dir_output`, `dir_target_output`, @@ -77,6 +86,60 @@ make_swale_runner <- function(path_list, debug = FALSE) { counter <- 0L + master_path <- NULL + template_rain <- NULL + + # One-time site master: base.h5 plus everything that is identical for + # every run (calculation settings, ET/rain time series). Each run then + # copies the master and writes only its ~15 small parameter datasets -- + # the full read/write cycle of all datasets (incl. multi-year curves) + # per engine run dominated the runtime of the optimisation searches. + prepare_master <- function(paths) { + mp <- file.path(paths$dir_input, + sprintf("%s_master.h5", scenario_prefix)) + fs::dir_create(paths$dir_input, recurse = TRUE) + fs::file_copy(path = paths$path_base, new_path = mp, overwrite = TRUE) + + h5m <- hdf5r::H5File$new(mp, mode = "a") + on.exit(try(h5m$close_all(), silent = TRUE), add = TRUE) + + static_vals <- list( + `//Berechnungsparameter/Zeitschritt_Infiltration` = timestep_hours, + `//Berechnungsparameter/Zeitschritt_ET` = timestep_hours, + `//Berechnungsparameter/Zeitschritt_Verschaltungen` = timestep_hours, + `//Berechnungsparameter/R-Plots` = 0, + `//Berechnungsparameter/Ausgabemodus` = "Optimierung", + `//Berechnungsparameter/Evapotranspiration_aktiv` = 1, + `//Massnahmenelemente/Dach/Berechnungsparameter/Evapotranspiration_aktiv` = 1, + `//Massnahmenelemente/Mulde_Rigole/Berechnungsparameter/Evapotranspiration_aktiv` = 1, + `//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` = 1 + ) + if (!is.null(timeseries_et)) { + static_vals$`//Kurven/ET0` <- timeseries_et + } + if (!is.null(timeseries_rain)) { + curves <- h5_read_values( + h5m, paths = c("//Kurven/Growth_1", "//Kurven/Shading_1") + ) + grow <- curves[["//Kurven/Growth_1"]] + shad <- curves[["//Kurven/Shading_1"]] + grow$time[2] <- max(timeseries_rain$time) + shad$time[2] <- max(timeseries_rain$time) + static_vals$`//Kurven/Regen` <- timeseries_rain + static_vals$`//Kurven/Growth_1` <- grow + static_vals$`//Kurven/Shading_1` <- shad + } else { + # kept for per-run rain_factor scaling (Eisenstadt variant) + template_rain <<- h5_read_values( + h5m, paths = "//Kurven/Regen" + )[["//Kurven/Regen"]] + } + + h5_write_values(h5m, static_vals, resize = TRUE, + scalar_strategy = "error", verbose = FALSE) + h5m$close_all() + master_path <<- mp + } function(params) { params <- as.list(params) @@ -101,11 +164,13 @@ make_swale_runner <- function(path_list, s_name <- sprintf("%s%05d", scenario_prefix, counter) paths <- kwb.utils::resolve(path_list, dir_target = s_name) + if (is.null(master_path)) prepare_master(paths) + fs::dir_create(paths$dir_input, recurse = TRUE) fs::dir_create(paths$dir_output, recurse = TRUE) fs::dir_create(paths$dir_target_output, recurse = TRUE) - fs::file_copy(path = paths$path_base, + fs::file_copy(path = master_path, new_path = paths$path_target_input, overwrite = TRUE) @@ -116,49 +181,33 @@ make_swale_runner <- function(path_list, normalizePath(fs::path_abs(paths$dir_target_output)), "\\" ) - vals <- h5_read_values(h5) - - vals$`//Berechnungsparameter/Ergebnispfad` <- new_path - vals$`//Berechnungsparameter/Zeitschritt_Infiltration` <- timestep_hours - vals$`//Berechnungsparameter/Zeitschritt_ET` <- timestep_hours - vals$`//Berechnungsparameter/Zeitschritt_Verschaltungen` <- timestep_hours - vals$`//Berechnungsparameter/R-Plots` <- 0 - vals$`//Berechnungsparameter/Ausgabemodus` <- "Optimierung" - vals$`//Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - - vals$`//Massnahmenelemente/Dach/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - vals$`//Massnahmenelemente/Dach/Allgemein/Flaeche` <- params$connected_area - - vals$`//Massnahmenelemente/Mulde_Rigole/Berechnungsparameter/Evapotranspiration_aktiv` <- 1 - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Regen-Skalierungsfaktor` <- 1 - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` <- params$mulde_area - vals$`//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` <- params$mulde_height - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` <- - c(0.3, st$Startwerte_theta_ActualSoilMoisture) - vals$`//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` <- - c(params$filter_height, params$storage_height) - vals$`//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` <- st$thetaWP_MoistureAtWiltingPoint - vals$`//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` <- st$thetaFC_MoistureAtFieldCapacity - vals$`//Bodenarten/Speicher/thetaS_MoistureAtSaturation` <- st$thetaS_MoistureAtSaturation - vals$`//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` <- - params$bottom_hydraulicconductivity - vals$`//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` <- lai - - vals$`//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` <- - params$filter_hydraulicconductivity - vals$`//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` <- - psi_s_mm(params$filter_hydraulicconductivity) - - if (!is.null(timeseries_et)) { - vals$`//Kurven/ET0` <- timeseries_et - } - if (!is.null(timeseries_rain)) { - vals$`//Kurven/Regen` <- timeseries_rain - vals$`//Kurven/Growth_1`$time[2] <- max(timeseries_rain$time) - vals$`//Kurven/Shading_1`$time[2] <- max(timeseries_rain$time) - } else if (is.data.frame(vals[["//Kurven/Regen"]])) { - vals[["//Kurven/Regen"]]$value <- - vals[["//Kurven/Regen"]]$value * rain_factor + vals <- list( + `//Berechnungsparameter/Ergebnispfad` = new_path, + `//Massnahmenelemente/Dach/Allgemein/Flaeche` = params$connected_area, + `//Massnahmenelemente/Mulde_Rigole/Allgemein/Flaeche` = params$mulde_area, + `//Massnahmenelemente/Mulde_Rigole/Eigenschaften_Oberflaeche/Ueberlaufhoehe` = params$mulde_height, + `//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Startwerte_theta_ActualSoilMoisture` = + c(0.3, st$Startwerte_theta_ActualSoilMoisture), + `//Massnahmenelemente/Mulde_Rigole/Bodenschichtung/Schichtdicken` = + c(params$filter_height, params$storage_height), + `//Bodenarten/Speicher/thetaWP_MoistureAtWiltingPoint` = st$thetaWP_MoistureAtWiltingPoint, + `//Bodenarten/Speicher/thetaFC_MoistureAtFieldCapacity` = st$thetaFC_MoistureAtFieldCapacity, + `//Bodenarten/Speicher/thetaS_MoistureAtSaturation` = st$thetaS_MoistureAtSaturation, + `//Massnahmenelemente/Mulde_Rigole/Allgemein/Endversickerungsrate` = + params$bottom_hydraulicconductivity, + `//Massnahmenelemente/Mulde_Rigole/Parameter_Evapotranspiration/LAI_LeafAreaIndex` = lai, + `//Bodenarten/Bodenfilter/Ks_HydraulicConductivity` = + params$filter_hydraulicconductivity, + `//Bodenarten/Bodenfilter/Psi_Saugspannung_CapillarySuction` = + psi_s_mm(params$filter_hydraulicconductivity) + ) + # rain_factor is documented to be ignored when own rain series are + # written (timeseries_rain); it scales the base.h5 curve otherwise + if (is.null(timeseries_rain) && rain_factor != 1 && + is.data.frame(template_rain)) { + scaled <- template_rain + scaled$value <- scaled$value * rain_factor + vals$`//Kurven/Regen` <- scaled } h5_write_values(h5, vals, resize = TRUE, diff --git a/man/make_swale_runner.Rd b/man/make_swale_runner.Rd index 4f1d88e..60f0278 100644 --- a/man/make_swale_runner.Rd +++ b/man/make_swale_runner.Rd @@ -78,6 +78,15 @@ rain curve shipped in \code{base.h5} by \code{rain_factor} (leave \code{timeseries_rain} = \code{NULL}), Wien and Bad Aussee replace the rain and ET0 curves entirely (\code{timeseries_rain} / \code{timeseries_et}, values in mm/h as written by the vignettes). + +On the first call the runner prepares a \strong{site master file} once: +\code{base.h5} plus everything identical for every run (calculation +settings, ET/rain time series). Each run then copies the master and +writes only its ~15 small parameter datasets. Compared to the +previous full read/rewrite of \emph{all} datasets per run this removes +the dominant per-run overhead of the optimisation searches +(hundreds of runs; for Wien / Bad Aussee it skips rewriting the +15-year rain series on every single engine run). } \seealso{ \code{\link[=optimise_swale_design]{optimise_swale_design()}}, \code{\link[=find_min_feasible]{find_min_feasible()}} diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index f7a5bb2..d4328ba 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -134,8 +134,11 @@ sites <- list( BadAussee = list(dir = "badaussee", timeseries = TRUE, prior = "simulation_results_optimisation_BadAussee.csv") ) -# Schneller Funktionstest (~10-15 min statt Stunden): nur Eisenstadt -- -# 1-Jahres-Modell, ~2 s je Engine-Lauf: +# Schneller Funktionstest (~15-30 min statt Stunden): nur Eisenstadt -- +# 1-Jahres-Modell, ~2 s je Engine-Lauf. Zusaetzlich beschleunigt ein +# reduziertes Budget (z. B. max_evals <- 50) und, auf Windows deutlich, +# eine Virenscanner-Ausnahme fuer %LOCALAPPDATA%\Temp (jede Szenario- +# Datei und jeder Engine-Start wird sonst einzeln gescannt): # sites <- sites["Eisenstadt_2005"] fixed <- list(connected_area = 1000, From a9a0b21e150b7e1cf169a528c5431b4abc57814f Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 16:48:50 +0000 Subject: [PATCH 24/34] Lattice polish: boundary-slide and floor-probe candidates Comparing the Eisenstadt quick-test results against the bisection showed the simultaneous NM optimiser landing up to 8.8% above the bisection optimum in three cells (box x=0, trench x=0, trench x=5). Two structural gaps in the polish, not search-budget issues: - it could only step each axis straight down, so it could not slide ALONG the feasibility boundary (trade the expensive lever, area, down against the cheap one, mulde_height, up) - box x=0 got stuck at (61 m2, depth 200) where (55 m2, depth 300) is cheaper - single steps could not cross a +1 counting-wobble band even when the whole lower mulde_height range is feasible again below it (trench x=5: stuck at depth 270 while depth 100 is feasible and ~800 EUR cheaper) Each polish round now additionally proposes a boundary slide (area - step, mulde_height at its maximum) and a mulde_height floor probe (area, height_bounds[1]) - both plain evaluated candidates, so no monotonicity assumption enters the simultaneous optimiser. On the synthetic brute-force benchmark all three methods now converge to the same lattice optimum (worst ratio 1.012, previously NM 1.016 / DE 1.028 / Halton 1.081) at ~12% more runs for NM, and a synthetic wobble-band scenario lands within 0.9% of the reference. 160 tests green. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 7 ++++- R/optimise_swale_design_simultaneous.R | 31 ++++++++++++++++++++--- man/optimise_swale_design_simultaneous.Rd | 13 +++++++--- 3 files changed, 44 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index 1608afe..56bf8c1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -47,7 +47,12 @@ (accelerated 8/4/2/1-tolerance pattern descent from the cheapest feasible design of every storage level visited, capped at the 6 cheapest levels for the continuous gravel trench — the storage axis - separates cost valleys that single coordinate steps cannot cross): + separates cost valleys that single coordinate steps cannot cross; + each round also proposes a *boundary slide* — area down with + `mulde_height` at its maximum, the two-coordinate trade towards the + cheap end of the feasibility boundary — and a `mulde_height` *floor + probe* that jumps over +1 counting-wobble bands, both plain + evaluated candidates without any monotonicity assumption): `"nelder_mead"` (default; deterministic multistart via `stats::optim()` — prior warm start, previous-target optimum, one anchor start per storage level, space-filling points; every start diff --git a/R/optimise_swale_design_simultaneous.R b/R/optimise_swale_design_simultaneous.R index 837e002..076d28a 100644 --- a/R/optimise_swale_design_simultaneous.R +++ b/R/optimise_swale_design_simultaneous.R @@ -121,9 +121,16 @@ make_lcg <- function(seed) { #' visited -- capped at the 6 cheapest levels, which only bites for #' the continuous gravel trench (the discrete box has at most a #' handful) -- because the storage axis separates cost valleys that -#' single coordinate steps cannot cross. It stops when no parameter -#' can be reduced any further: the result is locally optimal on the -#' tolerance lattice, whatever the search method delivered. +#' single coordinate steps cannot cross. Besides the per-axis down +#' steps each round proposes a \emph{boundary slide} (area down with +#' `mulde_height` at its maximum -- the two-coordinate trade towards +#' the cheap end of the feasibility boundary) and a +#' \emph{mulde_height floor probe} (at large `x` the overflow count +#' saturates, so the whole lower height range can be feasible even +#' when a +1 counting wobble blocks every single step). All are just +#' evaluated candidates -- no monotonicity assumption enters. The +#' result is locally optimal on the tolerance lattice, whatever the +#' search method delivered. #' } #' #' The discrete infiltration-box levels are mapped onto a continuous @@ -596,6 +603,24 @@ optimise_swale_design_simultaneous <- function(run_fn, list(area = cur$area, h_m = cur$h_m, h_s = h_s_down) )) } + # slide along the feasibility boundary: trade the expensive + # lever (area) down against the cheap one (mulde_height) at its + # maximum -- a two-coordinate move the axis steps cannot make + hm_up <- hm_upper(cur$h_s) + if (a_down < cur$area - 1e-9 && hm_up > cur$h_m + 1e-9) { + candidates <- c(candidates, list( + list(area = a_down, h_m = hm_up, h_s = cur$h_s) + )) + } + # floor probe: at large x the overflow count saturates, so the + # whole lower mulde_height range can be feasible even when a +1 + # counting wobble blocks every single step below the current + # value (cached after the first evaluation) + if (cur$h_m > height_bounds[1] + 1e-9) { + candidates <- c(candidates, list( + list(area = cur$area, h_m = height_bounds[1], h_s = cur$h_s) + )) + } improved <- FALSE for (p in candidates) { r <- consider(p$area, p$h_m, p$h_s) diff --git a/man/optimise_swale_design_simultaneous.Rd b/man/optimise_swale_design_simultaneous.Rd index 88cc6fc..7034f59 100644 --- a/man/optimise_swale_design_simultaneous.Rd +++ b/man/optimise_swale_design_simultaneous.Rd @@ -152,9 +152,16 @@ runs from the cheapest feasible design of every storage level visited -- capped at the 6 cheapest levels, which only bites for the continuous gravel trench (the discrete box has at most a handful) -- because the storage axis separates cost valleys that -single coordinate steps cannot cross. It stops when no parameter -can be reduced any further: the result is locally optimal on the -tolerance lattice, whatever the search method delivered. +single coordinate steps cannot cross. Besides the per-axis down +steps each round proposes a \emph{boundary slide} (area down with +\code{mulde_height} at its maximum -- the two-coordinate trade towards +the cheap end of the feasibility boundary) and a +\emph{mulde_height floor probe} (at large \code{x} the overflow count +saturates, so the whole lower height range can be feasible even +when a +1 counting wobble blocks every single step). All are just +evaluated candidates -- no monotonicity assumption enters. The +result is locally optimal on the tolerance lattice, whatever the +search method delivered. } The discrete infiltration-box levels are mapped onto a continuous From 148aadc987b8f18b253bafa61de48d67dda54d1a Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 17:07:54 +0000 Subject: [PATCH 25/34] Document the cost hierarchy hard-coded in the bisection search order The bisection makes two distinct assumptions, and only one was documented: besides hydraulic monotonicity (needed for interval halving, immune to cost changes) its search ORDER encodes a cost hierarchy - shrink area first at maximum depth, escalate storage only when area is pinned at its bound, shrink depth last. That order picks the corner of the feasibility boundary that is optimal for the default rates (per mm of capacity and m2: depth ~0.07 EUR, box storage ~0.44 EUR, area pays all four cost components at once); cost_rates only prices the found designs afterwards, it does not steer the search. With strongly different rates the optimal corner moves to places the order never visits: with box material at 5 EUR/m3 the bisection returns 20832 EUR (155 m2, storage 300) where the simultaneous search - which carries cost_rates inside its objective - finds 12682 EUR (63 m2, storage 1200), 39% cheaper. Added as a regression test. Docs now state this in optimise_swale_design(), the bisection vignette's cost-rates section, and the simultaneous vignette's Einordnung, which also distinguishes the two causes of "simultaneous systematically cheaper": violated monotonicity (model alarm) vs. a cost hierarchy that no longer matches the chosen rates (use the simultaneous optimiser as the primary method for cost sensitivity studies). 164 tests green. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- R/optimise_swale_design.R | 13 ++++++++++ man/optimise_swale_design.Rd | 14 ++++++++++ .../test-optimise_swale_design_simultaneous.R | 26 +++++++++++++++++++ vignettes/workflow_optimisation.Rmd | 10 ++++++- .../workflow_optimisation_simultaneous.Rmd | 15 +++++++++++ 5 files changed, 77 insertions(+), 1 deletion(-) diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index f5722a0..234bffd 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -40,6 +40,19 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' engine run is cached, so the sweep over all `x_targets` and both storage #' types shares evaluations. #' +#' **The search order hard-codes a cost hierarchy** (per mm of storage +#' capacity and m2 of swale, at the default rates: `mulde_height` costs +#' only excavation ~0.07 EUR, box storage ~0.44 EUR, and `mulde_area` +#' pays all four cost components at once). It picks the corner of the +#' feasibility boundary that is optimal *for rates in the neighbourhood +#' of [default_cost_rates()]* -- `cost_rates` only prices the found +#' designs afterwards, it does not steer the search. For strongly +#' different rates (e.g. cheap storage material, expensive excavation) +#' the cost-optimal corner moves and this optimiser will systematically +#' miss it; use [optimise_swale_design_simultaneous()] -- which carries +#' `cost_rates` inside its objective -- as the primary method for cost +#' sensitivity studies. +#' #' @param run_fn `function(params)` running one scenario and returning at #' least `n_overflows` plus `sum_overflows` (mm) or `overflow_volume_m3`; #' typically created with [make_swale_runner()]. `params` is a named list diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index 20b877b..3cbb02c 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -83,6 +83,20 @@ cost-free and dominant, see the \code{monotonicity_analysis} vignette). Every engine run is cached, so the sweep over all \code{x_targets} and both storage types shares evaluations. } +\details{ +\strong{The search order hard-codes a cost hierarchy} (per mm of storage +capacity and m2 of swale, at the default rates: \code{mulde_height} costs +only excavation ~0.07 EUR, box storage ~0.44 EUR, and \code{mulde_area} +pays all four cost components at once). It picks the corner of the +feasibility boundary that is optimal \emph{for rates in the neighbourhood +of \code{\link[=default_cost_rates]{default_cost_rates()}}} -- \code{cost_rates} only prices the found +designs afterwards, it does not steer the search. For strongly +different rates (e.g. cheap storage material, expensive excavation) +the cost-optimal corner moves and this optimiser will systematically +miss it; use \code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}} -- which carries +\code{cost_rates} inside its objective -- as the primary method for cost +sensitivity studies. +} \seealso{ \code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}} (alternative: all parameters at once via penalised Nelder-Mead, as an independent diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R index 67c82c6..5a8f057 100644 --- a/tests/testthat/test-optimise_swale_design_simultaneous.R +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -220,6 +220,32 @@ test_that("Ergebnis traegt die Attribute evaluations und n_runs_total", { expect_identical(attr(out, "n_runs_total"), nrow(ev)) }) +test_that("simultane Suche folgt veraenderten Kostensaetzen, Bisektion nicht", { + # Die Bisektions-Reihenfolge (Flaeche zuerst, Speicher nur im + # Notfall) kodiert die Default-Kostenhierarchie; cost_rates bepreist + # dort nur nachtraeglich. Bei sehr billigem Speichermaterial liegt + # das Optimum bei hoher Speicherstufe + kleiner Flaeche -- eine Ecke, + # die die Bisektion nie besucht, die simultane Suche (cost_rates in + # der Zielfunktion) aber findet. + run <- sim_run_factory(demand = 3.6e5) + cheap_box <- default_cost_rates() + cheap_box$infiltration_box_eur_per_m3 <- 5 + spec <- default_storage_spec()["infiltration_box"] + + bis <- optimise_swale_design(run, x_targets = 0, fixed = sim_fixed, + storage_spec = spec, + cost_rates = cheap_box, verbose = FALSE) + sim <- optimise_swale_design_simultaneous(run, x_targets = 0, + fixed = sim_fixed, + storage_spec = spec, + cost_rates = cheap_box, + verbose = FALSE) + expect_identical(bis$status, "ok") + expect_identical(sim$status, "ok") + expect_gt(sim$storage_height, bis$storage_height) + expect_lt(sim$cost_total, bis$cost_total * 0.95) +}) + test_that("alle Methoden funktionieren mit Ein-Typ-storage_spec", { run <- sim_run_factory(demand = 3.6e5) for (m in c("nelder_mead", "diff_evolution", "halton_search")) { diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index 63c3285..ddab109 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -180,7 +180,15 @@ knitr::kable(tibble::tibble( Die Kostensätze sind die Defaults nach Leimgruber (2026-03-27, `default_cost_rates()`); einzelne Sätze lassen sich hier überschreiben — -gerechnet wird zunächst mit den Defaults: +gerechnet wird zunächst mit den Defaults. **Achtung bei stark +veränderten Sätzen:** Die Suchreihenfolge der Bisektion (Fläche zuerst, +Tiefe zuletzt, Speicher nur im Notfall) kodiert die Kostenhierarchie +der *Default*-Sätze; `cost_rates` bepreist hier nur die gefundenen +Designs, lenkt aber nicht die Suche. Wer z. B. den Speicher deutlich +verbilligt oder den Aushub verteuert, verschiebt das Optimum in Ecken, +die diese Reihenfolge nie besucht — für Kosten-Sensitivitätsanalysen +die Vignette `workflow_optimisation_simultaneous` verwenden (dort +stecken die Sätze in der Zielfunktion): ```{r cost_rates, eval = can_run} cost_rates <- default_cost_rates() diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index d4328ba..0a268cc 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -468,6 +468,21 @@ ggplot(methoden[methoden$status == "ok", ], gegenseitig, wenn ihre Kosten je Zelle nur um wenige Prozent differieren — dann ist das Optimum eine Eigenschaft des Problems, nicht des Suchwegs. +- **Wenn die simultane Suche systematisch günstiger ist**, gibt es zwei + mögliche Ursachen: (a) die Monotonie-Annahme der Bisektion ist + verletzt (echter Modell-Alarm → `monotonicity_analysis` prüfen), oder + (b) die **Kostenhierarchie**, die in der Bisektions-*Reihenfolge* + steckt (Fläche teuerster Hebel → zuerst schrumpfen; Tiefe billigster + → zuletzt; Speicher nur im Notfall eskalieren), passt nicht mehr zu + den gewählten `cost_rates`. Die Reihenfolge ist für die + Default-Sätze richtig (je mm Kapazität und m²: Tiefe ~0.07 €, + Box-Speicher ~0.44 €, Fläche zahlt alle Terme zugleich), aber z. B. + bei sehr billigem Speichermaterial wandert das Optimum zu "hoher + Speicher + kleine Fläche" — eine Ecke, die die Bisektion nie besucht. + Die simultane Suche trägt die `cost_rates` in ihrer Zielfunktion und + folgt jeder Hierarchie automatisch: **für + Kosten-Sensitivitätsanalysen ist sie das primäre Verfahren**, nicht + die Gegenprobe. - **`monotonicity_warning = TRUE`** heißt hier: Unter den Evaluationen der Zelle liegt ein *strikt größeres* Design mit mehr Überläufen *und* mehr Überlaufvolumen — echte Nicht-Monotonie; dann verdient die From 09bd3a70e82d7dc5f50048aaa73f4112e82d6fb8 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 5 Aug 2026 17:17:58 +0000 Subject: [PATCH 26/34] Derive the bisection search order from cost_rates (specific-cost proxy) Follow-up to documenting the hard-coded cost hierarchy: for the current three levers the order does not need to be hard-coded at all. With the capacity model V ~ area * (mulde_height + porosity * storage_height) and every cost component proportional to area, each lever has a marginal cost per mm of capacity, the area cancels out of the comparison, and the cost-optimal corner of the feasibility boundary is computable analytically from the rates: - maximising mulde_height first is optimal for ANY rates under this cost model (it costs only excavation while area pays all four components plus the capacity-free filter depth) - so that part of the order is now provably rates-independent, not assumed - the starting storage level is the rate-dependent choice: solve_cell picks the level with minimal specific cost (EUR per mm capacity) instead of always the smallest; the continuous trench compares its endpoints (linear-fractional, endpoint-optimal). Under default rates the proxy picks the smallest level, reproducing the previous behaviour exactly. default_storage_spec() now carries the layer porosity (box 0.95, trench 0.3) that the proxy needs; specs without it keep the legacy order. With box material at 5 EUR/m3 the bisection now finds the 63 m2 / storage 1200 corner for 12.7k EUR in 15 runs - previously 20.8k EUR (155 m2 / storage 300), and on par with the simultaneous optimiser's 12.7k EUR at ~130 runs. The regression test now asserts both optimisers agree under changed rates, the legacy fallback, and unchanged default-rate behaviour. The proxy is first-order and only ranks capacity-additive levers - parameters with nonlinear hydraulic effects (e.g. variable filter kf) remain the domain of the simultaneous optimiser; docs and both vignettes updated accordingly. 167 tests green. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 22 +++++-- R/optimise_swale_design.R | 62 ++++++++++++++----- R/stack_levels.R | 18 ++++-- man/default_storage_spec.Rd | 13 +++- man/optimise_swale_design.Rd | 28 +++++---- .../test-optimise_swale_design_simultaneous.R | 32 +++++++--- vignettes/workflow_optimisation.Rmd | 19 +++--- .../workflow_optimisation_simultaneous.Rmd | 22 +++---- 8 files changed, 150 insertions(+), 66 deletions(-) diff --git a/NEWS.md b/NEWS.md index 56bf8c1..eb34a0f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,10 +20,24 @@ 5 112 validation comparisons). An optional `split_jitter` randomises the bisection split point — a Monte-Carlo of the search path (repeated runs with different seeds must agree within `tol`). - - `optimise_swale_design()` — coordinate descent in cost order: shrink - `mulde_area` (the expensive lever) first, then `mulde_height` (the - cheap one); the storage layer starts at its smallest level and is - escalated only when the area is stuck at its upper bound. One shared + - `optimise_swale_design()` — coordinate descent whose **search order + is derived from `cost_rates`** via a specific-cost proxy (EUR per + mm of storage capacity, capacity model V ≈ area × (mulde_height + + porosity × storage_height); porosity from `default_storage_spec()`): + maximising `mulde_height` first is provably optimal for any rates + under this cost model, and the starting storage level is the + cheapest level per mm of capacity — the smallest under the default + rates, a high level when e.g. the storage material is cheap (with + box material at 5 EUR/m³ this finds the 63 m²/1200 mm corner for + 12.7k EUR in 15 runs, where the fixed legacy order returned 155 m²/ + 300 mm for 20.8k EUR; regression-tested against the simultaneous + optimiser). Specs without a `porosity` entry keep the legacy order; + the proxy assumes capacity-additive levers, so parameters with + nonlinear hydraulic effects remain the domain of + `optimise_swale_design_simultaneous()`. Within a cell the descent + then runs: minimal feasible `mulde_area` at maximal `mulde_height` + on the chosen storage level, storage escalated only when the area + is stuck at its upper bound, `mulde_height` shrunk last. One shared evaluation cache spans all `x_targets` and both storage types (a run classifies itself for every target at once), warm-start brackets are derived from prior brute-force results (CSV schema of the diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index 234bffd..8af028e 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -40,18 +40,22 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' engine run is cached, so the sweep over all `x_targets` and both storage #' types shares evaluations. #' -#' **The search order hard-codes a cost hierarchy** (per mm of storage -#' capacity and m2 of swale, at the default rates: `mulde_height` costs -#' only excavation ~0.07 EUR, box storage ~0.44 EUR, and `mulde_area` -#' pays all four cost components at once). It picks the corner of the -#' feasibility boundary that is optimal *for rates in the neighbourhood -#' of [default_cost_rates()]* -- `cost_rates` only prices the found -#' designs afterwards, it does not steer the search. For strongly -#' different rates (e.g. cheap storage material, expensive excavation) -#' the cost-optimal corner moves and this optimiser will systematically -#' miss it; use [optimise_swale_design_simultaneous()] -- which carries -#' `cost_rates` inside its objective -- as the primary method for cost -#' sensitivity studies. +#' **The search order is derived from `cost_rates`** via a +#' specific-cost proxy (EUR per mm of storage capacity, capacity model +#' `V ~ area * (mulde_height + porosity * storage_height)`; the layer +#' porosity comes from `storage_spec`, see [default_storage_spec()]): +#' maximising `mulde_height` first is optimal for *any* rates under +#' this cost model (it costs only excavation, while area pays every +#' component), and the starting storage level is chosen as the +#' cheapest level per mm of capacity -- the smallest level under the +#' default rates, a high level when e.g. the storage material is cheap. +#' Without a `porosity` entry in `storage_spec` the legacy order +#' (smallest level first) is used. The proxy is a first-order +#' heuristic: it assumes capacity-additive levers and cannot rank +#' parameters with nonlinear hydraulic effects (e.g. a variable filter +#' conductivity) -- for those, and as the assumption-free cross-check, +#' use [optimise_swale_design_simultaneous()], which carries +#' `cost_rates` directly inside its objective. #' #' @param run_fn `function(params)` running one scenario and returning at #' least `n_overflows` plus `sum_overflows` (mm) or `overflow_volume_m3`; @@ -199,11 +203,40 @@ optimise_swale_design <- function(run_fn, n_runs_new = runs_executed - runs_before ) + # start storage level: derived from the cost rates when the spec + # carries the layer porosity -- the cheapest level per mm of storage + # capacity (capacity model V ~ area * (h_m + porosity * h_s), all + # cost terms ~ area, so the area cancels out of the comparison). + # Under the default rates this picks the smallest level (storage is + # the expensive lever); under e.g. cheap storage material it starts + # high where coordinate descent would otherwise never look. Without + # a porosity entry: legacy order (smallest level first). + choose_start_hs <- function(candidates) { + p <- spec$porosity + storage_rate <- switch( + type, + infiltration_box = cost_rates$infiltration_box_eur_per_m3, + gravel_trench = cost_rates$gravel_trench_eur_per_m3 + ) + if (is.null(p) || is.null(storage_rate)) return(min(candidates)) + sc <- vapply(candidates, function(s) { + hm <- hm_upper(s) + if (hm < height_bounds[1]) return(Inf) + f <- cost_rates$excavation_eur_per_m3 * + (hm + filter_height + s) / 1000 + + cost_rates$profiling_eur_per_m2 + + cost_rates$filter_eur_per_m3 * filter_height / 1000 + + storage_rate * s / 1000 + f / (hm + p * s) + }, numeric(1)) + candidates[which.min(sc)] + } + if (discrete) { levels_all <- sort(spec$levels) levels_all <- levels_all[hm_upper(levels_all) >= height_bounds[1]] if (length(levels_all) == 0) return(infeasible_row()) - h_s <- levels_all[1] + h_s <- choose_start_hs(levels_all) } else { gb <- spec$bounds if (!is.null(max_total_depth)) { @@ -213,7 +246,8 @@ optimise_swale_design <- function(run_fn, # admissible storage height), only gb[2] < gb[1] is infeasible if (gb[2] < gb[1]) return(infeasible_row()) gravel_tol <- if (is.null(spec$tol)) 25 else spec$tol - h_s <- gb[1] + # linear-fractional in h_s -> the proxy optimum is at an endpoint + h_s <- choose_start_hs(c(gb[1], gb[2])) } a_star <- NA_real_ diff --git a/R/stack_levels.R b/R/stack_levels.R index b13562a..de0698b 100644 --- a/R/stack_levels.R +++ b/R/stack_levels.R @@ -66,23 +66,33 @@ sickerbox_level_presets <- function(max_height = 2600) { #' `coupling_factor` (default 3, approximating the usable-porosity ratio #' 0.95 / 0.3). #' +#' Each entry also carries the **usable porosity** of the storage layer +#' (box 0.95, trench 0.3, matching [default_storage_types()]). The +#' bisection optimiser uses it to *derive* its search order from the +#' cost rates (cost per mm of storage capacity); without a `porosity` +#' entry it falls back to the default-rate hierarchy (smallest storage +#' level first). +#' #' @param levels Numeric vector of infiltration-box stack heights in mm. #' @param coupling_factor Factor between gravel-trench bounds and the box #' level range. #' @param gravel_tol Bisection tolerance for the continuous gravel-trench #' height in mm. #' -#' @return Named list with entries `infiltration_box` (with `levels`) and -#' `gravel_trench` (with `bounds` and `tol`). +#' @return Named list with entries `infiltration_box` (with `levels` and +#' `porosity`) and `gravel_trench` (with `bounds`, `tol` and +#' `porosity`). #' #' @export default_storage_spec <- function(levels = sickerbox_level_presets()$brute_force, coupling_factor = 3, gravel_tol = 25) { list( - infiltration_box = list(levels = sort(unique(levels))), + infiltration_box = list(levels = sort(unique(levels)), + porosity = 0.95), gravel_trench = list(bounds = coupling_factor * range(levels), - tol = gravel_tol) + tol = gravel_tol, + porosity = 0.3) ) } diff --git a/man/default_storage_spec.Rd b/man/default_storage_spec.Rd index 6e7347a..4f26657 100644 --- a/man/default_storage_spec.Rd +++ b/man/default_storage_spec.Rd @@ -20,8 +20,9 @@ level range.} height in mm.} } \value{ -Named list with entries \code{infiltration_box} (with \code{levels}) and -\code{gravel_trench} (with \code{bounds} and \code{tol}). +Named list with entries \code{infiltration_box} (with \code{levels} and +\code{porosity}) and \code{gravel_trench} (with \code{bounds}, \code{tol} and +\code{porosity}). } \description{ Storage-layer search space per storage type: the infiltration box uses @@ -30,3 +31,11 @@ trench is continuous with bounds coupled to the box level range by \code{coupling_factor} (default 3, approximating the usable-porosity ratio 0.95 / 0.3). } +\details{ +Each entry also carries the \strong{usable porosity} of the storage layer +(box 0.95, trench 0.3, matching \code{\link[=default_storage_types]{default_storage_types()}}). The +bisection optimiser uses it to \emph{derive} its search order from the +cost rates (cost per mm of storage capacity); without a \code{porosity} +entry it falls back to the default-rate hierarchy (smallest storage +level first). +} diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index 3cbb02c..b2deadc 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -84,18 +84,22 @@ engine run is cached, so the sweep over all \code{x_targets} and both storage types shares evaluations. } \details{ -\strong{The search order hard-codes a cost hierarchy} (per mm of storage -capacity and m2 of swale, at the default rates: \code{mulde_height} costs -only excavation ~0.07 EUR, box storage ~0.44 EUR, and \code{mulde_area} -pays all four cost components at once). It picks the corner of the -feasibility boundary that is optimal \emph{for rates in the neighbourhood -of \code{\link[=default_cost_rates]{default_cost_rates()}}} -- \code{cost_rates} only prices the found -designs afterwards, it does not steer the search. For strongly -different rates (e.g. cheap storage material, expensive excavation) -the cost-optimal corner moves and this optimiser will systematically -miss it; use \code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}} -- which carries -\code{cost_rates} inside its objective -- as the primary method for cost -sensitivity studies. +\strong{The search order is derived from \code{cost_rates}} via a +specific-cost proxy (EUR per mm of storage capacity, capacity model +\code{V ~ area * (mulde_height + porosity * storage_height)}; the layer +porosity comes from \code{storage_spec}, see \code{\link[=default_storage_spec]{default_storage_spec()}}): +maximising \code{mulde_height} first is optimal for \emph{any} rates under +this cost model (it costs only excavation, while area pays every +component), and the starting storage level is chosen as the +cheapest level per mm of capacity -- the smallest level under the +default rates, a high level when e.g. the storage material is cheap. +Without a \code{porosity} entry in \code{storage_spec} the legacy order +(smallest level first) is used. The proxy is a first-order +heuristic: it assumes capacity-additive levers and cannot rank +parameters with nonlinear hydraulic effects (e.g. a variable filter +conductivity) -- for those, and as the assumption-free cross-check, +use \code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}}, which carries +\code{cost_rates} directly inside its objective. } \seealso{ \code{\link[=optimise_swale_design_simultaneous]{optimise_swale_design_simultaneous()}} (alternative: all diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R index 5a8f057..7ccb8c7 100644 --- a/tests/testthat/test-optimise_swale_design_simultaneous.R +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -220,13 +220,13 @@ test_that("Ergebnis traegt die Attribute evaluations und n_runs_total", { expect_identical(attr(out, "n_runs_total"), nrow(ev)) }) -test_that("simultane Suche folgt veraenderten Kostensaetzen, Bisektion nicht", { - # Die Bisektions-Reihenfolge (Flaeche zuerst, Speicher nur im - # Notfall) kodiert die Default-Kostenhierarchie; cost_rates bepreist - # dort nur nachtraeglich. Bei sehr billigem Speichermaterial liegt - # das Optimum bei hoher Speicherstufe + kleiner Flaeche -- eine Ecke, - # die die Bisektion nie besucht, die simultane Suche (cost_rates in - # der Zielfunktion) aber findet. +test_that("beide Optimierer folgen veraenderten Kostensaetzen", { + # Bei sehr billigem Speichermaterial liegt das Optimum bei hoher + # Speicherstufe + kleiner Flaeche. Die simultane Suche traegt die + # cost_rates in der Zielfunktion; die Bisektion leitet ihre + # Start-Speicherstufe seit dem Spezifikkosten-Proxy ebenfalls aus den + # Saetzen ab (statt stur bei der kleinsten Stufe zu starten) -- beide + # muessen die billige Ecke finden und eng beieinander liegen. run <- sim_run_factory(demand = 3.6e5) cheap_box <- default_cost_rates() cheap_box$infiltration_box_eur_per_m3 <- 5 @@ -242,8 +242,22 @@ test_that("simultane Suche folgt veraenderten Kostensaetzen, Bisektion nicht", { verbose = FALSE) expect_identical(bis$status, "ok") expect_identical(sim$status, "ok") - expect_gt(sim$storage_height, bis$storage_height) - expect_lt(sim$cost_total, bis$cost_total * 0.95) + expect_identical(bis$storage_height, 1200) + expect_identical(sim$storage_height, 1200) + expect_lt(abs(sim$cost_total - bis$cost_total), 0.05 * bis$cost_total) + + # ohne porosity-Eintrag: Legacy-Reihenfolge (kleinste Stufe zuerst) + spec_legacy <- spec + spec_legacy$infiltration_box$porosity <- NULL + leg <- optimise_swale_design(run, x_targets = 0, fixed = sim_fixed, + storage_spec = spec_legacy, + cost_rates = cheap_box, verbose = FALSE) + expect_identical(leg$storage_height, 300) + + # unter Default-Saetzen waehlt der Proxy weiterhin die kleinste Stufe + def <- optimise_swale_design(run, x_targets = 0, fixed = sim_fixed, + storage_spec = spec, verbose = FALSE) + expect_identical(def$storage_height, 300) }) test_that("alle Methoden funktionieren mit Ein-Typ-storage_spec", { diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index ddab109..f7a9128 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -180,15 +180,16 @@ knitr::kable(tibble::tibble( Die Kostensätze sind die Defaults nach Leimgruber (2026-03-27, `default_cost_rates()`); einzelne Sätze lassen sich hier überschreiben — -gerechnet wird zunächst mit den Defaults. **Achtung bei stark -veränderten Sätzen:** Die Suchreihenfolge der Bisektion (Fläche zuerst, -Tiefe zuletzt, Speicher nur im Notfall) kodiert die Kostenhierarchie -der *Default*-Sätze; `cost_rates` bepreist hier nur die gefundenen -Designs, lenkt aber nicht die Suche. Wer z. B. den Speicher deutlich -verbilligt oder den Aushub verteuert, verschiebt das Optimum in Ecken, -die diese Reihenfolge nie besucht — für Kosten-Sensitivitätsanalysen -die Vignette `workflow_optimisation_simultaneous` verwenden (dort -stecken die Sätze in der Zielfunktion): +gerechnet wird zunächst mit den Defaults. Die Suchreihenfolge der +Bisektion wird dabei **aus den Sätzen hergeleitet** (Spezifikkosten-Proxy: +€ je mm Speicherkapazität, Kapazitätsmodell V ≈ Fläche × (Tiefe + +Porosität × Speicher); die Porosität liefert `default_storage_spec()`): +Die Muldentiefe zu maximieren ist unter diesem Kostenmodell für *jeden* +Satz optimal, die Start-Speicherstufe wählt der Proxy — kleinste Stufe +bei den Default-Sätzen, hohe Stufe z. B. bei billigem Speichermaterial. +Der Proxy ist eine Näherung erster Ordnung (kapazitäts-additive Hebel); +die annahmefreie Gegenprobe — und das Mittel der Wahl bei nichtlinearen +Hebeln — bleibt die Vignette `workflow_optimisation_simultaneous`: ```{r cost_rates, eval = can_run} cost_rates <- default_cost_rates() diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index 0a268cc..6f8a613 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -471,18 +471,16 @@ ggplot(methoden[methoden$status == "ok", ], - **Wenn die simultane Suche systematisch günstiger ist**, gibt es zwei mögliche Ursachen: (a) die Monotonie-Annahme der Bisektion ist verletzt (echter Modell-Alarm → `monotonicity_analysis` prüfen), oder - (b) die **Kostenhierarchie**, die in der Bisektions-*Reihenfolge* - steckt (Fläche teuerster Hebel → zuerst schrumpfen; Tiefe billigster - → zuletzt; Speicher nur im Notfall eskalieren), passt nicht mehr zu - den gewählten `cost_rates`. Die Reihenfolge ist für die - Default-Sätze richtig (je mm Kapazität und m²: Tiefe ~0.07 €, - Box-Speicher ~0.44 €, Fläche zahlt alle Terme zugleich), aber z. B. - bei sehr billigem Speichermaterial wandert das Optimum zu "hoher - Speicher + kleine Fläche" — eine Ecke, die die Bisektion nie besucht. - Die simultane Suche trägt die `cost_rates` in ihrer Zielfunktion und - folgt jeder Hierarchie automatisch: **für - Kosten-Sensitivitätsanalysen ist sie das primäre Verfahren**, nicht - die Gegenprobe. + (b) der **Spezifikkosten-Proxy**, aus dem die Bisektion ihre + Suchreihenfolge herleitet (€ je mm Speicherkapazität, Kapazitätsmodell + V ≈ Fläche × (Tiefe + Porosität × Speicher)), greift zu kurz — etwa + weil ein Hebel nicht kapazitäts-additiv wirkt (z. B. eine variable + Filterdurchlässigkeit, die die Hydraulik nichtlinear verändert) oder + das Kapazitätsmodell die Standort-Hydraulik schlecht beschreibt. Die + simultane Suche trägt die `cost_rates` direkt in ihrer Zielfunktion + und braucht weder Proxy noch Kapazitätsmodell: Sie ist die + annahmefreie Instanz und **das primäre Verfahren, sobald Parameter + ohne saubere Grenzkosten-je-Kapazität ins Spiel kommen**. - **`monotonicity_warning = TRUE`** heißt hier: Unter den Evaluationen der Zelle liegt ein *strikt größeres* Design mit mehr Überläufen *und* mehr Überlaufvolumen — echte Nicht-Monotonie; dann verdient die From 7572a516f03334849e4ac4f17e2a8d8ebacb4cb2 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 6 Aug 2026 06:52:16 +0000 Subject: [PATCH 27/34] Document the area_tol precision lever The final mulde_height trim has two distinct sources of slack, and only one of them is real: at low overflow targets it merely harvests the area search's tolerance overshoot (a search artefact worth ~18% of what finer area resolution would recover, since height only saves excavation while area pays all four cost components), at high targets it exploits the wide overflow-count plateaus where height has almost no hydraulic effect (real savings, e.g. 300 -> 100 mm at Eisenstadt x = 5, ~600 EUR, unreachable via finer area search because the next area step down immediately overshoots the target). Document the cheap fix for the artefact part: thanks to the bisection, halving area_tol costs exactly one additional engine run per area search while halving the worst-case cost overshoot (~area_tol x specific cost per m2, a few percent at the default 2 m2). Noted in the area_tol roxygen docs and as a comment on the vignette's search-space knob. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- R/optimise_swale_design.R | 9 ++++++++- man/optimise_swale_design.Rd | 9 ++++++++- vignettes/workflow_optimisation.Rmd | 5 ++++- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index 8af028e..d33e349 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -65,7 +65,14 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' @param x_targets Integer vector of overflow targets (feasible :<=> #' `n_overflows <= x`), default `0:5`. #' @param area_bounds,area_tol Search range (m2) and resolution for -#' `mulde_area`. +#' `mulde_area`. The found area sits up to one `area_tol` above the +#' exact feasibility boundary (worst-case cost overshoot roughly +#' `area_tol` x specific cost per m2, i.e. a few percent at the +#' default 2 m2); thanks to the bisection, every *halving* of +#' `area_tol` costs only one additional engine run per area search -- +#' the cheapest precision lever of this optimiser. It also shrinks +#' the tolerance-artefact part of the final `mulde_height` trim (the +#' values just below the height maximum at low `x_targets`). #' @param height_bounds,height_tol Search range (mm) and resolution for #' `mulde_height`. #' @param storage_spec Storage search space per type, see diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index b2deadc..5a1ba30 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -32,7 +32,14 @@ everything in \code{fixed}.} \code{n_overflows <= x}), default \code{0:5}.} \item{area_bounds, area_tol}{Search range (m2) and resolution for -\code{mulde_area}.} +\code{mulde_area}. The found area sits up to one \code{area_tol} above the +exact feasibility boundary (worst-case cost overshoot roughly +\code{area_tol} x specific cost per m2, i.e. a few percent at the +default 2 m2); thanks to the bisection, every \emph{halving} of +\code{area_tol} costs only one additional engine run per area search -- +the cheapest precision lever of this optimiser. It also shrinks +the tolerance-artefact part of the final \code{mulde_height} trim (the +values just below the height maximum at low \code{x_targets}).} \item{height_bounds, height_tol}{Search range (mm) and resolution for \code{mulde_height}.} diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index f7a9128..8b78c74 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -147,7 +147,10 @@ stehen sie explizit, damit sie sichtbar und anpassbar sind: ```{r search_space, eval = can_run} area_bounds <- c(25, 200) # Muldenflaeche [m2], stufenlos -area_tol <- 2 # Aufloesung der Flaechensuche [m2] +area_tol <- 2 # Aufloesung der Flaechensuche [m2]; + # jede Halbierung kostet nur 1 Lauf je + # Flaechensuche und halbiert den + # toleranzbedingten Kostenueberschuss height_bounds <- c(100, 300) # Muldentiefe [mm], stufenlos height_tol <- 10 # Aufloesung der Tiefensuche [mm] storage_spec <- default_storage_spec() From ed9c438ba11c4a22c4c38e811f2f25a731156649 Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 7 Aug 2026 09:09:32 +0000 Subject: [PATCH 28/34] Prepare release 0.1.0 for Zenodo archiving - DESCRIPTION: version 0.0.0.9000 -> 0.1.0 - NEWS.md: development-version header becomes the 0.1.0 release header - CITATION.cff: citation metadata for GitHub's "Cite this repository" and the Zenodo GitHub integration (author with ORCID, MIT, keywords, abstract noting that the proprietary Tandler engine is downloaded from the separate kwb.raindrop.binaries repository and is not part of this package) - .zenodo.json: explicit Zenodo deposit metadata (creators, license, keywords, funding note for RAINDROP / GZ C300428) - inst/CITATION: R-style citation() entry - .Rbuildignore: exclude the repo-level citation files from the built package (inst/CITATION ships with it) The GitHub release v0.1.0 itself is cut from the default branch after merging; enable the Zenodo webhook for KWB-R/kwb.raindrop beforehand so the release is archived and receives a DOI. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- .Rbuildignore | 2 ++ .zenodo.json | 31 +++++++++++++++++++++++++++++++ CITATION.cff | 37 +++++++++++++++++++++++++++++++++++++ DESCRIPTION | 2 +- NEWS.md | 2 +- inst/CITATION | 17 +++++++++++++++++ 6 files changed, 89 insertions(+), 2 deletions(-) create mode 100644 .zenodo.json create mode 100644 CITATION.cff create mode 100644 inst/CITATION diff --git a/.Rbuildignore b/.Rbuildignore index 7e8b18a..38da99b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -13,3 +13,5 @@ ^vignettes/optimiser_vs_bruteforce$ ^\.positai$ ^\.claude$ +^CITATION\.cff$ +^\.zenodo\.json$ diff --git a/.zenodo.json b/.zenodo.json new file mode 100644 index 0000000..cd307a7 --- /dev/null +++ b/.zenodo.json @@ -0,0 +1,31 @@ +{ + "title": "kwb.raindrop: R Package for Optimisation Simulations for Rainwater Management", + "description": "

R interface and control unit for the RAINDROP hydrodynamic planning tool: long-term simulation of blue-green infrastructure (swale-trench elements) driven by real climate series, plus two cost optimisers that find the cost-minimal design per allowed overflow frequency — a deterministic bisection-based coordinate descent whose search order is derived from the construction cost rates, and an assumption-free simultaneous search (penalised Nelder-Mead, differential evolution and Halton sampling) as cross-check.

The proprietary calculation engine ("Regenwasserbewirtschaftung", © Tandler.com GmbH) is not part of this archive; it is downloaded on demand from the companion repository kwb.raindrop.binaries.

", + "upload_type": "software", + "access_right": "open", + "license": "MIT", + "creators": [ + { + "name": "Rustler, Michael", + "orcid": "0000-0003-0647-7726", + "affiliation": "Kompetenzzentrum Wasser Berlin gGmbH (KWB)" + } + ], + "keywords": [ + "blue-green infrastructure", + "sponge city", + "stormwater management", + "long-term simulation", + "cost optimisation", + "infiltration swale", + "R package" + ], + "related_identifiers": [ + { + "relation": "isSupplementTo", + "identifier": "https://github.com/KWB-R/kwb.raindrop", + "scheme": "url" + } + ], + "notes": "Developed within the project RAINDROP (Rainwater Drainage Optimization, GZ C300428), funded by the Austrian Federal Ministry of Agriculture, Forestry, Regions and Water Management." +} diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 0000000..f906950 --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,37 @@ +cff-version: 1.2.0 +message: "If you use this software, please cite it using the metadata below." +type: software +title: "kwb.raindrop: R Package for Optimisation Simulations for Rainwater Management" +version: 0.1.0 +date-released: "2026-08-07" +license: MIT +repository-code: "https://github.com/KWB-R/kwb.raindrop" +url: "https://kwb-r.github.io/kwb.raindrop" +authors: + - family-names: Rustler + given-names: Michael + orcid: "https://orcid.org/0000-0003-0647-7726" + affiliation: "Kompetenzzentrum Wasser Berlin gGmbH (KWB)" +keywords: + - blue-green infrastructure + - sponge city + - stormwater management + - long-term simulation + - cost optimisation + - infiltration swale + - R package +abstract: >- + R interface and control unit for the RAINDROP hydrodynamic planning + tool: long-term simulation of blue-green infrastructure (swale-trench + elements) driven by real climate series, plus two cost optimisers + that find the cost-minimal design per allowed overflow frequency - a + deterministic bisection-based coordinate descent whose search order + is derived from the construction cost rates, and an + assumption-free simultaneous search (penalised Nelder-Mead, + differential evolution and Halton sampling) as cross-check. The + proprietary calculation engine ("Regenwasserbewirtschaftung", + (c) Tandler.com GmbH) is not part of this package; it is downloaded + on demand from the companion repository kwb.raindrop.binaries. + Developed within the project RAINDROP (Rainwater Drainage + Optimization, GZ C300428), funded by the Austrian Federal Ministry + of Agriculture, Forestry, Regions and Water Management. diff --git a/DESCRIPTION b/DESCRIPTION index 3f6e263..f5fa2b4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: kwb.raindrop Title: R Package for Optimisation Simulations for Rainwater Management Simulations Performed with Calculation Engine Provided by Tandler -Version: 0.0.0.9000 +Version: 0.1.0 Authors@R: c( person("Michael", "Rustler", , "michael.rustler@kompetenz-wasser.de", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-0647-7726")), diff --git a/NEWS.md b/NEWS.md index eb34a0f..6a500c7 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# kwb.raindrop (development version) +# kwb.raindrop 0.1.0 (2026-08-07) ## New features diff --git a/inst/CITATION b/inst/CITATION new file mode 100644 index 0000000..4d53ab8 --- /dev/null +++ b/inst/CITATION @@ -0,0 +1,17 @@ +citHeader("To cite kwb.raindrop in publications use:") + +bibentry( + bibtype = "Manual", + title = paste("kwb.raindrop: R Package for Optimisation Simulations", + "for Rainwater Management"), + author = person("Michael", "Rustler", + comment = c(ORCID = "0000-0003-0647-7726")), + year = "2026", + note = "R package version 0.1.0", + url = "https://github.com/KWB-R/kwb.raindrop" +) + +citFooter(paste( + "After the first Zenodo release, please prefer the version DOI", + "shown at https://github.com/KWB-R/kwb.raindrop (Cite this repository)." +)) From dba44fe0dc65a99ebebec97430a5fe9ab7369b12 Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 7 Aug 2026 09:19:56 +0000 Subject: [PATCH 29/34] NEWS: flag the cleanup=TRUE default; tests: expect_equal for floats - NEWS.md: the make_swale_runner() entry now leads with an explicit behaviour note that cleanup = TRUE (the default) deletes each scenario's output HDF5s (Mulde_Rigole.h5, Dach.h5, Fehlerprotokoll.h5, ...) right after the thinned result row is read, and that cleanup = FALSE keeps them - so consumers are not surprised that only the returned tibble survives a run. - test-optimise_swale_design_simultaneous.R: float comparisons (cost_total, mulde_area, storage_height, mulde_height) use expect_equal(tolerance = 0) instead of expect_identical - exact values without bitwise/type strictness; integer counts, strings and .Random.seed stay expect_identical. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- NEWS.md | 16 ++++++++++------ .../test-optimise_swale_design_simultaneous.R | 16 ++++++++-------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/NEWS.md b/NEWS.md index 6a500c7..a332abc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -90,12 +90,16 @@ rain + ET0 series in mm/h incl. the Growth/Shading end-time fix). Returns the thinned one-row optimisation result augmented with `overflow_volume_m3` (= `sum_overflows` [mm] × `mulde_area` / 1000). - Deletes each scenario's input copy and output directory right after - that row has been read (`cleanup = TRUE`, the default; failed runs - keep their files) — without this, long searches (hundreds of engine - runs per task, each with its own `base.h5` copy plus output HDF5s) - fill the temp drive and the engine dies with HDF5 `errno = 28` - ("No space left on device"). Prepares a **site master file** once + **Behaviour note — files are deleted by default:** with + `cleanup = TRUE` (the default) each scenario's input copy *and its + output HDF5s* (`Mulde_Rigole.h5`, `Dach.h5`, `Fehlerprotokoll.h5`, + …) are removed right after the one-row result has been read — only + the returned tibble survives a run. Pass `cleanup = FALSE` if you + need the raw scenario files (failed runs always keep theirs for + debugging). Rationale: without the cleanup, long searches (hundreds + of engine runs per task, each with its own `base.h5` copy plus + output HDF5s) fill the temp drive and the engine dies with HDF5 + `errno = 28` ("No space left on device"). Prepares a **site master file** once (base.h5 + calculation settings + ET/rain series) and writes only the ~15 small parameter datasets per run instead of reading and rewriting *every* dataset each time — that full HDF5 round trip diff --git a/tests/testthat/test-optimise_swale_design_simultaneous.R b/tests/testthat/test-optimise_swale_design_simultaneous.R index 7ccb8c7..1c7585e 100644 --- a/tests/testthat/test-optimise_swale_design_simultaneous.R +++ b/tests/testthat/test-optimise_swale_design_simultaneous.R @@ -169,8 +169,8 @@ test_that("degenerierte Rigol-Achse (genau eine zulaessige Hoehe) ist loesbar", max_total_depth = 1300, verbose = FALSE ) expect_identical(out$status, "ok") - expect_identical(out$storage_height, 900) - expect_identical(out$mulde_height, 100) + expect_equal(out$storage_height, 900, tolerance = 0) + expect_equal(out$mulde_height, 100, tolerance = 0) }) test_that("NA-Zeilen im Prior stuerzen den Warmstart nicht ab", { @@ -242,8 +242,8 @@ test_that("beide Optimierer folgen veraenderten Kostensaetzen", { verbose = FALSE) expect_identical(bis$status, "ok") expect_identical(sim$status, "ok") - expect_identical(bis$storage_height, 1200) - expect_identical(sim$storage_height, 1200) + expect_equal(bis$storage_height, 1200, tolerance = 0) + expect_equal(sim$storage_height, 1200, tolerance = 0) expect_lt(abs(sim$cost_total - bis$cost_total), 0.05 * bis$cost_total) # ohne porosity-Eintrag: Legacy-Reihenfolge (kleinste Stufe zuerst) @@ -252,12 +252,12 @@ test_that("beide Optimierer folgen veraenderten Kostensaetzen", { leg <- optimise_swale_design(run, x_targets = 0, fixed = sim_fixed, storage_spec = spec_legacy, cost_rates = cheap_box, verbose = FALSE) - expect_identical(leg$storage_height, 300) + expect_equal(leg$storage_height, 300, tolerance = 0) # unter Default-Saetzen waehlt der Proxy weiterhin die kleinste Stufe def <- optimise_swale_design(run, x_targets = 0, fixed = sim_fixed, storage_spec = spec, verbose = FALSE) - expect_identical(def$storage_height, 300) + expect_equal(def$storage_height, 300, tolerance = 0) }) test_that("alle Methoden funktionieren mit Ein-Typ-storage_spec", { @@ -310,8 +310,8 @@ test_that("Differential Evolution ist deterministisch und laesst Rs RNG in Ruhe" fixed = sim_fixed, method = "diff_evolution", verbose = FALSE) - expect_identical(de1$cost_total, de2$cost_total) - expect_identical(de1$mulde_area, de2$mulde_area) + expect_equal(de1$cost_total, de2$cost_total, tolerance = 0) + expect_equal(de1$mulde_area, de2$mulde_area, tolerance = 0) # anderer Seed = anderer Suchpfad, aber gleiches Optimum (Toleranzen) de3 <- optimise_swale_design_simultaneous(run, x_targets = 1, From 20880548315848c683a4d8f27775770f68bf878d Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 7 Aug 2026 09:21:24 +0000 Subject: [PATCH 30/34] make_swale_runner(): guard curve reads in prepare_master() prepare_master() read //Kurven/Regen (and Growth_1/Shading_1) unconditionally, so a base.h5 template without these datasets crashed with a cryptic low-level error. Now the available datasets are listed once and only existing curves are touched: - timeseries_rain given: //Kurven/Regen must exist (clear error naming the template path otherwise); the Growth/Shading end-time fix is applied only to curves that exist and have the expected time/value shape - no timeseries_rain: the template rain curve is cached only if present; a per-run rain_factor != 1 without a usable template curve now throws a clear error instead of silently not scaling Requirements documented in the roxygen docs. Co-Authored-By: Claude Opus 5 Claude-Session: https://claude.ai/code/session_017npvdq8XW1Lg1t2dNX9sGH --- R/make_swale_runner.R | 45 ++++++++++++++++++++++++++-------------- man/make_swale_runner.Rd | 10 ++++++--- 2 files changed, 37 insertions(+), 18 deletions(-) diff --git a/R/make_swale_runner.R b/R/make_swale_runner.R index 7a3690f..abe4e6a 100644 --- a/R/make_swale_runner.R +++ b/R/make_swale_runner.R @@ -42,9 +42,13 @@ psi_s_mm <- function(kf_mmh) { #' `path_results_hdf5_flaeche`, `file_target`). #' @param timestep_hours Engine time step in hours (default 0.1). #' @param timeseries_rain Optional data.frame `time`/`value` (mm/h) written -#' to `//Kurven/Regen`; when given, `//Kurven/Growth_1` and -#' `//Kurven/Shading_1` end times are extended to the rain series end and -#' `rain_factor` is ignored. +#' to `//Kurven/Regen` (the dataset must exist in `base.h5`); when +#' given, the `//Kurven/Growth_1` and `//Kurven/Shading_1` end times +#' are extended to the rain series end (skipped for templates without +#' these curves) and `rain_factor` is ignored. Without +#' `timeseries_rain`, a per-run `rain_factor != 1` requires +#' `//Kurven/Regen` to exist as a time series in `base.h5` -- a clear +#' error is thrown otherwise. #' @param timeseries_et Optional data.frame `time`/`value` (mm/h) written #' to `//Kurven/ET0`. #' @param storage_types Soil presets of the storage layer per storage type, @@ -117,18 +121,26 @@ make_swale_runner <- function(path_list, if (!is.null(timeseries_et)) { static_vals$`//Kurven/ET0` <- timeseries_et } + # base.h5 templates differ in which curves they ship -- only touch + # datasets that actually exist (missing Growth/Shading just skips + # the end-time fix; a missing rain curve only matters if a run + # later asks for rain_factor != 1, which then errors clearly) + existing <- list_h5_datasets(h5m)$path if (!is.null(timeseries_rain)) { - curves <- h5_read_values( - h5m, paths = c("//Kurven/Growth_1", "//Kurven/Shading_1") - ) - grow <- curves[["//Kurven/Growth_1"]] - shad <- curves[["//Kurven/Shading_1"]] - grow$time[2] <- max(timeseries_rain$time) - shad$time[2] <- max(timeseries_rain$time) + if (!"//Kurven/Regen" %in% existing) { + stop("make_swale_runner(): base.h5 has no dataset //Kurven/Regen ", + "to replace with timeseries_rain: ", paths$path_base) + } static_vals$`//Kurven/Regen` <- timeseries_rain - static_vals$`//Kurven/Growth_1` <- grow - static_vals$`//Kurven/Shading_1` <- shad - } else { + for (curve in c("//Kurven/Growth_1", "//Kurven/Shading_1")) { + if (!curve %in% existing) next + cv <- h5_read_values(h5m, paths = curve)[[curve]] + if (is.data.frame(cv) && length(cv$time) >= 2) { + cv$time[2] <- max(timeseries_rain$time) + static_vals[[curve]] <- cv + } + } + } else if ("//Kurven/Regen" %in% existing) { # kept for per-run rain_factor scaling (Eisenstadt variant) template_rain <<- h5_read_values( h5m, paths = "//Kurven/Regen" @@ -203,8 +215,11 @@ make_swale_runner <- function(path_list, ) # rain_factor is documented to be ignored when own rain series are # written (timeseries_rain); it scales the base.h5 curve otherwise - if (is.null(timeseries_rain) && rain_factor != 1 && - is.data.frame(template_rain)) { + if (is.null(timeseries_rain) && rain_factor != 1) { + if (!is.data.frame(template_rain)) { + stop("make_swale_runner(): rain_factor != 1 requires base.h5 to ", + "contain //Kurven/Regen as a time series (time/value)") + } scaled <- template_rain scaled$value <- scaled$value * rain_factor vals$`//Kurven/Regen` <- scaled diff --git a/man/make_swale_runner.Rd b/man/make_swale_runner.Rd index 60f0278..b42c579 100644 --- a/man/make_swale_runner.Rd +++ b/man/make_swale_runner.Rd @@ -26,9 +26,13 @@ make_swale_runner( \item{timestep_hours}{Engine time step in hours (default 0.1).} \item{timeseries_rain}{Optional data.frame \code{time}/\code{value} (mm/h) written -to \verb{//Kurven/Regen}; when given, \verb{//Kurven/Growth_1} and -\verb{//Kurven/Shading_1} end times are extended to the rain series end and -\code{rain_factor} is ignored.} +to \verb{//Kurven/Regen} (the dataset must exist in \code{base.h5}); when +given, the \verb{//Kurven/Growth_1} and \verb{//Kurven/Shading_1} end times +are extended to the rain series end (skipped for templates without +these curves) and \code{rain_factor} is ignored. Without +\code{timeseries_rain}, a per-run \code{rain_factor != 1} requires +\verb{//Kurven/Regen} to exist as a time series in \code{base.h5} -- a clear +error is thrown otherwise.} \item{timeseries_et}{Optional data.frame \code{time}/\code{value} (mm/h) written to \verb{//Kurven/ET0}.} From 6e8625db4424adf420d5936c969d086a8211a380 Mon Sep 17 00:00:00 2001 From: mrustl Date: Fri, 7 Aug 2026 11:40:22 +0200 Subject: [PATCH 31/34] Bumped to roxygen2 8.1.0; use onnly Eisenstadt for simulataneous optimisation testing --- .github/workflows/claude.yaml | 2 +- DESCRIPTION | 2 +- NAMESPACE | 176 ++++++++++-------- .../workflow_optimisation_simultaneous.Rmd | 2 +- 4 files changed, 101 insertions(+), 81 deletions(-) diff --git a/.github/workflows/claude.yaml b/.github/workflows/claude.yaml index 2da55d5..2813c65 100644 --- a/.github/workflows/claude.yaml +++ b/.github/workflows/claude.yaml @@ -35,4 +35,4 @@ jobs: uses: anthropics/claude-code-action@v1 with: claude_code_oauth_token: ${{ secrets.CLAUDE_CODE_OAUTH_TOKEN }} - claude_args: '--model claude-opus-4-7' + claude_args: '--model claude-opus-4-8' diff --git a/DESCRIPTION b/DESCRIPTION index f5fa2b4..e3ce958 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -51,4 +51,4 @@ Remotes: github::kwb-r/kwb.utils Encoding: UTF-8 Roxygen: list(markdown = TRUE) -Config/roxygen2/version: 8.0.0 +Config/roxygen2/version: 8.1.0 diff --git a/NAMESPACE b/NAMESPACE index 88d18a0..d76aeb1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,92 +42,112 @@ export(run_model) export(run_scenarios) export(sickerbox_level_presets) export(stack_levels) -importFrom(dplyr,"%>%") -importFrom(dplyr,across) -importFrom(dplyr,all_of) -importFrom(dplyr,arrange) -importFrom(dplyr,bind_cols) -importFrom(dplyr,bind_rows) -importFrom(dplyr,case_when) -importFrom(dplyr,coalesce) -importFrom(dplyr,desc) -importFrom(dplyr,everything) -importFrom(dplyr,filter) -importFrom(dplyr,group_by) -importFrom(dplyr,if_else) -importFrom(dplyr,left_join) -importFrom(dplyr,mutate) -importFrom(dplyr,n) -importFrom(dplyr,n_distinct) -importFrom(dplyr,pull) -importFrom(dplyr,relocate) -importFrom(dplyr,select) -importFrom(dplyr,slice) -importFrom(dplyr,summarise) -importFrom(dplyr,transmute) -importFrom(dplyr,ungroup) +importFrom(dplyr, + "%>%", + across, + all_of, + arrange, + bind_cols, + bind_rows, + case_when, + coalesce, + desc, + everything, + filter, + group_by, + if_else, + left_join, + mutate, + n, + n_distinct, + pull, + relocate, + select, + slice, + summarise, + transmute, + ungroup +) importFrom(forcats,fct_reorder) -importFrom(fs,dir_create) -importFrom(fs,file_copy) -importFrom(fs,file_exists) -importFrom(fs,path_abs) -importFrom(future,multisession) -importFrom(future,plan) -importFrom(future,sequential) +importFrom(fs, + dir_create, + file_copy, + file_exists, + path_abs +) +importFrom(future, + multisession, + plan, + sequential +) importFrom(future.apply,future_lapply) -importFrom(ggplot2,aes) -importFrom(ggplot2,coord_cartesian) -importFrom(ggplot2,element_text) -importFrom(ggplot2,facet_grid) -importFrom(ggplot2,facet_wrap) -importFrom(ggplot2,geom_boxplot) -importFrom(ggplot2,geom_jitter) -importFrom(ggplot2,geom_line) -importFrom(ggplot2,geom_point) -importFrom(ggplot2,geom_text) -importFrom(ggplot2,geom_violin) -importFrom(ggplot2,ggplot) -importFrom(ggplot2,guide_legend) -importFrom(ggplot2,guides) -importFrom(ggplot2,labs) -importFrom(ggplot2,position_identity) -importFrom(ggplot2,position_jitter) -importFrom(ggplot2,position_nudge) -importFrom(ggplot2,scale_alpha_identity) -importFrom(ggplot2,scale_color_manual) -importFrom(ggplot2,scale_colour_manual) -importFrom(ggplot2,scale_fill_manual) -importFrom(ggplot2,scale_shape_manual) -importFrom(ggplot2,scale_size) -importFrom(ggplot2,scale_x_continuous) -importFrom(ggplot2,scale_x_discrete) -importFrom(ggplot2,scale_y_continuous) -importFrom(ggplot2,scale_y_discrete) -importFrom(ggplot2,theme) -importFrom(ggplot2,theme_bw) -importFrom(ggplot2,vars) +importFrom(ggplot2, + aes, + coord_cartesian, + element_text, + facet_grid, + facet_wrap, + geom_boxplot, + geom_jitter, + geom_line, + geom_point, + geom_text, + geom_violin, + ggplot, + guide_legend, + guides, + labs, + position_identity, + position_jitter, + position_nudge, + scale_alpha_identity, + scale_color_manual, + scale_colour_manual, + scale_fill_manual, + scale_shape_manual, + scale_size, + scale_x_continuous, + scale_x_discrete, + scale_y_continuous, + scale_y_discrete, + theme, + theme_bw, + vars +) importFrom(grDevices,colorRampPalette) importFrom(hdf5r,H5File) importFrom(kwb.event,hsEvents) -importFrom(kwb.utils,catAndRun) -importFrom(kwb.utils,resolve) +importFrom(kwb.utils, + catAndRun, + resolve +) importFrom(lubridate,as_datetime) importFrom(magrittr,"%>%") importFrom(parallel,detectCores) -importFrom(progressr,handler_cli) -importFrom(progressr,handler_rstudio) -importFrom(progressr,handler_txtprogressbar) -importFrom(progressr,handlers) -importFrom(progressr,progressor) -importFrom(progressr,with_progress) -importFrom(purrr,map_chr) -importFrom(purrr,map_dfr) +importFrom(progressr, + handler_cli, + handler_rstudio, + handler_txtprogressbar, + handlers, + progressor, + with_progress +) +importFrom(purrr, + map_chr, + map_dfr +) importFrom(rlang,.data) -importFrom(stats,median) -importFrom(stats,setNames) +importFrom(stats, + median, + setNames +) importFrom(stringr,str_c) -importFrom(tibble,as_tibble) -importFrom(tibble,tibble) -importFrom(tidyr,pivot_longer) -importFrom(tidyr,pivot_wider) +importFrom(tibble, + as_tibble, + tibble +) +importFrom(tidyr, + pivot_longer, + pivot_wider +) importFrom(utils,modifyList) diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index 6f8a613..f3dac5a 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -139,7 +139,7 @@ sites <- list( # reduziertes Budget (z. B. max_evals <- 50) und, auf Windows deutlich, # eine Virenscanner-Ausnahme fuer %LOCALAPPDATA%\Temp (jede Szenario- # Datei und jeder Engine-Start wird sonst einzeln gescannt): -# sites <- sites["Eisenstadt_2005"] +sites <- sites["Eisenstadt_2005"] fixed <- list(connected_area = 1000, filter_height = 300, From ae01c8f43f9a98bdabf98a9e4a8f13e2433151e5 Mon Sep 17 00:00:00 2001 From: mrustl Date: Fri, 7 Aug 2026 13:34:20 +0200 Subject: [PATCH 32/34] Add project logo to documentation website --- _pkgdown.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 41550e7..eb91d3a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -4,8 +4,8 @@ authors: href: https://www.kompetenz-wasser.de/en/ueber-uns/team/michael-rustler RAINDROP: href: https://www.kompetenz-wasser.de/en/forschung/projekte/raindrop - # html: Project RAINDROP + html: Project RAINDROP Kompetenzzentrum Wasser Berlin gGmbH (KWB): href: http://www.kompetenz-wasser.de html: Date: Fri, 7 Aug 2026 12:11:51 +0000 Subject: [PATCH 33/34] Remove deploy-only articles from pkgdown site, link results externally vignettes/index.Rmd (brute-force link hub) and vignettes/monotonicity_analysis.Rmd are deleted (they remain in the git history): their relative links only work in the deploy structure on raindrop.kompetenz-wasser.io and their result files never exist on GitHub Actions, so the pkgdown-built copies were link-dead shells. The complete rendered pages live on that server. - New "Ergebnisse" navbar menu linking the published results (brute force, monotonicity analysis, optimiser vs. brute force). - The two optimisation vignettes and the roxygen docs of find_min_feasible(), optimise_swale_design() and optimise_swale_design_simultaneous() now link the monotonicity analysis on that server instead of the removed vignette. - Drop the stale vignettes/index.Rmd entry from .Rbuildignore and the mono_* mention from .gitignore. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_017E2RpwmBRnnDHRmxjXRh4x --- .Rbuildignore | 1 - .gitignore | 8 +- NEWS.md | 13 + R/find_min_feasible.R | 6 +- R/optimise_swale_design.R | 7 +- R/optimise_swale_design_simultaneous.R | 4 +- _pkgdown.yml | 17 + man/find_min_feasible.Rd | 6 +- man/optimise_swale_design.Rd | 7 +- man/optimise_swale_design_simultaneous.Rd | 4 +- vignettes/index.Rmd | 328 ------------- vignettes/monotonicity_analysis.Rmd | 455 ------------------ vignettes/workflow_optimisation.Rmd | 4 +- .../workflow_optimisation_simultaneous.Rmd | 7 +- 14 files changed, 64 insertions(+), 803 deletions(-) delete mode 100644 vignettes/index.Rmd delete mode 100644 vignettes/monotonicity_analysis.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index 38da99b..16df298 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,7 +8,6 @@ ^codecov\.yml$ ^index\.md$ ^README\.md$ -^vignettes/index\.Rmd$ ^vignettes/monotonicity_analysis$ ^vignettes/optimiser_vs_bruteforce$ ^\.positai$ diff --git a/.gitignore b/.gitignore index da55509..1567446 100644 --- a/.gitignore +++ b/.gitignore @@ -6,10 +6,10 @@ docs inst/doc .positai -# Von den Vignetten erzeugte Ergebnisdateien (Workflows: simulation_results_*; -# monotonicity_analysis.Rmd: mono_*). Reproduzierbar durch erneutes Rendern -# -> nicht einchecken. HTML- und R-Dateien unter vignettes/ ignoriert -# bereits vignettes/.gitignore (*.html, *.R). +# Von den Vignetten erzeugte Ergebnisdateien (simulation_results_*). +# Reproduzierbar durch erneutes Rendern -> nicht einchecken. HTML- und +# R-Dateien unter vignettes/ ignoriert bereits vignettes/.gitignore +# (*.html, *.R). vignettes/*.csv vignettes/*.pdf vignettes/figure/ diff --git a/NEWS.md b/NEWS.md index a332abc..61a79b2 100644 --- a/NEWS.md +++ b/NEWS.md @@ -364,6 +364,19 @@ `Muldenfläche [m²]=125` instead of the raw `mulde_area=125`; pass `param_labels =` to the plot functions to override. +## Documentation website + +* The two deploy-only articles `vignettes/index.Rmd` (brute-force link + hub) and `vignettes/monotonicity_analysis.Rmd` are removed from the + repository (they remain in the git history). Their relative links only + worked in the deploy structure on + and their result files never + exist on GitHub Actions, so the pkgdown-built copies were link-dead + shells. The complete rendered pages live on that server; the pkgdown + navbar instead gains an "Ergebnisse" menu linking them (brute force, + monotonicity analysis, optimiser vs. brute force), and the two + optimisation vignettes link the monotonicity analysis there too. + ## Consistency * Non-ASCII characters in R code are now unicode-escaped: all string literals diff --git a/R/find_min_feasible.R b/R/find_min_feasible.R index 69a76ec..0347431 100644 --- a/R/find_min_feasible.R +++ b/R/find_min_feasible.R @@ -4,8 +4,10 @@ #' value of one design parameter for which the overflow target is met #' (`n_overflows <= x_max`), assuming quasi-monotone feasibility (larger #' value = never more overflows; verified for the RAINDROP model in the -#' `monotonicity_analysis` vignette). Each evaluation halves the search -#' interval, so `ceiling(log2(range / tol))` evaluations suffice. +#' monotonicity analysis, +#' ). +#' Each evaluation halves the search interval, so +#' `ceiling(log2(range / tol))` evaluations suffice. #' #' Two safety rules from the monotonicity analysis are built in: #' \itemize{ diff --git a/R/optimise_swale_design.R b/R/optimise_swale_design.R index d33e349..a4359fe 100644 --- a/R/optimise_swale_design.R +++ b/R/optimise_swale_design.R @@ -36,9 +36,10 @@ area_bracket_from_prior <- function(prior, type, h_s, h_m, x, bounds) { #' (`mulde_height`); the storage layer starts at its smallest level and is #' only escalated when the area is stuck at its upper bound. The filter #' conductivity is expected to be fixed at the maximum via `fixed` (it is -#' cost-free and dominant, see the `monotonicity_analysis` vignette). Every -#' engine run is cached, so the sweep over all `x_targets` and both storage -#' types shares evaluations. +#' cost-free and dominant, see the monotonicity analysis, +#' ). +#' Every engine run is cached, so the sweep over all `x_targets` and both +#' storage types shares evaluations. #' #' **The search order is derived from `cost_rates`** via a #' specific-cost proxy (EUR per mm of storage capacity, capacity model diff --git a/R/optimise_swale_design_simultaneous.R b/R/optimise_swale_design_simultaneous.R index 076d28a..1bdf3dd 100644 --- a/R/optimise_swale_design_simultaneous.R +++ b/R/optimise_swale_design_simultaneous.R @@ -137,7 +137,9 @@ make_lcg <- function(seed) { #' latent axis (each level owns an equal share of `[0, 1]`), the gravel #' trench is searched continuously. The filter conductivity is expected to #' be fixed at the maximum via `fixed` (cost-free and dominant, see the -#' `monotonicity_analysis` vignette). `max_total_depth` is enforced by +#' monotonicity analysis, +#' ). +#' `max_total_depth` is enforced by #' construction (the `mulde_height` axis is compressed to the remaining #' depth), so no simulation runs are spent on depth-invalid designs. #' diff --git a/_pkgdown.yml b/_pkgdown.yml index eb91d3a..0fa93d7 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -19,6 +19,23 @@ template: primary: '#007aff' border-radius: 0.5rem btn-border-radius: 0.25rem +# Die Ergebnis-Seiten (Brute-Force-Linkhub, Monotonie-Analyse, Vergleich +# Optimierer vs. Brute-Force) sind kein Teil der pkgdown-Site: Sie werden +# vollstaendig auf raindrop.kompetenz-wasser.io gepflegt und deployt und +# hier nur extern verlinkt. +navbar: + structure: + left: [intro, reference, articles, ergebnisse, tutorials, news] + components: + ergebnisse: + text: Ergebnisse + menu: + - text: Brute-Force + href: https://raindrop.kompetenz-wasser.io/brute-force/ + - text: Monotonie-Analyse + href: https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/ + - text: Optimierer vs. Brute-Force + href: https://raindrop.kompetenz-wasser.io/optimisation/optimiser_vs_brute-force/ development: mode: auto diff --git a/man/find_min_feasible.Rd b/man/find_min_feasible.Rd index 4137642..5ab26cc 100644 --- a/man/find_min_feasible.Rd +++ b/man/find_min_feasible.Rd @@ -66,8 +66,10 @@ Core building block of the swale-design optimiser: finds the smallest value of one design parameter for which the overflow target is met (\code{n_overflows <= x_max}), assuming quasi-monotone feasibility (larger value = never more overflows; verified for the RAINDROP model in the -\code{monotonicity_analysis} vignette). Each evaluation halves the search -interval, so \code{ceiling(log2(range / tol))} evaluations suffice. +monotonicity analysis, +\url{https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/}). +Each evaluation halves the search interval, so +\code{ceiling(log2(range / tol))} evaluations suffice. } \details{ Two safety rules from the monotonicity analysis are built in: diff --git a/man/optimise_swale_design.Rd b/man/optimise_swale_design.Rd index 5a1ba30..c181baf 100644 --- a/man/optimise_swale_design.Rd +++ b/man/optimise_swale_design.Rd @@ -86,9 +86,10 @@ expensive lever first (\code{mulde_area}), then the cheap one (\code{mulde_height}); the storage layer starts at its smallest level and is only escalated when the area is stuck at its upper bound. The filter conductivity is expected to be fixed at the maximum via \code{fixed} (it is -cost-free and dominant, see the \code{monotonicity_analysis} vignette). Every -engine run is cached, so the sweep over all \code{x_targets} and both storage -types shares evaluations. +cost-free and dominant, see the monotonicity analysis, +\url{https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/}). +Every engine run is cached, so the sweep over all \code{x_targets} and both +storage types shares evaluations. } \details{ \strong{The search order is derived from \code{cost_rates}} via a diff --git a/man/optimise_swale_design_simultaneous.Rd b/man/optimise_swale_design_simultaneous.Rd index 7034f59..6e80ae4 100644 --- a/man/optimise_swale_design_simultaneous.Rd +++ b/man/optimise_swale_design_simultaneous.Rd @@ -168,7 +168,9 @@ The discrete infiltration-box levels are mapped onto a continuous latent axis (each level owns an equal share of \verb{[0, 1]}), the gravel trench is searched continuously. The filter conductivity is expected to be fixed at the maximum via \code{fixed} (cost-free and dominant, see the -\code{monotonicity_analysis} vignette). \code{max_total_depth} is enforced by +monotonicity analysis, +\url{https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/}). +\code{max_total_depth} is enforced by construction (the \code{mulde_height} axis is compressed to the remaining depth), so no simulation runs are spent on depth-invalid designs. diff --git a/vignettes/index.Rmd b/vignettes/index.Rmd deleted file mode 100644 index ad13d7f..0000000 --- a/vignettes/index.Rmd +++ /dev/null @@ -1,328 +0,0 @@ ---- -title: "RainDrop Optimierung – Brute Force" -author: "Michael Rustler" -date: "`r Sys.Date()`" -output: - html_document: - toc: true - toc_depth: 4 - number_sections: true ---- - -```{r setup, include=FALSE} -knitr::opts_chunk$set(echo = FALSE, message = FALSE, warning = FALSE) - -sites <- c("Eisenstadt_2005", "Wien", "BadAussee") - -# index.html liegt im gleichen Verzeichnis wie der Ordner "brute-force" -base_dir <- "." - -design_spaces <- paste0( - "mulde-area_vs_", - c("filter_hydraulicconductivity", "mulde_height", "storage_height") -) - -rel <- function(...) file.path(..., fsep = "/") - -md_link_line <- function(label, href) sprintf("- [%s](%s)", label, href) - -md_list <- function(lines) knitr::asis_output(paste(lines, collapse = "\n")) -``` - -# Hintergrund - -xxx - -# Methodik - -Die Modellierung erfolgte in R mit dem R Paket [kwb.raindrop](https://github.com/kwb-r/kwb.raindrop). -Das genaue Vorgehen ist für jede Fallstudie im folgenden im R Markdown reproduzierbar -dokumentiert. - -```{r brute_force_rmarkdown, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/workflow_%s.html)\n", - site, - base_dir, - site - )) -} -``` - -# Ergebnisse - -Die Ergebnisse für die einjährige Berechnung (Eisenstadt für Jahr 2005) und die -beiden 15 jährigen Zeitreihen (2011-2025) für Wien und Bad Aussee finden sich in -unten stehenden Links: - -Als **Gültigkeitskriterium** — die maximal zulässige Anzahl Überlaufereignisse — -wurde passend zur Simulationsdauer gewählt: **Eisenstadt ≤ 1** (Simulationszeit -1 Jahr) und **Wien / Bad Aussee ≤ 5** (15-jährige Regen-/ET-Reihe). Dieser -Schwellenwert steuert die Farbgebung (grün = gültig, rot = zu viele Überläufe) -und den in den Kostenplot-Titeln angegebenen Anteil gültiger Szenarien. - -## Tabellen - -```{r brute_force_tabelle, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s.html)\n", - site, - base_dir, - site - )) -} - -``` - -## CSV - -Die in den [obenstehenden Tabellen](#tabellen) dargestellten Ergebnisse können auch als `.csv` Datei -heruntergeladen werden. - -```{r brute_force_csv, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s.csv)\n", - site, - base_dir, - site - )) -} -``` - -## Interaktive Visualisierungen - -### Sensitive Modellparameter - -Haupteffekte je Parameter (Violin-/Box-/Punkt-Plots, nach Effektstärke -sortiert). Der **Speichertyp** ist als eigenes Panel enthalten -(Sickerbox vs. Schotterrigol). - -```{r brute_force_plots_main, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_main-effects.html)\n", - site, - base_dir, - site - )) -} -``` - -### Design Spaces - -In den nachfolgende Abbildungen wird die **Muldenfläche** (x-Achse) mit -**einem weiteren Parameter** (y-Achse) dargestellt. Diese sind im folgenden: - -- ***Muldenhöhe*** - -- ***Speicherhöhe*** - -- ***hydraulische Leitfähigkeit*** des Bodenfilters - -Die beiden **Speichertypen** liegen als **zwei Panels untereinander** -(Sickerbox oben, Schotterrigole unten; die Punkte bleiben Kreise, da -die Panel-Streifen den Typ benennen). Die y-Achsen sind je Panel frei -skaliert, so dass z. B. bei -der **Speicherhöhe** jedes Panel nur die für den Typ getesteten Höhen -zeigt (Sickerbox 300–1200 mm, Schotterrigole 900–3600 mm). - -```{r brute_force_plots_design-spaches, echo = FALSE, results='asis'} -cat("| Design Space |", paste(sites, collapse = " | "), "|\n") -cat("|---|", paste(rep("---", length(sites)), collapse = "|"), "|\n") - -for (ds in design_spaces) { - - ds_label <- sub("^mulde-area_vs_", "", ds) - - row_links <- sapply(sites, function(site) { - sprintf( - "[%s](%s/simulation_results_optimisation_%s_design-space_%s.html)", - ds_label, - base_dir, - site, - ds - ) - }) - - cat("|", ds_label, "|", paste(row_links, collapse = " | "), "|\n") -} -``` - -### Wasserbilanz - -Streudiagramm **Infiltration [%]** (x) vs. **Evapotranspiration [%]** (y) je -Szenario, Punktfarbe = Anzahl Überlaufereignisse, Punktform = -**Speichertyp** (Viereck = Sickerbox, Dreieck = Schotterrigole). Der -Tooltip zeigt die Wasserbilanz, den Speichertyp und die variierenden -Design-Parameter. - -```{r brute_force_plots_water-balance, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_water-balance.html)\n", - site, - base_dir, - site - )) -} -``` - -### Kosten - -Sechs komplementäre, interaktive Sichten auf die **Baukosten** der -Szenarien und ihren Zusammenhang mit Überläufen, Wasserhaushalt und -Design-Parametern. Alle teilen denselben Punkt-Tooltip -(Wasserhaushalt, Kostenaufteilung, variierende Parameter). Der -**Speichertyp** ist überall einheitlich kodiert: in den Streudiagrammen -über die **Punktform** (Viereck = Sickerbox/Infiltration box, -Dreieck = Schotterrigol/Gravel trench), in den Boxplots über **zwei -Panels untereinander** (Sickerbox oben, Schotterrigol unten). - -#### Kosten vs. Überlaufvolumen - -Streudiagramm über den kompletten Design-Raum: **x-Achse Gesamtkosten -[€]**, **y-Achse Überlaufvolumen [m³]** (aus `sum_overflows` [mm] und -`mulde_area` [m²]), Punktfarbe nach **Anzahl Überlaufereignisse** (0–5, -`>5` = rot, Legende oben), Punktform nach **Speichertyp** (Viereck = -Sickerbox, Dreieck = Schotterrigol). Mouseover zeigt den Wasserhaushalt -(Evapotranspiration, Versickerung, Überlauf in %), das nutzbare -Speichervolumen, die vollständige -Kostenaufteilung (Aushub, Profilierung, Bodenfilter, Speicherschicht, -Gesamt), die **Kosten je Prozent Evapotranspiration über dem -Referenz-Minimum der gültigen Szenarien [€/%]** (Referenzwert in der -Tooltip-Zeile genannt) plus -die variierenden Design-Parameter des Szenarios. - -```{r brute_force_plots_cost-overflow, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-vs-overflow-volume.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Kosten vs. Evapotranspiration - -Streudiagramm analog zum vorigen, aber mit der **Evapotranspiration [%]** -(Anteil der Evapotranspiration am Gesamtwasserinput des Elements) auf der -y-Achse: **x-Achse Gesamtkosten [€]**, Punktfarbe nach **Anzahl -Überlaufereignisse**, Punktform nach **Speichertyp** (Viereck = -Sickerbox, Dreieck = Schotterrigol). Zeigt, wie viel Evapotranspiration man -je Budget bekommt und welche Szenarien dabei gültig bleiben — -identischer Tooltip. - -```{r brute_force_plots_cost-evaporation, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-vs-evaporation.html)\n", - site, - base_dir, - site - )) -} -``` - -Alle Boxplots zeigen die **Gesamtkosten** [€] (y-Achse) je **Anzahl -Überlaufereignisse** (x-Achse; `0`–`5` einzeln, `>5` = Rest gebündelt; im -`>5`-Kasten wird das Szenario mit den wenigsten Überläufen markiert), -überlagert mit den Szenarien als Punkte (Kreise; die Panel-Streifen -benennen den Typ), und trennen die beiden -**Speichertypen in zwei Panels untereinander** (Sickerbox oben, -Schotterrigol unten). Je Box und Panel ist ein -**bestes** Szenario -als Raute in der jeweiligen Gruppenfarbe (schwarz umrandet) markiert; die -Markierungen **aller** Klassen sind je Panel zur Frontier-Linie verbunden. -Punkt-Mouseover: Wasserhaushalt, Kostenaufteilung, variierende Parameter. -Die drei Varianten optimieren je Box ein **anderes Ziel** (Kosten als -Tie-Break) und ergeben so drei verschiedene Frontier-Linien: - -#### Boxplot – günstigste je Kategorie - -Das **günstigste** Szenario je Box. Punktgröße = Überlaufvolumen [m³]. - -```{r brute_force_plots_cost-boxplot-cheapest, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-cheapest.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – geringstes Überlaufvolumen - -Das Szenario je Box mit dem **geringsten Überlaufvolumen** (bei Gleichstand -das günstigste). Die Markierung ist mit ihrem **Überlaufvolumen [m³] und -dessen Anteil [%]** beschriftet. Punktgröße = Überlaufvolumen. - -```{r brute_force_plots_cost-boxplot-min-overflow, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-min-overflow.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – höchste Evapotranspiration - -Das Szenario je Box mit der **höchsten Evapotranspiration** (bei Gleichstand das -günstigste). Die Markierung ist mit ihrer **Evapotranspiration [%]** beschriftet; -hier kodiert die **Punktgröße die Evapotranspiration** statt des Überlaufvolumens. - -```{r brute_force_plots_cost-boxplot-max-evap, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-by-overflows-boxplot-max-evap.html)\n", - site, - base_dir, - site - )) -} -``` - -#### Boxplot – Kosten je Prozent Evapotranspiration - -**Marginale** Kosteneffizienz der Evapotranspiration: y-Achse sind die -**Kosten je Prozentpunkt Evapotranspiration über dem Referenz-Minimum -[€/%]** — Gesamtkosten geteilt durch die Mehr-Evapotranspiration -gegenüber der Referenz. Die Referenz ist die **minimale -Evapotranspiration der gültigen Szenarien** (Anzahl Überlaufereignisse -≤ Schwellenwert; gibt es keine gültigen, der komplette Modelllauf) — -diese Basis-Evapotranspiration ist damit „gratis"; bezahlt wird nur der -Zugewinn. Die **Referenz** (minimale Evapotranspiration [%], -Gültigkeitskriterium und zugehörige -Szenario-ID) steht in der zweiten Titelzeile; Szenarien auf oder unter -der Referenz (inkl. des Referenz-Szenarios selbst) haben keine -definierte Kennzahl und entfallen im Plot. Aufteilung -je **Anzahl Überlaufereignisse**, -wieder mit den beiden **Speichertypen als zwei Panels untereinander**. -Je Box und Panel ist das Szenario mit den **geringsten Kosten je -Prozentpunkt** markiert und mit seinem Wert [€/%] plus dem erkauften -Zugewinn **„(+ x.x % Evapotranspiration)"** beschriftet; die -**Punktgröße kodiert die Evapotranspiration [%]**. So lässt sich direkt -ablesen, mit welcher Speichertechnik und welchem Design ein -zusätzlicher Prozentpunkt Evapotranspiration am günstigsten erkauft wird. - -```{r brute_force_plots_cost-per-evap-boxplot, echo = FALSE, results='asis'} -for (site in sites) { - cat(sprintf( - "- [%s](%s/simulation_results_optimisation_%s_cost-per-evap-boxplot.html)\n", - site, - base_dir, - site - )) -} -``` - - diff --git a/vignettes/monotonicity_analysis.Rmd b/vignettes/monotonicity_analysis.Rmd deleted file mode 100644 index 544f0de..0000000 --- a/vignettes/monotonicity_analysis.Rmd +++ /dev/null @@ -1,455 +0,0 @@ ---- -title: "Monotonie-Check der Optimierungsergebnisse" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Monotonie-Check der Optimierungsergebnisse} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- - -```{r setup, include = FALSE, eval = TRUE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.width = 7, - fig.height = 3.2 -) - -# Diese Vignette wertet die Ergebnis-CSVs der drei Workflow-Vignetten aus -# (workflow_badaussee, workflow_eisenstadt-2005, workflow_wien). Sie ist -# bedingt: alle Analyse-Chunks laufen nur, wenn die CSVs neben dieser -# Datei liegen -- also NACH einem lokalen Lauf der Workflows (Windows + -# Engine). Auf CI/GitHub Actions wird nur der Text gerendert. -result_files <- c( - BadAussee = "simulation_results_optimisation_BadAussee.csv", - Eisenstadt = "simulation_results_optimisation_Eisenstadt_2005.csv", - Wien = "simulation_results_optimisation_Wien.csv" -) -results_available <- all(file.exists(result_files)) - -# Auf GH Actions (pkgdown-Deploy) liegt der Ergebnisbericht (index.html) -# nicht neben dem gerenderten Artikel -- der Link darauf wird dann nicht -# gesetzt (nur beim lokalen Rendern in den Ordner monotonicity_analysis/). -is_ghactions <- tolower(Sys.getenv("GITHUB_ACTIONS")) == "true" || - tolower(Sys.getenv("CI")) %in% c("true", "1", "yes") -``` - -## Worum geht es? - -Der geplante Optimierer sucht die günstigste Muldenkonfiguration per -**Bisektion** (Intervallhalbierung): "Zu klein" → größer probieren, -"reicht" → kleiner probieren. Das funktioniert nur, wenn eine Regel gilt: - -> **Monotonie:** Wird das Bauwerk größer (mehr Fläche, mehr Tiefe, mehr -> Speicher, durchlässigerer Filter), darf es niemals *mehr* -> Überlaufereignisse geben als vorher. - -Diese Vignette prüft die Regel an allen Nachbarpaaren des Brute-Force-Rasters -(je Standort 576 Läufe, 1 704 Vergleichspaare — insgesamt 5 112). -Verglichen werden immer zwei Läufe, die sich **nur in einem Parameter um eine -Stufe** unterscheiden. Zusätzlich geprüft: das Überlaufvolumen in m³ -(`sum_overflows` ist mm Wassersäule über der Muldenfläche, daher -m³ = mm × Muldenfläche / 1000), die Verdunstung sowie zwei -Struktur-Eigenschaften, die der Optimierer nutzt (Ambiguitätsband, -Schwellentreppe, kf-Dominanz). - -## Voraussetzungen - -Diese Vignette **nach den drei Workflow-Vignetten ausführen** — sie liest -deren Ergebnisdateien (`simulation_results_optimisation_*.csv`) aus dem -`vignettes/`-Verzeichnis. - -```{r availability_note, echo = FALSE, results = 'asis', eval = !results_available} -cat(paste0( - "> **Hinweis:** Es wurden keine Ergebnisdateien gefunden — die ", - "Analyse-Chunks wurden übersprungen. Bitte zuerst die Workflow-Vignetten ", - "(Bad Aussee, Eisenstadt 2005, Wien) lokal ausführen (Windows + Engine) ", - "und diese Vignette anschließend erneut rendern.\n" -)) -``` - -### Verwendete Dateien und Ablage-Struktur - -Die Links folgen der Deploy-Struktur auf dem Server: Diese Analyse, der -Ergebnisbericht und die Detailtabellen liegen unter -`…/optimisation/monotonicity_analysis/`, die Ergebnisse der -Workflow-Vignetten unter `…/optimisation/brute-force/`. Damit die Links auch -lokal stimmen, wird diese Vignette in den gleichnamigen Unterordner -gerendert: - -```r -rmarkdown::render("monotonicity_analysis.Rmd", - output_dir = "monotonicity_analysis") -``` - -(Eingelesen werden die CSVs unverändert aus `vignettes/`, wo die Workflows -sie ablegen — nur die Links zeigen auf die Deploy-Orte.) - -| Standort | Eingangsdaten (CSV) | Interaktive Ergebnistabelle | -|----------|---------------------|-----------------------------| -| Bad Aussee | [CSV](../brute-force/simulation_results_optimisation_BadAussee.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_BadAussee.html) | -| Eisenstadt 2005 | [CSV](../brute-force/simulation_results_optimisation_Eisenstadt_2005.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_Eisenstadt_2005.html) | -| Wien | [CSV](../brute-force/simulation_results_optimisation_Wien.csv) | [HTML-Tabelle](../brute-force/simulation_results_optimisation_Wien.html) | - -```{r report_link, echo = FALSE, results = 'asis', eval = !is_ghactions} -cat(paste0( - "Der zusammenfassende, allgemeinverständliche Ergebnisbericht (Artefakt, ", - "Titel: „Monotonie-Analyse RAINDROP“) liegt als [index.html](index.html) ", - "direkt neben dieser Seite — als Verzeichnis-Startseite von ", - "`…/optimisation/monotonicity_analysis/`. Nicht zu verwechseln mit dem ", - "„Brute-Force“-Linkhub: Dessen Quelle `index.Rmd` liegt in `vignettes/`, ", - "sein gerendertes `index.html` eine Ebene über dieser Seite.\n" -)) -``` - -```{r libraries, eval = results_available, message = FALSE} -library(dplyr) -library(ggplot2) - -geom_params <- c("mulde_area", "mulde_height", "filter_hydraulicconductivity", - "storage_type", "storage_height") -check_params <- setdiff(geom_params, "storage_type") - -results <- lapply(result_files, function(f) { - readr::read_csv(f, show_col_types = FALSE) %>% - # Die Engine liefert die Ueberlaufrate in mm/h bezogen auf die - # Muldenflaeche; sum_overflows ist damit mm Wassersaeule. - # Volumen: m3 = mm x Muldenflaeche / 1000. - mutate(overflow_volume_m3 = sum_overflows * mulde_area / 1000) -}) - -# Alle Nachbarschritte entlang eines Parameters: alle uebrigen Parameter -# fixieren ("Gruppe"), nach dem Parameter sortieren, jeden Uebergang zum -# Nachbarwert als Schritt ausgeben. Verletzung :<=> dn > 0. -step_table <- function(d, v) { - grp <- setdiff(geom_params, v) - d %>% - group_by(across(all_of(grp))) %>% - arrange(.data[[v]], .by_group = TRUE) %>% - mutate(val_from = lag(.data[[v]]), - val_to = .data[[v]], - n_from = lag(n_overflows), - vol_from = lag(overflow_volume_m3), - et_from = lag(element.WB_Evapotranspiration_), - is_last = row_number() == n()) %>% - ungroup() %>% - filter(!is.na(val_from)) %>% - mutate(dn = n_overflows - n_from, - dvol = overflow_volume_m3 - vol_from, - det = element.WB_Evapotranspiration_ - et_from) -} - -steps_all <- purrr::map_dfr(names(results), function(site) { - purrr::map_dfr(check_params, function(v) { - step_table(results[[site]], v) %>% mutate(site = site, param = v) - }) -}) -``` - -## 1 Schrittverteilung: fällt, Plateau oder steigt? - -Plateaus (keine Änderung) sind unkritisch — sie sind die flachen Stufen der -Treppenfunktion und entstehen vor allem dort, wo bereits n = 0 -erreicht ist. Kritisch sind nur Anstiege ("mehr Überläufe trotz größer"). - -```{r step_distribution, eval = results_available} -step_distribution <- steps_all %>% - group_by(site, param) %>% - summarise(steps = n(), - faellt = sum(dn < 0), - plateau = sum(dn == 0), - steigt = sum(dn > 0), - steigt_anteil_pct = round(100 * mean(dn > 0), 2), - max_sprung = max(dn), - .groups = "drop") - -knitr::kable(step_distribution) -``` - -## 2 Die Verletzungen im Detail - -Jede Verletzung wird mit ihrer Volumen-Gegenprobe (in m³) gezeigt: Fällt das -Überlaufvolumen am selben Schritt weiter, ist der Anstieg des Zählers ein -Artefakt der Ereignistrennung (Pausen > 4 h teilen ein langes -Überlaufereignis in zwei gezählte), keine echte Verschlechterung. - -```{r violations, eval = results_available} -violations <- steps_all %>% - filter(dn > 0) %>% - transmute(site, param, - kontext = paste0("h_m ", mulde_height, - " | kf ", filter_hydraulicconductivity, - " | ", storage_type, - ifelse(param == "storage_height", "", - paste0(" ", storage_height))), - von = val_from, nach = val_to, - n = paste0(n_from, " → ", n_overflows), - volumen_m3 = paste0(round(vol_from, 1), " → ", - round(overflow_volume_m3, 1)), - volumen_delta_pct = round(100 * dvol / vol_from, 1), - am_rasterrand = is_last) - -DT::datatable(violations, filter = "top", - options = list(pageLength = 25, autoWidth = TRUE)) -``` - -Zur Anschauung dieselbe Bauweise an allen drei Standorten (Muldentiefe -300 mm, kf 360 mm/h, Sickerbox 300 mm): Der Zähler fällt -überall steil — nur in Bad Aussee springt er am letzten Rasterschritt von -1 auf 2 (roter Punkt), während das Volumen auch dort weiter fällt. - -```{r example_series, eval = results_available, warning = FALSE} -example_series <- purrr::map_dfr(names(results), function(site) { - results[[site]] %>% - filter(mulde_height == 300, filter_hydraulicconductivity == 360, - storage_type == "infiltration_box", storage_height == 300) %>% - arrange(mulde_area) %>% - mutate(site = site, - verletzung = n_overflows > lag(n_overflows, default = Inf)) -}) - -ggplot(example_series, aes(mulde_area, n_overflows)) + - geom_line(colour = "grey50") + - geom_point(aes(colour = verletzung), size = 2, show.legend = FALSE) + - scale_colour_manual(values = c(`FALSE` = "steelblue4", `TRUE` = "firebrick")) + - scale_y_sqrt() + - facet_wrap(~ site, scales = "free_y") + - labs(title = "Ueberlaufereignisse je Muldenflaeche (Wurzel-Skala)", - x = "Muldenflaeche [m2]", y = "Anzahl Ueberlaufereignisse") + - theme_bw() - -ggplot(example_series, aes(mulde_area, overflow_volume_m3)) + - geom_line(colour = "grey50") + - geom_point(colour = "springgreen4", size = 2) + - scale_y_sqrt() + - facet_wrap(~ site, scales = "free_y") + - labs(title = "Ueberlaufvolumen je Muldenflaeche (Wurzel-Skala): faellt ausnahmslos", - x = "Muldenflaeche [m2]", y = "Ueberlaufvolumen [m3]") + - theme_bw() -``` - -## 3 Gegenprobe: das Überlaufvolumen (m³) - -Auch in m³ gerechnet (mm Wassersäule × Muldenfläche / 1000 — entlang der -Fläche wächst der Umrechnungsfaktor mit, die Monotonie ist also nicht -automatisch übertragbar) gilt das Ergebnis: - -```{r volume, eval = results_available} -volume_check <- steps_all %>% - group_by(site) %>% - summarise(steps = n(), - volumen_steigt = sum(dvol > 1e-9), - plateau = sum(abs(dvol) <= 1e-9), - volumen_faellt = sum(dvol < -1e-9), - .groups = "drop") - -knitr::kable(volume_check) -``` - -## 4 Verdunstung: hängt nur an der Fläche - -```{r et, eval = results_available} -et_check <- steps_all %>% - group_by(site, param) %>% - summarise(steigt_pct = round(100 * mean(det > 1e-9), 1), - flach_pct = round(100 * mean(abs(det) <= 1e-9), 1), - faellt_pct = round(100 * mean(det < -1e-9), 1), - .groups = "drop") - -knitr::kable(et_check) -``` - -Konsequenz für das Sekundärziel "Verdunstung maximieren": Der Trade-off -Kosten ↔ Verdunstung verläuft eindimensional entlang der -Muldenfläche — mehr Verdunstung gibt es nur über mehr Fläche. - -## 5 Ambiguitätsband und Schwellentreppe - -Für die Bisektion relevant: Gibt es Konfigurationsgruppen, in denen oberhalb -der ersten zulässigen Fläche wieder eine unzulässige liegt (Ambiguitätsband)? -Und ist die Schwellentreppe a*(x) — die kleinste zulässige Fläche je -Überlaufziel x — monoton (ein lockereres Ziel verlangt nie mehr Fläche)? - -```{r ambiguity, eval = results_available} -grp_area <- setdiff(geom_params, "mulde_area") - -ambiguity <- purrr::map_dfr(names(results), function(site) { - purrr::map_dfr(0:5, function(x) { - results[[site]] %>% - group_by(across(all_of(grp_area))) %>% - summarise(first_ok = ifelse(any(n_overflows <= x), - min(mulde_area[n_overflows <= x]), NA), - last_bad = ifelse(any(n_overflows > x), - max(mulde_area[n_overflows > x]), NA), - .groups = "drop") %>% - summarise(site = site, x = x, - gruppen = n(), - mit_loesung = sum(!is.na(first_ok)), - ambig = sum(!is.na(first_ok) & !is.na(last_bad) & - last_bad > first_ok), - max_band_m2 = max(c(0, (last_bad - first_ok)[ - !is.na(first_ok) & !is.na(last_bad)]), na.rm = TRUE)) - }) -}) - -knitr::kable(ambiguity) - -staircase <- purrr::map_dfr(names(results), function(site) { - results[[site]] %>% - group_by(across(all_of(grp_area))) %>% - reframe(x = 0:5, - a_star = sapply(0:5, function(x) - ifelse(any(n_overflows <= x), - min(mulde_area[n_overflows <= x]), NA))) %>% - group_by(across(all_of(grp_area))) %>% - summarise(treppen_verletzungen = { - a <- a_star[order(x)] - a <- a[!is.na(a)] - if (length(a) > 1) sum(diff(a) > 0) else 0L - }, .groups = "drop") %>% - summarise(site = site, branches = n(), - treppen_verletzungen = sum(treppen_verletzungen)) -}) - -knitr::kable(staircase) -``` - -## 6 kf-Dominanz: der Filter ist ein Gratis-Hebel - -Die Filterdurchlässigkeit kostet nichts (sie taucht in `compute_costs()` -nicht auf). Wenn sie gleichzeitig die Verdunstung nicht verändert und die -Überläufe nie erhöht, kann der Optimierer sie fest auf das Maximum setzen. - -```{r kf_dominance, eval = results_available} -kf_dominance <- purrr::map_dfr(names(results), function(site) { - results[[site]] %>% - group_by(filter_hydraulicconductivity) %>% - summarise(site = site, - mittlere_ET_pct = round(mean(element.WB_Evapotranspiration_), 2), - mittlere_n_overflows = round(mean(n_overflows), 1), - mittleres_volumen_m3 = round(mean(overflow_volume_m3), 1), - .groups = "drop") -}) - -knitr::kable(kf_dominance) -``` - -## 7 Warmstart: billigstes zulässiges Raster-Design je Ziel x - -Diese Tabelle ist der Startpunkt der Bisektion: das jeweils günstigste -zulässige Design aus dem vorhandenen Raster (bei kf = Maximum), je -Überlaufziel x und Speichertyp. Der Optimierer verfeinert nur noch im -25-m²-Bracket darunter. - -```{r warmstart, eval = results_available} -warmstart <- purrr::map_dfr(names(results), function(site) { - d <- results[[site]] %>% - filter(filter_hydraulicconductivity == max(filter_hydraulicconductivity)) - purrr::map_dfr(0:5, function(x) { - d %>% - filter(n_overflows <= x) %>% - group_by(storage_type) %>% - slice_min(cost_total, n = 1, with_ties = FALSE) %>% - ungroup() %>% - transmute(site = site, x = x, storage_type, mulde_area, mulde_height, - storage_height, cost_total, - overflow_volume_m3 = round(overflow_volume_m3, 1), - ET_pct = round(element.WB_Evapotranspiration_, 1)) - }) -}) - -DT::datatable(warmstart, filter = "top", - options = list(pageLength = 12, autoWidth = TRUE)) -``` - -## Fazit: Regeln für den Optimierer - -Stand der letzten vollständigen Auswertung (2026-07-10): 5 112 -Vergleichspaare, 13 Verletzungen (0,25 %), alle mit Sprunghöhe genau +1 -und fallendem Volumen — Eisenstadt 0, Wien 1 (bei n ≈ 287, -irrelevant für x ≤ 5), Bad Aussee 12 (alle am Rasterrand -175 → 200 m², Niveau n = 1). Das -Überlaufvolumen stieg in keinem einzigen Vergleich. **Die -Monotonie-Voraussetzung der Bisektion ist damit erfüllt**, abgesichert durch -drei Regeln: - -1. **Grid-Warmstart:** Bisektion nur im 25-m²-Bracket um das bekannte - `first_ok` aus dem Raster verfeinern — dort ist die Grenze an allen drei - Standorten eindeutig. -2. **Rand-Guard statt Abbruch:** Fällt der obere Intervallrand nur um +1 - über das Ziel (n = x + 1), erst Cache-/Rasterpunkte darunter - prüfen, bevor "keine Lösung" gemeldet wird. -3. **Volumen als Schiedsrichter:** Bei jedem nicht-monotonen Flip prüfen, ob - `sum_overflows` weiter gefallen ist. Ja → bekannter Zähl-Wobble, - weiterrechnen. Nein → Warnung (bisher nie aufgetreten) — der eingebaute - Rauchmelder für künftige Standorte. - -Beim Hinzufügen eines neuen Standorts: Workflows laufen lassen und diese -Vignette erneut rendern. Zeigt Abschnitt 1 Sprünge > +1 oder Abschnitt 3 -steigendes Volumen, ist die Bisektion für diesen Standort nicht abgesichert. - -```{r export, eval = results_available, message = FALSE} -save_table_html <- function(df, file, title) { - htmlwidgets::saveWidget( - DT::datatable(df, filter = "top", - options = list(pageLength = 25, autoWidth = TRUE)), - file = file, selfcontained = TRUE, title = title - ) - # saveWidget() laesst bei Zielpfaden ausserhalb des Arbeitsverzeichnisses - # den "_files"-lib-Ordner stehen, obwohl die Datei selfcontained - # ist -> redundante Duplikate aufraeumen. - unlink(sub("\\.html$", "_files", file), recursive = TRUE) -} - -exports <- list( - mono_step_distribution = list(df = step_distribution, - titel = "Monotonie: Schrittverteilung"), - mono_violations_detail = list(df = violations, - titel = "Monotonie: Verletzungen im Detail"), - mono_volume = list(df = volume_check, - titel = "Monotonie: Ueberlaufvolumen (m3)"), - mono_et = list(df = et_check, - titel = "Monotonie: Verdunstung"), - mono_ambiguity = list(df = ambiguity, - titel = "Ambiguitaetsband je Ziel x"), - mono_staircase = list(df = staircase, - titel = "Schwellentreppe a*(x)"), - mono_kf_dominance = list(df = kf_dominance, - titel = "kf-Dominanz"), - mono_warmstart_designs = list(df = warmstart, - titel = "Warmstart-Designs") -) - -# Exporte in den Unterordner des Ergebnisberichts (index.html), damit der -# gesamte Ordner monotonicity_analysis/ als eine Einheit deploybar ist. -out_dir <- "monotonicity_analysis" -dir.create(out_dir, showWarnings = FALSE) - -for (name in names(exports)) { - readr::write_csv(exports[[name]]$df, file.path(out_dir, paste0(name, ".csv"))) - save_table_html(exports[[name]]$df, file.path(out_dir, paste0(name, ".html")), - title = exports[[name]]$titel) -} - -# Den Rmd-Quellcode mit in den Deploy-Ordner kopieren, damit der Link -# "monotonicity_analysis.Rmd" des Ergebnisberichts (index.html) dort -# funktioniert. -invisible(file.copy("monotonicity_analysis.Rmd", - file.path(out_dir, "monotonicity_analysis.Rmd"), - overwrite = TRUE)) -``` - -Die exportierten Detailtabellen liegen neben dieser Seite (im Unterordner -`monotonicity_analysis/`), jeweils als CSV und als interaktive -HTML-Tabelle: - -| Tabelle | Inhalt | CSV | HTML | -|---------|--------|-----|------| -| Schrittverteilung | fällt / Plateau / steigt je Standort × Parameter | [CSV](mono_step_distribution.csv) | [HTML](mono_step_distribution.html) | -| Verletzungen | alle 13 Fälle mit Volumen-Gegenprobe (m³) | [CSV](mono_violations_detail.csv) | [HTML](mono_violations_detail.html) | -| Überlaufvolumen | Monotonie des Volumens in m³ | [CSV](mono_volume.csv) | [HTML](mono_volume.html) | -| Verdunstung | ET-Richtung je Parameter | [CSV](mono_et.csv) | [HTML](mono_et.html) | -| Ambiguitätsband | Eindeutigkeit der Zulässigkeitsgrenze je Ziel x | [CSV](mono_ambiguity.csv) | [HTML](mono_ambiguity.html) | -| Schwellentreppe | Monotonie von a*(x) je Branch | [CSV](mono_staircase.csv) | [HTML](mono_staircase.html) | -| kf-Dominanz | ET / Überläufe / Volumen je kf-Stufe | [CSV](mono_kf_dominance.csv) | [HTML](mono_kf_dominance.html) | -| Warmstart-Designs | billigstes zulässiges Raster-Design je x und Speichertyp | [CSV](mono_warmstart_designs.csv) | [HTML](mono_warmstart_designs.html) | diff --git a/vignettes/workflow_optimisation.Rmd b/vignettes/workflow_optimisation.Rmd index 8b78c74..fbbd302 100644 --- a/vignettes/workflow_optimisation.Rmd +++ b/vignettes/workflow_optimisation.Rmd @@ -42,7 +42,9 @@ x = 0…5 — pro Speichertyp (Sickerbox / Schotterrigol) — mit `optimise_swale_design()` statt eines Brute-Force-Rasters. Das Verfahren ist reine Bisektion ("Zahlenraten"): Fläche schrumpfen, dann Muldentiefe, Speicher nur erhöhen, wenn die Fläche am Anschlag klemmt. Voraussetzung -ist die in der Vignette `monotonicity_analysis` belegte Monotonie +ist die in der +[Monotonie-Analyse](https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/) +belegte Monotonie ("größer = nie mehr Überläufe"); die dort abgeleiteten Absicherungen (Rand-Guard, Volumen-Schiedsrichter) sind in `find_min_feasible()` eingebaut. Eine unabhängige **Gegenprobe ohne Monotonie-Annahme** — diff --git a/vignettes/workflow_optimisation_simultaneous.Rmd b/vignettes/workflow_optimisation_simultaneous.Rmd index f3dac5a..7ab14dd 100644 --- a/vignettes/workflow_optimisation_simultaneous.Rmd +++ b/vignettes/workflow_optimisation_simultaneous.Rmd @@ -39,7 +39,8 @@ t_vignette_start <- Sys.time() Die Vignette `workflow_optimisation` findet die günstigste Muldenkonfiguration je Überlaufziel per **Bisektion**: Parameter nacheinander, gestützt auf die Monotonie je Parameter -(`monotonicity_analysis`). Diese Vignette ist die **unabhängige +([Monotonie-Analyse](https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/)). +Diese Vignette ist die **unabhängige Gegenprobe**: `optimise_swale_design_simultaneous()` optimiert **alle Parameter gleichzeitig** — Fläche, Muldentiefe und Speicherhöhe in einem Zug — und kommt dabei *ohne* die Monotonie-Annahme aus. @@ -470,7 +471,9 @@ ggplot(methoden[methoden$status == "ok", ], nicht des Suchwegs. - **Wenn die simultane Suche systematisch günstiger ist**, gibt es zwei mögliche Ursachen: (a) die Monotonie-Annahme der Bisektion ist - verletzt (echter Modell-Alarm → `monotonicity_analysis` prüfen), oder + verletzt (echter Modell-Alarm → die + [Monotonie-Analyse](https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/) + prüfen), oder (b) der **Spezifikkosten-Proxy**, aus dem die Bisektion ihre Suchreihenfolge herleitet (€ je mm Speicherkapazität, Kapazitätsmodell V ≈ Fläche × (Tiefe + Porosität × Speicher)), greift zu kurz — etwa From 909a3065f0e517753c0264d9848d766e1c851e01 Mon Sep 17 00:00:00 2001 From: Claude Date: Fri, 7 Aug 2026 12:42:03 +0000 Subject: [PATCH 34/34] Use English labels for the external-results navbar menu The pkgdown navbar chrome is English (Get started, Reference, Articles, Changelog), so the new menu is now "More results" with English item labels (brute force, monotonicity analysis, optimiser vs. brute force). The German link texts inside the German-language vignettes are kept. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_017E2RpwmBRnnDHRmxjXRh4x --- NEWS.md | 2 +- _pkgdown.yml | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index 61a79b2..f71f353 100644 --- a/NEWS.md +++ b/NEWS.md @@ -373,7 +373,7 @@ and their result files never exist on GitHub Actions, so the pkgdown-built copies were link-dead shells. The complete rendered pages live on that server; the pkgdown - navbar instead gains an "Ergebnisse" menu linking them (brute force, + navbar instead gains a "More results" menu linking them (brute force, monotonicity analysis, optimiser vs. brute force), and the two optimisation vignettes link the monotonicity analysis there too. diff --git a/_pkgdown.yml b/_pkgdown.yml index 0fa93d7..016636d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -25,16 +25,16 @@ template: # hier nur extern verlinkt. navbar: structure: - left: [intro, reference, articles, ergebnisse, tutorials, news] + left: [intro, reference, articles, results, tutorials, news] components: - ergebnisse: - text: Ergebnisse + results: + text: More results menu: - - text: Brute-Force + - text: Brute force href: https://raindrop.kompetenz-wasser.io/brute-force/ - - text: Monotonie-Analyse + - text: Monotonicity analysis href: https://raindrop.kompetenz-wasser.io/optimisation/monotonicity_analysis/ - - text: Optimierer vs. Brute-Force + - text: Optimiser vs. brute force href: https://raindrop.kompetenz-wasser.io/optimisation/optimiser_vs_brute-force/ development: mode: auto