Release v0.1.0

.github/workflows/R-CMD-check.yaml

@@ -48,7 +48,7 @@ jobs:
 
       - name: Cache R packages
         if: runner.os != 'Windows'
-        uses: actions/cache@v1
+        uses: actions/cache@v4
         with:
           path: ${{ env.R_LIBS_USER }}
           key: ${{ runner.os }}-r-${{ matrix.config.r }}-3-${{ hashFiles('depends.Rds') }}
@@ -74,7 +74,7 @@ jobs:
 
       - name: Upload check results
         if: failure()
-        uses: actions/upload-artifact@v2
+        uses: actions/upload-artifact@v4
         with:
           name: ${{ runner.os }}-r${{ matrix.config.r }}-results
           path: check

.github/workflows/pkgdown.yaml

@@ -27,7 +27,7 @@ jobs:
         shell: Rscript {0}
 
       - name: Cache R packages
-        uses: actions/cache@v2
+        uses: actions/cache@v4
         with:
           path: ${{ env.R_LIBS_USER }}
           key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}

.github/workflows/test-coverage.yaml

@@ -30,7 +30,7 @@ jobs:
         shell: Rscript {0}
 
       - name: Cache R packages
-        uses: actions/cache@v1
+        uses: actions/cache@v4
         with:
           path: ${{ env.R_LIBS_USER }}
           key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }}

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: kwb.hydrus1d
 Title: R Interface for the Last Official Release of Hydrus1D (V4.17.0140)
     for Windows
