v0.3.0: Allow parameter override, consider tree measures

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: kwb.smartwater
 Title: Functions Related to the SmartWater Project
-Version: 0.2.1
+Version: 0.3.0
 Authors@R: c(
     person("Hauke", "Sonnenberg", , "hauke.sonnenberg@kompetenz-wasser.de", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9134-2871")),
@@ -22,7 +22,7 @@ Suggests:
     plumber2,
     testthat (>= 3.0.0)
 Remotes:
-    github::kwb-r/kwb.rabimo@dev,
+    github::kwb-r/kwb.rabimo@v2.2.0,
     github::kwb-r/kwb.utils
 Config/roxygen2/version: 8.0.0
 RoxygenNote: 7.3.3

NEWS.md

@@ -1,17 +1,24 @@
-# kwb.smartwater v0.2.1
+## kwb.smartwater v0.3.0 (2026-07-31)
+
+In this version,
+
+- tree measures are considered by increasing the vegetation class,
+- default model parameters can be overridden.
+
+## kwb.smartwater v0.2.1
 
 Fix bug in considering existing green roofs for status quo calculation
 
-# kwb.smartwater v0.2.0
+## kwb.smartwater v0.2.0
 
 Changed interface to the plot-related functions, allowing to specify the margins
 
-# kwb.smartwater v0.1.0
+## kwb.smartwater v0.1.0
 
 First version to be used by the Smartwater Web App, developed by 
 Technologiestiftung Berlin
 
-# kwb.smartwater 0.0.0.9000
+## kwb.smartwater 0.0.0.9000
 
 * Added a `NEWS.md` file to track changes to the package.
 * see https://style.tidyverse.org/news.html for writing a good `NEWS.md`

R/calculate_water_balance.R

@@ -6,15 +6,30 @@
 #'   \code{code}. There is one numeric field per measure. The names of the
 #'   measure-related fields must correspond to the \code{field_name}s returned 
 #'   by \code{\link{get_measure_info}}.
+#' @param parameters optional. List of parameters for each measure for which
+#'   parameter values shall be overridden. Its format should refer to the format
+#'   of the list returned by \code{\link{get_measure_info}(parameters_only =
+#'   TRUE)}.
 #' @param convert_types logical value indicating whether or not to convert the
 #'   data types in the \code{blocks} data frame as required by R-ABIMO.
+#' @param max_veg_class maximum vegetation class value. When increasing the
+#'   vegetation class index in order to consider tree measures, the resulting
+#'   vegetation class index of a block will be limited to this value. The
+#'   default is 80.
 #' @export
-calculate_water_balance <- function(blocks, measures, convert_types = FALSE) {
+calculate_water_balance <- function(
+    blocks,
+    measures,
+    parameters = NULL,
+    convert_types = FALSE,
+    max_veg_class = 80
+) {
 
-  #blocks <- kwb.smartwater::get_test_blocks()
-  #measures <- kwb.smartwater::get_test_block_measures()
-  #convert_types = FALSE
-  #kwb.utils::assignPackageObjects("kwb.smartwater")
+  # blocks <- kwb.smartwater::get_test_blocks()
+  # measures <- kwb.smartwater::get_test_block_measures()
+  # parameters = get_measure_info(parameters_only = TRUE)
+  # convert_types = FALSE
+  # kwb.utils::assignPackageObjects("kwb.smartwater")
 
   # kwb.rabimo is strict about data types. Therefore, convert data types as
   # necessary
@@ -28,7 +43,7 @@ calculate_water_balance <- function(blocks, measures, convert_types = FALSE) {
   }
 
   config <- kwb.rabimo:::reconfigure(kwb.rabimo::rabimo_inputs_2025$config)
-  config[["measures"]] <- get_measures_config()
+  config[["measures"]] <- get_measures_config(parameters)
 
   # Calculate water balance for natural state
   water_balance_natural <- kwb.rabimo::run_rabimo(
@@ -89,7 +104,16 @@ calculate_water_balance <- function(blocks, measures, convert_types = FALSE) {
         }
       }
 
-      # TODO: tree measures
+      # tree measures
+      veg_class_increment <- get_veg_class_increment(
+        tree_measure_volume = get_tree_measure_volume(block_measures, parameters),
+        unsealed_area_m2 = areas_m2$unsealed
+      )
+      block$veg_class <- min(
+        block$veg_class + veg_class_increment, 
+        max_veg_class
+      )
+
     }
 
     # Calculate m2 back into percentages
@@ -234,17 +258,22 @@ add_delta_w <- function(water_balance, delta_w) {
   cbind(water_balance, delta_w = delta_w[["delta_w"]])
 }
 
-get_measures_config <- function() {
+get_measures_config <- function(parameters = NULL) {
   lapply(
     X = stats::setNames(nm = c("green_roof", "infiltration", "retention")), 
     FUN = function(type) {
-      abimo_parameters <- lapply(get_measure_info(type), function(x) {
+      parameters <- lapply(get_measure_info(type), function(x) {
+        input_column <- x[["field_name"]]
         c(
-          list(input_column = x[["field_name"]]),
-          x[["abimo_parameters"]]
+          list(input_column = input_column),
+          if (!is.null(parameters) && length(parameters[[input_column]])) {
+            parameters[[input_column]] 
+          } else {
+            x[["parameters"]]
+          }
         )
       })
-      abimo_parameters[!sapply(abimo_parameters, is.null)]
+      parameters[!sapply(parameters, is.null)]
     }
   )
 }

R/frontend_helpers.R

@@ -6,23 +6,30 @@
 #'   ("green_roof", "pavement", "trees", "infiltration", "retention") for which 
 #'   to filter the output.
 #' @param field_name_only optional. Logical of length one indicating whether or 
-#'   not to return only the "field_name" instead of all info fields per measure
+#'   not to return only the "field_name" instead of all info fields per measure.
+#'   Default is FALSE.
+#' @param parameters_only if TRUE only returns parameters for each measure.
+#'   Default is FALSE.
 #' @export
-get_measure_info <- function(type = character(0), field_name_only = FALSE) {
+get_measure_info <- function(
+    type = character(0),
+    field_name_only = FALSE,
+    parameters_only = FALSE
+) {
   measures <- list(
     list(
       type = "green_roof",
       field_name = "green_roof_ext",
       long_name_de = "Extensive Dachbegr\u00fcnung",
-      abimo_parameters = list(
+      parameters = list(
         bagrov_value = 0.65
       )
     ),
     list(
       type = "green_roof",
       field_name = "green_roof_int",
       long_name_de = "Intensive Dachbegr\u00fcnung",
-      abimo_parameters = list(
+      parameters = list(
         bagrov_value = 0.75
       )
     ),
@@ -39,23 +46,34 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
     list(
       type = "trees",
       field_name = "trees_sm",
-      long_name_de = "B\u00e4ume (klein)"
+      long_name_de = "B\u00e4ume (klein)", 
+      parameters = list(
+        tree_volume = 200
+      )
     ),
     list(
       type = "trees",
       field_name = "trees_md",
-      long_name_de = "B\u00e4ume (mittel)"
+      long_name_de = "B\u00e4ume (mittel)", 
+      parameters = list(
+        tree_volume = 300
+      )
     ),
     list(
       type = "trees",
       field_name = "trees_lg",
-      long_name_de = "B\u00e4ume (gro\u00df)"
+      long_name_de = "B\u00e4ume (gro\u00df)", 
+      parameters = list(
+        # 440 m3 determined for Bayerischer Platz, Berlin, rounded down to 
+        # nearest multiple of 100
+        tree_volume = 400 
+      )
     ),
     list(
       type = "infiltration",
       field_name = "to_swale", # "to_inf_mulde"
       long_name_de = "Mulde",
-      abimo_parameters = list(
+      parameters = list(
         evaporation_factor = 0.1,
         overflow_factor = 0.05        
       )
@@ -64,7 +82,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
       type = "infiltration",
       field_name = "to_surf_infil",
       long_name_de = "Fl\u00e4chenversickerung",
-      abimo_parameters = list(
+      parameters = list(
         evaporation_factor = 0.15,
         overflow_factor = 0.15
       )
@@ -73,7 +91,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
       type = "infiltration",
       field_name = "to_swale_trench", # "to_inf_mulde_rigole"
       long_name_de = "Mulden-Rigolen-Element",
-      abimo_parameters = list(
+      parameters = list(
         evaporation_factor = 0.08,
         overflow_factor = 0.1
       )
@@ -82,7 +100,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
       type = "infiltration",
       field_name = "to_tree_pit",
       long_name_de = "Optimierter Baumstandort",
-      abimo_parameters = list(
+      parameters = list(
         evaporation_factor = 0.2,
         overflow_factor = 0.15
       )
@@ -91,7 +109,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
       type = "infiltration",
       field_name = "to_trench",
       long_name_de = "Rigole",
-      abimo_parameters = list(
+      parameters = list(
         evaporation_factor = 0.15,
         overflow_factor = 0.15
       )
@@ -100,7 +118,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
       type = "retention",
       field_name = "to_cistern", # "to_retention"
       long_name_de = "Zisterne", # (= Regentonne)
-      abimo_parameters = list(
+      parameters = list(
         overflow_factor = 0.5
       )
     )
@@ -109,6 +127,7 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
   collect <- function(x, field) {
     sapply(x, `[[`, field)
   }
+  # filter for type if type is given
   if (length(type) > 0L) {
     allowed_types <- unique(collect(measures, "type"))
     unknown_types <- setdiff(type, allowed_types)
@@ -122,10 +141,15 @@ get_measure_info <- function(type = character(0), field_name_only = FALSE) {
     measures <- measures[collect(measures, "type") %in% type]
   }
   if (field_name_only) {
-    collect(measures, "field_name")
-  } else {
-    measures
+    return(collect(measures, "field_name"))
+  }
+  if (parameters_only) {
+    return(stats::setNames(
+      lapply(measures, `[[`, "parameters"),
+      collect(measures, "field_name")
+      ))
   }
+  measures
 }
 
 #' Get one block (columns as expected by kwb.rabimo) for testing
@@ -183,7 +207,7 @@ rabimo_block_to_partial_areas_m2 <- function(block) {
   current <- cbind(current, as.data.frame(as.list(
     stats::setNames(rep(0, length(measures)), measures)
   )))
-
+  
   # recalculate `pvd`, `sealed`, `unsealed`
   current <- update_calculated_fields(current)
 
@@ -257,10 +281,10 @@ apply_measure <- function(areas, measure) {
   if (!name %in% get_measure_info(field_name_only = TRUE)) {
     stop(sprintf("Measure '%s' not supported!", name))
   }
-
+  
   # Add the area of the measure to area that is already allocated to the measure
   areas[[name]] <- areas[[name]] + measure[["area"]]
-
+  
   # Only measures related to paving need special treatment ("accordeon"):
   if (name == "unpaving") {
 

R/veg_class_functions.R

@@ -0,0 +1,46 @@
+get_tree_measure_volume <- function(block_measures, parameters = NULL) {
+
+  stopifnot(is.data.frame(block_measures), 
+            nrow(block_measures) == 1L)
+
+  default_tree_parameters <- get_measure_info("trees", parameters_only = TRUE)
+
+  stopifnot(all(names(default_tree_parameters) %in% names(block_measures)))
+
+  fields_trees <- get_measure_info("trees", TRUE)
+
+  sum(sapply(fields_trees, function(field) {
+
+    # field <- fields_trees[1]
+
+    n_trees <- block_measures[[field]]
+    volume_per_tree <- if (!is.null(parameters) && length(parameters[[field]])) {
+      parameters[[field]]$tree_volume
+    } else {
+      default_tree_parameters[[field]]$tree_volume
+    }
+    n_trees * volume_per_tree
+  }))
+}
+
+
+#' Vegetation Class Increment Caused by Planting Trees
+#' 
+#' @param unsealed_area_m2 unpaved area (= total_area * (1 - roof - pvd)) in m2
+#' @param m slope of the linear relation between normalised vegetation volume 
+#'   per unsealed area (vegnorm) and veg_scaled. Default: 4.7, calculated from
+#'   block with highest vegetation class in Berlin (code = 0000000012002198): 
+#'   m = veg_scaled/vegnorm = 118.1306/24.92435
+#' @param tree_measure_volume assumed green volume of trees in m3.
+get_veg_class_increment <- function(
+    tree_measure_volume,
+    unsealed_area_m2, 
+    m = 4.7
+)
+{
+  if (unsealed_area_m2 == 0) {
+    return(0)
+  }
+  m * tree_measure_volume / unsealed_area_m2 
+}
+

inst/scripts/plumber.R

@@ -22,15 +22,17 @@ function(type = character(0), field_name_only = FALSE)
 #* Run R-Abimo for a given set of block areas and a given set of corresponding measures.
 #* @param blocks:data.frame Array of block areas, as e.g. returned by /get_test_blocks
 #* @param measures:data.frame Array of objects containing information about the planned measures in m2. Each object has a text field "code" that identifies the block area to which the measures relate. All other fields are numeric and relate to a measure type. See /get_test_block_measures for an example object and for the expected measure names.
+#* @param parameters:list Optional. Object with element names corresponding to measure names. Each element contains parameters to be overridden for the corresponding measure. 
 #* @serializer unboxedJSON
 function(
     blocks = kwb.smartwater::get_test_blocks(), 
-    measures = kwb.smartwater::get_test_block_measures()
+    measures = kwb.smartwater::get_test_block_measures(),
+    parameters = kwb.smartwater::get_measure_info(parameters_only = TRUE)
 )
 {
   to_plumber_response(try({
     kwb.smartwater::calculate_water_balance(
-      blocks, measures, convert_types = TRUE
+      blocks, measures, parameters = parameters, convert_types = TRUE
     )
   }))
 }