Get rid of "sealed", "area_main", "area_road"

hsonne · hsonne · commit 883bebb0bf81 · 2025-03-31T16:04:20.000+02:00
diff --git a/R/distribute_measures.R b/R/distribute_measures.R
@@ -38,9 +38,6 @@ distribute_measures <- function(blocks, targets, intermediates = FALSE)
   blocks$pvd <- unpaved_area_table$pvd
   blocks$to_swale <- swale_connection_table$to_swale
 
-  # Recalculate "sealed"
-  blocks$sealed <- get_sealed(blocks)
-
   # Return the tables with intermediate values as attributes, if requested
   if (intermediates) {
     return(structure(
@@ -153,7 +150,8 @@ get_paved_area <- function(blocks)
 # get_sealed_area --------------------------------------------------------------
 get_sealed_area <- function(blocks)
 {
-  select_columns(blocks, "sealed") * get_main_area(blocks)
+  (select_columns(blocks, "roof") + select_columns(blocks, "pvd")) *
+    get_main_area(blocks)
 }
 
 # get_swale_connection_table ---------------------------------------------------
diff --git a/R/generate_rabimo_area.R b/R/generate_rabimo_area.R
@@ -31,11 +31,14 @@ generate_rabimo_area <- function(code, ..., column_info = read_column_info())
   key_value_pairs[is_integer] <- lapply(key_value_pairs[is_integer], as.integer)
 
   # Compose a one-row data frame from the key-value pairs
-  result <- kwb.utils::callWith(data.frame, key_value_pairs, ...)
+  further_args <- list(...)
+  #further_args <- list()
+  args <- key_value_pairs
+  args[names(further_args)] <- further_args
 
-  # Add columns "code", "main_frac"
-  fetch <- create_accessor(result)
+  result <- do.call(data.frame, args)
+
+  # Add column "code"
   result["code"] <- code
-  result["main_frac"] <- round(fetch("area_main")/fetch("total_area") , 2L)
   result
 }
diff --git a/R/prepare_input_data.R b/R/prepare_input_data.R
@@ -17,6 +17,11 @@
 prepare_input_data <- function(data, config, dbg = TRUE)
 {
   #kwb.utils::assignPackageObjects("kwb.rabimo")
+
+  #data <- sf::read_sf("~/../Downloads/raw_combined.gpkg")
+  #data$geom <- NULL
+  #data <- as.data.frame(data)
+
   #data <- kwb.abimo::abimo_input_2019
   #data <- berlin_2020_data
   #data <- kwb.utils:::get_cached("berlin_2020_data")
@@ -57,7 +62,7 @@ prepare_input_data <- function(data, config, dbg = TRUE)
     data$berlin_usage[is_road] <- 300L
 
     # Copy district information into the correct column (not needed anymore)
-    if("BEZIRK_1" %in% names(data)){
+    if ("BEZIRK_1" %in% names(data)) {
       stopifnot(identical(data$BEZIRK_1, data$district))
     }
     # data$district[is_road] <- select_columns(data, "BEZIRK_1")[is_road]
@@ -92,11 +97,20 @@ prepare_input_data <- function(data, config, dbg = TRUE)
   data[["prec_yr"]] <- fetch_data("prec_yr") *
     fetch_config("precipitation_correction_factor")
 
-  # Calculate total area
-  data[["total_area"]] <- fetch_data("area_main") + fetch_data("area_road")
-
   # Convert percentages to fractions
-  data <- calculate_fractions(data)
+  data[["total_area"]] <- fetch_data("FLGES") + fetch_data("STR_FLGES")
+
+  # Transform percentage to fractions
+  data[["main_frac"]] <- fetch_data("FLGES") / data[["total_area"]]
+  data[["road_frac"]] <- fetch_data("STR_FLGES") / data[["total_area"]]
+
+  # Determine names of columns that need to be divided by 100
+  columns_to_divide_by_100 <- read_column_info() %>%
+    dplyr::filter(.data[["by_100"]] == "x") %>%
+    select_columns("rabimo_berlin") %>%
+    intersect(names(data))
+
+  data[columns_to_divide_by_100] <- lapply(data[columns_to_divide_by_100], `/`, 100)
 
   # insert empty to_swale column (fraction of the area connected to a swale)
   data[["to_swale"]] <- 0
@@ -169,7 +183,7 @@ identify_data_format_or_stop <- function(data)
 # get_column_renamings ---------------------------------------------------------
 get_column_renamings <- function()
 {
-  read_column_info() %>%
+  renamings <- read_column_info() %>%
     dplyr::filter(nzchar(.data[["abimo_berlin"]])) %>%
     to_lookup_list(data = select_columns(., c("abimo_berlin", "rabimo_berlin")))
 }
@@ -194,31 +208,6 @@ read_column_info <- function()
     )
 }
 
-# calculate_fractions ----------------------------------------------------------
-calculate_fractions <- function(data)
-{
-  # Column accessor
-  fetch_data <- create_accessor(data)
-
-  total_area <- fetch_data("total_area")
-
-  # Transform percentage to fractions
-  data[["main_frac"]] <- fetch_data("area_main") / total_area
-  data[["road_frac"]] <- fetch_data("area_road") / total_area
-
-  # Determine names of columns that need to be divided by 100
-  columns <- read_column_info() %>%
-    dplyr::filter(.data[["by_100"]] == "x") %>%
-    select_columns("rabimo_berlin") %>%
-    intersect(names(data))
-
-  for (column in columns) {
-    data[[column]] <- fetch_data(column) / 100
-  }
-
-  data
-}
-
 # get_usage_tuple --------------------------------------------------------------
 
 #' Get Usage Tuple (Land_type, Veg_class, Irrigation) from NUTZUNG and TYP
diff --git a/R/run_rabimo_with_measures.R b/R/run_rabimo_with_measures.R
@@ -14,6 +14,7 @@ run_rabimo_with_measures <- function(
     config = kwb.rabimo::rabimo_inputs_2020$config
 )
 {
+  #kwb.utils::assignPackageObjects("kwb.rabimo")
   rescaled_targets <- rescale_target_values(
     new_targets = measures,
     blocks = blocks
diff --git a/data/rabimo_inputs_2020.rda b/data/rabimo_inputs_2020.rda
diff --git a/inst/extdata/column-names.csv b/inst/extdata/column-names.csv
@@ -6,9 +6,7 @@ epot_yr,,,Long-term average potential evapotranspiration per year,mm,required,in
 epot_s,,,Long-term average potential evapotranspiration per summer half year (May to October),mm,required,integer,500
 district,BEZIRK,,Specific to Berlin: identifier of city district,-,required?,character,0
 total_area,,,Total block area,m2,required,numeric,100
-area_main,FLGES,,Total non-road area within the block,m2,required?,numeric,100
-area_road,STR_FLGES,,Total road area within the block,m2,required?,numeric,0.0
-main_frac,,,Non-road fraction of total block area (area_main/total_area),0..1,required,numeric,
+main_frac,,,Non-road fraction of total_area,0..1,required,numeric,1.0
 roof,PROBAU,x,Roof fraction of non-road built area,0..1,required,numeric,0.2
 green_roof,,,Green roof fraction of roof area,0..1,required,numeric,0.0
 swg_roof,KAN_BEB,x,Fraction of roof area connected to the sewer ,0..1,required,numeric,1.0
@@ -19,7 +17,7 @@ srf2_pvd,BELAG2,x,Fraction of paved area belonging to surface class 2,0..1,requi
 srf3_pvd,BELAG3,x,Fraction of paved area belonging to surface class 3,0..1,required,numeric,0.1
 srf4_pvd,BELAG4,x,Fraction of paved area belonging to surface class 4,0..1,required,numeric,0.1
 srf5_pvd,BELAG5,x,Fraction of paved area belonging to surface class 5,0..1,required,numeric,0.1
-road_frac,,,Road fraction of total block area (area_road/total_area),0..1,required,numeric,0.0
+road_frac,,,Road fraction of total_area,0..1,required,numeric,0.0
 pvd_r,VGSTRASSE,x,Paved fraction of road area,0..1,required,numeric,0.9
 swg_pvd_r,KAN_STR,x,Fraction of paved road area connected to the sewer,0..1,required,numeric,1.0
 srf1_pvd_r,STR_BELAG1,x,Fraction of road area belonging to surface class 1,0..1,required,numeric,0.9
@@ -31,7 +29,7 @@ gw_dist,FLUR,,Depth to the water table,m,required,numeric,3.0
 ufc30,FELD_30,,Usable field capacity 0..30 cm,% by volume,required,numeric,13.0
 ufc150,FELD_150,,Usable field capacity 0..150 cm,% by volume,required,numeric,13.0
 land_type,,,Land type,-,required,character,urban
-veg_class,,,Vegetation class,-,required,integer,35.0
-irrigation,,,Average irrigation per year,mm,required,integer,0.0
+veg_class,,,Vegetation class,-,required,numeric,35.0
+irrigation,,,Average irrigation per year,mm,required,integer,0
 berlin_usage,NUTZUNG,,Specific to Berlin: Main usage of block,-,berlin-specific,numeric,
 berlin_type,TYP,,Specific to Berlin: Type of block,-,berlin-specific,numeric,
diff --git a/inst/scripts/distribute-measures.R b/inst/scripts/distribute-measures.R
@@ -128,7 +128,6 @@ create_example_blocks <- function(block_areas)
   blocks <- do.call(rbind, lapply(codes, kwb.rabimo:::generate_rabimo_area))
 
   blocks$total_area <- total_areas
-  blocks$area_main <- total_areas
   blocks$green_roof <- get_green_roof(block_areas)
   blocks$pvd <- get_paved(block_areas)
 
diff --git a/inst/scripts/test-rabimo.R b/inst/scripts/test-rabimo.R
@@ -94,30 +94,15 @@ if (FALSE)
   #kwb.utils::hsOpenWindowsExplorer(get_path("results"))
 }
 
-# MAIN: Convert column names (max 10 chars) in input data ----------------------
+# MAIN: Update data stored in the package --------------------------------------
 if (FALSE)
 {
   inputs <- kwb.rabimo::rabimo_inputs_2020
-  inputs$data <- kwb.utils::renameColumns(inputs$data, list(
-    area_rd = "area_road",
-    main_fraction = "main_frac",
-    road_fraction = "road_frac",
-    pvd_rd = "pvd_r",
-    swg_pvd_rd = "swg_pvd_r",
-    srf1_pvd_rd = "srf1_pvd_r",
-    srf2_pvd_rd = "srf2_pvd_r",
-    srf3_pvd_rd = "srf3_pvd_r",
-    srf4_pvd_rd = "srf4_pvd_r"
+  str(inputs$data)
+  inputs$data$veg_class <- as.numeric(inputs$data$veg_class)
+  inputs$data <- kwb.utils::removeColumns(inputs$data, c(
+    "sealed", "area_main", "area_road"
   ))
-
-  names_1 <- names(inputs$data)
-  names_1 <- setdiff(names_1, "block_type")
-
-  names_2 <- kwb.rabimo::read_column_info()$rabimo_berlin
-  names_2 <- setdiff(names_2, c("berlin_usage", "berlin_type"))
-
-  stopifnot(all(names_1 %in% names_2))
-
   rabimo_inputs_2020 <- inputs
   usethis::use_data(rabimo_inputs_2020, overwrite = TRUE)
 }
diff --git a/tests/testthat/test-function-calculate_fractions.R b/tests/testthat/test-function-calculate_fractions.R
diff --git a/tests/testthat/test-function-prepare_berlin_inputs.R b/tests/testthat/test-function-prepare_berlin_inputs.R
@@ -7,22 +7,31 @@ test_that("prepare_berlin_inputs() works", {
   expect_error(f())
 
   data_file <- tempfile(fileext = ".dbf")
-
   foreign::write.dbf(kwb.abimo::abimo_input_2019, data_file)
 
   result <- f(data_file, dbg = FALSE)
 
   expect_type(result, "list")
-
   expect_identical(names(result), c("data", "config"))
 
   expect_identical(names(result$data), c(
-    "code", "prec_yr", "prec_s", "epot_yr", "epot_s", "district", "total_area",
-    "area_main", "area_road", "main_frac", "roof", "green_roof", "swg_roof",
+    "code",
+    "prec_yr", "prec_s",
+    "epot_yr", "epot_s",
+    "district",
+    "total_area",
+
+    # main
+    "main_frac",
+    "roof", "green_roof", "swg_roof",
     "pvd", "swg_pvd",
     "srf1_pvd", "srf2_pvd", "srf3_pvd", "srf4_pvd", "srf5_pvd",
-    "road_frac", "pvd_r", "swg_pvd_r", "srf1_pvd_r", "srf2_pvd_r",
-    "srf3_pvd_r", "srf4_pvd_r", "to_swale", "gw_dist", "ufc30",
+
+    # road
+    "road_frac", "pvd_r", "swg_pvd_r",
+    "srf1_pvd_r", "srf2_pvd_r", "srf3_pvd_r", "srf4_pvd_r",
+
+    "to_swale", "gw_dist", "ufc30",
     "ufc150", "land_type", "veg_class", "irrigation", "block_type"
   ))
 
diff --git a/tests/testthat/test-function-run_rabimo.R b/tests/testthat/test-function-run_rabimo.R
@@ -25,7 +25,7 @@ test_that("run_rabimo() works", {
     ufc30 = -123,
     ufc150 = 1.2,
     gw_dist = c(-1,-2,1),
-    veg_class = 1L,
+    veg_class = 1.0,
     irrigation = -1L,
     main_frac = c(1, 1, 0.3),
     roof = c(0.1, 0.2, 0.3),
@@ -76,6 +76,4 @@ test_that("run_rabimo() works", {
   expect_s3_class(result, "data.frame")
   expect_true(nrow(result) == nrow(data))
 
-
-
 })
diff --git a/tests/testthat/test-function-run_rabimo_with_measures.R b/tests/testthat/test-function-run_rabimo_with_measures.R
@@ -6,6 +6,7 @@ test_that("run_rabimo_with_measures() works", {
   expect_error(f())
 
   data <- kwb.rabimo::rabimo_inputs_2020$data
+
   blocks <- data[sample(seq_len(nrow(data)), 10L), ]
 
   stats <- kwb.rabimo:::get_measure_stats(blocks)

Original file line number	Diff line number	Diff line change
`@@ -14,6 +14,7 @@ run_rabimo_with_measures <- function(`
`14`	`14`	`config = kwb.rabimo::rabimo_inputs_2020$config`
`15`	`15`	`)`
`16`	`16`	`{`
	`17`	`+ #kwb.utils::assignPackageObjects("kwb.rabimo")`
`17`	`18`	`rescaled_targets <- rescale_target_values(`
`18`	`19`	`new_targets = measures,`
`19`	`20`	`blocks = blocks`