Nothing
#' Generates a `new_travail.usm` file from usm XML files content and some
#' switch parameters for lai forcing, parameters forcing and usm chaining.
#'
#' @param usm_data a named list of informations attached to an usm definition
#' (coming from an usms.xml file)
#' @param usm Usm name
#' @param lai_forcing 1, if `lai` is to be read from a daily lai, 0 otherwise
#' input file.
#' @param codesuite 1, if the usm is to be chained with the previous
#' simulated (for getting system state variables), 0 otherwise
#' input file.
#' @param codoptim 1, if parameters are to be read from a `param.sti` file
#' (containing parameters values to be forced), 0 otherwise
#' @param out_dir Directory path where to store the `new_travail.usm` file.
#'
#' @return None
#'
#' @keywords internal
#'
#' @noRd
#'
gen_new_travail <- function(usm_data,
usm,
workspace,
lai_forcing = NULL,
codesuite = NULL,
codoptim = NULL,
out_dir = NULL) {
data_plt2 <- c()
if (usm_data$nbplantes > 1)
data_plt2 <- c("fplt2", "ftec2", "flai2")
data_order <- c("codesimul", "codoptim", "codesuite", "nbplantes", "nom",
"datedebut", "datefin", "finit", "numsol", "nomsol",
"fstation",
"fclim1", "fclim2", "nbans", "culturean", "fplt1",
"ftec1", "flai1", data_plt2)
if (is.null(out_dir)) out_dir <- workspace
out_file <- file.path(out_dir, "new_travail.usm")
p_table <- vector(mode = "character", length = 2 * length(data_order))
for (p in seq_along(data_order)) {
idx <- p * 2
p_table[idx - 1] <- paste0(":", as.character(data_order[p]))
p_table[idx] <- usm_data[[data_order[p]]]
}
ret <- try(writeLines(text = p_table, con = out_file))
if (methods::is(ret, "try-error")) {
return(invisible(FALSE))
}
return(invisible(TRUE))
}
#' Get information attached to a usm from usms.xml, and possibly change
#' some forcing options
#'
#' @param usms_doc xml document object loaded from an usms xml file
#' @param usm Usm name
#' @param workspace Path of a JavaSTICS workspace
#' @param lai_forcing 1, if `lai` is to be read from a daily lai, 0 otherwise
#' input file.
#' @param codesuite 1, if the usm is to be chained with the previous
#' simulated (for getting system state variables), 0 otherwise
#' input file.
#' @param codoptim 1, if parameters are to be read from a `param.sti` file
#' (containing parameters values to be forced), 0 otherwise
#'
#' @return a named list
#'
#' @keywords internal
#'
#' @noRd
#'
#'
get_usm_data <- function(usms_doc,
usm,
workspace,
lai_forcing = NULL,
codesuite = NULL,
codoptim = NULL) {
data <- XML::getNodeSet(usms_doc@content,
path = paste0("//usm[@nom='", usm, "']"),
fun = XML::xmlToList)[[1]]
n <- names(data)
n[11] <- "plante1"
n[12] <- "plante2"
names(data) <- n
# forcing codesimul
# 0: culture, 1: feuille, lai forcing
data$codesimul <- get_codesimul(as.numeric(data$codesimul))
if (!is.null(lai_forcing) && lai_forcing %in% c(0, 1))
data$codesimul <- get_codesimul(lai_forcing)
# forcing codoptim
data$codoptim <- 0
if (!is.null(codoptim) && codoptim %in% c(0, 1))
data$codoptim <- codoptim
data$codesuite <- 0
# forcing codesuite
if (!is.null(codesuite) && codesuite %in% c(0, 1))
data$codesuite <- codesuite
# nbplantes
data$nbplantes <- as.numeric(data$nbplantes)
# nom
data$nom <- usm
# debut
data$datedebut <- as.numeric(data$datedebut)
# fin
data$datefin <- as.numeric(data$datefin)
# init
# already defined
# soil number
# not used by STICS !!!!
data$numsol <- 1
# nomsol
# already defined
# station
# already defined
# fclim1
# already defined
# fclim2
# already defined
# add constraint on culturean
data$culturean <- as.numeric(data$culturean)
if (data$culturean != 1)
data$culturean <- 2
# add constraint on culturean
data$culturean <- as.numeric(data$culturean)
if (data$culturean != 1)
data$culturean <- 0
# nbans
data$nbans <- get_years_number(
file.path(workspace, c(data$fclim1, data$fclim2))
)
data$fplt1 <- data$plante1$fplt
data$ftec1 <- data$plante1$ftec
data$flai1 <- data$plante1$flai
data$fobs1 <- data$plante1$fobs
if (data$flai1 == "null" || data$flai1 == "defaut.lai")
data$codesimul <- get_codesimul(0)
if (data$nbplantes > 1) {
data$fplt2 <- data$plante2$fplt
data$ftec2 <- data$plante2$ftec
data$flai2 <- data$plante2$flai
data$fobs2 <- data$plante2$fobs
}
data[["ftec"]] <- NULL
data[["fplt"]] <- NULL
data[["flai"]] <- NULL
data[["fobs"]] <- NULL
data[["plante1"]] <- NULL
data[["plante2"]] <- NULL
data[[".attrs"]] <- NULL
return(data)
}
#' Getting the string indicating a forcing lai mode or not
#'
#' @param lai_forcing 0 for forcing mode, 0 otherwise
#'
#' @return a string, either "culture" or "feuille"
#' @keywords internal
#'
#' @noRd
#'
get_codesimul <- function(lai_forcing = 0) {
if (lai_forcing == 0) return("culture")
if (lai_forcing == 1) return("feuille")
stop("Error on lai forcing value: ",
lai_forcing,
"\nmIt must be 0 or 1 !")
}
#' Calculating simulation years number
#'
#' @param clim_path character vector of 2 weather data files
#' for the first and the last year
#'
#' @return years number
#' @keywords internal
#'
#' @noRd
#'
get_years_number <- function(clim_path) {
year1 <- get_year(clim_path = clim_path[1])
if (clim_path[1] == clim_path[2]) {
year2 <- year1
} else {
year2 <- get_year(clim_path = clim_path[2])
}
if (any(is.na(c(year1, year2))))
stop(
"Impossible to calculate the number of years from weather data files !"
)
return(year2 - year1 + 1)
}
#' Get weather data file year
#'
#' @param clim_path path of a weather data file
#'
#' @return a year (numeric)
#' @keywords internal
#'
#' @noRd
#'
get_year <- function(clim_path) {
if (!file.exists(clim_path)) stop()
line_str <- gsub(pattern = "\\t",
x = trimws(readLines(con = clim_path, n = 1)),
replacement = " ")
words <- strsplit(line_str, split = " ")[[1]]
# filtering empty strings
words <- words[words != ""]
year_str <- words[2]
ret <- try(year <- as.numeric(year_str))
if (methods::is(ret, "try-error")) {
return(invisible(NA))
}
return(year)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.