From 17bc9549839a4992727db3ed79e9a33a4111c6cb Mon Sep 17 00:00:00 2001 From: mrustl Date: Tue, 9 Jul 2024 11:22:54 +0200 Subject: [PATCH] Add write_profile() --- NAMESPACE | 2 + R/.read_selector.R | 13 ++- R/.write_profile.R | 109 ---------------------- R/write_profile.R | 152 +++++++++++++++++++++++++++++++ man/write_formatted_materials.Rd | 19 ++++ man/write_formatted_profile.Rd | 19 ++++ man/write_profile.Rd | 19 ++++ 7 files changed, 219 insertions(+), 114 deletions(-) delete mode 100644 R/.write_profile.R create mode 100644 R/write_profile.R create mode 100644 man/write_formatted_materials.Rd create mode 100644 man/write_formatted_profile.Rd create mode 100644 man/write_profile.Rd diff --git a/NAMESPACE b/NAMESPACE index 1c770cf..7b2baed 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/.read_selector.R b/R/.read_selector.R index 754c270..fe5511d 100644 --- a/R/.read_selector.R +++ b/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' ", diff --git a/R/.write_profile.R b/R/.write_profile.R deleted file mode 100644 index 11c8016..0000000 --- a/R/.write_profile.R +++ /dev/null @@ -1,109 +0,0 @@ -write_formatted_materials <- function(df) { - # Hilfsfunktion zum Formatieren einer Zahl in wissenschaftlicher Notation - format_number <- function(x) { - sprintf("% .6e", x) - } - - # 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 = " ") - }) - -} - - -write_formatted_profile <- function(df) { - # Hilfsfunktion zum Formatieren einer Zahl in wissenschaftlicher Notation - format_number <- function(x) { - sprintf("% .13e", x) - } - - # 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,4,5)) { - 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 = " ") - }) - -} - - - -write_profile <- function(profile, - path) { - - - 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 = "")) - } - - paste0(stringr::str_pad(c(max(profile$profile$node_id), - 1, - sum(stringr::str_detect(names(profile$profile),"conc")), - 1), - width = 5, - side = "left"), - " x", - 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 <- c(headers_profile[1], - stringr::str_to_title(headers_profile[-1])) - - c("Pcp_File_Version=4", - stringr::str_pad(n_materials,width = 5, side = "left"), - write_formatted_materials(profile$mat_props), - "headers", - write_formatted_profile(profile$profile), - obsnodes - ) - - -} diff --git a/R/write_profile.R b/R/write_profile.R new file mode 100644 index 0000000..704905a --- /dev/null +++ b/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) +} diff --git a/man/write_formatted_materials.Rd b/man/write_formatted_materials.Rd new file mode 100644 index 0000000..1107398 --- /dev/null +++ b/man/write_formatted_materials.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_profile.R +\name{write_formatted_materials} +\alias{write_formatted_materials} +\title{Helper function: write formatted soil materials} +\usage{ +write_formatted_materials(df) +} +\arguments{ +\item{df}{df with soil materials as retrieved by \code{read_profile} and +sublist "mat_props"} +} +\value{ +formatted soil materials +} +\description{ +Helper function: write formatted soil materials +} +\keyword{internal} diff --git a/man/write_formatted_profile.Rd b/man/write_formatted_profile.Rd new file mode 100644 index 0000000..ebefd0d --- /dev/null +++ b/man/write_formatted_profile.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_profile.R +\name{write_formatted_profile} +\alias{write_formatted_profile} +\title{Helper function: write formatted soil profile} +\usage{ +write_formatted_profile(df) +} +\arguments{ +\item{df}{df with soil profile as retrieved by \code{read_profile} and sublist +profile} +} +\value{ +formatted soil materials +} +\description{ +Helper function: write formatted soil profile +} +\keyword{internal} diff --git a/man/write_profile.Rd b/man/write_profile.Rd new file mode 100644 index 0000000..a3bcfe2 --- /dev/null +++ b/man/write_profile.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_profile.R +\name{write_profile} +\alias{write_profile} +\title{Write PROFILE.dat} +\usage{ +write_profile(profile, path) +} +\arguments{ +\item{profile}{profile in structure as imported with \code{read_profile}} + +\item{path}{path to export PROFILE.dat} +} +\value{ +writes PROFILE.dat to user specified path +} +\description{ +Write PROFILE.dat +}