-Version: 0.0.0.9000
+Version: 0.1.0
 Authors@R: 
     c(person(given = "Michael",
              family = "Rustler",
@@ -33,6 +33,7 @@ Imports:
     rlang,
     stringr,
     tibble,
+    tidyr,
     tidyselect
 Suggests: 
     covr,
@@ -43,5 +44,5 @@ Remotes:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.2
+RoxygenNote: 7.3.2
 VignetteBuilder: knitr

LICENSE

@@ -1,6 +1,6 @@
 MIT License
 
-Copyright (c) 2022 Kompetenzzentrum Wasser Berlin gGmbH (KWB)
+Copyright (c) 2022 - 2025 Kompetenzzentrum Wasser Berlin gGmbH (KWB)
 
 Permission is hereby granted, free of charge, to any person obtaining a copy
 of this software and associated documentation files (the "Software"), to deal

LICENSE.md

@@ -1,6 +1,6 @@
 # MIT License
 
-Copyright (c) 2022 Kompetenzzentrum Wasser Berlin gGmbH (KWB)
+Copyright (c) 2022 - 2025 Kompetenzzentrum Wasser Berlin gGmbH (KWB)
 
 Permission is hereby granted, free of charge, to any person obtaining a copy
 of this software and associated documentation files (the "Software"), to deal

NAMESPACE

@@ -3,19 +3,31 @@
 export("%>%")
 export(check_hydrus_exe)
 export(defaults_atmosphere)
+export(extend_soil_profile)
 export(get_atmosphere_headers)
 export(get_output_meta)
 export(get_units_list)
 export(prepare_atmosphere_input)
 export(read_alevel)
+export(read_atmosph)
+export(read_balance)
+export(read_hydrus1d)
 export(read_meta_general)
+export(read_obsnode)
+export(read_profile)
 export(read_runinf)
+export(read_selector)
 export(read_solute)
 export(read_tlevel)
 export(run_model)
 export(write_atmosphere)
+export(write_hydrus1d)
+export(write_profile)
+export(write_selector)
 importFrom(archive,archive_extract)
+importFrom(dplyr,arrange)
 importFrom(dplyr,bind_cols)
+importFrom(dplyr,bind_rows)
 importFrom(dplyr,select)
 importFrom(fs,dir_create)
 importFrom(fs,file_copy)
@@ -29,18 +41,27 @@ importFrom(kwb.utils,safePath)
 importFrom(kwb.utils,stringList)
 importFrom(magrittr,"%>%")
 importFrom(readr,fwf_widths)
+importFrom(readr,read_csv)
 importFrom(readr,read_delim)
 importFrom(readr,read_fwf)
+importFrom(readr,read_table)
 importFrom(rlang,.data)
+importFrom(stats,median)
+importFrom(stats,setNames)
 importFrom(stringr,str_detect)
+importFrom(stringr,str_extract)
 importFrom(stringr,str_pad)
+importFrom(stringr,str_remove)
 importFrom(stringr,str_remove_all)
 importFrom(stringr,str_replace)
+importFrom(stringr,str_replace_all)
 importFrom(stringr,str_split)
 importFrom(stringr,str_split_fixed)
+importFrom(stringr,str_to_title)
 importFrom(stringr,str_trim)
 importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
+importFrom(tidyr,pivot_longer)
 importFrom(tidyselect,all_of)
 importFrom(tidyselect,starts_with)
 importFrom(utils,read.fwf)

NEWS.md

@@ -1,4 +1,8 @@
-# kwb.hydrus1d 0.0.0.9000
+# [kwb.hydrus1d 0.1.0](https://github.com/KWB-R/kwb.hydrus1d/releases/tag/v0.1.0) <small>2025-01-07</small>
+
+* First release. All functions developed within FlexTreat project and used for 
+modelling of solute flow and transport until the groundwater surface (i.e. bottom 
+of soil profile) 
 
 * Added a `NEWS.md` file to track changes to the package.
 

R/.check_obsnode.R

@@ -0,0 +1,83 @@
+paths_list <- list(
+  #extdata = system.file("extdata", package = "flextreat.hydrus1d"),
+  #root_server = "Y:/WWT_Department/Projects/FlexTreat/Work-packages/AP3/3_1_4_Prognosemodell/Vivian/Rohdaten/H1D",
+  #root_local = "C:/kwb/projects/flextreat/3_1_4_Prognosemodell/Vivian/Rohdaten/H1D",
+  root_local = "C:/kwb/projects/flextreat/hydrus/Szenarien_10day",
+  exe_dir = "<root_local>",
+  model_name = "1a2a - Kopie",
+  model_dir = "<exe_dir>/<model_name>",
+  scenario = "1a2a",
+  atmosphere = "<model_dir>/ATMOSPH.IN",
+  a_level = "<model_dir>/A_LEVEL.out",
+  profile = "<model_dir>/PROFILE.dat",
+  obs_node = "<model_dir>/Obs_Node.out",
+  t_level = "<model_dir>/T_LEVEL.out",
+  runinf = "<model_dir>/Run_Inf.out",
+  selector = "<model_dir>/SELECTOR.in",
+  solute_id = "1",
+  solute = "<model_dir>/solute<solute_id>.out",
+  soil_data = "<extdata>/input-data/soil/soil_geolog.csv"
+)
+
+
+paths <- kwb.utils::resolve(paths_list)
+
+
+atmos <- kwb.hydrus1d::read_atmosph(paths$atmosphere)
+
+atmos$data <- atmos$data %>%
+  dplyr::mutate(dplyr::across(tidyselect::starts_with("X") | tidyselect::starts_with("c"),
+                              ~ . / 1000))
+
+
+atm_prep <- kwb.hydrus1d::write_atmosphere(atmos$data[1:13])
+writeLines(atm_prep, paths$atmosphere)
+
+kwb.hydrus1d::run_model(model_path = paths$model_dir)
+
+obsnode <- kwb.hydrus1d::read_obsnode(paths$obs_node)
+profile <- kwb.hydrus1d::read_profile(paths$profile)
+alevel <- kwb.hydrus1d::read_alevel(paths$a_level)
+tlevel <- kwb.hydrus1d::read_tlevel(paths$t_level)
+
+obs_profile <- obsnode %>%  dplyr::left_join(profile %>%
+                                             dplyr::select(c(node_id, x)),
+                                             by = "node_id") %>%
+  dplyr::mutate(x = forcats::as_factor(x))
+
+obs_profile %>%
+  dplyr::filter(grepl("^mass1", variable)) %>%
+  dplyr::group_by(x) %>%
+  dplyr::summarise(value = sum(value)) %>%
+  dplyr::bind_rows(tibble::tibble(value = -10*sum(atmos$data$Prec*atmos$data$cTop),
+                                  x = forcats::as_factor(0))) %>%
+  ggplot2::ggplot(mapping = ggplot2::aes(x = x,
+                                         y = value)) +
+  ggplot2::geom_col() +
+  # ggplot2::ggplot(mapping = ggplot2::aes(x = time,
+  #                                        y = value)) +
+  # ggplot2::geom_line() +
+  # ggplot2::facet_wrap(~ x, ncol = 1) +
+  ggplot2::theme_bw()
+
+solute <- kwb.hydrus1d::read_solute(paths$solute)
+
+
+sum(atmos$data$Prec*atmos$data$cTop)
+
+100*max(solute$sum_cv_top)/sum(atmos$data$Prec*atmos$data$cTop)
+
+# top_out <- solute$cv_top < 0
+# top_in <- solute$cv_top > 0
+#
+# sum(solute$cv_top[top_in]*solute$c_top[top_in])
+# sum(solute$cv_top[top_out]*solute$c_top[top_out])
+
+
+solute_date <- flextreat.hydrus1d::aggregate_solute(solute,
+                                                    col_aggr = "date")
+
+solute_date$mass_top
+
+
+

R/.read_selector.R

@@ -1,5 +1,7 @@
 if(FALSE) {
-selector_list <- read_selector_list(path = "inst/extdata/model/test/SELECTOR.IN")
+selector_in <- file.path(paths$model_dir, "SELECTOR.in")
+
+selector_list <- read_selector_list(path = selector_in)
 
 selector_list$`_BLOCK_B_WATER_FLOW_INFORMATION`
 
@@ -9,6 +11,11 @@ waterflow_list
 as.character(write_waterflow_txt(waterflow_list))
 
 write_selector_text(selector_list)
+
+res_write <- res
+names(res_write) <- to_orig_headers(names(res))
+unlist(res_write)
+
 }
 
 read_waterflow <- function(txt) {
@@ -128,10 +135,6 @@ to_orig_headers <- function(header_names) {
   stringr::str_pad(width = 72, side = "right", pad = "*")
 }
 
-res_write <- res
-names(res_write) <- to_orig_headers(names(res))
-unlist(res_write)
-
 
 end_of_input_file <- function() {
   stringr::str_pad("*** END OF INPUT FILE 'SELECTOR.IN' ",

R/convert_atmosphere_to_string.R

@@ -35,7 +35,8 @@ convert_atmosphere_to_string <- function(
   do_pad_short <- function(x) stringr::str_pad(x, pad_short, "left")
   do_pad_long <- function(x) stringr::str_pad(x, pad_long, "left")
 
-  headers <- get_atmosphere_headers()
+  #headers <- get_atmosphere_headers()
+  headers <- names(atm)
 
   headers_short <- "tAtm"
   headers_long <- setdiff(headers, headers_short)
@@ -51,7 +52,10 @@ convert_atmosphere_to_string <- function(
   names(atm)[is_short] <- do_pad_short(names(atm)[is_short])
   names(atm)[is_long] <- do_pad_long(names(atm)[is_long])
 
-  header_text <- kwb.utils::collapsed(names(atm), "")
+  header_text <- c(names(atm)[!grepl("[cTop|cBot][1-9]0?", names(atm))],
+                   do_pad_long("RootDepth")) %>%
+    kwb.utils::collapsed(collapse = "")
+
   body_lines <- apply(atm, 1L, kwb.utils::collapsed, "")
 
   kwb.utils::collapsed(c(header_text, body_lines), "\n")

R/extend_soil_profile.R

@@ -0,0 +1,53 @@
+#' Extend soil profile
+#'
+#' @param df data frame with soil profile. As retrieved by \code{read_profile}
+#' and go to sublist "profile"
+#' @param x_end maximum soil depth to be used for extrapolation (or reduction)
+#'
+#' @return extended (or reduced) soil profile
+#' @export
+#'
+#' @importFrom dplyr arrange bind_rows
+#'
+extend_soil_profile <- function(df, x_end) {
+
+  if (x_end > min(df$x)) {
+    if (any(x_end == df$x)) {
+      return(df[which(x_end <= df$x), ])
+    }
+  } else {
+    # Original x-Abstand ermitteln
+    x_diff <- mean(diff(df$x))
+
+    # Neue x-Werte erstellen basierend auf dem vorgegebenen Endwert für x
+    new_x <- seq(min(df$x), x_end, by = x_diff)
+
+    # Anzahl der neuen x-Werte bestimmen
+    num_new_rows <- length(new_x)
+
+    # Letzte gültige Werte für die Spalten extrahieren
+    last_vals <- sapply(df, tail, 1)
+
+    # Dataframe mit neuen Werten erstellen
+    new_df <- data.frame(
+      x = new_x,
+      node_id = max(df$node_id) + 1:num_new_rows
+    )
+
+    # Spalten aus dem ursprünglichen DataFrame übernehmen
+    for (col in names(df)) {
+      if (col %in% c("x", "node_id")) next  # x und node_id überspringen
+      new_df[[col]] <- rep(last_vals[[col]], num_new_rows)
+    }
+
+    # Kombinieren und Sortieren der Dataframes
+    new_df <- new_df[-1,]
+    new_df$node_id <- new_df$node_id - 1
+
+    combined_df <- dplyr::bind_rows(df, new_df)
+
+    sorted_df <- dplyr::arrange(combined_df, node_id)
+
+    return(sorted_df)
+  }
+}

R/prepare_atmosphere_input.R

@@ -8,7 +8,7 @@
 get_atmosphere_headers <- function() {
 
   c("tAtm", "Prec", "rSoil", "rRoot", "hCritA", "rB", "hB", "ht",
-    "tTop", "tBot", "Ampl", "cTop", "cBot", "RootDepth")
+    "tTop", "tBot", "Ampl", "cTop", "cBot")
 }
 
 #' Prepare Atmosphere Input
@@ -31,8 +31,15 @@ prepare_atmosphere_input <- function(
 )
 {
   required_parameters <- get_atmosphere_headers()
+  n_solutes_per_run <- 12
+  optional_parameters <- sapply(2:n_solutes_per_run, function(i) {
+    c(sprintf("cTop%d", i), sprintf("cBot%d", i))
+  }) %>% as.vector()
+
+
 
   is_given <- required_parameters %in% names(inputs)
+  is_given_optional <- optional_parameters %in% names(inputs)
   has_default <- required_parameters %in% names(defaults)
 
   if (any(is_missing <- !is_given & !has_default)) {
@@ -44,7 +51,9 @@ prepare_atmosphere_input <- function(
 
   dplyr::bind_cols(
     inputs[, required_parameters[is_given], drop = FALSE],
+    inputs[, optional_parameters[is_given_optional], drop = FALSE],
     defaults[, required_parameters[!is_given & has_default], drop = FALSE]
   ) %>%
-    dplyr::select(tidyselect::all_of(required_parameters))
+    dplyr::select(tidyselect::all_of(required_parameters),
+                  tidyselect::all_of(optional_parameters[is_given_optional]))
 }