From fb8984b9d1fd42bc43e813e8bf878397940d15f1 Mon Sep 17 00:00:00 2001 From: mrustl Date: Mon, 15 Jul 2024 15:28:51 +0200 Subject: [PATCH] Add first version of write_selector() --- R/write_selector.R | 195 ++++++++++++++++++++++++++++++++++++++++++ man/write_selector.Rd | 16 ++++ 2 files changed, 211 insertions(+) create mode 100644 R/write_selector.R create mode 100644 man/write_selector.Rd diff --git a/R/write_selector.R b/R/write_selector.R new file mode 100644 index 0000000..655f4d0 --- /dev/null +++ b/R/write_selector.R @@ -0,0 +1,195 @@ +#' Write SELECTOR.in +#' +#' @param selector list with imported SELECTOR.in \code{read_selector} +#' @param path path to SELECTOR.in for export +#' @export + +write_selector <- function(selector, path) { + + basic_values <- selector$basic + basic_names <- names(selector$basic) + + i_head <- which(basic_names == "Heading") + i_units <- grep("Unit", basic_names) + i_multi_start <- grep("lWat|lSnow|NMat", basic_names) + i_multi_end <- c(i_multi_start[2:3] - 1, length(basic_names)) + n_multi <- 1+ i_multi_end - i_multi_start + + + basic_txt <- c( + "*** BLOCK A: BASIC INFORMATION *****************************************", + basic_names[i_head], + as.character(basic_values[i_head]), + paste0(paste0(basic_names[i_units], collapse = " "), + "(indicated units are obligatory for all input data)", + collapse = " "), + sapply(i_units, function(i) basic_values[i]) %>% as.character(), + lapply(1:3, function(i) { + c(basic_names[i_multi_start[i]:i_multi_end[i]] %>% + stringr::str_pad(width = 10, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim(), + unlist(basic_values[i_multi_start[i]:i_multi_end[i]]) %>% + to_fortran_truefalse() %>% + stringr::str_pad(width = 10, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim()) + }) %>% unlist()) + + + waterflow_values <- selector$waterflow[-length(selector$waterflow)] + waterflow_names <- names(selector$waterflow[-length(selector$waterflow)]) + + + i_multi_start <- grep("MaxIt|TopInf|BotInf|hTab1|Model", waterflow_names) + i_multi_end <- c(i_multi_start[2:length(i_multi_start)] - 1, length(waterflow_names)) + n_multi <- 1+ i_multi_end - i_multi_start + + waterflow_txt <- c( + "*** BLOCK B: WATER FLOW INFORMATION ************************************", + sapply(seq_along(i_multi_start), function(i) { + + additional_text <- if (waterflow_names[i_multi_start[i]] == "MaxIt") { + " (maximum number of iterations and tolerances)" + } else { + "" + } + + c(paste0(paste0(stringr::str_pad(waterflow_names[i_multi_start[i]:i_multi_end[i]], + width = 8, + side = "right"), collapse = "") %>% + stringr::str_trim(), + additional_text, + collapse = ""), + paste0(waterflow_values[i_multi_start[i]:i_multi_end[i]] %>% + to_fortran_truefalse() %>% + stringr::str_pad(width = 8, + side = "right"), collapse = "") %>% + stringr::str_trim())}), + stringr::str_pad(names(selector$waterflow$soil), width = 12, side = "right") %>% + paste0(collapse = "") %>% stringr::str_trim(), + sapply(seq_len(nrow(selector$waterflow$soil)), function(i) { + stringr::str_pad(selector$waterflow$soil[i,], width = 12, side = "right") %>% + paste0(collapse = "") %>% stringr::str_trim() + }) + ) + + time_values <- selector$time[-length(selector$time)] + time_names <- names(selector$time)[-length(selector$time)] + + i_multi_start <- grep("^dt$|^tInit$|^lPrintD$", time_names) + i_multi_end <- c(i_multi_start[2:3] - 1, length(time_names)) + n_multi <- 1+ i_multi_end - i_multi_start + + time_print_start <- seq(1,length(selector$time$TPrint),6) + time_print_end <- c(time_print_start[2:length(time_print_start)] - 1, + length(selector$time$TPrint)) + + time_txt <- c( + "*** BLOCK C: TIME INFORMATION ******************************************", + sapply(seq_along(i_multi_start), function(i) { + width <- if(i == 3) { + 20} else { + 10 + } + c(paste0(stringr::str_pad(time_names[i_multi_start[i]:i_multi_end[i]], + width = width, + side = "right"), collapse = "") %>% + stringr::str_trim(), + paste0(time_values[i_multi_start[i]:i_multi_end[i]] %>% + to_fortran_truefalse() %>% + stringr::str_pad(width = width, + side = "right"), collapse = "") %>% + stringr::str_trim())}), + "TPrint(1),TPrint(2),...,TPrint(MPL)", + sapply(seq_along(time_print_start), function(i) { + selector$time$TPrint[time_print_start[i]:time_print_end[i]] %>% + stringr::str_pad(width = 11, side = "left") %>% + paste0(collapse = " ") + }) + ) + + + sel_ids <- grep(pattern = "transport|solute_", names(selector$solute), invert = TRUE) + + sol_names <- names(selector$solute)[sel_ids] + sol_values <- selector$solute[sel_ids] + + + i_multi_start <- grep("Epsi|iNonEqul|kTopSolute|tPulse", sol_names) + i_multi_end <- c(i_multi_start[2:length(i_multi_start)] - 1, length(sol_names)) + n_multi <- 1+ i_multi_end - i_multi_start + + + solutes_txt <- c( + "*** BLOCK F: SOLUTE TRANSPORT INFORMATION *****************************************************", + sapply(1:2, function(i) { + sol_names_sel <- sol_names[i_multi_start[i]:i_multi_end[i]] + + c(paste0(sol_names[i_multi_start[i]:i_multi_end[i]] %>% + #stringr::str_remove(pattern = "unknown[0-9][0-9]?") %>% + stringr::str_pad(width = 12, + side = "right"), collapse = "") %>% + stringr::str_trim(), + paste0(sol_values[i_multi_start[i]:i_multi_end[i]] %>% + to_fortran_truefalse() %>% + stringr::str_pad(width = 12, + side = "right"), collapse = "") %>% + stringr::str_trim())}), + stringr::str_pad(names(selector$solute$transport), width = 11, side = "right") %>% + paste0(collapse = " ") %>% stringr::str_trim(), + sapply(seq_len(nrow(selector$solute$transport)), function(i) { + stringr::str_pad(selector$solute$transport[i,], width = 11, side = "right") %>% + paste0(collapse = " ") %>% stringr::str_trim()}), + sapply(seq_len(sum(stringr::str_detect(names(selector$solute), "solute_"))), function(i) { + solute_sel <- selector$solute[[sprintf("solute_%d", i)]] + + c(names(solute_sel$diffusion) %>% + stringr::str_pad(width = 12, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim() %>% + stringr::str_c(" n-th solute"), + solute_sel$diffusion %>% + stringr::str_pad(width = 12, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim(), + names(solute_sel$reaction) %>% + stringr::str_pad(width = 12, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim(), + sapply(seq_len(nrow(solute_sel$reaction)), function(i) { + + solute_sel$reaction[i,] %>% + stringr::str_pad(width = 12, side = "right") %>% + paste0(collapse = "") %>% + stringr::str_trim()}) + ) + + }) %>% as.character(), + sapply(3:4, function(i) { + sol_names_sel <- sol_names[i_multi_start[i]:i_multi_end[i]] + + if(any(stringr::str_detect(sol_names_sel, "unknown"))) { + sol_names_sel <- sol_names_sel %>% + stringr::str_remove(pattern = "unknown[0-9][0-9]?") + } + + c(paste0(sol_names_sel %>% + #stringr::str_remove(pattern = "unknown[0-9][0-9]?") %>% + stringr::str_pad(width = 12, + side = "right"), collapse = "") %>% + stringr::str_trim(), + paste0(sol_values[i_multi_start[i]:i_multi_end[i]] %>% + to_fortran_truefalse() %>% + stringr::str_pad(width = 12, + side = "right"), collapse = "") %>% + stringr::str_trim())}) + ) + + + lines <- c("Pcp_File_Version=4", + basic_txt, + waterflow_txt, + time_txt, + solutes_txt) +} diff --git a/man/write_selector.Rd b/man/write_selector.Rd new file mode 100644 index 0000000..7890538 --- /dev/null +++ b/man/write_selector.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_selector.R +\name{write_selector} +\alias{write_selector} +\title{Write SELECTOR.in} +\usage{ +write_selector(selector, path) +} +\arguments{ +\item{selector}{list with imported SELECTOR.in \code{read_selector}} + +\item{path}{path to SELECTOR.in for export} +} +\description{ +Write SELECTOR.in +}