Monotonie-Check der Optimierungsergebnisse

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)

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))

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()

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)

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)

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)

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)

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))

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 "<name>_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))