Add write_profile()

NAMESPACE

@@ -21,6 +21,7 @@ export(read_tlevel)
 export(run_model)
 export(write_atmosphere)
 export(write_hydrus1d)
+export(write_profile)
 importFrom(archive,archive_extract)
 importFrom(dplyr,bind_cols)
 importFrom(dplyr,select)
@@ -52,6 +53,7 @@ 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)

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/write_profile.R

@@ -0,0 +1,152 @@
+#' Helper function: write formatted soil materials
+#'
+#' @param df df with soil materials as retrieved by \code{read_profile} and
+#' sublist "mat_props"
+#' @return formatted soil materials
+#' @keywords internal
+#'
+write_formatted_materials <- function(df) {
+  # Hilfsfunktion zum Formatieren einer Zahl in wissenschaftlicher Notation
+  format_number <- function(x) {
+    formatted <- sprintf("% .6e", x)
+    formatted <- gsub("e([+-])([0-9])", "e\\10\\2", formatted)  # Hinzufügen von führenden Nullen
+    return(formatted)
+  }
+  # Hilfsfunktion zum Formatieren einer Integer-Zahl mit fixer Länge von 5 Zeichen
+  format_integer <- function(x) {
+    sprintf("%5d", x)
+  }
+
+  # Data Frame konvertieren und formatieren
+  formatted_df <- df
+  formatted_df[] <- lapply(seq_along(df), function(i) {
+    col <- df[[i]]
+    if (is.numeric(col) && i == 1) {
+      sapply(col, format_integer)  # Erste Spalte als Integer formatieren
+    } else if (is.numeric(col)) {
+      sapply(col, format_number)   # Restliche Spalten in wissenschaftlicher Notation formatieren
+    } else {
+      col
+    }
+  })
+
+  # Formatierte Zeilen erstellen
+  apply(formatted_df, 1, function(row) {
+    paste(row, collapse = " ")
+  })
+
+}
+
+
+#' Helper function: write formatted soil profile
+#'
+#' @param df df with soil profile as retrieved by \code{read_profile} and sublist
+#' profile
+#'
+#' @return formatted soil materials
+#' @keywords internal
+write_formatted_profile <- function(df) {
+  # Hilfsfunktion zum Formatieren einer Zahl in wissenschaftlicher Notation
+  format_number <- function(x) {
+    formatted <- sprintf("% .6e", x)
+    formatted <- gsub("e([+-])([0-9])", "e\\10\\2", formatted)  # Hinzufügen von führenden Nullen
+    return(formatted)
+  }
+
+  # Hilfsfunktion zum Formatieren einer Integer-Zahl mit fixer Länge von 5 Zeichen
+  format_integer <- function(x) {
+    sprintf("%5d", x)
+  }
+
+  # Data Frame konvertieren und formatieren
+  formatted_df <- df
+  formatted_df[] <- lapply(seq_along(df), function(i) {
+    col <- df[[i]]
+    if (is.numeric(col) && i %in% c(1)) {
+      sapply(col,  function(x)   sprintf("%5d", x))  # Erste Spalte als Integer formatieren
+    }
+      else if (is.numeric(col) && i %in% c(4,5)) {
+      sapply(col, function(x) sprintf("%4d", x))
+    } else if (is.numeric(col)) {
+      sapply(col, format_number)   # Restliche Spalten in wissenschaftlicher Notation formatieren
+    } else {
+      col
+    }
+  })
+
+  # Formatierte Zeilen erstellen
+  apply(formatted_df, 1, function(row) {
+    paste(row, collapse = " ")
+  })
+
+}
+
+
+
+#' Write PROFILE.dat
+#'
+#' @param profile profile in structure as imported with \code{read_profile}
+#' @param path path to export PROFILE.dat
+#'
+#' @return writes PROFILE.dat to user specified path
+#' @export
+#'
+#' @importFrom stringr str_pad str_detect str_to_title
+write_profile <- function(profile,
+                          path) {
+
+  stopifnot(length(path) > 0)
+
+
+  n_materials <- nrow(profile$mat_props)
+
+  obsnodes <- stringr::str_pad(profile$obsnodes$n,width = 5,side = "left")
+
+  if(profile$obsnodes$n > 0) {
+    obsnodes <- c(obsnodes,
+                  paste0(stringr::str_pad(profile$obsnodes$ids,width = 5,side = "left"),
+                       collapse = ""))
+  }
+
+  headers_profile_base <- c(stringr::str_pad(c(max(profile$profile$node_id),
+                            1,
+                            sum(stringr::str_detect(names(profile$profile),"conc")),
+                            1),
+                          width = 5,
+                          side = "left"),
+                          " x") %>% paste0(collapse = "")
+
+        headers_profile <- names(profile$profile)[!names(profile$profile) %in% c("x", "node_id")]
+
+        is_conc <- stringr::str_detect(headers_profile, "conc")
+
+        if(sum(is_conc) > 1) {
+          headers_profile <- c(headers_profile[!is_conc], "conc")
+        }
+
+        headers_profile[-1] <- stringr::str_to_title(headers_profile[-1])
+
+        headers_profile <- c(headers_profile_base,
+                             stringr::str_pad(headers_profile[1], width = 10, side = "left"),
+                             stringr::str_pad(headers_profile[2], width = 9, side = "left"),
+                             stringr::str_pad(headers_profile[3], width = 5, side = "left"),
+                             stringr::str_pad(headers_profile[4], width = 10, side = "left"),
+                             stringr::str_pad(headers_profile[5], width = 14, side = "left"),
+                             stringr::str_pad(headers_profile[6], width = 15, side = "left"),
+                             stringr::str_pad(headers_profile[7], width = 15, side = "left"),
+                             stringr::str_pad(headers_profile[8], width = 14, side = "left"),
+                             if(length(headers_profile[9]) > 0) {
+                              stringr::str_pad(headers_profile[9], width = 14, side = "left") %>%
+                               stringr::str_pad(width = 15, side = "right")
+                             }) %>% paste0(collapse = "")
+
+  lines_to_write <- c("Pcp_File_Version=4",
+    stringr::str_pad(n_materials,width = 5, side = "left"),
+    write_formatted_materials(profile$mat_props),
+    headers_profile,
+    write_formatted_profile(profile$profile),
+    obsnodes
+  )
+
+  writeLines(lines_to_write, path)
+}