From c017783f66a4aa0958f83584d569995dbb84215a Mon Sep 17 00:00:00 2001 From: mrustl Date: Fri, 12 Jul 2024 09:02:30 +0200 Subject: [PATCH] Improve plots a bit --- R/.virtual_storage.R | 136 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 126 insertions(+), 10 deletions(-) diff --git a/R/.virtual_storage.R b/R/.virtual_storage.R index e974390..dab017f 100644 --- a/R/.virtual_storage.R +++ b/R/.virtual_storage.R @@ -10,12 +10,28 @@ scenarios <- c("soil-3m_no-irrig") scenarios <- c("soil-3m", "soil-3m_no-irrig") +scenarios <- sprintf("soil-2m_irrig-%02ddays", seq(10,30,10)) + +scenarios <- sprintf("soil-2m_irrig-%02ddays", 5) + + soil_depths <- c(1, 1.5, 2, 3) scenarios <- sapply(soil_depths, function(x) { - c(sprintf("soil-%sm", as.character(x)), + c(sprintf("soil-%sm_irrig-01days", as.character(x)), sprintf("soil-%sm_no-irrig", as.character(x)))}) %>% as.vector() +soil_depths <- c(1, 1.5, 2, 3) +irrigation_intervals <- c(1, 5, 10, 20, 30) + +scenarios <- sapply(soil_depths, function(x) { + sapply(irrigation_intervals, function(y) { + c(sprintf("soil-%sm_irrig-%02ddays", as.character(x), y), + sprintf("soil-%sm_no-irrig", as.character(x))) +}) +}) %>% as.vector() + + # org <- fs::dir_ls(paths$exe_dir, regexp = "soil-[1|3]m", type = "directory") # new <- stringr::str_replace(org, pattern = "m_", replacement = "m_no-irrig_") # fs::dir_copy(org, new) @@ -107,6 +123,36 @@ paths <- kwb.utils::resolve(paths_list) no_irrig <- stringr::str_detect(paths$model_dir, "no-irrig") +irrig_pattern <- "irrig-[0-9][0-9]?days" +irrig_int <- stringr::str_detect(paths$model_dir, irrig_pattern) + +if(irrig_int) { + +string_irrig <- stringr::str_extract(paths$model_dir, sprintf("_%s", irrig_pattern)) + +if(!fs::dir_exists(paths$model_dir)) { + +model_to_copy <- stringr::str_replace(paths$model_dir, string_irrig, "_irrig-01days") + +fs::dir_copy(model_to_copy, paths$model_dir) +} + +if(!fs::file_exists(paths$model_gui_path)) { + modelgui_to_copy <- stringr::str_replace(paths$model_gui_path, string_irrig, "_irrig-01days") + fs::file_copy(modelgui_to_copy, paths$model_gui_path) + +} + +string_irrig_int <- stringr::str_extract(paths$model_dir, "[0-9][0-9]?days") + +irrig_interval <- sprintf("%s %s", + string_irrig_int %>% + stringr::str_extract("\\d+") %>% + as.integer(), + string_irrig_int %>% + stringr::str_extract("[a-z]+")) +} + # org <- fs::dir_ls(path =paths$exe_dir, # regexp = "1a2a_soil-1.5m_.*\\.h1d$") @@ -146,7 +192,38 @@ atm <- flextreat.hydrus1d::prepare_atmosphere_data() #no-irrigation if(no_irrig) atm[,c("groundwater.mmPerDay", "clearwater.mmPerDay")] <- 0 + +sum_per_interval <- function(data, interval) { + + data_org <- data + + data <- data %>% + dplyr::select(tidyselect::all_of(c("date", + "groundwater.mmPerDay", + "clearwater.mmPerDay"))) + + cols_sum <- names(data)[names(data) != "date"] + + data_summed <- data %>% + dplyr::mutate(group = lubridate::floor_date(date, unit = interval)) %>% # Konvertiere date in datetime-Format + dplyr::group_by(group) %>% # Gruppiere nach Zeitintervallen + dplyr::summarise_at(.vars = tidyselect::all_of(cols_sum), + .funs = sum) %>% # Berechne die Summe für jedes Intervall + dplyr::rename(date = group) + + data_org[, cols_sum] <- 0 + data_org[data_org$date %in% data_summed$date, cols_sum] <- data_summed[,cols_sum] + data_org +} + atm_selected <- flextreat.hydrus1d::select_hydrologic_years(atm) + +if(irrig_int) { +atm_selected <- sum_per_interval(data = atm_selected, + interval = irrig_interval) + +} + # atm_prep <- flextreat.hydrus1d::prepare_atmosphere(atm = atm_selected, # conc_irrig_clearwater = c(6.738, # 0.875, @@ -461,22 +538,28 @@ traveltime_bp <- lapply(traveltimes_list, function(x) { x %>% dplyr::filter(percentiles == 0.5) }) %>% dplyr::bind_rows(.id = "scenario") %>% - dplyr::filter(!stringr::str_detect(scenario, "1.5")) + dplyr::filter(!stringr::str_detect(scenario, "1.5")) %>% + dplyr::mutate(quarter = lubridate::quarter(traveltime_bp$date) %>% as.factor(), + soil_depth = stringr::str_extract(scenario, "soil-.*m") %>% + stringr::str_remove_all("soil-|m") %>% as.factor()) -scenario_by_mean_traveltime <- traveltime_bp %>% +scenario_by_median_traveltime <- traveltime_bp %>% dplyr::group_by(scenario) %>% - dplyr::summarise(mean = mean(time_diff, na.rm = TRUE)) %>% - dplyr::arrange(mean) + dplyr::summarise(median = median(time_diff, na.rm = TRUE)) %>% + dplyr::arrange(median) +traveltime_bp <- traveltime_bp %>% + dplyr::left_join(scenario_by_median_traveltime) scenario_by_mean_traveltime$scenario y_lim <- c(0,350) + tt_bp_total <- traveltime_bp %>% - ggplot2::ggplot(ggplot2::aes(x = scenario, y = time_diff)) + + ggplot2::ggplot(ggplot2::aes(x = forcats::fct_reorder(scenario, median), y = time_diff)) + ggplot2::geom_boxplot(outliers = FALSE) + ggplot2::geom_jitter(position = ggplot2::position_jitter(width = 0.1), col = "darkgrey", @@ -486,12 +569,45 @@ tt_bp_total <- traveltime_bp %>% title = "Boxplot: median traveltime total") + ggplot2::theme_bw() +tt_bp_total + + +tt_bp_total_soil <- traveltime_bp %>% + ggplot2::ggplot(ggplot2::aes(x = forcats::fct_reorder(scenario, median), y = time_diff, col = soil_depth)) + + ggplot2::geom_boxplot(outliers = FALSE) + + ggplot2::geom_jitter(position = ggplot2::position_jitter(width = 0.1), + alpha = 0.6) + + ggplot2::ylim(y_lim) + + ggplot2::labs(y = "Median Traveltime (days)", x = "Scenario", + col = "Soil Depth (m)", + title = "Boxplot: median traveltime total") + + ggplot2::theme_bw() + + ggplot2::theme(legend.position = "top") + +tt_bp_total_soil + + + +tt_bp_total_quartal <- traveltime_bp %>% + ggplot2::ggplot(ggplot2::aes(x = forcats::fct_reorder(scenario, median), y = time_diff)) + + ggplot2::geom_boxplot(outliers = FALSE) + + ggplot2::geom_jitter(position = ggplot2::position_jitter(width = 0.1), + mapping = ggplot2::aes(col = quarter), + alpha = 0.6) + + ggplot2::ylim(y_lim) + + ggplot2::labs(y = "Median Traveltime (days)", x = "Scenario", + col = "Quartal", + title = "Boxplot: median traveltime total") + + ggplot2::theme_bw() + + ggplot2::theme(legend.position = "top") + +tt_bp_total_quartal + tt_bp_quarter <- traveltime_bp %>% - dplyr::mutate(quarter = lubridate::quarter(traveltime_bp$date) %>% as.factor()) %>% -ggplot2::ggplot(ggplot2::aes(x = scenario, y = time_diff, col = quarter)) + - ggplot2::geom_boxplot() + + ggplot2::ggplot(ggplot2::aes(x = forcats::fct_reorder(scenario, median), y = time_diff, col = quarter)) + + ggplot2::geom_boxplot(outliers = FALSE) + ggplot2::geom_jitter(position = ggplot2::position_jitterdodge( jitter.width = 0.1, dodge.width = 0.75), @@ -504,7 +620,7 @@ ggplot2::ggplot(ggplot2::aes(x = scenario, y = time_diff, col = quarter)) + ggplot2::theme_bw() + ggplot2::theme(legend.position = "top") - +tt_bp_quarter htmlwidgets::saveWidget(widget = plotly::ggplotly(tt_bp_total), title = "Boxplot: median traveltime total",