diff --git a/.github/workflows/style.yaml b/.github/workflows/style.yaml
new file mode 100644
index 00000000..0fd50fe9
--- /dev/null
+++ b/.github/workflows/style.yaml
@@ -0,0 +1,85 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+ pull_request:
+ paths:
+ [
+ "**.[rR]",
+ "**.[qrR]md",
+ "**.[rR]markdown",
+ "**.[rR]nw",
+ "**.[rR]profile",
+ ]
+ workflow_dispatch:
+
+name: style
+
+permissions: read-all
+
+jobs:
+ style:
+ runs-on: ubuntu-latest
+ permissions:
+ contents: write
+ env:
+ GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+ steps:
+ - name: Checkout repo
+ uses: actions/checkout@v4
+ with:
+ fetch-depth: 0
+
+ - name: Setup R
+ uses: r-lib/actions/setup-r@v2
+ with:
+ use-public-rspm: true
+
+ - name: Install dependencies
+ uses: r-lib/actions/setup-r-dependencies@v2
+ with:
+ extra-packages: any::styler, any::roxygen2
+ needs: styler
+
+ - name: Enable styler cache
+ run: styler::cache_activate()
+ shell: Rscript {0}
+
+ - name: Determine cache location
+ id: styler-location
+ run: |
+ cat(
+ "location=",
+ styler::cache_info(format = "tabular")$location,
+ "\n",
+ file = Sys.getenv("GITHUB_OUTPUT"),
+ append = TRUE,
+ sep = ""
+ )
+ shell: Rscript {0}
+
+ - name: Cache styler
+ uses: actions/cache@v4
+ with:
+ path: ${{ steps.styler-location.outputs.location }}
+ key: ${{ runner.os }}-styler-${{ github.sha }}
+ restore-keys: |
+ ${{ runner.os }}-styler-
+ ${{ runner.os }}-
+
+ - name: Style
+ run: styler::style_pkg()
+ shell: Rscript {0}
+
+ - name: Commit and push changes
+ run: |
+ if FILES_TO_COMMIT=($(git diff-index --name-only ${{ github.sha }} \
+ | egrep --ignore-case '\.(R|[qR]md|Rmarkdown|Rnw|Rprofile)$'))
+ then
+ git config --local user.name "$GITHUB_ACTOR"
+ git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com"
+ git commit ${FILES_TO_COMMIT[*]} -m "Style code (GHA)"
+ git pull --ff-only
+ git push origin
+ else
+ echo "No changes to commit."
+ fi
diff --git a/R/add_node_to_doc.R b/R/add_node_to_doc.R
index 26a5c7ef..b90957fa 100644
--- a/R/add_node_to_doc.R
+++ b/R/add_node_to_doc.R
@@ -42,7 +42,6 @@
#' @noRd
#'
add_node_to_doc <- function(xml_doc, new_node, nodes_nb = 1, parent_path) {
-
# Checking that parent_path is valid xpath for xml_doc
if (is.null(get_nodes(xml_doc, parent_path))) {
warning(paste("Given xpath is not a valid one:", parent_path))
diff --git a/R/add_stics_nodes.R b/R/add_stics_nodes.R
index 74c89963..eb6ee467 100644
--- a/R/add_stics_nodes.R
+++ b/R/add_stics_nodes.R
@@ -24,8 +24,6 @@
#'
add_stics_nodes <- function(xml_doc, formalism_name = NULL, nodes_nb = 1,
stics_version = "latest") {
-
-
# Getting nodes types that may be added to xml_doc
node_types <- get_xml_base_node()
diff --git a/R/all_in_par.R b/R/all_in_par.R
index e11d41e4..af65355c 100644
--- a/R/all_in_par.R
+++ b/R/all_in_par.R
@@ -1,4 +1,3 @@
-
#' Return all possible STICS inputs parameters
#'
#' @description Helper function to print the list of all possible parameters
@@ -20,21 +19,23 @@
#' @noRd
#'
all_in_par <- function(stics_version = "latest") {
-
# Checking and getting the right version
stics_version <- check_version_compat(stics_version = stics_version)
# if (get_version_num(stics_version = stics_version) < 9.2) {
# cols_idx <- 1:4
# } else {
- cols_idx <- c(1, 4, 7:8,2)
+ cols_idx <- c(1, 4, 7:8, 2)
# }
par_df <- utils::read.csv2(
file.path(
- get_examples_path(file_type = "csv",
- stics_version = stics_version),
- "inputs.csv"),
+ get_examples_path(
+ file_type = "csv",
+ stics_version = stics_version
+ ),
+ "inputs.csv"
+ ),
header = FALSE,
stringsAsFactors = FALSE
)[, cols_idx]
@@ -81,13 +82,11 @@ all_in_par <- function(stics_version = "latest") {
#' # Find for a particular version:
#' SticsRFiles::get_param_info("alb", stics_version = "V9.0")
#'
-#'
#' @export
#'
get_param_info <- function(param = NULL,
keyword = NULL,
stics_version = "latest") {
-
all_pars <- all_in_par(stics_version)
if (!is.null(keyword)) {
@@ -110,13 +109,13 @@ get_param_info <- function(param = NULL,
return(all_pars)
}
-get_idx_matches <- function(string, names){
- unlist(lapply(string,
- function(x) {
- grep(x, names, ignore.case = TRUE)
- }
- )
- )
+get_idx_matches <- function(string, names) {
+ unlist(lapply(
+ string,
+ function(x) {
+ grep(x, names, ignore.case = TRUE)
+ }
+ ))
}
#' Search if a STICS parameter exist
@@ -142,8 +141,6 @@ get_idx_matches <- function(string, names){
#'
is_stics_param <- function(param,
stics_version = "latest") {
-
-
all_pars <- all_in_par(stics_version)
par_parsed <- var_to_col_names(param)
pars_names_parsed <- var_to_col_names(all_pars$name)
@@ -151,8 +148,10 @@ is_stics_param <- function(param,
par_found <- !is.na(index_par)
if (any(!par_found)) {
cli::cli_alert_warning(
- paste0("paremeters{?s} {.var {par_parsed[!par_found]}}",
- " not found. Try {.code get_param_info()}.")
+ paste0(
+ "paremeters{?s} {.var {par_parsed[!par_found]}}",
+ " not found. Try {.code get_param_info()}."
+ )
)
}
return(par_found)
diff --git a/R/all_out_var.R b/R/all_out_var.R
index 5dc4a97b..04948121 100644
--- a/R/all_out_var.R
+++ b/R/all_out_var.R
@@ -1,4 +1,3 @@
-
#' Return all possible STICS outputs for var.mod
#'
#' @description Helper function to print the list of all possible variables
@@ -20,7 +19,6 @@
#' @noRd
#'
all_out_var <- function(stics_version = "latest") {
-
# Checking and getting the right version
stics_version <- check_version_compat(stics_version = stics_version)
@@ -32,9 +30,12 @@ all_out_var <- function(stics_version = "latest") {
var_df <- utils::read.csv2(
file.path(
- get_examples_path(file_type = "csv",
- stics_version = stics_version),
- "outputs.csv"),
+ get_examples_path(
+ file_type = "csv",
+ stics_version = stics_version
+ ),
+ "outputs.csv"
+ ),
header = FALSE,
stringsAsFactors = FALSE
)[, cols_idx]
@@ -78,23 +79,21 @@ all_out_var <- function(stics_version = "latest") {
#' # Find for a particular version:
#' SticsRFiles::get_var_info("lai", stics_version = "V9.0")
#'
-#'
#' @export
#'
get_var_info <- function(var = NULL,
keyword = NULL,
stics_version = "latest") {
-
all_vars <- all_out_var(stics_version)
if (!is.null(var)) {
var <- var_to_col_names(var)
vars_names_parsed <- var_to_col_names(all_vars$name)
- idx <- unlist(lapply(var,
- function(x) {
- grep(x, vars_names_parsed, ignore.case = TRUE)
- }
- )
- )
+ idx <- unlist(lapply(
+ var,
+ function(x) {
+ grep(x, vars_names_parsed, ignore.case = TRUE)
+ }
+ ))
all_vars[idx, ]
} else if (!is.null(keyword)) {
idx <- grepl(keyword, all_vars$definition, ignore.case = TRUE)
@@ -127,7 +126,6 @@ get_var_info <- function(var = NULL,
#'
is_stics_var <- function(var,
stics_version = "latest") {
-
all_vars <- all_out_var(stics_version)
var_parsed <- var_to_col_names(var)
vars_names_parsed <- var_to_col_names(all_vars$name)
@@ -136,8 +134,10 @@ is_stics_var <- function(var,
var_found <- !is.na(index_var)
if (any(!var_found)) {
cli::cli_alert_warning(
- paste0("Variable{?s} {.var {var_parsed[!var_found]}}",
- " not found. Try {.code get_var_info()}.")
+ paste0(
+ "Variable{?s} {.var {var_parsed[!var_found]}}",
+ " not found. Try {.code get_var_info()}."
+ )
)
}
return(var_found)
diff --git a/R/attributes_list2matrix.R b/R/attributes_list2matrix.R
index 28e810cd..0c9f0ddc 100644
--- a/R/attributes_list2matrix.R
+++ b/R/attributes_list2matrix.R
@@ -11,8 +11,10 @@
#'
#' xml_path <- file.path(get_examples_path(file_type = "xml"), "sols.xml")
#' sols_doc <- xmldocument(xml_path)
-#' node_set <- get_nodes(sols_doc,
-#' "//*[@nom=\"solcanne\" or @nom=\"mulchbat\"]")
+#' node_set <- get_nodes(
+#' sols_doc,
+#' "//*[@nom=\"solcanne\" or @nom=\"mulchbat\"]"
+#' )
#' attr_list <- sapply(node_set, function(x) XML::xmlAttrs(x))
#'
#' #> [[1]]
diff --git a/R/check_choice_param.R b/R/check_choice_param.R
index 889e5b51..4ec2c4fe 100644
--- a/R/check_choice_param.R
+++ b/R/check_choice_param.R
@@ -15,7 +15,6 @@
#' }
#'
check_choice_param <- function(xml_doc, param_name, stop = FALSE) {
-
#--------------------------------------------------------------------#
# This is for the moment a specific case attached to tec files:
# parameter names attached to intervention nodes
diff --git a/R/check_java_workspace.R b/R/check_java_workspace.R
index c38281bd..ec6fe702 100644
--- a/R/check_java_workspace.R
+++ b/R/check_java_workspace.R
@@ -15,7 +15,6 @@
#' @noRd
check_java_workspace <- function(javastics, workspace = NULL) {
-
# Ensure that the user working directory is unchanged after
# the function has run
current_wd <- getwd()
diff --git a/R/check_param_names.R b/R/check_param_names.R
index 45bd230e..20c71a94 100644
--- a/R/check_param_names.R
+++ b/R/check_param_names.R
@@ -1,6 +1,5 @@
check_param_names <- function(param_names, ref_names, pattern_tag = "",
err_stop = TRUE) {
-
# Checking parameter names from param_table against xml ones
# param_names <- unique(gsub(pattern =
# paste0("\\_(",pattern_tag,"){0,1}[1-9]+"), x = tolower(param_names), ""))
diff --git a/R/col_names_to_var.R b/R/col_names_to_var.R
index 748825b3..b7439631 100644
--- a/R/col_names_to_var.R
+++ b/R/col_names_to_var.R
@@ -23,9 +23,13 @@ col_names_to_var <- function(var_list = c()) {
# Getting the index of the variables to convert
#
idx_end_convert <- unlist(lapply(X = words, function(x) {
- end_conv <- grepl("[n | 0-9*]|nboite|nboite-1|ao|as",
- x[length(x)])
- if (end_conv) return(TRUE)
+ end_conv <- grepl(
+ "[n | 0-9*]|nboite|nboite-1|ao|as",
+ x[length(x)]
+ )
+ if (end_conv) {
+ return(TRUE)
+ }
FALSE
}))
@@ -44,9 +48,11 @@ col_names_to_var <- function(var_list = c()) {
# for varname_1, var_name_1,
# TODO: fix the case var_name_1_2
conv_var_list <-
- gsub("_(n{1}|\\d{1,2}|nboite|nboite-1|ao|as)$",
- "(\\1",
- conv_var_list)
+ gsub(
+ "_(n{1}|\\d{1,2}|nboite|nboite-1|ao|as)$",
+ "(\\1",
+ conv_var_list
+ )
any_opening <- grepl("\\(", conv_var_list)
diff --git a/R/compute_date_from_day.R b/R/compute_date_from_day.R
index 6d4277a3..fc4f1e14 100644
--- a/R/compute_date_from_day.R
+++ b/R/compute_date_from_day.R
@@ -16,10 +16,12 @@
#'
#' @export
#'
-compute_date_from_day <- function(day, start_year){
- stopifnot(all(is.numeric(day)),
- length(start_year) == 1,
- is.numeric(start_year))
+compute_date_from_day <- function(day, start_year) {
+ stopifnot(
+ all(is.numeric(day)),
+ length(start_year) == 1,
+ is.numeric(start_year)
+ )
return(as.Date(day - 1, origin = paste0(start_year, "-01-01")))
}
diff --git a/R/compute_day_number.R b/R/compute_day_number.R
index 704da129..11987f1a 100644
--- a/R/compute_day_number.R
+++ b/R/compute_day_number.R
@@ -6,7 +6,7 @@
#' @author Timothee Flutre
#' @keywords internal
#' @noRd
-get_day_of_year <- function(date){
+get_day_of_year <- function(date) {
stopifnot(methods::is(date, "Date"))
return(lubridate::yday(date))
@@ -22,11 +22,12 @@ get_day_of_year <- function(date){
#' @author Timothee Flutre
#' @keywords internal
#' @noRd
-is_leap_year <- function(year, integer = FALSE){
-
+is_leap_year <- function(year, integer = FALSE) {
is_leap <- year %% 4 == 0 & (year %% 100 != 0 | year %% 400 == 0)
- if (integer) return(as.integer(is_leap))
+ if (integer) {
+ return(as.integer(is_leap))
+ }
return(is_leap)
}
@@ -53,26 +54,25 @@ is_leap_year <- function(year, integer = FALSE){
#' compute_day_from_date(date = "2015-02-10", start_year = 2014)
#'
#' date <- as.Date("2009-02-10")
-#' compute_day_from_date(date = date, start_year = 2008 )
+#' compute_day_from_date(date = date, start_year = 2008)
#'
#' dates <- c(as.Date("2008-02-10"), as.Date("2009-02-10"))
-#' compute_day_from_date(date = dates, start_year = 2008 )
+#' compute_day_from_date(date = dates, start_year = 2008)
#'
#' @export
compute_day_from_date <- function(date,
start_year = NULL,
- start_date = lifecycle::deprecated()){
-
-
+ start_date = lifecycle::deprecated()) {
# In case of several input dates
- if(length(date) > 1) {
+ if (length(date) > 1) {
out <- unlist(
lapply(date, function(x) {
- compute_day_from_date(date = x,
- start_year = start_year,
- start_date = start_date)
- }
- )
+ compute_day_from_date(
+ date = x,
+ start_year = start_year,
+ start_date = start_date
+ )
+ })
)
return(out)
}
@@ -80,33 +80,43 @@ compute_day_from_date <- function(date,
# To keep compatibility with the previous argument start_date
# conversion to year
if (lifecycle::is_present(start_date)) {
- lifecycle::deprecate_warn("1.4.0",
- "compute_day_from_date(start_date)",
- "compute_day_from_date(start_year)")
+ lifecycle::deprecate_warn(
+ "1.4.0",
+ "compute_day_from_date(start_date)",
+ "compute_day_from_date(start_year)"
+ )
start_year <- lubridate::year(as.Date(start_date))
}
- stopifnot(methods::is(as.Date(date), "Date") || methods::is(date, "Date"),
- is.null(start_year) || methods::is(start_year, "numeric"))
+ stopifnot(
+ methods::is(as.Date(date), "Date") || methods::is(date, "Date"),
+ is.null(start_year) || methods::is(start_year, "numeric")
+ )
# Converting a character date to Date format
- if(is.character(date)) date <- as.Date(date)
+ if (is.character(date)) date <- as.Date(date)
day_of_year <- get_day_of_year(date)
date_year <- lubridate::year(date)
# No start_year, or start_year == date year
# returning the current date year day
- if (is.null(start_year))
+ if (is.null(start_year)) {
start_year <- date_year
+ }
- if (date_year == start_year) return(day_of_year)
+ if (date_year == start_year) {
+ return(day_of_year)
+ }
# Impossible case
- if(start_year > date_year)
- stop("The start year ", start_year,
- " is greater than the date year ", date_year, "!")
+ if (start_year > date_year) {
+ stop(
+ "The start year ", start_year,
+ " is greater than the date year ", date_year, "!"
+ )
+ }
# Several years
years <- seq(start_year, date_year - 1)
@@ -115,6 +125,5 @@ compute_day_from_date <- function(date,
# Calculating the day number over years
return(365 * (length(years) - leap_year_number) +
366 * leap_year_number +
- day_of_year
- )
+ day_of_year)
}
diff --git a/R/convert_xml2txt.R b/R/convert_xml2txt.R
index e1a8f357..988851cb 100644
--- a/R/convert_xml2txt.R
+++ b/R/convert_xml2txt.R
@@ -21,7 +21,6 @@
#' @return None
#'
#' @examples
-#'
#' \dontrun{
#' xml_path <- "/path/to/corn_plt.xml"
#' javastics_path <- "/path/to/JavaSTICS/folder"
@@ -38,26 +37,31 @@ convert_xml2txt <- function(file,
xml_file = lifecycle::deprecated(),
plt_num = lifecycle::deprecated(),
out_file = lifecycle::deprecated()) {
-
if (lifecycle::is_present(xml_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "convert_xml2txt(xml_file)",
- "convert_xml2txt(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "convert_xml2txt(xml_file)",
+ "convert_xml2txt(file)"
+ )
} else {
xml_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(plt_num)) {
- lifecycle::deprecate_warn("1.0.0",
- "convert_xml2txt(plt_num)",
- "convert_xml2txt(plant_id)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "convert_xml2txt(plt_num)",
+ "convert_xml2txt(plant_id)"
+ )
} else {
plt_num <- plant_id # to remove when we update inside the function
}
if (lifecycle::is_present(out_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "convert_xml2txt(out_file)",
- "convert_xml2txt(save_as)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "convert_xml2txt(out_file)",
+ "convert_xml2txt(save_as)"
+ )
} else {
out_file <- save_as # to remove when we update inside the function
}
@@ -79,8 +83,10 @@ convert_xml2txt <- function(file,
)
# Using tags from in files names for the xml file type identification
- tags <- list("_ini\\.xml", "sols\\.xml", "_plt\\.xml",
- "_tec\\.xml", "_sta\\.xml", "_newform\\.xml", "_gen\\.xml")
+ tags <- list(
+ "_ini\\.xml", "sols\\.xml", "_plt\\.xml",
+ "_tec\\.xml", "_sta\\.xml", "_newform\\.xml", "_gen\\.xml"
+ )
idx <- which(unlist(lapply(tags, function(x) grepl(x, xml_file))))
calc_name <- length(idx) > 0
@@ -123,4 +129,3 @@ convert_xml2txt <- function(file,
return(status)
}
-
diff --git a/R/convert_xml2txt_int.R b/R/convert_xml2txt_int.R
index 66cb7d5e..127b9941 100644
--- a/R/convert_xml2txt_int.R
+++ b/R/convert_xml2txt_int.R
@@ -14,7 +14,7 @@
#' \dontrun{
#' xml_plt <- file.path(get_examples_path(file_type = "xml"), "file_plt.xml")
#' xsl_file <-
-#' "/path/to/JavaSTICS/folder/bin/resources/xml/stylesheet/xml2txt.xsl"
+#' "/path/to/JavaSTICS/folder/bin/resources/xml/stylesheet/xml2txt.xsl"
#'
#' convert_xml2txt_int(xml_file = xml_plt, style_file = xsl_file)
#' }
@@ -24,12 +24,12 @@
#' @noRd
#'
convert_xml2txt_int <- function(xml_file, style_file, out_file = NULL) {
-
f_names <- c(xml_file, style_file)
ex_files <- file.exists(f_names)
if (any(!ex_files)) {
- warning("At least one input file doesn't exist ! \n",
- paste(f_names[!ex_files], collapse = ", ")
+ warning(
+ "At least one input file doesn't exist ! \n",
+ paste(f_names[!ex_files], collapse = ", ")
)
return(FALSE)
}
@@ -37,7 +37,7 @@ convert_xml2txt_int <- function(xml_file, style_file, out_file = NULL) {
# checking files extensions
names_split <- lapply(f_names, function(x) {
unlist(strsplit(x, ".",
- fixed = TRUE
+ fixed = TRUE
))
})
@@ -66,7 +66,7 @@ convert_xml2txt_int <- function(xml_file, style_file, out_file = NULL) {
out_file <- file.path(
dirname(xml_file),
paste0(unlist(strsplit(basename(xml_file), ".",
- fixed = TRUE
+ fixed = TRUE
))[1], ".", ext)
)
}
diff --git a/R/download_data.R b/R/download_data.R
index eb988841..555aa842 100644
--- a/R/download_data.R
+++ b/R/download_data.R
@@ -26,21 +26,24 @@ download_data <- function(out_dir = tempdir(), example_dirs = NULL,
stics_version = "latest",
dir = lifecycle::deprecated(),
version_name = lifecycle::deprecated()) {
-
# Managing the parameter name changes from 0.5.0 and onward:
if (lifecycle::is_present(dir)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_data(dir)",
- "download_data(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_data(dir)",
+ "download_data(out_dir)"
+ )
} else {
dir <- out_dir # to remove when we update inside the function
}
# Managing the parameter name changes from 0.5.0 and onward:
if (lifecycle::is_present(version_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_data(version_name)",
- "download_data(stics_version)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_data(version_name)",
+ "download_data(stics_version)"
+ )
} else {
version_name <- stics_version # to remove when we update inside the function
}
@@ -52,19 +55,25 @@ download_data <- function(out_dir = tempdir(), example_dirs = NULL,
# Getting path string(s) from examples data file
- dirs_str <- get_referenced_dirs(dirs = example_dirs,
- stics_version = version_name)
+ dirs_str <- get_referenced_dirs(
+ dirs = example_dirs,
+ stics_version = version_name
+ )
# Not any examples_dirs not found in example data file
- if (base::is.null(dirs_str))
+ if (base::is.null(dirs_str)) {
stop("Error: no available data for ", example_dirs)
+ }
data_dir <- normalizePath(dir, winslash = "/", mustWork = FALSE)
data_dir_zip <- normalizePath(file.path(data_dir, "master.zip"),
- winslash = "/",
- mustWork = FALSE)
- utils::download.file("https://github.com/SticsRPacks/data/archive/master.zip",
- data_dir_zip)
+ winslash = "/",
+ mustWork = FALSE
+ )
+ utils::download.file(
+ "https://github.com/SticsRPacks/data/archive/master.zip",
+ data_dir_zip
+ )
df_name <- utils::unzip(data_dir_zip, exdir = data_dir, list = TRUE)
@@ -75,11 +84,14 @@ download_data <- function(out_dir = tempdir(), example_dirs = NULL,
))
# No data corresponding to example_dirs request in the archive !
- if (!length(arch_files))
- stop("No downloadable data for example(s), version: ",
- example_dirs,
- ",",
- version_name)
+ if (!length(arch_files)) {
+ stop(
+ "No downloadable data for example(s), version: ",
+ example_dirs,
+ ",",
+ version_name
+ )
+ }
# Finally extracting data
utils::unzip(data_dir_zip, exdir = data_dir, files = arch_files)
@@ -118,11 +130,11 @@ download_data <- function(out_dir = tempdir(), example_dirs = NULL,
#' }
#'
get_referenced_dirs <- function(dirs = NULL, stics_version = NULL) {
-
# Loading csv file with data information
ver_data <- get_versions_info(stics_version = stics_version)
- if (base::is.null(ver_data))
+ if (base::is.null(ver_data)) {
stop("No examples data referenced for version: ", stics_version)
+ }
dirs_names <- grep(pattern = "^study_case", x = names(ver_data), value = TRUE)
if (base::is.null(dirs)) dirs <- dirs_names
diff --git a/R/download_usm_xl.R b/R/download_usm_xl.R
index 9ee422f9..46c3c3b0 100644
--- a/R/download_usm_xl.R
+++ b/R/download_usm_xl.R
@@ -30,7 +30,6 @@
#'
#' download_usm_xl()
#'
-#'
#' @export
#'
@@ -44,23 +43,29 @@ download_usm_xl <- function(file = NULL,
dest_dir = lifecycle::deprecated(),
...) {
if (lifecycle::is_present(xl_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_xl(xl_name)",
- "download_usm_xl(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_xl(xl_name)",
+ "download_usm_xl(file)"
+ )
} else {
xl_name <- file # to remove when we update inside the function
}
if (lifecycle::is_present(version_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_xl(version_name)",
- "download_usm_xl(stics_version)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_xl(version_name)",
+ "download_usm_xl(stics_version)"
+ )
} else {
version_name <- stics_version # to remove when we update inside the function
}
if (lifecycle::is_present(dest_dir)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_xl(dest_dir)",
- "download_usm_xl(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_xl(dest_dir)",
+ "download_usm_xl(out_dir)"
+ )
} else {
dest_dir <- out_dir # to remove when we update inside the function
}
@@ -81,8 +86,10 @@ download_usm_xl <- function(file = NULL,
xl_name <- xl_patt
}
- xl_dir <- get_examples_path(file_type = "xl",
- stics_version = version_name)
+ xl_dir <- get_examples_path(
+ file_type = "xl",
+ stics_version = version_name
+ )
files_list <- list.files(xl_dir, pattern = xl_patt)
@@ -111,16 +118,21 @@ download_usm_xl <- function(file = NULL,
success <- file.copy(from = src_list, to = dest_dir, overwrite = overwrite)
if (any(success)) {
- if (verbose)
- message(paste(files_list[success],
- " has been copied in directory ",
- dest_dir))
+ if (verbose) {
+ message(paste(
+ files_list[success],
+ " has been copied in directory ",
+ dest_dir
+ ))
+ }
dest_list <- dest_list[success]
}
- if (!all(success))
+ if (!all(success)) {
warning("Error copying files:\n", paste(src_list[!success],
- collapse = "\n"))
+ collapse = "\n"
+ ))
+ }
return(invisible(dest_list))
@@ -165,23 +177,29 @@ download_usm_csv <- function(file = NULL,
version_name = lifecycle::deprecated(),
dest_dir = lifecycle::deprecated()) {
if (lifecycle::is_present(csv_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_csv(csv_name)",
- "download_usm_csv(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_csv(csv_name)",
+ "download_usm_csv(file)"
+ )
} else {
csv_name <- file # to remove when we update inside the function
}
if (lifecycle::is_present(version_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_csv(version_name)",
- "download_usm_csv(stics_version)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_csv(version_name)",
+ "download_usm_csv(stics_version)"
+ )
} else {
version_name <- stics_version # to remove when we update inside the function
}
if (lifecycle::is_present(dest_dir)) {
- lifecycle::deprecate_warn("1.0.0",
- "download_usm_csv(dest_dir)",
- "download_usm_csv(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "download_usm_csv(dest_dir)",
+ "download_usm_csv(out_dir)"
+ )
} else {
dest_dir <- out_dir # to remove when we update inside the function
}
diff --git a/R/exist_param_xml.R b/R/exist_param_xml.R
index a81aa868..a6064db6 100644
--- a/R/exist_param_xml.R
+++ b/R/exist_param_xml.R
@@ -24,7 +24,6 @@
#'
exist_param_xml <- function(param,
stics_version = "latest") {
-
# Finding exact matchs in found names
par_names <- get_param_data_df(
param = param,
@@ -72,8 +71,6 @@ exist_param_xml <- function(param,
#'
exist_param_csv <- function(param,
javastics) {
-
-
# Keeping names to modify with real names
final_names <- param
diff --git a/R/exists_param.R b/R/exists_param.R
index 91425fa3..142b0463 100644
--- a/R/exists_param.R
+++ b/R/exists_param.R
@@ -1,4 +1,3 @@
-
#' Test if a parameter exists
#'
#' @description Test if a parameter exists in an XML file
diff --git a/R/expand_stics_names.R b/R/expand_stics_names.R
index 245f00d3..e7ca242c 100644
--- a/R/expand_stics_names.R
+++ b/R/expand_stics_names.R
@@ -21,19 +21,18 @@
#' @noRd
#'
expand_stics_names <- function(in_csv_file, out_csv_file, header = FALSE) {
-
skip <- as.integer(header)
in_data <- utils::read.table(in_csv_file,
sep = ";", stringsAsFactors = FALSE,
header = FALSE, skip = skip
)
- #if (base::is.null(header_vec)) {
- names(in_data) <- c(
- "name", "def", "unit", "param", "dim", "type",
- "min", "max", "optim", "n"
- )
- #}
+ # if (base::is.null(header_vec)) {
+ names(in_data) <- c(
+ "name", "def", "unit", "param", "dim", "type",
+ "min", "max", "optim", "n"
+ )
+ # }
# getting param names to duplicate
par_to_expand <- in_data[in_data$dim > 1, ]
diff --git a/R/file_document.R b/R/file_document.R
index a29eeded..1ff71663 100644
--- a/R/file_document.R
+++ b/R/file_document.R
@@ -27,41 +27,44 @@ setClass(
)
# constructor
-setMethod("filedocument", signature(file = "character", type = "character"),
- function(file = character(length = 0), type = character(length = 0)) {
- return(methods::new("file_document", file, type))
- }
+setMethod(
+ "filedocument", signature(file = "character", type = "character"),
+ function(file = character(length = 0), type = character(length = 0)) {
+ return(methods::new("file_document", file, type))
+ }
)
# file only
-setMethod("filedocument", signature(file = "character", type = "missing"),
- function(file = character(length = 0), type = character(length = 0)) {
- return(methods::new("file_document", file))
- }
+setMethod(
+ "filedocument", signature(file = "character", type = "missing"),
+ function(file = character(length = 0), type = character(length = 0)) {
+ return(methods::new("file_document", file))
+ }
)
-setMethod("initialize", "file_document",
- function(.Object,
- file = character(length = 0),
- type = character(length = 0)) {
- if (missing(file)) {
- stop("missing file name")
- }
+setMethod(
+ "initialize", "file_document",
+ function(.Object,
+ file = character(length = 0),
+ type = character(length = 0)) {
+ if (missing(file)) {
+ stop("missing file name")
+ }
- .Object@name <- basename(file)
- .Object@dir <- normalizePath(dirname(file))
- .Object@ext <- calc_ext(.Object@name)
+ .Object@name <- basename(file)
+ .Object@dir <- normalizePath(dirname(file))
+ .Object@ext <- calc_ext(.Object@name)
- .Object@type <- calc_type(.Object)
+ .Object@type <- calc_type(.Object)
- .Object@warn <- FALSE
+ .Object@warn <- FALSE
- methods::validObject(.Object)
- return(.Object)
- }
+ methods::validObject(.Object)
+ return(.Object)
+ }
)
@@ -70,157 +73,173 @@ setMethod("initialize", "file_document",
# replace
# set
-setReplaceMethod("set_warn", signature(object = "file_document"),
- function(object, value) {
- object@warn <- value
- return(object)
- }
+setReplaceMethod(
+ "set_warn", signature(object = "file_document"),
+ function(object, value) {
+ object@warn <- value
+ return(object)
+ }
)
-setReplaceMethod("set_name", signature(object = "file_document"),
- function(object, value) {
- object@name <- value
- return(object)
- }
+setReplaceMethod(
+ "set_name", signature(object = "file_document"),
+ function(object, value) {
+ object@name <- value
+ return(object)
+ }
)
-setReplaceMethod("set_dir", signature(object = "file_document"),
- function(object, value) {
- object@dir <- normalizePath(value)
- return(object)
- }
+setReplaceMethod(
+ "set_dir", signature(object = "file_document"),
+ function(object, value) {
+ object@dir <- normalizePath(value)
+ return(object)
+ }
)
-setReplaceMethod("set_ext", signature(object = "file_document"),
- function(object, value) {
- object@ext <- value
- # add reconstruct file name !!!!!!!!!
- return(object)
- }
+setReplaceMethod(
+ "set_ext", signature(object = "file_document"),
+ function(object, value) {
+ object@ext <- value
+ # add reconstruct file name !!!!!!!!!
+ return(object)
+ }
)
# set
-setMethod("set_name", signature(object = "file_document"),
- function(object, value) {
- object@name <- value
- return(object)
- }
+setMethod(
+ "set_name", signature(object = "file_document"),
+ function(object, value) {
+ object@name <- value
+ return(object)
+ }
)
# getter methods
-setMethod("get_name", signature(object = "file_document"),
- function(object) {
- return(object@name)
- }
+setMethod(
+ "get_name", signature(object = "file_document"),
+ function(object) {
+ return(object@name)
+ }
)
#
-setMethod("get_dir", signature(object = "file_document"),
- function(object) {
- return(object@dir)
- }
+setMethod(
+ "get_dir", signature(object = "file_document"),
+ function(object) {
+ return(object@dir)
+ }
)
#
-setMethod("get_ext", signature(object = "file_document"),
- function(object) {
- return(object@ext)
- }
+setMethod(
+ "get_ext", signature(object = "file_document"),
+ function(object) {
+ return(object@ext)
+ }
)
-setMethod("get_type", signature(object = "file_document"),
- function(object) {
- return(object@type)
- }
+setMethod(
+ "get_type", signature(object = "file_document"),
+ function(object) {
+ return(object@type)
+ }
)
-setMethod("get_path", signature(object = "file_document"),
- function(object) {
- return(file.path(object@dir, object@name))
- }
+setMethod(
+ "get_path", signature(object = "file_document"),
+ function(object) {
+ return(file.path(object@dir, object@name))
+ }
)
-setMethod("exist", signature(object = "file_document"),
- function(object) {
- message <- FALSE
- # TODO: make distinction between dir and file !!!
- p <- get_path(object)
- ret <- file.exists(p)
-
- if (ret) {
- if (isdir(object)) {
- ret <- ret & get_type(object) == "dir"
- } else {
- ret <- ret & get_type(object) == "file"
- }
- }
- if (!ret & message) {
- message(paste0(" File doesn't exist: ", p))
- }
- return(ret)
- }
+setMethod(
+ "exist", signature(object = "file_document"),
+ function(object) {
+ message <- FALSE
+ # TODO: make distinction between dir and file !!!
+ p <- get_path(object)
+ ret <- file.exists(p)
+
+ if (ret) {
+ if (isdir(object)) {
+ ret <- ret & get_type(object) == "dir"
+ } else {
+ ret <- ret & get_type(object) == "file"
+ }
+ }
+ if (!ret & message) {
+ message(paste0(" File doesn't exist: ", p))
+ }
+ return(ret)
+ }
)
-setMethod("show", "file_document",
- function(object) {
- print(paste0(" name : ", object@name))
- print(paste0(" type : ", object@type))
- print(paste0(" dir : ", object@dir))
- print(paste0(" ext : ", object@ext))
- }
+setMethod(
+ "show", "file_document",
+ function(object) {
+ print(paste0(" name : ", object@name))
+ print(paste0(" type : ", object@type))
+ print(paste0(" dir : ", object@dir))
+ print(paste0(" ext : ", object@ext))
+ }
)
#
-setMethod("create", signature(object = "file_document"),
- function(object) {
- p <- get_path(object)
- if (!exist(object)) {
- if (object@type == "file") {
- file.create(p)
- }
- if (object@type == "dir") {
- dir.create(p)
- }
- } else {
- warning(paste0(" File already exists : ", p))
- }
- }
+setMethod(
+ "create", signature(object = "file_document"),
+ function(object) {
+ p <- get_path(object)
+ if (!exist(object)) {
+ if (object@type == "file") {
+ file.create(p)
+ }
+ if (object@type == "dir") {
+ dir.create(p)
+ }
+ } else {
+ warning(paste0(" File already exists : ", p))
+ }
+ }
)
#
-setMethod("move", signature(object = "file_document"),
- function(object, to_file) {
- # cas : rename, move
- if (exist(object)) {
- if (dir.exists(to_file)) {
- to_file <- file.path(to_file, object@name)
- }
- file.rename(get_path(object), to_file)
-
- object <- methods::new(class(object)[[1]], to_file)
- } else {
- set_name(object) <- to_file
- }
- return(object)
- }
+setMethod(
+ "move", signature(object = "file_document"),
+ function(object, to_file) {
+ # cas : rename, move
+ if (exist(object)) {
+ if (dir.exists(to_file)) {
+ to_file <- file.path(to_file, object@name)
+ }
+ file.rename(get_path(object), to_file)
+
+ object <- methods::new(class(object)[[1]], to_file)
+ } else {
+ set_name(object) <- to_file
+ }
+ return(object)
+ }
)
#
-setMethod("rename", signature(object = "file_document"),
- function(object, to_file) {
- move(object, to_file)
- }
+setMethod(
+ "rename", signature(object = "file_document"),
+ function(object, to_file) {
+ move(object, to_file)
+ }
)
#
-setMethod("delete", signature(object = "file_document"),
- function(object) {
- if (exist(object)) {
- file.remove(get_path(object))
- }
- }
+setMethod(
+ "delete", signature(object = "file_document"),
+ function(object) {
+ if (exist(object)) {
+ file.remove(get_path(object))
+ }
+ }
)
@@ -230,86 +249,91 @@ setMethod("delete", signature(object = "file_document"),
# from this class ???
#
-setMethod("infos", signature(object = "ANY"),
- function(object, type) {
- if (methods::is(object, "character")) {
- p <- object
- } else {
- p <- get_path(object)
- }
- # type: all,size,mtime,isdir
- ret <- file.info("")
- if (type == "all") {
- ret <- file.info(p)
- } else {
- ret <- file.info(p)[[type]]
- }
- return(ret)
- }
+setMethod(
+ "infos", signature(object = "ANY"),
+ function(object, type) {
+ if (methods::is(object, "character")) {
+ p <- object
+ } else {
+ p <- get_path(object)
+ }
+ # type: all,size,mtime,isdir
+ ret <- file.info("")
+ if (type == "all") {
+ ret <- file.info(p)
+ } else {
+ ret <- file.info(p)[[type]]
+ }
+ return(ret)
+ }
)
#
-setMethod("isdir", signature(object = "ANY"),
- function(object) {
- ret <- infos(object, "isdir")
- if (is.na(ret)) {
- stop("Unavailable information: file or dir doesn't exist !")
- }
- return(ret)
- }
+setMethod(
+ "isdir", signature(object = "ANY"),
+ function(object) {
+ ret <- infos(object, "isdir")
+ if (is.na(ret)) {
+ stop("Unavailable information: file or dir doesn't exist !")
+ }
+ return(ret)
+ }
)
#
-setMethod("isempty", signature(object = "ANY"),
- function(object) {
- # for files and dirs
- ret <- infos(object, "size") == 0
- if (is.na(ret)) {
- stop("Unavailable information: file doesn't exist !")
- }
- if (isdir(object)) {
- if (methods::is(object, "character")) {
- l <- list.files(object)
- } else {
- l <- list.files(get_path(object))
- }
- ret <- length(l) == 0
- }
- return(ret)
- }
+setMethod(
+ "isempty", signature(object = "ANY"),
+ function(object) {
+ # for files and dirs
+ ret <- infos(object, "size") == 0
+ if (is.na(ret)) {
+ stop("Unavailable information: file doesn't exist !")
+ }
+ if (isdir(object)) {
+ if (methods::is(object, "character")) {
+ l <- list.files(object)
+ } else {
+ l <- list.files(get_path(object))
+ }
+ ret <- length(l) == 0
+ }
+ return(ret)
+ }
)
#
-setMethod("calc_ext", signature(object = "ANY"),
- function(object) {
- ext <- ""
- if (methods::is(object, "character")) {
- name <- object
- } else {
- name <- object@name
- }
- char_vec <- unlist(strsplit(name, "[.]"))
- n_char <- length(char_vec)
- if (n_char > 1) {
- ext <- char_vec[[n_char]]
- }
-
- return(ext)
- }
+setMethod(
+ "calc_ext", signature(object = "ANY"),
+ function(object) {
+ ext <- ""
+ if (methods::is(object, "character")) {
+ name <- object
+ } else {
+ name <- object@name
+ }
+ char_vec <- unlist(strsplit(name, "[.]"))
+ n_char <- length(char_vec)
+ if (n_char > 1) {
+ ext <- char_vec[[n_char]]
+ }
+
+ return(ext)
+ }
)
-setMethod("calc_type", signature(object = "ANY"),
- function(object) {
- # default type
- type <- "file"
- if (methods::is(object, "character")) {
- name <- object
- } else {
- name <- get_path(object)
- }
- # keep this order for identifying file from dir
- if (file.exists(name)) type <- "file"
- if (dir.exists(name)) type <- "dir"
- return(type)
- }
+setMethod(
+ "calc_type", signature(object = "ANY"),
+ function(object) {
+ # default type
+ type <- "file"
+ if (methods::is(object, "character")) {
+ name <- object
+ } else {
+ name <- get_path(object)
+ }
+ # keep this order for identifying file from dir
+ if (file.exists(name)) type <- "file"
+ if (dir.exists(name)) type <- "dir"
+ return(type)
+ }
)
diff --git a/R/force_param_values.R b/R/force_param_values.R
index 7a0f6e96..9e87b6c4 100644
--- a/R/force_param_values.R
+++ b/R/force_param_values.R
@@ -43,9 +43,11 @@ force_param_values <- function(workspace,
javastics,
param_values = lifecycle::deprecated()) {
if (lifecycle::is_present(param_values)) {
- lifecycle::deprecate_warn("1.0.0",
- "force_param_values(param_values)",
- "force_param_values(values)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "force_param_values(param_values)",
+ "force_param_values(values)"
+ )
} else {
param_values <- values # to remove when we update inside the function
}
@@ -61,7 +63,6 @@ force_param_values <- function(workspace,
})
}
} else {
-
# convert into vector in case a tibble is given instead of a vector
param_values <-
stats::setNames(as.numeric(param_values), names(param_values))
diff --git a/R/gen_climate.R b/R/gen_climate.R
index cc48aa82..bed6f8eb 100644
--- a/R/gen_climate.R
+++ b/R/gen_climate.R
@@ -10,8 +10,10 @@
#'
#' @examples
#' \dontrun{
-#' gen_climate(c("path/to/weather.year1", "path/to/weather.year2"),
-#' "/path/to/out/dir" )
+#' gen_climate(
+#' c("path/to/weather.year1", "path/to/weather.year2"),
+#' "/path/to/out/dir"
+#' )
#' }
#'
#' @keywords internal
@@ -19,7 +21,6 @@
#' @noRd
#'
gen_climate <- function(files_path, out_dir) {
-
# generate intermediate paths for a multi-years simulation
# i.e. greater than 2
files_path <- complete_climate_paths(files_path)
@@ -31,8 +32,9 @@ gen_climate <- function(files_path, out_dir) {
}
ret <- try(
- writeLines(text = climate_lines,
- con = file.path(out_dir, "climat.txt")
+ writeLines(
+ text = climate_lines,
+ con = file.path(out_dir, "climat.txt")
)
)
@@ -41,7 +43,6 @@ gen_climate <- function(files_path, out_dir) {
}
return(invisible(TRUE))
-
}
@@ -54,7 +55,8 @@ gen_climate <- function(files_path, out_dir) {
#' @examples
#' \dontrun{
#' complete_climate_paths(
-#' c("path/to/weather.year1", "path/to/weather.year2"))
+#' c("path/to/weather.year1", "path/to/weather.year2")
+#' )
#' }
#'
#' @keywords internal
@@ -63,9 +65,10 @@ gen_climate <- function(files_path, out_dir) {
#'
#'
complete_climate_paths <- function(files_path) {
-
files_nb <- length(files_path)
- if (files_nb < 2) return(files_path)
+ if (files_nb < 2) {
+ return(files_path)
+ }
# Here we do not suppose that the file extension contains
# the year of the data
diff --git a/R/gen_general_param_xml.R b/R/gen_general_param_xml.R
index 517ea6de..149310b6 100644
--- a/R/gen_general_param_xml.R
+++ b/R/gen_general_param_xml.R
@@ -20,25 +20,27 @@
#' @examples
#' gen_general_param_xml(out_dir = tempdir())
#'
-#' gen_general_param_xml(out_dir = tempdir(),
-#' stics_version = "V10.0",
-#' overwrite = TRUE)
+#' gen_general_param_xml(
+#' out_dir = tempdir(),
+#' stics_version = "V10.0",
+#' overwrite = TRUE
+#' )
#'
#' @export
#'
gen_general_param_xml <- function(out_dir,
stics_version = "latest",
overwrite = FALSE) {
-
-
# check/get version
stics_version <- get_xml_stics_version(
stics_version = stics_version
)
# getting dir path of templates
- files_dir <- get_examples_path(file_type = "xml",
- stics_version = stics_version)
+ files_dir <- get_examples_path(
+ file_type = "xml",
+ stics_version = stics_version
+ )
# Copying files to out_dir
files_name <- c("param_gen.xml", "param_newform.xml")
@@ -46,11 +48,11 @@ gen_general_param_xml <- function(out_dir,
copy_status <- file.copy(xml_files, out_dir, overwrite = overwrite)
- if (!all(copy_status))
- stop("Some error occured while copying files: \n",
- paste(files_name[!copy_status], collapse = ", \n"),
- "\nConsider setting overwrite to TRUE as function additional input")
-
-
-
+ if (!all(copy_status)) {
+ stop(
+ "Some error occured while copying files: \n",
+ paste(files_name[!copy_status], collapse = ", \n"),
+ "\nConsider setting overwrite to TRUE as function additional input"
+ )
+ }
}
diff --git a/R/gen_ini_doc.R b/R/gen_ini_doc.R
index f642cd27..d1887061 100644
--- a/R/gen_ini_doc.R
+++ b/R/gen_ini_doc.R
@@ -33,8 +33,6 @@ gen_ini_doc <- function(xml_doc = NULL,
params_desc = NULL,
stics_version = "latest",
check_names = TRUE) {
-
-
# check/get version
stics_version <- get_xml_stics_version(
stics_version = stics_version,
diff --git a/R/gen_ini_xml.R b/R/gen_ini_xml.R
index 06677829..a98a7f54 100644
--- a/R/gen_ini_xml.R
+++ b/R/gen_ini_xml.R
@@ -58,7 +58,7 @@
#' ini_param_df <- read_excel(xl_path, sheet = "Ini")
#' gen_ini_xml(
#' out_dir = tempdir(),
-#' param_df = ini_param_df[1:2,]
+#' param_df = ini_param_df[1:2, ]
#' )
#'
#' @export
@@ -72,23 +72,29 @@ gen_ini_xml <- function(param_df,
param_table = lifecycle::deprecated(),
out_path = lifecycle::deprecated()) {
if (lifecycle::is_present(ini_in_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_ini_xml(ini_in_file)",
- "gen_ini_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_ini_xml(ini_in_file)",
+ "gen_ini_xml(file)"
+ )
} else {
ini_in_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(param_table)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_ini_xml(param_table)",
- "gen_ini_xml(param_df)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_ini_xml(param_table)",
+ "gen_ini_xml(param_df)"
+ )
} else {
param_table <- param_df # to remove when we update inside the function
}
if (lifecycle::is_present(out_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_ini_xml(out_path)",
- "gen_ini_xml(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_ini_xml(out_path)",
+ "gen_ini_xml(out_dir)"
+ )
} else {
out_path <- out_dir # to remove when we update inside the function
}
@@ -126,9 +132,10 @@ gen_ini_xml <- function(param_df,
if (any(out_idx)) {
message("\nErrors have been detected while trying to replace",
- "parameters values in xml documents",
- paste(sum(!out_idx), "files have been generated !"),
- appendLF = TRUE)
+ "parameters values in xml documents",
+ paste(sum(!out_idx), "files have been generated !"),
+ appendLF = TRUE
+ )
# selecting available documents to produce
xml_docs <- xml_docs[out_idx]
}
@@ -166,6 +173,7 @@ gen_ini_xml <- function(param_df,
delete(xml_docs[[f]])
}
- if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document"))
+ if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document")) {
delete(xml_doc_tmpl)
+ }
}
diff --git a/R/gen_new_travail.R b/R/gen_new_travail.R
index 14add59e..f3f2ebb3 100644
--- a/R/gen_new_travail.R
+++ b/R/gen_new_travail.R
@@ -27,17 +27,18 @@ gen_new_travail <- function(usm_data,
codesuite = NULL,
codoptim = NULL,
out_dir = NULL) {
-
-
data_plt2 <- c()
- if (usm_data$nbplantes > 1)
+ 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)
+ 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
@@ -88,10 +89,10 @@ get_usm_data <- function(usms_doc,
lai_forcing = NULL,
codesuite = NULL,
codoptim = NULL) {
-
data <- XML::getNodeSet(usms_doc@content,
- path = paste0("//usm[@nom='", usm, "']"),
- fun = XML::xmlToList)[[1]]
+ path = paste0("//usm[@nom='", usm, "']"),
+ fun = XML::xmlToList
+ )[[1]]
n <- names(data)
n[11] <- "plante1"
n[12] <- "plante2"
@@ -101,19 +102,22 @@ get_usm_data <- function(usms_doc,
# 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))
+ 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))
+ 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))
+ if (!is.null(codesuite) && codesuite %in% c(0, 1)) {
data$codesuite <- codesuite
+ }
# nbplantes
data$nbplantes <- as.numeric(data$nbplantes)
@@ -148,13 +152,15 @@ get_usm_data <- function(usms_doc,
# add constraint on culturean
data$culturean <- as.numeric(data$culturean)
- if (data$culturean != 1)
+ if (data$culturean != 1) {
data$culturean <- 2
+ }
# add constraint on culturean
data$culturean <- as.numeric(data$culturean)
- if (data$culturean != 1)
+ if (data$culturean != 1) {
data$culturean <- 0
+ }
# nbans
data$nbans <- get_years_number(
@@ -169,8 +175,9 @@ get_usm_data <- function(usms_doc,
data$fobs1 <- data$plante1$fobs
- if (data$flai1 == "null" || data$flai1 == "defaut.lai")
+ if (data$flai1 == "null" || data$flai1 == "defaut.lai") {
data$codesimul <- get_codesimul(0)
+ }
if (data$nbplantes > 1) {
data$fplt2 <- data$plante2$fplt
@@ -205,14 +212,19 @@ get_usm_data <- function(usms_doc,
#' @noRd
#'
get_codesimul <- function(lai_forcing = 0) {
+ if (lai_forcing == 0) {
+ return("culture")
+ }
- if (lai_forcing == 0) return("culture")
-
- if (lai_forcing == 1) return("feuille")
+ if (lai_forcing == 1) {
+ return("feuille")
+ }
- stop("Error on lai forcing value: ",
- lai_forcing,
- "\nmIt must be 0 or 1 !")
+ stop(
+ "Error on lai forcing value: ",
+ lai_forcing,
+ "\nmIt must be 0 or 1 !"
+ )
}
@@ -229,7 +241,6 @@ get_codesimul <- function(lai_forcing = 0) {
#'
get_years_number <- function(clim_path) {
-
year1 <- get_year(clim_path = clim_path[1])
if (clim_path[1] == clim_path[2]) {
@@ -238,13 +249,13 @@ get_years_number <- function(clim_path) {
year2 <- get_year(clim_path = clim_path[2])
}
- if (any(is.na(c(year1, year2))))
+ 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
@@ -259,12 +270,13 @@ get_years_number <- function(clim_path) {
#'
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 = " ")
+ line_str <- gsub(
+ pattern = "\\t",
+ x = trimws(readLines(con = clim_path, n = 1)),
+ replacement = " "
+ )
words <- strsplit(line_str, split = " ")[[1]]
@@ -279,5 +291,4 @@ get_year <- function(clim_path) {
}
return(year)
-
}
diff --git a/R/gen_obs.R b/R/gen_obs.R
index 20913e3f..a78e7771 100644
--- a/R/gen_obs.R
+++ b/R/gen_obs.R
@@ -71,8 +71,9 @@ gen_obs <- function(df,
usm_names <- unique(obs_table[[usm_idx]])
# Treating a usms_list input
- if (!base::is.null(usms_list))
+ if (!base::is.null(usms_list)) {
usm_names <- usm_names[usm_names %in% usms_list]
+ }
nb_usms <- length(usm_names)
@@ -136,8 +137,6 @@ gen_obs <- function(df,
#' @noRd
#'
gen_obs_ <- function(obs_table, file_path) {
-
-
# Checking file path
dir_name <- dirname(file_path)
if (!dir.exists(dir_name)) {
@@ -157,8 +156,10 @@ gen_obs_ <- function(obs_table, file_path) {
obs_date_df <- obs_table[, grep(patt_str, colnames(obs_table)), drop = FALSE]
if (!dim(obs_var_df)[2] || dim(obs_date_df)[2] < 4) {
- warning("Missing columns for dates,",
- " or no observation variables values to write !")
+ warning(
+ "Missing columns for dates,",
+ " or no observation variables values to write !"
+ )
return(invisible(FALSE))
}
@@ -172,11 +173,12 @@ gen_obs_ <- function(obs_table, file_path) {
colnames(obs_table) <- col_names_to_var(colnames(obs_table))
ret <- try(utils::write.table(obs_table,
- file_path,
- sep = ";",
- na = "-999.99",
- row.names = FALSE,
- quote = FALSE))
+ file_path,
+ sep = ";",
+ na = "-999.99",
+ row.names = FALSE,
+ quote = FALSE
+ ))
# Checking if any error writing the file
if (methods::is(ret, "try-error")) {
diff --git a/R/gen_paramsti.R b/R/gen_paramsti.R
index 8b694df1..fbe28560 100644
--- a/R/gen_paramsti.R
+++ b/R/gen_paramsti.R
@@ -22,7 +22,6 @@ gen_paramsti <- function(workspace,
par_names,
par_values,
file_name = "param.sti") {
-
# Checking if workspace exists
if (!dir.exists(workspace)) {
stop(paste(workspace, ": directory does not exist !"))
diff --git a/R/gen_sol_xsl_file.R b/R/gen_sol_xsl_file.R
index d6a091e5..c8951b5b 100644
--- a/R/gen_sol_xsl_file.R
+++ b/R/gen_sol_xsl_file.R
@@ -7,7 +7,7 @@
#'
#' @examples
#' \dontrun{
-#' SticsRFiles:::gen_sol_xsl_file("soil_name", "V10" )
+#' SticsRFiles:::gen_sol_xsl_file("soil_name", "V10")
#' }
#'
#' @keywords internal
@@ -15,7 +15,6 @@
#' @noRd
#'
gen_sol_xsl_file <- function(soil_name, stics_version = "latest") {
-
xsl_dir <- get_examples_path("xsl", stics_version = stics_version)
sol_xsl <- file.path(xsl_dir, "sol2txt.xsl")
@@ -31,9 +30,11 @@ gen_sol_xsl_file <- function(soil_name, stics_version = "latest") {
idx <- grep(pattern = "variable", x = file_lines)
# replace nomsol in it
- file_lines[idx] <- gsub(pattern = "\\?",
- x = file_lines[idx],
- replacement = soil_name)
+ file_lines[idx] <- gsub(
+ pattern = "\\?",
+ x = file_lines[idx],
+ replacement = soil_name
+ )
ret <- try(writeLines(text = file_lines, con = sol_xsl))
diff --git a/R/gen_sols_xml.R b/R/gen_sols_xml.R
index 1ce05b07..768c84d6 100644
--- a/R/gen_sols_xml.R
+++ b/R/gen_sols_xml.R
@@ -56,8 +56,10 @@
#' xl_path <- download_usm_xl(file = "inputs_stics_example.xlsx")
#'
#' sols_param_df <- read_params_table(file = xl_path, sheet_name = "Soils")
-#' gen_sols_xml(file = file.path(tempdir(), "sols.xml"),
-#' param_df = sols_param_df)
+#' gen_sols_xml(
+#' file = file.path(tempdir(), "sols.xml"),
+#' param_df = sols_param_df
+#' )
#'
#' @export
#'
@@ -103,8 +105,8 @@ gen_sols_xml <- function(file,
if (lifecycle::is_present(sols_nb)) {
lifecycle::deprecate_warn("1.0.0",
- "gen_sols_xml(sols_nb)",
- details = "directly computed in the function."
+ "gen_sols_xml(sols_nb)",
+ details = "directly computed in the function."
)
} else {
sols_nb <- nrow(sols_param)
@@ -138,7 +140,7 @@ gen_sols_xml <- function(file,
# finalizing object
delete(xml_doc)
- if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document"))
+ if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document")) {
delete(xml_doc_tmpl)
-
+ }
}
diff --git a/R/gen_sta_doc.R b/R/gen_sta_doc.R
index 996abf10..01851c98 100644
--- a/R/gen_sta_doc.R
+++ b/R/gen_sta_doc.R
@@ -26,8 +26,6 @@ gen_sta_doc <- function(xml_doc = NULL,
param_table = NULL,
stics_version = "latest",
check_names = TRUE) {
-
-
# check/get version
stics_version <- get_xml_stics_version(
stics_version = stics_version,
diff --git a/R/gen_sta_xml.R b/R/gen_sta_xml.R
index 2185ef6b..0bbeb4b2 100644
--- a/R/gen_sta_xml.R
+++ b/R/gen_sta_xml.R
@@ -54,23 +54,29 @@ gen_sta_xml <- function(param_df,
sta_in_file = lifecycle::deprecated(),
out_path = lifecycle::deprecated()) {
if (lifecycle::is_present(param_table)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_sta_xml(param_table)",
- "gen_sta_xml(param_df)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_sta_xml(param_table)",
+ "gen_sta_xml(param_df)"
+ )
} else {
param_table <- param_df # to remove when we update inside the function
}
if (lifecycle::is_present(sta_in_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_sta_xml(sta_in_file)",
- "gen_sta_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_sta_xml(sta_in_file)",
+ "gen_sta_xml(file)"
+ )
} else {
sta_in_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(out_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_sta_xml(out_path)",
- "gen_sta_xml(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_sta_xml(out_path)",
+ "gen_sta_xml(out_dir)"
+ )
} else {
out_path <- out_dir # to remove when we update inside the function
}
@@ -108,9 +114,13 @@ gen_sta_xml <- function(param_df,
out_idx <- unlist(lapply(xml_docs, base::is.null))
if (any(out_idx)) {
- message(paste0("\nErrors have been detected while trying to replace",
- "parameters values in xml documents\n"),
- paste(sum(!out_idx), "files have been generated !\n"))
+ message(
+ paste0(
+ "\nErrors have been detected while trying to replace",
+ "parameters values in xml documents\n"
+ ),
+ paste(sum(!out_idx), "files have been generated !\n")
+ )
# selecting available documents to produce
xml_docs <- xml_docs[out_idx]
@@ -148,7 +158,7 @@ gen_sta_xml <- function(param_df,
delete(xml_docs[[f]])
}
- if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document"))
+ if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document")) {
delete(xml_doc_tmpl)
-
+ }
}
diff --git a/R/gen_tec_doc.R b/R/gen_tec_doc.R
index 664246c1..a09580f2 100644
--- a/R/gen_tec_doc.R
+++ b/R/gen_tec_doc.R
@@ -35,8 +35,6 @@ gen_tec_doc <- function(xml_doc = NULL,
stics_version = "latest",
dict = NULL,
...) {
-
-
dot_args <- list(...)
dot_args_names <- names(dot_args)
@@ -68,7 +66,7 @@ gen_tec_doc <- function(xml_doc = NULL,
gen_tec_doc(
xml_doc = clone_xml_doc(xml_doc),
param_table = as.data.frame(t(x),
- stringsAsFactors = FALSE
+ stringsAsFactors = FALSE
),
stics_version = stics_version,
dict = dict,
@@ -84,13 +82,11 @@ gen_tec_doc <- function(xml_doc = NULL,
param_table <- param_table %>%
dplyr::select(where(function(x) !is.na(x)) &
- where(function(x) {
- c <- x != "NA"
- if (is.na(c)) c <- TRUE
- return(c)
-
- }
- ))
+ where(function(x) {
+ c <- x != "NA"
+ if (is.na(c)) c <- TRUE
+ return(c)
+ }))
# TODO : Avoid making conversion at each call !!!!!!
# getting values of params declared in the table
@@ -179,8 +175,8 @@ gen_tec_doc <- function(xml_doc = NULL,
nb_values <- length(param_values)
if ((nb_values > 0) && nb_par == nb_values) {
set_param_value(xml_doc,
- param_name = par_name,
- param_value = param_values
+ param_name = par_name,
+ param_value = param_values
)
} else {
if (nb_par > 0) {
@@ -206,8 +202,10 @@ gen_tec_doc <- function(xml_doc = NULL,
"is unique in the original xml file,",
"and not attached to \"intervention\"\n"
))
- message(paste0("Multiple values are present in input table,",
- " check consistency with formalism definition !\n"))
+ message(paste0(
+ "Multiple values are present in input table,",
+ " check consistency with formalism definition !\n"
+ ))
message("The treatment for this parameter has aborted.\n")
next
}
diff --git a/R/gen_tec_xml.R b/R/gen_tec_xml.R
index 9cba03ce..e149ede2 100644
--- a/R/gen_tec_xml.R
+++ b/R/gen_tec_xml.R
@@ -65,27 +65,32 @@ gen_tec_xml <- function(param_df = NULL,
param_table = lifecycle::deprecated(),
tec_in_file = lifecycle::deprecated(),
out_path = lifecycle::deprecated()) {
-
# TODO: refactor with gen_sta_file, gen_ini_file : same code
if (lifecycle::is_present(param_table)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_tec_xml(param_table)",
- "gen_tec_xml(param_df)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_tec_xml(param_table)",
+ "gen_tec_xml(param_df)"
+ )
} else {
param_table <- param_df # to remove when we update inside the function
}
if (lifecycle::is_present(tec_in_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_tec_xml(tec_in_file)",
- "gen_tec_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_tec_xml(tec_in_file)",
+ "gen_tec_xml(file)"
+ )
} else {
tec_in_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(out_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_tec_xml(out_path)",
- "gen_tec_xml(out_dir)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_tec_xml(out_path)",
+ "gen_tec_xml(out_dir)"
+ )
} else {
out_path <- out_dir # to remove when we update inside the function
}
@@ -127,9 +132,13 @@ gen_tec_xml <- function(param_df = NULL,
out_idx <- unlist(lapply(xml_docs, base::is.null))
if (any(out_idx)) {
- message(paste0("\nErrors have been detected while trying to replace",
- "parameters values in xml documents\n"),
- paste(sum(!out_idx), "files have been generated !\n"))
+ message(
+ paste0(
+ "\nErrors have been detected while trying to replace",
+ "parameters values in xml documents\n"
+ ),
+ paste(sum(!out_idx), "files have been generated !\n")
+ )
# selecting available documents to produce
xml_docs <- xml_docs[out_idx]
}
@@ -172,7 +181,7 @@ gen_tec_xml <- function(param_df = NULL,
delete(xml_docs[[f]])
}
- if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document"))
+ if (!base::is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document")) {
delete(xml_doc_tmpl)
-
+ }
}
diff --git a/R/gen_usms_sols_doc.R b/R/gen_usms_sols_doc.R
index 54c2b025..486ab585 100644
--- a/R/gen_usms_sols_doc.R
+++ b/R/gen_usms_sols_doc.R
@@ -34,8 +34,6 @@ gen_usms_sols_doc <- function(doc_type,
nodes_nb = NULL,
nodes_param = NULL,
stics_version = "latest") {
-
-
# for usms and sols files
doc_types <- list()
@@ -103,16 +101,19 @@ gen_usms_sols_doc <- function(doc_type,
# Creating nodes for usms or sols
add_node_to_doc(xml_doc_out,
- xml_nodes[[1]],
- nodes_nb = elts_nb - 1,
- parent_path = root_str)
+ xml_nodes[[1]],
+ nodes_nb = elts_nb - 1,
+ parent_path = root_str
+ )
# Warning if nodes number > 1
# I that case, the xml_doc_out cannot be considered as a template
if (doc_nodes_nb > 1) {
- stop("Multiple elements in ",
- doc_type,
- " file, cannot be used as a template !")
+ stop(
+ "Multiple elements in ",
+ doc_type,
+ " file, cannot be used as a template !"
+ )
}
# Not any parameters values for overloading
@@ -122,12 +123,16 @@ gen_usms_sols_doc <- function(doc_type,
}
switch(doc_type,
- usms = set_usms_param_xml(xml_doc = xml_doc_out,
- usms_param = nodes_param,
- overwrite = TRUE),
- sols = set_sols_param_xml(xml_doc = xml_doc_out,
- sols_param = nodes_param,
- overwrite = TRUE)
+ usms = set_usms_param_xml(
+ xml_doc = xml_doc_out,
+ usms_param = nodes_param,
+ overwrite = TRUE
+ ),
+ sols = set_sols_param_xml(
+ xml_doc = xml_doc_out,
+ sols_param = nodes_param,
+ overwrite = TRUE
+ )
)
rm(xml_nodes)
diff --git a/R/gen_usms_xml.R b/R/gen_usms_xml.R
index 536757d6..682451f8 100644
--- a/R/gen_usms_xml.R
+++ b/R/gen_usms_xml.R
@@ -52,8 +52,10 @@
#' @examples
#' xl_path <- download_usm_xl(file = "inputs_stics_example.xlsx")
#' usms_param_df <- read_params_table(file = xl_path, sheet_name = "USMs")
-#' gen_usms_xml(file = file.path(tempdir(), "usms.xml"),
-#' param_df = usms_param_df)
+#' gen_usms_xml(
+#' file = file.path(tempdir(), "usms.xml"),
+#' param_df = usms_param_df
+#' )
#'
#' @export
#'
@@ -67,23 +69,29 @@ gen_usms_xml <- function(file,
usms_param = lifecycle::deprecated(),
usms_in_file = lifecycle::deprecated()) {
if (lifecycle::is_present(usms_out_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_usms_xml(usms_out_file)",
- "gen_usms_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_usms_xml(usms_out_file)",
+ "gen_usms_xml(file)"
+ )
} else {
usms_out_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(usms_param)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_usms_xml(usms_param)",
- "gen_usms_xml(param_df)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_usms_xml(usms_param)",
+ "gen_usms_xml(param_df)"
+ )
} else {
usms_param <- param_df # to remove when we update inside the function
}
if (lifecycle::is_present(usms_in_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "gen_usms_xml(usms_in_file)",
- "gen_usms_xml(template)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "gen_usms_xml(usms_in_file)",
+ "gen_usms_xml(template)"
+ )
} else {
usms_in_file <- template # to remove when we update inside the function
}
@@ -135,8 +143,9 @@ gen_usms_xml <- function(file,
save_xml_doc(xml_doc, usms_out_file)
}
- if (!is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document"))
+ if (!is.null(xml_doc_tmpl) && inherits(xml_doc_tmpl, "xml_document")) {
delete(xml_doc_tmpl)
+ }
delete(xml_doc)
}
diff --git a/R/gen_usms_xml2txt.R b/R/gen_usms_xml2txt.R
index 5fd58324..6e71cb3e 100644
--- a/R/gen_usms_xml2txt.R
+++ b/R/gen_usms_xml2txt.R
@@ -58,7 +58,6 @@
#' # For an usms list
#' usm <- c("usm1", "usm2")
#' gen_usms_xml2txt(javastics, workspace, usm)
-#'
#' }
#'
#' @export
@@ -78,8 +77,6 @@ gen_usms_xml2txt <- function(javastics = NULL,
workspace_path = lifecycle::deprecated(),
target_path = lifecycle::deprecated(),
usms_list = lifecycle::deprecated()) {
-
-
# javastics_path
if (lifecycle::is_present(javastics_path)) {
lifecycle::deprecate_warn(
@@ -99,8 +96,10 @@ gen_usms_xml2txt <- function(javastics = NULL,
workspace_path <- workspace # to remove when we update inside the function
}
if (grepl("\ ", workspace_path)) {
- stop(paste0("Space into workspace is not supported. Please copy ",
- "the content of workspace folder in a path without space."))
+ stop(paste0(
+ "Space into workspace is not supported. Please copy ",
+ "the content of workspace folder in a path without space."
+ ))
}
# target_path
if (lifecycle::is_present(target_path)) {
@@ -123,9 +122,12 @@ gen_usms_xml2txt <- function(javastics = NULL,
if (java_converter) {
# javastics directory must be given
- if (is.null(javastics))
- stop("For using JavaSTICS commande line converter ",
- "the JavaSTICS directory must be set in function inputs !")
+ if (is.null(javastics)) {
+ stop(
+ "For using JavaSTICS commande line converter ",
+ "the JavaSTICS directory must be set in function inputs !"
+ )
+ }
# checking javastics path
check_java_path(javastics_path)
@@ -198,14 +200,15 @@ gen_usms_xml2txt <- function(javastics = NULL,
if (length(usms_list) == 0) {
usms_list <- full_usms_list
} else {
-
# Checking if the input usms_list is included in the full list
usms_exist <- usms_list %in% full_usms_list
# Error if any unknown usm name !
if (!all(usms_exist)) {
- stop("At least one usm does not exist in usms.xml file : ",
- usms_list[!usms_exist])
+ stop(
+ "At least one usm does not exist in usms.xml file : ",
+ usms_list[!usms_exist]
+ )
}
}
@@ -218,24 +221,36 @@ gen_usms_xml2txt <- function(javastics = NULL,
# Checking XML files existence, check_files
all_files_exist <- unlist(
- lapply(all_files_list, function(x) return(all(x$all_exist))))
+ lapply(all_files_list, function(x) {
+ return(all(x$all_exist))
+ })
+ )
if (!all(all_files_exist)) {
unknown_files <-
unlist(
- lapply(all_files_list[!all_files_exist],
- function(x) {x$paths[!x$all_exist]}),
+ lapply(
+ all_files_list[!all_files_exist],
+ function(x) {
+ x$paths[!x$all_exist]
+ }
+ ),
use.names = FALSE
)
- miss_files_mess <- paste(sprintf(fmt = "%s: %s \n", usms_list[!all_files_exist],
- unknown_files), collapse = "")
+ miss_files_mess <- paste(sprintf(
+ fmt = "%s: %s \n", usms_list[!all_files_exist],
+ unknown_files
+ ), collapse = "")
mess_length <- sum(nchar(miss_files_mess)) + 100L
- if (options("warning.length")$warning.length < mess_length)
+ if (options("warning.length")$warning.length < mess_length) {
options(warning.length = mess_length)
+ }
- stop("Missing files have been detected for usm(s):\n",
- miss_files_mess)
+ stop(
+ "Missing files have been detected for usm(s):\n",
+ miss_files_mess
+ )
}
# removing usms with missing files
@@ -244,9 +259,9 @@ gen_usms_xml2txt <- function(javastics = NULL,
if (java_converter) {
# Getting javastics cmd line
cmd_list <- get_javastics_cmd(javastics_path,
- java_cmd = java_cmd,
- type = "generate",
- workspace = workspace_path
+ java_cmd = java_cmd,
+ type = "generate",
+ workspace = workspace_path
)
cmd_args <- cmd_list$cmd_generate
cmd <- cmd_list$command
@@ -261,8 +276,10 @@ gen_usms_xml2txt <- function(javastics = NULL,
# multiple usms. In that case files will be overwritten.
# So fixing it to TRUE
if (!dir_per_usm_flag && usms_number > 1) {
- warning("Generating files in the JavaSTICS workspace",
- " is not compatible with multiple usms !")
+ warning(
+ "Generating files in the JavaSTICS workspace",
+ " is not compatible with multiple usms !"
+ )
dir_per_usm_flag <- TRUE
}
@@ -303,8 +320,10 @@ gen_usms_xml2txt <- function(javastics = NULL,
out_files_idx_path <- file.exists(out_files_work_path)
out_files_path <- out_files_work_path[out_files_idx_path]
if (!all(out_files_idx_path)) {
- out_files_path <- c(out_files_path,
- out_files_java_path[!out_files_idx_path])
+ out_files_path <- c(
+ out_files_path,
+ out_files_java_path[!out_files_idx_path]
+ )
}
# For keeping target usms dir paths
@@ -314,7 +333,6 @@ gen_usms_xml2txt <- function(javastics = NULL,
exec_status <- rep(TRUE, length = usms_number)
for (i in 1:usms_number) {
-
usm_name <- usms_list[i]
# Removing all previous generated files, to be sure.
@@ -338,8 +356,9 @@ gen_usms_xml2txt <- function(javastics = NULL,
exec_status[i] <- !any(grepl(pattern = "ERROR", ret))
if (!exec_status[i]) {
# displaying usm name
- if (verbose)
+ if (verbose) {
cli::cli_alert_danger("USM {.val {usm_name}} creation failed")
+ }
next
}
@@ -350,18 +369,20 @@ gen_usms_xml2txt <- function(javastics = NULL,
to = usm_path, overwrite = TRUE
))
}
-
} else {
-
usm_data <- get_usm_data(usms_doc, usm_name, workspace_path)
usm_files_path <- all_files_list[[usm_name]]$paths
- clim_files_path <- usm_files_path[grep(pattern = "\\.xml$",
- x = usm_files_path,
- invert = TRUE)]
- files_idx <- grep(pattern = "\\.xml$",
- usm_files_path)
+ clim_files_path <- usm_files_path[grep(
+ pattern = "\\.xml$",
+ x = usm_files_path,
+ invert = TRUE
+ )]
+ files_idx <- grep(
+ pattern = "\\.xml$",
+ usm_files_path
+ )
xml_files_path <- usm_files_path[files_idx]
# generation status vector for xml files and new_travail.usm
@@ -392,26 +413,30 @@ gen_usms_xml2txt <- function(javastics = NULL,
# generate sol2txt.xsl
ret <- gen_sol_xsl_file(usm_data$nomsol, stics_version)
- if (!ret)
+ if (!ret) {
warning("Problem when generating soil xsl file !")
+ }
}
- gen_files_status[f] <- convert_xml2txt(file = file_path,
- stics_version = stics_version,
- out_dir = usm_path,
- plant_id = plant_id)
-
+ gen_files_status[f] <- convert_xml2txt(
+ file = file_path,
+ stics_version = stics_version,
+ out_dir = usm_path,
+ plant_id = plant_id
+ )
}
# generating new_travail.usm
gen_files_status[f + 1] <- gen_new_travail(usm_data,
- usm = usm_name,
- workspace = workspace_path,
- out_dir = usm_path)
+ usm = usm_name,
+ workspace = workspace_path,
+ out_dir = usm_path
+ )
# generating climat.txt file
gen_files_status[f + 2] <- gen_climate(clim_files_path,
- out_dir = usm_path)
+ out_dir = usm_path
+ )
# setting exec status result
exec_status[i] <- all(gen_files_status)
@@ -447,9 +472,10 @@ gen_usms_xml2txt <- function(javastics = NULL,
to = usm_path, overwrite = TRUE
)
} else {
- if (verbose)
+ if (verbose) {
cli::cli_alert_warning(paste0("Obs file not found for USM", "
{.val {usm_name}}: {.file {obs_path}}"))
+ }
}
# Copying lai files if lai forcing
@@ -461,10 +487,13 @@ gen_usms_xml2txt <- function(javastics = NULL,
to = usm_path, overwrite = TRUE
)
} else {
- if (verbose)
- cli::cli_alert_warning(paste0("LAI file not found for USM ",
- "{.val {usm_name}}: {.file ",
- "{lai_file_path[i]}}"))
+ if (verbose) {
+ cli::cli_alert_warning(paste0(
+ "LAI file not found for USM ",
+ "{.val {usm_name}}: {.file ",
+ "{lai_file_path[i]}}"
+ ))
+ }
}
})
}
@@ -472,8 +501,9 @@ gen_usms_xml2txt <- function(javastics = NULL,
global_copy_status[i] <- copy_status & out_copy_status
# displaying usm name
- if (verbose)
+ if (verbose) {
cli::cli_alert_info("USM {.val {usm_name}} successfully created")
+ }
# Storing the current usm target path
usms_path[i] <- usm_path
diff --git a/R/gen_varmod.R b/R/gen_varmod.R
index d49f04da..680313b0 100644
--- a/R/gen_varmod.R
+++ b/R/gen_varmod.R
@@ -30,7 +30,6 @@
#' gen_varmod(tempdir(), "masec(n)", append = TRUE)
#' # NB: var.mod will have "lai(n)","hauteur" and "masec(n)"
#'
-#'
#' @export
#'
gen_varmod <- function(workspace,
@@ -41,8 +40,6 @@ gen_varmod <- function(workspace,
force = FALSE,
var_names = lifecycle::deprecated(),
version = lifecycle::deprecated()) {
-
-
# var_names
if (lifecycle::is_present(var_names)) {
lifecycle::deprecate_warn(
@@ -92,8 +89,9 @@ gen_varmod <- function(workspace,
var_names <- var_names[var_exist]
}
- if (!length(var_names))
+ if (!length(var_names)) {
warning("Not any variable name to add to the var.mod file!")
+ }
if (isTRUE(force)) {
var_names[var_exist] <- var_to_stics_name(var_names[var_exist])
@@ -106,9 +104,11 @@ gen_varmod <- function(workspace,
vars <- readLines(file_path)
commonvars <- var_names %in% vars
if (any(commonvars)) {
- cli::cli_alert_warning(paste0("Variable{?s} {.var ",
- "{var_names[commonvars]}} already in",
- " {.code var.mod}. Not repeating it."))
+ cli::cli_alert_warning(paste0(
+ "Variable{?s} {.var ",
+ "{var_names[commonvars]}} already in",
+ " {.code var.mod}. Not repeating it."
+ ))
}
var_names <- var_names[!commonvars]
if (length(var_names) == 0) {
diff --git a/R/get_climate_txt.R b/R/get_climate_txt.R
index 896237af..00d9a5a0 100644
--- a/R/get_climate_txt.R
+++ b/R/get_climate_txt.R
@@ -33,7 +33,6 @@ get_climate_txt <- function(workspace,
preserve = TRUE,
dirpath = lifecycle::deprecated(),
filename = lifecycle::deprecated()) {
-
# Managing deprecated arguments
# dirpath
if (lifecycle::is_present(dirpath)) {
diff --git a/R/get_cultivars_list.R b/R/get_cultivars_list.R
index 1d88d8e1..a608591b 100644
--- a/R/get_cultivars_list.R
+++ b/R/get_cultivars_list.R
@@ -15,7 +15,6 @@
#' @export
#'
get_cultivars_list <- function(file) {
-
xml_doc <- xmldocument(file)
stopifnot(is_stics_plt(xml_doc))
@@ -23,15 +22,17 @@ get_cultivars_list <- function(file) {
xml_name <- "variete"
cv_list <- unique(
- unlist(
- lapply(
- XML::getNodeSet(doc = xml_doc@content,
- path = paste0("//", xml_name)),
- function(x) {
- XML::xmlGetAttr(x, "nom")
- }
- )
+ unlist(
+ lapply(
+ XML::getNodeSet(
+ doc = xml_doc@content,
+ path = paste0("//", xml_name)
+ ),
+ function(x) {
+ XML::xmlGetAttr(x, "nom")
+ }
)
+ )
)
return(cv_list)
diff --git a/R/get_cultivars_param.R b/R/get_cultivars_param.R
index b1160e68..d4bfd296 100644
--- a/R/get_cultivars_param.R
+++ b/R/get_cultivars_param.R
@@ -17,7 +17,6 @@
#' @export
#'
get_cultivars_param <- function(file) {
-
cv_list <- get_cultivars_list(file)
out <- get_param_xml(file, select = "variete", select_value = cv_list)
diff --git a/R/get_file.R b/R/get_file.R
index 6e110ef3..0eba9334 100644
--- a/R/get_file.R
+++ b/R/get_file.R
@@ -39,7 +39,6 @@ get_file <- function(workspace,
javastics_path = NULL,
verbose = TRUE,
type = c("sim", "obs")) {
-
type <- match.arg(type, c("sim", "obs"), several.ok = FALSE)
usms_path <- NULL
@@ -52,7 +51,6 @@ get_file <- function(workspace,
# is inactivated, before doing tests on performances.
# TODO: add a else condition with same command using
# workspace and "usms.xml"
-
}
# Not keeping usms_filepath if does not exist
@@ -125,7 +123,6 @@ get_file_ <- function(workspace,
javastics_path = NULL,
verbose = TRUE,
type = c("sim", "obs")) {
-
# TODO: add checking dates_list format, or apply the used format in sim
# data.frame
@@ -141,21 +138,24 @@ get_file_ <- function(workspace,
}
# Getting files list from workspace vector
- workspace_files <- list.files(pattern = file_pattern,
- path = workspace,
- recursive = FALSE)
+ workspace_files <- list.files(
+ pattern = file_pattern,
+ path = workspace,
+ recursive = FALSE
+ )
# Checking if usm_name correspond to existing simulation
# or observation files, a warning with missing outputs/obs usm
# names
if (length(workspace_files) && !is.null(usm_name)) {
- idx <- lapply(str2regex(usm_name),
- function(y) {
- # using optional "p" or "a" in pattern for associated crops
- # p for principal crop, a for associated crop
- patt <- paste0(y, "[a|p]?\\.", file_ext)
- grep(pattern = patt, x = workspace_files)
- }
+ idx <- lapply(
+ str2regex(usm_name),
+ function(y) {
+ # using optional "p" or "a" in pattern for associated crops
+ # p for principal crop, a for associated crop
+ patt <- paste0(y, "[a|p]?\\.", file_ext)
+ grep(pattern = patt, x = workspace_files)
+ }
)
usm_idx <- unlist(lapply(idx, function(x) length(x) > 0))
files_idx <- unlist(idx)
@@ -166,14 +166,16 @@ get_file_ <- function(workspace,
if (!is.null(usm_name)) {
workspace_sub <- file.path(workspace, usm_name)
workspace_files_sub <- unlist(
- lapply(workspace_sub,
- {
- function(x) list.files(path = x,
- pattern = file_pattern,
- recursive = FALSE,
- full.names = TRUE)
- }
- )
+ lapply(workspace_sub, {
+ function(x) {
+ list.files(
+ path = x,
+ pattern = file_pattern,
+ recursive = FALSE,
+ full.names = TRUE
+ )
+ }
+ })
)
}
@@ -182,12 +184,13 @@ get_file_ <- function(workspace,
# checking common files
common_idx <- basename(workspace_files_sub) %in% workspace_files
if (any(common_idx)) {
- warning("Files exist in both ",
- workspace,
- " and ",
- workspace_sub[common_idx],
- ": \n",
- paste(basename(workspace_files_sub)[common_idx], collapse = ", ")
+ warning(
+ "Files exist in both ",
+ workspace,
+ " and ",
+ workspace_sub[common_idx],
+ ": \n",
+ paste(basename(workspace_files_sub)[common_idx], collapse = ", ")
)
}
} else {
@@ -198,12 +201,14 @@ get_file_ <- function(workspace,
if (!length(workspace_files) > 0) {
# No sim/obs file found
if (!length(workspace_files_sub) > 0) {
- warning("Not any ",
- full_type,
- " file detected neither in workspace ",
- workspace_sub,
- "nor in sub-dir(s)",
- workspace_files_sub)
+ warning(
+ "Not any ",
+ full_type,
+ " file detected neither in workspace ",
+ workspace_sub,
+ "nor in sub-dir(s)",
+ workspace_files_sub
+ )
return()
}
workspace_files <- workspace_files_sub
@@ -274,8 +279,12 @@ get_file_ <- function(workspace,
if (length(workspace) > 1) {
idx <- sapply(
str2regex(basename(workspace)),
- function(y) grep(pattern = paste0("^", y, "$"),
- x = names(file_name))
+ function(y) {
+ grep(
+ pattern = paste0("^", y, "$"),
+ x = names(file_name)
+ )
+ }
)
@@ -288,16 +297,19 @@ get_file_ <- function(workspace,
}
# Getting sim/obs data list
- df_list <- mapply(function(dirpath, filename, p_name) {
- get_file_one(dirpath,
- filename,
- p_name,
- verbose,
- dates_list,
- var_list)
- },
- dirpath = workspace, filename = file_name, p_name = plant_names,
- SIMPLIFY = FALSE, USE.NAMES = FALSE
+ df_list <- mapply(
+ function(dirpath, filename, p_name) {
+ get_file_one(
+ dirpath,
+ filename,
+ p_name,
+ verbose,
+ dates_list,
+ var_list
+ )
+ },
+ dirpath = workspace, filename = file_name, p_name = plant_names,
+ SIMPLIFY = FALSE, USE.NAMES = FALSE
)
names(df_list) <- names(file_name)
@@ -370,7 +382,6 @@ get_file_from_usms <- function(workspace,
type = c("sim", "obs"),
usm_name = NULL,
verbose = TRUE) {
-
# Getting usms names from the usms.xml file
usms <- get_usms_list(file = file.path(usms_path))
@@ -382,8 +393,10 @@ get_file_from_usms <- function(workspace,
if (!all(usm_exist)) {
if (verbose) {
cli::cli_alert_danger(
- paste0("The usm{?s} {.val {usm_name[!usm_exist]}}",
- " d{?oes/o} not exist in the workspace!")
+ paste0(
+ "The usm{?s} {.val {usm_name[!usm_exist]}}",
+ " d{?oes/o} not exist in the workspace!"
+ )
)
cli::cli_alert_info("Usm{?s} found in the workspace: {.val {usms}}")
}
@@ -442,9 +455,12 @@ get_file_from_usms <- function(workspace,
#'
#' @examples
#' \dontrun{
-#' parse_mixed_file(list("banana.obs", "IC_banana_sorghuma.obs",
-#' "IC_banana_sorghump.obs"),
-#' type = "obs"
+#' parse_mixed_file(
+#' list(
+#' "banana.obs", "IC_banana_sorghuma.obs",
+#' "IC_banana_sorghump.obs"
+#' ),
+#' type = "obs"
#' )
#'
#' # Simulations with usm names starting with "a", with or
@@ -532,12 +548,13 @@ parse_mixed_file <- function(file_names, type = c("sim", "obs")) {
#'
str2regex <- function(in_str) {
regex_chars <- c("\\.", "\\+", "\\*")
- replace_chars <- paste0("\\",regex_chars)
+ replace_chars <- paste0("\\", regex_chars)
out_str <- in_str
for (i in seq_along(regex_chars)) {
out_str <- stringr::str_replace_all(out_str,
- pattern = regex_chars[i],
- replacement = replace_chars[i])
+ pattern = regex_chars[i],
+ replacement = replace_chars[i]
+ )
}
out_str
}
diff --git a/R/get_file_int.R b/R/get_file_int.R
index 6a10bab0..7f9bcc0b 100644
--- a/R/get_file_int.R
+++ b/R/get_file_int.R
@@ -29,7 +29,6 @@ get_file_int <- function(workspace,
filename,
plant_name = NULL,
verbose = TRUE) {
-
if (verbose) message(filename)
if (is.list(filename)) filename <- unlist(filename)
@@ -49,9 +48,9 @@ get_file_int <- function(workspace,
out_table <- mapply(function(x, y) {
out <- try(data.table::fread(file.path(workspace, x),
- data.table = FALSE,
- na.strings = c("************", "NA"),
- stringsAsFactors = FALSE
+ data.table = FALSE,
+ na.strings = c("************", "NA"),
+ stringsAsFactors = FALSE
))
# Removing empty extra lines (without year)
@@ -59,8 +58,10 @@ get_file_int <- function(workspace,
if (inherits(out, "try-error")) {
- cli::cli_alert_warning(paste0("couldn't find valid file for ",
- "{.val {file.path(workspace,x)}}"))
+ cli::cli_alert_warning(paste0(
+ "couldn't find valid file for ",
+ "{.val {file.path(workspace,x)}}"
+ ))
return(NULL)
}
colnames(out) <- var_to_col_names(colnames(out))
@@ -75,16 +76,16 @@ get_file_int <- function(workspace,
out_table <- dplyr::bind_rows(out_table)
if (nrow(out_table) > 0) {
-
out_table <- dplyr::mutate(out_table,
- Date = as.POSIXct(
- x = paste(out_table$ian,
- out_table$mo,
- out_table$jo,
- sep = "-"),
- format = "%Y-%m-%d",
- tz = "UTC"
- )
+ Date = as.POSIXct(
+ x = paste(out_table$ian,
+ out_table$mo,
+ out_table$jo,
+ sep = "-"
+ ),
+ format = "%Y-%m-%d",
+ tz = "UTC"
+ )
) %>%
dplyr::relocate(dplyr::all_of("Date")) %>%
dplyr::select(-dplyr::all_of(c("ian", "mo", "jo", "jul")))
diff --git a/R/get_formalisms_xml.R b/R/get_formalisms_xml.R
index 398fa415..8e97b87e 100644
--- a/R/get_formalisms_xml.R
+++ b/R/get_formalisms_xml.R
@@ -28,8 +28,6 @@
get_formalisms_xml <- function(xml_file,
par_name = NULL,
by_form = TRUE) {
-
-
# Just in case to be sure that xml files are different
xml_file <- unique(xml_file)
diff --git a/R/get_java_workspace.R b/R/get_java_workspace.R
index 5409e4e2..218a6696 100644
--- a/R/get_java_workspace.R
+++ b/R/get_java_workspace.R
@@ -18,8 +18,6 @@
#'
get_java_workspace <- function(javastics) {
-
-
# checking javastics path
check_java_path(javastics)
@@ -33,9 +31,12 @@ get_java_workspace <- function(javastics) {
xml_pref <- xmldocument(xml_path)
current_wd <- get_values(xml_pref, '//entry[@key="workingDirectory.current"]')
- if (base::is.null(current_wd))
- stop("JavaSTICS working directory hasn't been set ",
- "(use set_java_wd to do so)!")
+ if (base::is.null(current_wd)) {
+ stop(
+ "JavaSTICS working directory hasn't been set ",
+ "(use set_java_wd to do so)!"
+ )
+ }
delete(xml_pref)
diff --git a/R/get_lai_forcing.R b/R/get_lai_forcing.R
index 6f2c9853..3038446c 100644
--- a/R/get_lai_forcing.R
+++ b/R/get_lai_forcing.R
@@ -18,7 +18,6 @@
#' get_lai_forcing(xml_usms, "wheat")
#' get_lai_forcing(xml_usms, c("wheat", "intercrop_pea_barley"))
#'
-#'
#' @export
#'
get_lai_forcing <- function(usm_file_path, usms_list = c()) {
@@ -30,17 +29,22 @@ get_lai_forcing <- function(usm_file_path, usms_list = c()) {
return()
}
- if (!base::file.exists(usm_file_path))
+ if (!base::file.exists(usm_file_path)) {
stop(usm_file_path, " does not exist")
+ }
if (usm) {
- return(get_lai_forcing_txt(usm_txt_path = usm_file_path,
- usm_name = usms_list))
+ return(get_lai_forcing_txt(
+ usm_txt_path = usm_file_path,
+ usm_name = usms_list
+ ))
}
if (usms) {
- return(get_lai_forcing_xml(usm_xml_path = usm_file_path,
- usms_list = usms_list))
+ return(get_lai_forcing_xml(
+ usm_xml_path = usm_file_path,
+ usms_list = usms_list
+ ))
}
}
@@ -65,7 +69,6 @@ get_lai_forcing <- function(usm_file_path, usms_list = c()) {
#' @noRd
#'
get_lai_forcing_xml <- function(usm_xml_path, usms_list = c()) {
-
# Loading xml file as xml_document object
usms_doc <- xmldocument(usm_xml_path)
@@ -74,7 +77,6 @@ get_lai_forcing_xml <- function(usm_xml_path, usms_list = c()) {
get_lai_forcing_xml_doc <- function(usm_doc, usms_list = c()) {
-
# Getting plants nb per usm
lai_forced <- as.logical(as.numeric(get_values(usm_doc, "//codesimul")))
@@ -102,8 +104,9 @@ get_lai_forcing_txt <- function(usm_txt_path, usm_name = NULL) {
usm_data <- get_usm_txt(filepath = usm_txt_path)
# Checking usm name
- if (!base::is.null(usm_name) && usm_data$nom != usm_name)
+ if (!base::is.null(usm_name) && usm_data$nom != usm_name) {
stop(usm_name, ": wrong usm name")
+ }
# Returning a named vector
lai_forced <- usm_data$codesimul == "feuille"
diff --git a/R/get_name_value_file_value.R b/R/get_name_value_file_value.R
index 7bea4e81..4ea16b09 100644
--- a/R/get_name_value_file_value.R
+++ b/R/get_name_value_file_value.R
@@ -17,7 +17,6 @@
get_name_value_file_value <- function(file_path,
param_names,
names_dict = NULL) {
-
# Case plt, station, tempopar.sti, tempoparv6.sti
lines_list <- readLines(file_path, warn = FALSE)
diff --git a/R/get_obs.R b/R/get_obs.R
index 7ff76c26..9e1594ed 100644
--- a/R/get_obs.R
+++ b/R/get_obs.R
@@ -87,8 +87,6 @@ get_obs <- function(workspace,
dates_list = lifecycle::deprecated(),
usms_filepath = lifecycle::deprecated(),
javastics_path = lifecycle::deprecated()) {
-
-
# Managing deprecated arguments
# usm_name
if (lifecycle::is_present(usm_name)) {
@@ -110,17 +108,21 @@ get_obs <- function(workspace,
}
# usms_filepath
if (lifecycle::is_present(usms_filepath)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_obs(usms_filepath)",
- "get_obs(usms_file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_obs(usms_filepath)",
+ "get_obs(usms_file)"
+ )
} else {
usms_filepath <- usms_file # to remove when we update inside the function
}
# javastics_path
if (lifecycle::is_present(javastics_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_obs(javastics_path)",
- "get_obs(javastics)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_obs(javastics_path)",
+ "get_obs(javastics)"
+ )
} else {
javastics_path <- javastics # to remove when we update inside the function
}
diff --git a/R/get_option_choice_param_values.R b/R/get_option_choice_param_values.R
index 4fe31a6a..b76f0846 100644
--- a/R/get_option_choice_param_values.R
+++ b/R/get_option_choice_param_values.R
@@ -27,7 +27,6 @@
get_option_choice_param_values <- function(xml_file_path,
option_param_name,
choice_name_or_code) {
-
# TODO: see if choice_name_or_code could be optional, to give
# param values for all choices ??
@@ -35,17 +34,21 @@ get_option_choice_param_values <- function(xml_file_path,
# true : choice name
# false : choice code
if (is.na(as.numeric(choice_name_or_code))) {
- xpath <- paste0('//option[@nomParam="',
- option_param_name,
- '"]/choix[@nom="',
- choice_name_or_code,
- '"]/param')
+ xpath <- paste0(
+ '//option[@nomParam="',
+ option_param_name,
+ '"]/choix[@nom="',
+ choice_name_or_code,
+ '"]/param'
+ )
} else {
- xpath <- paste0('//option[@nomParam="',
- option_param_name,
- '"]/choix[@code="',
- choice_name_or_code,
- '"]/param')
+ xpath <- paste0(
+ '//option[@nomParam="',
+ option_param_name,
+ '"]/choix[@code="',
+ choice_name_or_code,
+ '"]/param'
+ )
}
diff --git a/R/get_options_choices.R b/R/get_options_choices.R
index 41315270..159e76f1 100644
--- a/R/get_options_choices.R
+++ b/R/get_options_choices.R
@@ -25,8 +25,6 @@
#' @noRd
#'
get_options_choices <- function(xml_file_path, options_names = NULL) {
-
-
# If no options_names given, taking the full list
if (base::is.null(options_names)) {
names_vec <- get_options_names(xml_file_path)
diff --git a/R/get_options_names.R b/R/get_options_names.R
index 726a65da..e64ceb25 100644
--- a/R/get_options_names.R
+++ b/R/get_options_names.R
@@ -23,7 +23,6 @@
#' @noRd
#'
get_options_names <- function(xml_file_path, option_names = NULL) {
-
# Loading xml file
xml_param <- xmldocument(xml_file_path)
diff --git a/R/get_param_bounds.R b/R/get_param_bounds.R
index 937ab80e..4099e8b1 100644
--- a/R/get_param_bounds.R
+++ b/R/get_param_bounds.R
@@ -21,8 +21,10 @@
#'
#' par_bounds <- get_param_bounds(sta_doc, "zr")
#'
-#' par_bounds_list <- get_param_bounds(sta_doc,
-#' c("zr", "altistation"))
+#' par_bounds_list <- get_param_bounds(
+#' sta_doc,
+#' c("zr", "altistation")
+#' )
#'
#'
#' get_param_bounds(sta_doc, c("zr", "altistation"), "min")
@@ -36,7 +38,6 @@ get_param_bounds <- function(xml_doc,
param_name,
bounds_name = NULL,
output = "data.frame") {
-
def_names <- c("min", "max")
df_out <- output == "data.frame"
@@ -145,7 +146,6 @@ fix_bounds <- function(values, bounds_name, param_name) {
#'
#'
fix_missing_bounds <- function(values, bounds_name) {
-
# Fixing missing values
val <- unlist(values)
@@ -162,8 +162,6 @@ fix_missing_bounds <- function(values, bounds_name) {
fix_dup_bounds <- function(values, bounds_name, param_name) {
-
-
# Fixing duplicates
values <- lapply(values, unique)
duplicates <- unlist(lapply(values, function(x) length(x) > 1))
diff --git a/R/get_param_desc.R b/R/get_param_desc.R
index 7c53b8d4..c7ecac32 100644
--- a/R/get_param_desc.R
+++ b/R/get_param_desc.R
@@ -17,14 +17,17 @@ get_param_desc <- function(file_path = NULL,
stics_version = "latest",
name = NULL,
kind = FALSE) {
-
# TODO
# file_path : check if it is a JavaSTICS dir, calculate
# check if the file exists in the dir
if (base::is.null(file_path)) {
- file_path <- file.path(get_examples_path(file_type = "csv",
- stics_version = stics_version),
- "inputs.csv")
+ file_path <- file.path(
+ get_examples_path(
+ file_type = "csv",
+ stics_version = stics_version
+ ),
+ "inputs.csv"
+ )
}
@@ -32,9 +35,10 @@ get_param_desc <- function(file_path = NULL,
if (!file.exists(file_path)) stop(paste("Unknown file:", file_path))
param_df <- utils::read.csv2(file_path,
- header = FALSE,
- stringsAsFactors = FALSE,
- strip.white = TRUE)
+ header = FALSE,
+ stringsAsFactors = FALSE,
+ strip.white = TRUE
+ )
param_df <- param_df[, 1:8]
colnames(param_df) <-
diff --git a/R/get_param_formalisms.R b/R/get_param_formalisms.R
index 3d05130d..5a41b559 100644
--- a/R/get_param_formalisms.R
+++ b/R/get_param_formalisms.R
@@ -17,8 +17,10 @@
#'
#' par_form <- get_param_formalisms(sta_doc, "zr")
#'
-#' par_form_list <- get_param_formalisms(sta_doc,
-#' c("zr", "altistation"))
+#' par_form_list <- get_param_formalisms(
+#' sta_doc,
+#' c("zr", "altistation")
+#' )
#' }
#'
#' @keywords internal
@@ -27,7 +29,6 @@
#'
#'
get_param_formalisms <- function(xml_doc, name = NULL, form_only = FALSE) {
-
# For multiple documents
if (is.list(xml_doc) && length(xml_doc) > 1) {
names <- lapply(
@@ -92,7 +93,6 @@ get_param_formalisms <- function(xml_doc, name = NULL, form_only = FALSE) {
param_formalism_elt <- function(xml_doc, xpath, name) {
-
# Formatting a parameter formalism list unit
values <- get_attrs_values(xml_doc, xpath, "nom")
diff --git a/R/get_param_info_xml.R b/R/get_param_info_xml.R
index b18e6d16..dd6f2771 100644
--- a/R/get_param_info_xml.R
+++ b/R/get_param_info_xml.R
@@ -68,8 +68,10 @@ get_param_data_df <- function(param = NULL,
stics_version <- get_xml_stics_version(stics_version)
# Getting XML examples files dir from the package
- xml_dir <- get_examples_path(file_type = "xml",
- stics_version = stics_version)
+ xml_dir <- get_examples_path(
+ file_type = "xml",
+ stics_version = stics_version
+ )
# Getting the XML files list
files_list <- list.files(
@@ -88,7 +90,7 @@ get_param_data_df <- function(param = NULL,
# getting parameters from an inputs.csv file
if (length(files_list) == 1 &&
- grepl(pattern = "inputs.csv", x = files_list)) {
+ grepl(pattern = "inputs.csv", x = files_list)) {
param_names <- utils::read.csv2(
file,
header = FALSE,
@@ -149,7 +151,6 @@ get_param_data_df <- function(param = NULL,
form_list2df <- function(formalism_list) {
-
# filtering NA list values (files whithout formalisms)
formalism_list <- formalism_list[unlist(lapply(formalism_list, is.list))]
@@ -171,10 +172,12 @@ form_list2df <- function(formalism_list) {
out_form <- c(out_form, rep(form, length(par_names)))
out_param <- c(out_param, par_names)
}
- out[[i]] <- data.frame(file = out_file,
- formalism = out_form,
- name = out_param,
- stringsAsFactors = FALSE)
+ out[[i]] <- data.frame(
+ file = out_file,
+ formalism = out_form,
+ name = out_param,
+ stringsAsFactors = FALSE
+ )
}
# returning the tibble
diff --git a/R/get_param_names.R b/R/get_param_names.R
index 65d0f4bc..d4bb4848 100644
--- a/R/get_param_names.R
+++ b/R/get_param_names.R
@@ -27,43 +27,56 @@ get_param_names <- function(xml_object,
parent_sel_attr = NULL,
full_list = FALSE,
root_name = NULL) {
-
-
xml_node <- NULL
param_name <- NULL
tmp_xml_object <- NULL
if (all(!is.null(c(parent_name, parent_sel_attr)))) {
-
- if (parent_name %in% c("formalisme", "formalismev", "optionv",
- "usm", "sol", "variete"))
+ if (parent_name %in% c(
+ "formalisme", "formalismev", "optionv",
+ "usm", "sol", "variete"
+ )) {
tmp_xml_object <- get_nodes(xml_object,
- path = paste0("//", parent_name,
- "[@nom='",
- parent_sel_attr,
- "']"))[[1]]
+ path = paste0(
+ "//", parent_name,
+ "[@nom='",
+ parent_sel_attr,
+ "']"
+ )
+ )[[1]]
+ }
if (is.null(tmp_xml_object)) {
- if (parent_name == "option")
+ if (parent_name == "option") {
tmp_xml_object <- get_nodes(xml_object,
- path = paste0("//", parent_name,
- "[@nomParam='",
- parent_sel_attr,
- "']"))[[1]]
+ path = paste0(
+ "//", parent_name,
+ "[@nomParam='",
+ parent_sel_attr,
+ "']"
+ )
+ )[[1]]
+ }
}
# plante: for usms and ini files
if (is.null(tmp_xml_object)) {
- if (parent_name == "plante")
+ if (parent_name == "plante") {
tmp_xml_object <- get_nodes(xml_object,
- path = paste0("//", parent_name,
- "[@dominance='",
- parent_sel_attr,
- "']"))[[1]]
+ path = paste0(
+ "//", parent_name,
+ "[@dominance='",
+ parent_sel_attr,
+ "']"
+ )
+ )[[1]]
+ }
}
- if (is.null(tmp_xml_object)) return()
+ if (is.null(tmp_xml_object)) {
+ return()
+ }
xml_object <- tmp_xml_object
@@ -131,24 +144,26 @@ get_param_names <- function(xml_object,
}
if (node_name == "colonne" &&
- (XML::xmlName(XML::xmlParent(xml_node)) %in% tab_names)) {
+ (XML::xmlName(XML::xmlParent(xml_node)) %in% tab_names)) {
attr_name <- "nom"
}
# Getting param_name from a node name
# but not in list "plante", "horizon" ,"initialisations", "sol", "usm"
if (attr_name == "none" &&
- !(node_name %in% c("plante", "horizon", "initialisations", "sol",
- "usm", "snow"))) {
+ !(node_name %in% c(
+ "plante", "horizon", "initialisations", "sol",
+ "usm", "snow"
+ ))) {
param_name <- node_name
}
# Getting param_name from an attribute value
if ((!is.null(parent_name) &&
- node_name != parent_name) ||
- (is.null(parent_name) &&
- attr_name %in% names(XML::xmlAttrs(xml_node)))) {
+ node_name != parent_name) ||
+ (is.null(parent_name) &&
+ attr_name %in% names(XML::xmlAttrs(xml_node)))) {
param_name <- XML::xmlAttrs(xml_node)[attr_name]
}
@@ -156,7 +171,7 @@ get_param_names <- function(xml_object,
# - if it does not exist
# - if a full param names list is asked
if (!base::is.null(param_name) &&
- (full_list || !(param_name %in% param_list))) {
+ (full_list || !(param_name %in% param_list))) {
param_list <- c(param_list, param_name)
}
@@ -173,11 +188,11 @@ get_param_names <- function(xml_object,
next
}
param_list <- get_param_names(childs[[n]],
- param_list,
- parent_name = parent_name,
- parent_sel_attr = parent_sel_attr,
- full_list = full_list,
- root_name = root_name
+ param_list,
+ parent_name = parent_name,
+ parent_sel_attr = parent_sel_attr,
+ full_list = full_list,
+ root_name = root_name
)
}
@@ -192,8 +207,9 @@ get_param_names <- function(xml_object,
)
# Specific to plt file: variete also exists in fichierstec as a parameter
- if (!is.null(root_name) && root_name == "fichierplt")
+ if (!is.null(root_name) && root_name == "fichierplt") {
names_filt <- c(names_filt, "variete")
+ }
param_list <- setdiff(param_list, names_filt)
diff --git a/R/get_param_names_xml.R b/R/get_param_names_xml.R
index 549b7b66..32049e98 100644
--- a/R/get_param_names_xml.R
+++ b/R/get_param_names_xml.R
@@ -32,7 +32,8 @@
#' param_names <- get_param_names_xml(xml_files_list)
#'
#' param_names <- get_param_names_xml(xml_files_list,
-#' param_name = c("al", "albedo"))
+#' param_name = c("al", "albedo")
+#' )
#' }
#'
#' @keywords internal
@@ -45,7 +46,6 @@ get_param_names_xml <- function(xml_file,
output = "data.frame",
combine = TRUE,
exact = FALSE) {
-
# Switch for transformations to data.frame format
df_out <- output == "data.frame"
df_comb <- df_out & combine
@@ -125,10 +125,11 @@ get_param_names_xml <- function(xml_file,
}
} else {
if (bounds) {
- param_names <- list(list(file = base::basename(xml_file),
- name = param_bounds))
+ param_names <- list(list(
+ file = base::basename(xml_file),
+ name = param_bounds
+ ))
} else {
-
# To a named list
names(param_names) <- base::basename(xml_file)
}
diff --git a/R/get_param_txt.R b/R/get_param_txt.R
index a221bd04..7b11cf78 100644
--- a/R/get_param_txt.R
+++ b/R/get_param_txt.R
@@ -63,13 +63,15 @@
#' # Get parameters for a specific plant
#' get_param_txt(workspace = path, plant_id = 1)
#' get_param_txt(workspace = path, param = "durvieF", plant_id = 1)
-#' get_param_txt(workspace = path, param = "durvieF", plant_id = 1,
-#' variety = varieties)
+#' get_param_txt(
+#' workspace = path, param = "durvieF", plant_id = 1,
+#' variety = varieties
+#' )
#'
#' # Get parameters for specific interventions or soil layers
-#' get_param_txt(workspace = path, param = "amount", value_id = c(1,3))
-#' get_param_txt(workspace = path, param = "Hinitf", value_id = c(1,3))
-#' get_param_txt(workspace = path, param = "epc", value_id = c(1,3))
+#' get_param_txt(workspace = path, param = "amount", value_id = c(1, 3))
+#' get_param_txt(workspace = path, param = "Hinitf", value_id = c(1, 3))
+#' get_param_txt(workspace = path, param = "epc", value_id = c(1, 3))
#'
#' @export
#'
@@ -82,7 +84,6 @@ get_param_txt <- function(workspace,
stics_version = "latest",
dirpath = lifecycle::deprecated(),
...) {
-
# dirpath
if (lifecycle::is_present(dirpath)) {
lifecycle::deprecate_warn(
@@ -96,32 +97,38 @@ get_param_txt <- function(workspace,
stics_version <- check_version_compat(stics_version = stics_version)
ini <- get_ini_txt(file.path(dirpath, "ficini.txt"),
- stics_version = stics_version)
+ stics_version = stics_version
+ )
# specifying plant(s) to use, and checking if a given plant_id is
# available ones
avail_plant_id <- seq_len(ini$nbplantes)
- if(is.null(plant_id)) {
+ if (is.null(plant_id)) {
plant_id <- avail_plant_id
} else {
- if(!all(plant_id %in% avail_plant_id))
- stop("Given plant id(s) (",
- paste(plant_id, collapse = ","), ") ",
- " do(es) not match available one(s) (",
- paste(avail_plant_id, collapse = ","), ")")
+ if (!all(plant_id %in% avail_plant_id)) {
+ stop(
+ "Given plant id(s) (",
+ paste(plant_id, collapse = ","), ") ",
+ " do(es) not match available one(s) (",
+ paste(avail_plant_id, collapse = ","), ")"
+ )
+ }
}
general <- get_general_txt(file.path(dirpath, "tempopar.sti"))
soil <- get_soil_txt(file.path(dirpath, "param.sol"),
- stics_version = stics_version)
+ stics_version = stics_version
+ )
station <- get_station_txt(file.path(dirpath, "station.txt"))
usm <- get_usm_txt(file.path(dirpath, "new_travail.usm"),
- plant_id = plant_id)
+ plant_id = plant_id
+ )
tmp <- get_tmp_txt(file.path(dirpath, "tempoparv6.sti"))
@@ -131,11 +138,11 @@ get_param_txt <- function(workspace,
several_fert <- several_thin <- is_pasture <- NULL
tmp_names <- names(tmp)
several_fert <- ifelse("option_engrais_multiple" %in% tmp_names &&
- tmp$option_engrais_multiple == 1, TRUE, FALSE)
+ tmp$option_engrais_multiple == 1, TRUE, FALSE)
several_thin <- ifelse("option_thinning" %in% tmp_names &&
- tmp$option_thinning == 1, TRUE, FALSE)
+ tmp$option_thinning == 1, TRUE, FALSE)
is_pasture <- ifelse("option_pature" %in% tmp_names &&
- tmp$option_pature == 1, TRUE, FALSE)
+ tmp$option_pature == 1, TRUE, FALSE)
tec <- plant <- stats::setNames(
vector(mode = "list", length = ini$nbplantes),
@@ -160,37 +167,43 @@ get_param_txt <- function(workspace,
))
varieties[[i]] <-
- get_plant_txt(file = file.path(dirpath,
- paste0("ficplt", i, ".txt")))$codevar
+ get_plant_txt(file = file.path(
+ dirpath,
+ paste0("ficplt", i, ".txt")
+ ))$codevar
tec_variety <- tec[[paste0("plant", i)]]$variete
- alert_msg <- paste0("Variety not found in plant file. Possible ",
- "varieties are: {.val {varieties}}")
+ alert_msg <- paste0(
+ "Variety not found in plant file. Possible ",
+ "varieties are: {.val {varieties}}"
+ )
plant[paste0("plant", i)] <-
list(get_plant_txt(file.path(dirpath, paste0("ficplt", i, ".txt")),
- variety =
- if (is.null(variety[[i]])) {
- if (!is.null(param)) {
- varieties[[i]][tec_variety]
- } else {
- NULL
- }
- } else {
- # variety
- if (is.character(variety[[i]])) {
- variety[[i]] <- match(variety[[i]],
- varieties[[i]])
- if (any(is.na(variety))) {
- cli::cli_alert_danger(alert_msg)
- return()
- }
- varieties[[i]][variety[[i]]]
- } else {
- varieties[[i]][variety[[i]]]
- }
- }
+ variety =
+ if (is.null(variety[[i]])) {
+ if (!is.null(param)) {
+ varieties[[i]][tec_variety]
+ } else {
+ NULL
+ }
+ } else {
+ # variety
+ if (is.character(variety[[i]])) {
+ variety[[i]] <- match(
+ variety[[i]],
+ varieties[[i]]
+ )
+ if (any(is.na(variety))) {
+ cli::cli_alert_danger(alert_msg)
+ return()
+ }
+ varieties[[i]][variety[[i]]]
+ } else {
+ varieties[[i]][variety[[i]]]
+ }
+ }
))
# Fixes the current variety
@@ -214,9 +227,10 @@ get_param_txt <- function(workspace,
# using or not ids for soil layers, technical interventions (ini, soil or
# tec parameters files)
parameters <- filter_param(parameters,
- param = param,
- exact = exact,
- value_id = value_id)
+ param = param,
+ exact = exact,
+ value_id = value_id
+ )
return(parameters)
@@ -235,8 +249,10 @@ filter_param <- function(in_list,
name <- names_vec[[i]]
if (is.list(in_list[[name]])) {
- tmp <- filter_param(in_list[[name]], param = param,
- exact = exact, value_id = value_id)
+ tmp <- filter_param(in_list[[name]],
+ param = param,
+ exact = exact, value_id = value_id
+ )
if (length(tmp) > 0) out_list[[name]] <- tmp
next
@@ -258,15 +274,18 @@ filter_param <- function(in_list,
if (any(idx)) {
out_list[[name]] <- in_list[[name]]
- if(is.null(value_id)) next
+ if (is.null(value_id)) next
# checking if given ids exist in parameter values
avail_ids <- seq_len(length(out_list[[name]]))
- if (!all(value_id %in% avail_ids))
- stop("Given ids (",
- paste(value_id, collapse = ", "),
- ") are not all available in existing ids (",
- paste(avail_ids, collapse = ", "),")")
+ if (!all(value_id %in% avail_ids)) {
+ stop(
+ "Given ids (",
+ paste(value_id, collapse = ", "),
+ ") are not all available in existing ids (",
+ paste(avail_ids, collapse = ", "), ")"
+ )
+ }
# sub scripting values
out_list[[name]] <- out_list[[name]][value_id]
@@ -321,8 +340,10 @@ filter_param <- function(in_list,
#' # Read the tec file directly:
#'
#' # First, get the parameters from the tmp file:
-#' tmp <- get_tmp_txt(file = file.path(get_examples_path(file_type = "txt"),
-#' "tempoparv6.sti"))
+#' tmp <- get_tmp_txt(file = file.path(
+#' get_examples_path(file_type = "txt"),
+#' "tempoparv6.sti"
+#' ))
#' several_fert <- ifelse(tmp$option_engrais_multiple == 1, TRUE, FALSE)
#' several_thin <- ifelse(tmp$option_thinning == 1, TRUE, FALSE)
#' is_pasture <- ifelse(tmp$option_pature == 1, TRUE, FALSE)
@@ -340,7 +361,6 @@ filter_param <- function(in_list,
get_ini_txt <- function(file = "ficini.txt",
stics_version,
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -353,8 +373,9 @@ get_ini_txt <- function(file = "ficini.txt",
stics_version <- check_version_compat(stics_version = stics_version)
- if (!file.exists(filepath))
+ if (!file.exists(filepath)) {
stop(filepath, ": does not exist !")
+ }
params <- readLines(filepath)
ini <- list()
@@ -366,11 +387,13 @@ get_ini_txt <- function(file = "ficini.txt",
stics_version_num <- get_version_num(stics_version = stics_version)
if (stics_version_num < 10) {
-
- if (length(params) > 48)
- stop("The used STICS version ",
- stics_version_num,
- " does not correspond to the file content (STICS version >= 10)")
+ if (length(params) > 48) {
+ stop(
+ "The used STICS version ",
+ stics_version_num,
+ " does not correspond to the file content (STICS version >= 10)"
+ )
+ }
ini$plant$plant1 <- list(
stade0 = params[[4]],
@@ -398,11 +421,13 @@ get_ini_txt <- function(file = "ficini.txt",
ini$NO3init <- params[[26]]
ini$NH4init <- params[[28]]
} else {
-
- if (length(params) < 48)
- stop("The used STICS version ",
- stics_version_num,
- " does not correspond to the file content (STICS version < 10)")
+ if (length(params) < 48) {
+ stop(
+ "The used STICS version ",
+ stics_version_num,
+ " does not correspond to the file content (STICS version < 10)"
+ )
+ }
ini$plant$plant1 <- list(
stade0 = params[[4]],
@@ -454,7 +479,6 @@ get_ini_txt <- function(file = "ficini.txt",
#' @export
get_general_txt <- function(file = "tempopar.sti",
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -473,7 +497,6 @@ get_general_txt <- function(file = "tempopar.sti",
#' @export
get_tmp_txt <- function(file = "tempoparv6.sti",
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -491,7 +514,6 @@ get_tmp_txt <- function(file = "tempoparv6.sti",
#' @export
get_plant_txt <- function(file = "ficplt1.txt", variety = NULL,
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -546,7 +568,6 @@ get_tec_txt <- function(file = "fictec1.txt",
is_pasture = NULL,
filepath = lifecycle::deprecated(),
...) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -557,8 +578,9 @@ get_tec_txt <- function(file = "fictec1.txt",
filepath <- file # to remove when we update inside the function
}
- if (!file.exists(filepath))
+ if (!file.exists(filepath)) {
stop(filepath, ": does not exist !")
+ }
# TODO: add dot args management
@@ -811,7 +833,6 @@ parname <- function(index, params, idx = NULL) {
}
val <- function(pval = list(index = 1, val = NA), values) {
-
if (pval$index == length(values)) {
return()
}
@@ -870,7 +891,7 @@ get_tec_txt_ <- function(params, values) {
# multiple parameters
if (all(param == parname(pval$index, params, -2))) {
value <- as.data.frame(as.list(value),
- stringsAsFactors = FALSE
+ stringsAsFactors = FALSE
)
names(value) <- param
v <- rbind(v, value)
@@ -882,7 +903,7 @@ get_tec_txt_ <- function(params, values) {
next
} else {
v <- as.data.frame(as.list(value),
- stringsAsFactors = FALSE
+ stringsAsFactors = FALSE
)
names(v) <- param
}
@@ -900,7 +921,6 @@ get_tec_txt_ <- function(params, values) {
get_soil_txt <- function(file = "param.sol",
stics_version,
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -913,8 +933,9 @@ get_soil_txt <- function(file = "param.sol",
stics_version <- check_version_compat(stics_version = stics_version)
- if (!file.exists(filepath))
+ if (!file.exists(filepath)) {
stop(filepath, ": does not exist !")
+ }
params <- readLines(filepath, warn = FALSE)
soil <- vector(mode = "list", length = 0)
@@ -1008,7 +1029,6 @@ get_station_txt <- function(file = "station.txt",
get_usm_txt <- function(file = "new_travail.usm",
plant_id = NULL,
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -1024,7 +1044,9 @@ get_usm_txt <- function(file = "new_travail.usm",
idx <- plant_id == 1:2
if (is.null(plant_id) ||
- (length(plant_id) == 2 && all(idx))) return(usm_params)
+ (length(plant_id) == 2 && all(idx))) {
+ return(usm_params)
+ }
# getting specific info attached to plant id
# fplt1 ou fplt2, ftec1 ou ftec2, flai1 ou flai2,
@@ -1057,16 +1079,18 @@ get_usm_txt <- function(file = "new_travail.usm",
#'
#' @examples
#' \dontrun{
-#' path <- file.path(get_examples_path(file_type = "txt",
-#' stics_version = "V8.5"), "station.txt")
+#' path <- file.path(get_examples_path(
+#' file_type = "txt",
+#' stics_version = "V8.5"
+#' ), "station.txt")
#' get_txt_generic(path)
#' }
#'
get_txt_generic <- function(file,
names = TRUE) {
-
- if (!file.exists(file))
+ if (!file.exists(file)) {
stop(file, ": does not exist !")
+ }
params <- readLines(file)
@@ -1126,7 +1150,7 @@ char2num <- function(x) {
}
if (!all(grepl(pattern = "[0-9]", x = x)) ||
- any(grepl(pattern = "[a-zA-Z]", x = x))) {
+ any(grepl(pattern = "[a-zA-Z]", x = x))) {
return(x)
}
diff --git a/R/get_param_type.R b/R/get_param_type.R
index bfa80bcf..f9a02e29 100644
--- a/R/get_param_type.R
+++ b/R/get_param_type.R
@@ -64,8 +64,10 @@ get_param_type <- function(xml_doc,
# implying they cannot be used as : node name or attribute name
filter_name <- FALSE
- find_bad_char <- grep(paste(c("[", char_to_filter, "]"), collapse = ""),
- param_name)
+ find_bad_char <- grep(
+ paste(c("[", char_to_filter, "]"), collapse = ""),
+ param_name
+ )
if (length(find_bad_char)) {
filter_name <- TRUE
@@ -97,7 +99,8 @@ get_param_type <- function(xml_doc,
type = "attr",
xpath = xpath_nodename,
length = 1,
- attr = "nom"))
+ attr = "nom"
+ ))
}
attr_values <- get_attrs_values(xml_doc, xpath_nodename, "dominance")
@@ -106,7 +109,8 @@ get_param_type <- function(xml_doc,
type = "attr",
xpath = xpath_nodename,
length = 1,
- attr = "dominance"))
+ attr = "dominance"
+ ))
}
# new case for getting values of the node childs
@@ -124,7 +128,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "nodename",
xpath = xpath_nodename,
- length = length(values)))
+ length = length(values)
+ ))
}
# for example for : nb_interventions
@@ -134,7 +139,8 @@ get_param_type <- function(xml_doc,
type = "attrname",
xpath = xpath_attrname,
length = 1,
- attr = param_name))
+ attr = param_name
+ ))
}
}
@@ -158,7 +164,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "table",
xpath = xpath_table,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
attr_values <- get_attrs_values(xml_doc, xpath_table2, "nom")
@@ -166,7 +173,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "table2",
xpath = xpath_table2,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
attr_values <- get_attrs_values(xml_doc, xpath_ent, "nom")
@@ -174,7 +182,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "node_table_ent",
xpath = xpath_ent,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
attr_values <- get_attrs_values(xml_doc, xpath_ent2, "nom")
@@ -182,7 +191,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "node_table_ent2",
xpath = xpath_ent2,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
return(list(type = "unknown", xpath = NULL, length = 0))
@@ -203,7 +213,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "attr_attr",
xpath = xpath_attr_attr,
- length = length(values)))
+ length = length(values)
+ ))
}
# No special character in param_name
@@ -222,7 +233,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "attr_attr2",
xpath = xpath_attr_attr,
- length = length(values)))
+ length = length(values)
+ ))
}
}
@@ -240,7 +252,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "choix_attr",
xpath = xpath_choix_attr,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
# No special character in param_name
@@ -259,7 +272,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "node_attr",
xpath = xpath_node_attr,
- ength = length(attr_values)))
+ ength = length(attr_values)
+ ))
}
}
@@ -270,17 +284,20 @@ get_param_type <- function(xml_doc,
new_parent_name <- paste0(parent_name, "[@nom=\"", parent_sel_attr, "\"]")
}
- xpath_node_param <- paste0("//",
- new_parent_name,
- "//param[@nom=\"",
- param_name, "\"]")
+ xpath_node_param <- paste0(
+ "//",
+ new_parent_name,
+ "//param[@nom=\"",
+ param_name, "\"]"
+ )
values <- get_values(xml_doc, xpath_node_param)
if (!base::is.null(values)) {
return(list(
type = "node_param",
xpath = xpath_node_param,
- length = length(values)))
+ length = length(values)
+ ))
}
@@ -321,7 +338,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "form_option",
xpath = xpath_form_option,
- length = 1))
+ length = 1
+ ))
}
@@ -333,18 +351,21 @@ get_param_type <- function(xml_doc,
new_parent_name <- paste0(parent_name, "[@nom=\"", parent_sel_attr, "\"]")
}
- xpath_node_option <- paste0("//",
- new_parent_name,
- "//option[@nomParam=\"",
- param_name,
- "\"]")
+ xpath_node_option <- paste0(
+ "//",
+ new_parent_name,
+ "//option[@nomParam=\"",
+ param_name,
+ "\"]"
+ )
attr_values <- get_attrs_values(xml_doc, xpath_node_option, "choix")
if (!base::is.null(attr_values)) {
return(list(
type = "node_option",
xpath = xpath_node_option,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
@@ -357,7 +378,8 @@ get_param_type <- function(xml_doc,
parent_name,
"[@dominance=\"",
parent_sel_attr,
- "\"]")
+ "\"]"
+ )
}
xpath_node_option <- paste0(
@@ -365,14 +387,16 @@ get_param_type <- function(xml_doc,
new_parent_name,
"//option[@nomParam=\"",
param_name,
- "\"]")
+ "\"]"
+ )
attr_values <- get_attrs_values(xml_doc, xpath_node_option, "choix")
if (!base::is.null(attr_values)) {
return(list(
type = "node_option",
xpath = xpath_node_option,
- length = length(attr_values)))
+ length = length(attr_values)
+ ))
}
@@ -394,7 +418,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "node_node",
xpath = xpath_node_node,
- length = length(values)))
+ length = length(values)
+ ))
}
@@ -413,14 +438,16 @@ get_param_type <- function(xml_doc,
new_parent_name,
"//",
param_name,
- "/horizon")
+ "/horizon"
+ )
values <- get_values(xml_doc, xpath_node_node)
if (!base::is.null(values)) {
return(list(
type = "node_node",
xpath = xpath_node_node,
- length = length(values)))
+ length = length(values)
+ ))
}
@@ -440,7 +467,8 @@ get_param_type <- function(xml_doc,
return(list(
type = "node_node",
xpath = xpath_node_node,
- length = length(values)))
+ length = length(values)
+ ))
}
}
@@ -449,7 +477,7 @@ get_param_type <- function(xml_doc,
# tableau/colonne node with a possible parent simple node,
- #possible selection with @nom
+ # possible selection with @nom
new_parent_name <- parent_name
if (!base::is.null(parent_sel_attr)) {
@@ -461,14 +489,16 @@ get_param_type <- function(xml_doc,
new_parent_name,
"//tableau/colonne[@nom=\"",
param_name,
- "\"]")
+ "\"]"
+ )
values <- get_values(xml_doc, xpath_node_table)
if (!base::is.null(values)) {
return(list(
type = "node_table",
xpath = xpath_node_table,
- length = length(values)))
+ length = length(values)
+ ))
}
# intervention/colonne node with a possible parent simple node,
@@ -482,14 +512,16 @@ get_param_type <- function(xml_doc,
xpath_node_table2 <- paste0(
"//",
new_parent_name,
- "//intervention/colonne[@nom=\"", param_name, "\"]")
+ "//intervention/colonne[@nom=\"", param_name, "\"]"
+ )
values <- get_values(xml_doc, xpath_node_table2)
if (!base::is.null(values)) {
return(list(
type = "node_table2",
xpath = xpath_node_table2,
- length = length(values)))
+ length = length(values)
+ ))
}
@@ -500,14 +532,16 @@ get_param_type <- function(xml_doc,
new_parent_name,
"//ta_entete/colonne[@nom=\"",
param_name,
- "\"]")
+ "\"]"
+ )
values <- get_values(xml_doc, xpath_node_table)
if (!base::is.null(values)) {
return(list(
type = "node_table_ent",
xpath = xpath_node_table,
- length = length(values)))
+ length = length(values)
+ ))
}
return(NULL)
diff --git a/R/get_param_value.R b/R/get_param_value.R
index 57991cea..41c60ef6 100644
--- a/R/get_param_value.R
+++ b/R/get_param_value.R
@@ -43,19 +43,22 @@ get_param_value <- function(xml_doc,
parent_name = NULL,
parent_sel_attr = NULL,
...) {
-
-
-
# ... for getting : ids, show_xpath and mult_par arguments
dot_args <- list(...)
dot_names <- names(dot_args)
# Getting ids and show_xpath
if ("ids" %in% dot_names) ids <- dot_args$ids else ids <- NULL
- if ("show_xpath" %in% dot_names)
- show_xpath <- dot_args$show_xpath else show_xpath <- FALSE
- if ("to_num" %in% dot_names)
- to_num <- dot_args$to_num else to_num <- TRUE
+ if ("show_xpath" %in% dot_names) {
+ show_xpath <- dot_args$show_xpath
+ } else {
+ show_xpath <- FALSE
+ }
+ if ("to_num" %in% dot_names) {
+ to_num <- dot_args$to_num
+ } else {
+ to_num <- TRUE
+ }
# Getting param values for the same parameters for the xml documents list
@@ -75,22 +78,28 @@ get_param_value <- function(xml_doc,
# If no given parameters names
if (base::is.null(param_name)) {
param_name <- get_param_names(xml_doc,
- parent_name = parent_name,
- parent_sel_attr = parent_sel_attr)
+ parent_name = parent_name,
+ parent_sel_attr = parent_sel_attr
+ )
# testing if param_name is empty
- if (is.null(param_name))
- stop(paste0("Not any parameter names detected for: \n",
- parent_name, " = ", parent_sel_attr))
-
+ if (is.null(param_name)) {
+ stop(paste0(
+ "Not any parameter names detected for: \n",
+ parent_name, " = ", parent_sel_attr
+ ))
+ }
}
# If not any names given
if (is.null(param_name)) stop("Parameter(s) name(s) must be given !")
# Setting multiple parameters names flag
- if ("mult_par" %in% dot_names)
- mult_par <- dot_args$mult_par else mult_par <- FALSE
+ if ("mult_par" %in% dot_names) {
+ mult_par <- dot_args$mult_par
+ } else {
+ mult_par <- FALSE
+ }
# recursive call for a list of parameter names
@@ -137,67 +146,67 @@ get_param_value <- function(xml_doc,
# TODO: see if it could be simplified with a default case !
switch(type,
- nodename = {
- value <- get_values(xml_doc, xpath, ids)
- },
- attr = {
- value <- get_attrs_values(xml_doc, xpath, param_type$attr, ids)
- },
- attrname = {
- value <- get_attrs_values(xml_doc, xpath, param_type$attr, ids)
- },
- param = {
- value <- get_values(xml_doc, xpath, ids)
- },
- option = {
- value <- get_attrs_values(xml_doc, xpath, "choix", ids)
- },
- table = {
- value <- get_values(xml_doc, xpath, ids)
- },
- table2 = {
- value <- get_values(xml_doc, xpath, ids)
- },
- node_param = {
- value <- get_values(xml_doc, xpath, ids)
- },
- choix_param = {
- value <- get_values(xml_doc, xpath, ids)
- },
- node_node = {
- value <- get_values(xml_doc, xpath, ids)
- },
- node_option = {
- value <- get_attrs_values(xml_doc, xpath, "choix", ids)
- },
- form_option = {
- value <- get_attrs_values(xml_doc, xpath, "choix", ids)
- },
- node_table = {
- value <- get_values(xml_doc, xpath, ids)
- },
- node_table2 = {
- value <- get_values(xml_doc, xpath, ids)
- },
- node_attr = {
- value <- get_attrs_values(xml_doc, xpath, "nom", ids)
- },
- attr_attr = {
- value <- get_values(xml_doc, xpath, ids)
- },
- attr_attr2 = {
- value <- get_attrs_values(xml_doc, xpath, param_name, ids)
- },
- choix_attr = {
- value <- get_attrs_values(xml_doc, xpath, param_name, ids)
- },
- nodename_childs = {
- value <- get_values(xml_doc, xpath, ids)
- }
-
-
- # TODO : add other cases for tables in ini, soil,
- # and other specific parameters
+ nodename = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ attr = {
+ value <- get_attrs_values(xml_doc, xpath, param_type$attr, ids)
+ },
+ attrname = {
+ value <- get_attrs_values(xml_doc, xpath, param_type$attr, ids)
+ },
+ param = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ option = {
+ value <- get_attrs_values(xml_doc, xpath, "choix", ids)
+ },
+ table = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ table2 = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ node_param = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ choix_param = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ node_node = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ node_option = {
+ value <- get_attrs_values(xml_doc, xpath, "choix", ids)
+ },
+ form_option = {
+ value <- get_attrs_values(xml_doc, xpath, "choix", ids)
+ },
+ node_table = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ node_table2 = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ node_attr = {
+ value <- get_attrs_values(xml_doc, xpath, "nom", ids)
+ },
+ attr_attr = {
+ value <- get_values(xml_doc, xpath, ids)
+ },
+ attr_attr2 = {
+ value <- get_attrs_values(xml_doc, xpath, param_name, ids)
+ },
+ choix_attr = {
+ value <- get_attrs_values(xml_doc, xpath, param_name, ids)
+ },
+ nodename_childs = {
+ value <- get_values(xml_doc, xpath, ids)
+ }
+
+
+ # TODO : add other cases for tables in ini, soil,
+ # and other specific parameters
)
diff --git a/R/get_param_xml.R b/R/get_param_xml.R
index 66ca785e..60b3ba22 100644
--- a/R/get_param_xml.R
+++ b/R/get_param_xml.R
@@ -44,7 +44,6 @@
#' # Getting parameters for irrigation (date and quantity)
#' get_param_xml(file, c("julapI_or_sum_upvt", "amount"))
#'
-#'
#' @export
get_param_xml <- function(file,
param = NULL,
@@ -59,25 +58,31 @@ get_param_xml <- function(file,
# Managing parameter names changes between versions:
if (lifecycle::is_present(xml_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_param_xml(xml_file)",
- "get_param_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_param_xml(xml_file)",
+ "get_param_xml(file)"
+ )
} else {
xml_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(param_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_param_xml(param_name)",
- "get_param_xml(param)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_param_xml(param_name)",
+ "get_param_xml(param)"
+ )
} else {
param_name <- param # to remove when we update inside the function
}
if (lifecycle::is_present(value)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_param_xml(value)",
- "get_param_xml(select_value)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_param_xml(value)",
+ "get_param_xml(select_value)"
+ )
} else {
value <- select_value # to remove when we update inside the function
}
@@ -107,17 +112,23 @@ get_param_xml <- function(file,
# If there are duplicated names in xml_file:
is_duplicated_name <- xml_names %>% duplicated()
- xml_names[is_duplicated_name] <- paste0("xml_",
- which(is_duplicated_name == TRUE),
- "_",
- xml_names[is_duplicated_name])
+ xml_names[is_duplicated_name] <- paste0(
+ "xml_",
+ which(is_duplicated_name == TRUE),
+ "_",
+ xml_names[is_duplicated_name]
+ )
# Fixing parameters with no values with NA
- values[[1]] <- lapply(values[[1]],
- function(x) {
- if (length(x) == 0) return(NA)
- x
- })
+ values[[1]] <- lapply(
+ values[[1]],
+ function(x) {
+ if (length(x) == 0) {
+ return(NA)
+ }
+ x
+ }
+ )
names(values) <- xml_names
diff --git a/R/get_params_dict.R b/R/get_params_dict.R
index 0dba47d2..edc24bf5 100644
--- a/R/get_params_dict.R
+++ b/R/get_params_dict.R
@@ -94,8 +94,9 @@ get_params_dict <- function(in_dict = NULL) { # , javastics_dir = NULL) {
checked <- check_dict(in_dict = in_dict)
- if (!checked)
+ if (!checked) {
stop("A least one XML parameter name does not match the reference list ! ")
+ }
# Merging the in_dict and the intern dict
new_dict <- merge_dict(in_dict, base_dict)
@@ -105,7 +106,6 @@ get_params_dict <- function(in_dict = NULL) { # , javastics_dir = NULL) {
merge_dict <- function(in_dict, base_dict) {
-
# We suppose here that all XML parameters names of the in_dict list
# have been previously checked in set_param_dict
diff --git a/R/get_params_from_doc.R b/R/get_params_from_doc.R
index b9ac6294..a96d4976 100644
--- a/R/get_params_from_doc.R
+++ b/R/get_params_from_doc.R
@@ -17,8 +17,10 @@ get_params_from_doc <- function(xml_doc_object,
stop("The document is not an xml_document !")
}
- root_names_attr <- c("fichierparamgen", "fichierpar", "fichiertec",
- "sols", "fichiersta")
+ root_names_attr <- c(
+ "fichierparamgen", "fichierpar", "fichiertec",
+ "sols", "fichiersta"
+ )
root_names_node <- c("usms", "initialisations")
root_node <- XML::xmlRoot(xml_doc_object@content)
@@ -26,8 +28,9 @@ get_params_from_doc <- function(xml_doc_object,
if (root_name %in% root_names_attr) {
params <- get_params_from_doc_attr(xml_doc_object,
- type_name = type_name,
- unique_val = unique_val)
+ type_name = type_name,
+ unique_val = unique_val
+ )
}
if (root_name %in% root_names_node) {
diff --git a/R/get_params_from_doc_attr.R b/R/get_params_from_doc_attr.R
index 70525afe..b6161ec6 100644
--- a/R/get_params_from_doc_attr.R
+++ b/R/get_params_from_doc_attr.R
@@ -13,7 +13,6 @@
get_params_from_doc_attr <- function(xml_doc,
type_name = NULL,
unique_val = TRUE) {
-
# For tec, param newform, param gen, sols, station
# files
type_names <- c("option", "param", "colonne", "colonne")
diff --git a/R/get_params_from_doc_node.R b/R/get_params_from_doc_node.R
index ba123dcf..2fbdf37e 100644
--- a/R/get_params_from_doc_node.R
+++ b/R/get_params_from_doc_node.R
@@ -14,7 +14,6 @@
get_params_from_doc_node <- function(xml_node,
param_list = c(),
unique_val = TRUE) {
-
# for ini, usms files
if (!methods::is(xml_node, "XMLInternalElementNode")) {
diff --git a/R/get_params_from_table.R b/R/get_params_from_table.R
index cae294f4..6ed8aa51 100644
--- a/R/get_params_from_table.R
+++ b/R/get_params_from_table.R
@@ -18,8 +18,10 @@
#' @examples
#' \dontrun{
#'
-#' download_usm_xl(file = "inputs_stics_example.xlsx",
-#' dest_dir = "/path/to/dest/dir")
+#' download_usm_xl(
+#' file = "inputs_stics_example.xlsx",
+#' dest_dir = "/path/to/dest/dir"
+#' )
#' xl_path <- file.path("/path/to/dest/dir", "inputs_stics_example.xlsx")
#' ini_param_df <- read_excel(xl_path, sheet = "Ini")
#' xml_path <- "path/to/ini/xml"
@@ -38,7 +40,6 @@ get_params_from_table <- function(params_table,
stopping = FALSE,
dict = NULL,
na_values = NA) {
-
# TODO: doing a merge with get_values_from_table
if (base::is.null(dict)) {
@@ -61,8 +62,10 @@ get_params_from_table <- function(params_table,
params_table <- params_table %>%
dplyr::rename_at(
dplyr::vars(dplyr::matches(paste0(key, "\\_[0-9*]"))),
- list(~ gsub(x = ., pattern = paste0("(", key, ")(\\_[0-9*])"),
- replacement = paste0(dict[[key]], "\\2")))
+ list(~ gsub(
+ x = ., pattern = paste0("(", key, ")(\\_[0-9*])"),
+ replacement = paste0(dict[[key]], "\\2")
+ ))
)
}
diff --git a/R/get_plant_name.R b/R/get_plant_name.R
index 2a80b3f1..fd3b0997 100644
--- a/R/get_plant_name.R
+++ b/R/get_plant_name.R
@@ -1,4 +1,3 @@
-
#' Get plant names
#'
#' @description Get the plant name (and file name) for each usm in a workspace
@@ -61,9 +60,11 @@ get_plant_name <- function(workspace,
# Some provided usms are not available:
if (!all(usm_exist)) {
if (verbose) {
- cli::cli_alert_danger(paste0("The usm{?s} ",
- "{.val {usm_name[!usm_exist]}}",
- " d{?oes/o} not exist in the workspace!"))
+ cli::cli_alert_danger(paste0(
+ "The usm{?s} ",
+ "{.val {usm_name[!usm_exist]}}",
+ " d{?oes/o} not exist in the workspace!"
+ ))
cli::cli_alert_info("Usm{?s} found in the workspace: {.val {usms}}")
}
stop(usm_name, ": do(es) not match usms")
@@ -74,34 +75,46 @@ get_plant_name <- function(workspace,
nb_plant <- get_plants_nb(usms_path)[usms]
# Getting plant files (fplt) for a set of usm
- plant_files <- get_param_xml(file = usms_path,
- param = "fplt",
- select = "usm",
- select_value = usms)
+ plant_files <- get_param_xml(
+ file = usms_path,
+ param = "fplt",
+ select = "usm",
+ select_value = usms
+ )
plant_files <- plant_files[[usms_filename]]$fplt
# Getting plant list:
if (length(plant_files) == 2 * length(usms)) {
# If plante dominance="1" and plante dominance="2" are declared,
- #put each one in a column:
- plant_list <- unlist(apply(matrix(plant_files,
- ncol = 2,
- byrow = TRUE),
- MARGIN = 1, list),
- recursive = FALSE)
-
+ # put each one in a column:
+ plant_list <- unlist(
+ apply(
+ matrix(plant_files,
+ ncol = 2,
+ byrow = TRUE
+ ),
+ MARGIN = 1, list
+ ),
+ recursive = FALSE
+ )
} else if (length(plant_files) == length(usms)) {
# If plante dominance="2" is not declared, repeat plante dominance="1"
# twice to get the same data structure:
- plant_list <- unlist(apply(matrix(c(plant_files, plant_files),
- ncol = 2,
- byrow = TRUE),
- MARGIN = 1, list),
- recursive = FALSE)
-
+ plant_list <- unlist(
+ apply(
+ matrix(c(plant_files, plant_files),
+ ncol = 2,
+ byrow = TRUE
+ ),
+ MARGIN = 1, list
+ ),
+ recursive = FALSE
+ )
} else {
- stop("plante dominance=\"2\" should always be declared in usms.xml",
- " even for sole crops (use null as values).")
+ stop(
+ "plante dominance=\"2\" should always be declared in usms.xml",
+ " even for sole crops (use null as values)."
+ )
}
names(plant_list) <- usms
@@ -117,14 +130,17 @@ get_plant_name <- function(workspace,
plant_xml[nb_plant == 1] <- "plant_1"
plant_xml[nb_plant > 1] <- c("plant_1", "plant_2")
names(plant_xml) <- usms
- if (verbose)
+ if (verbose) {
cli::cli_alert_warning("Error reading usms file, using dummy plant names")
+ }
return(plant_xml)
}
- alert_msg <- paste0("plant folder not found in the workspace, please add ",
- "{.code javastics_path} to use real plant names",
- " from javaStics.")
+ alert_msg <- paste0(
+ "plant folder not found in the workspace, please add ",
+ "{.code javastics_path} to use real plant names",
+ " from javaStics."
+ )
if (is.null(javastics_path)) {
plt_path <- file.path(workspace, "plant")
if (!all(dir.exists(plt_path))) {
@@ -147,9 +163,13 @@ get_plant_name <- function(workspace,
if (inherits(plant_names, "try-error")) {
plant_names <- plant_xml
- if (verbose) cli::cli_alert_warning(paste0("Error reading plant names, ",
- "using plant file names for the",
- " output instead"))
+ if (verbose) {
+ cli::cli_alert_warning(paste0(
+ "Error reading plant names, ",
+ "using plant file names for the",
+ " output instead"
+ ))
+ }
}
return(plant_names)
diff --git a/R/get_plants_nb.R b/R/get_plants_nb.R
index 269ae392..cd89dce1 100644
--- a/R/get_plants_nb.R
+++ b/R/get_plants_nb.R
@@ -32,9 +32,11 @@ get_plants_nb <- function(usms_file,
usms_list = c(),
usm_file_path = lifecycle::deprecated()) {
if (lifecycle::is_present(usm_file_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_plants_nb(usm_file_path)",
- "get_plants_nb(usms_file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_plants_nb(usm_file_path)",
+ "get_plants_nb(usms_file)"
+ )
} else {
usm_file_path <- usms_file # to remove when we update inside the function
}
@@ -49,8 +51,10 @@ get_plants_nb <- function(usms_file,
if (!base::file.exists(usm_file_path)) stop(usm_file_path, " does not exist")
if (usm) {
- return(get_plants_nb_txt(usm_txt_path = usm_file_path,
- usm_name = usms_list))
+ return(get_plants_nb_txt(
+ usm_txt_path = usm_file_path,
+ usm_name = usms_list
+ ))
} else {
return(get_plants_nb_xml(usms_file = usm_file_path, usms_list = usms_list))
}
@@ -88,7 +92,6 @@ get_plants_nb <- function(usms_file,
get_plants_nb_xml <- function(usms_file,
usms_list = c(),
usm_xml_path = lifecycle::deprecated()) {
-
# usm_xml_path
if (lifecycle::is_present(usm_xml_path)) {
lifecycle::deprecate_warn(
@@ -133,8 +136,9 @@ get_plants_nb_txt <- function(usm_txt_path, usm_name = NULL) {
usm_data <- get_usm_txt(filepath = usm_txt_path)
# Checking usm name
- if (!base::is.null(usm_name) && usm_data$nom != usm_name)
+ if (!base::is.null(usm_name) && usm_data$nom != usm_name) {
stop(usm_name, ": wrong usm name")
+ }
# Returning a named vector
plants_nb <- as.numeric(usm_data$nbplantes)
diff --git a/R/get_report_results.R b/R/get_report_results.R
index 07f05abe..6ada8215 100644
--- a/R/get_report_results.R
+++ b/R/get_report_results.R
@@ -1,4 +1,3 @@
-
#' Extracting data from the STICS report file
#'
#' @param workspace Path of the directory containing the STICS report file
@@ -34,16 +33,17 @@
#'
#' get_report_results(workspace = path, file_name = "mod_rapportA.sti")
#'
-#'
get_report_results <- function(workspace,
file_name = "mod_rapport.sti",
usm = NULL,
var_list = NULL,
usm_name = lifecycle::deprecated()) {
if (lifecycle::is_present(usm_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_report_results(usm_name)",
- "get_report_results(usm)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_report_results(usm_name)",
+ "get_report_results(usm)"
+ )
} else {
usm_name <- usm # to remove when we update inside the function
}
@@ -70,8 +70,9 @@ get_report_results <- function(workspace,
stringsAsFactors = FALSE
)
- if (any(is.na(h)))
+ if (any(is.na(h))) {
stop("Headers strings are not homogeneous in report file!")
+ }
} else {
warning("Not any header in report file (no col names in ouput)!")
}
diff --git a/R/get_sim.R b/R/get_sim.R
index 2a30a2e9..3adc19ed 100644
--- a/R/get_sim.R
+++ b/R/get_sim.R
@@ -102,46 +102,54 @@ get_sim <- function(workspace,
dates_list = lifecycle::deprecated(),
usms_filepath = lifecycle::deprecated(),
javastics_path = lifecycle::deprecated()) {
-
-
# Managing deprecated arguments
# usm_name
if (lifecycle::is_present(usm_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_sim(usm_name)",
- "get_sim(usm)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_sim(usm_name)",
+ "get_sim(usm)"
+ )
} else {
usm_name <- usm # to remove when we update inside the function
}
# var_list
if (lifecycle::is_present(var_list)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_sim(var_list)",
- "get_sim(var)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_sim(var_list)",
+ "get_sim(var)"
+ )
} else {
var_list <- var # to remove when we update inside the function
}
# dates_list
if (lifecycle::is_present(dates_list)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_sim(dates_list)",
- "get_sim(dates)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_sim(dates_list)",
+ "get_sim(dates)"
+ )
} else {
dates_list <- dates # to remove when we update inside the function
}
# usms_filepath
if (lifecycle::is_present(usms_filepath)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_sim(usms_filepath)",
- "get_sim(usms_file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_sim(usms_filepath)",
+ "get_sim(usms_file)"
+ )
} else {
usms_filepath <- usms_file # to remove when we update inside the function
}
# javastics_path
if (lifecycle::is_present(javastics_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_sim(javastics_path)",
- "get_sim(javastics)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_sim(javastics_path)",
+ "get_sim(javastics)"
+ )
} else {
javastics_path <- javastics # to remove when we update inside the function
}
diff --git a/R/get_soils_list.R b/R/get_soils_list.R
index bb68b59b..165a8da3 100644
--- a/R/get_soils_list.R
+++ b/R/get_soils_list.R
@@ -27,8 +27,10 @@
#' # Read from a soil file (all soil types available in a soil file)
#' soil_list <- get_soils_list(file = file.path(path, "sols.xml"))
#'
-#' soil_list <- get_soils_list(file = file.path(path, "usms.xml"),
-#' soil = c("solcanne", "sole"))
+#' soil_list <- get_soils_list(
+#' file = file.path(path, "usms.xml"),
+#' soil = c("solcanne", "sole")
+#' )
#' @export
#'
get_soils_list <- function(file,
@@ -36,16 +38,20 @@ get_soils_list <- function(file,
file_path = lifecycle::deprecated(),
name = lifecycle::deprecated()) {
if (lifecycle::is_present(file_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_soils_list(file_path)",
- "get_soils_list(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_soils_list(file_path)",
+ "get_soils_list(file)"
+ )
} else {
file_path <- file # to remove when we update inside the function
}
if (lifecycle::is_present(name)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_soils_list(name)",
- "get_soils_list(soil)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_soils_list(name)",
+ "get_soils_list(soil)"
+ )
} else {
name <- soil # to remove when we update inside the function
}
diff --git a/R/get_stics_versions_compat.R b/R/get_stics_versions_compat.R
index 85ff626f..c2a49a08 100644
--- a/R/get_stics_versions_compat.R
+++ b/R/get_stics_versions_compat.R
@@ -20,24 +20,24 @@
#' # Getting the previous version of the latest one
#' get_stics_versions_compat(-1)
#'
-#'
#' @export
#'
#'
get_stics_versions_compat <- function(version_index = NULL) {
-
# Getting versions list
ver_info <- get_versions_info()
versions_names <- ver_info$versions
- #num_versions <- as.numeric(gsub(pattern = "^[V]", "", versions_names))
+ # num_versions <- as.numeric(gsub(pattern = "^[V]", "", versions_names))
num_versions <- get_version_num(versions_names)
# Getting the latest version string
latest_version <- versions_names[num_versions == max(num_versions)]
# List of versions strings ans latest version string
- versions <- list(versions_list = versions_names,
- latest_version = latest_version)
+ versions <- list(
+ versions_list = versions_names,
+ latest_version = latest_version
+ )
if (is.null(version_index)) {
return(versions)
@@ -124,7 +124,6 @@ check_version_compat <- function(stics_version = "latest") {
#' )
#' }
get_versions_info <- function(stics_version = NULL, location = "install") {
-
# Getting available versions info from a file
ver_file <- get_versions_file_path(location = location)
@@ -170,10 +169,10 @@ get_versions_info <- function(stics_version = NULL, location = "install") {
#' get_version_num()
#' }
get_version_num <- function(stics_version = "latest", numeric = TRUE) {
- if(length(stics_version) > 1) {
- versions_list <- unlist(lapply(stics_version, function(x){
- get_version_num(x, numeric = numeric)}
- ))
+ if (length(stics_version) > 1) {
+ versions_list <- unlist(lapply(stics_version, function(x) {
+ get_version_num(x, numeric = numeric)
+ }))
return(versions_list)
}
@@ -185,17 +184,21 @@ get_version_num <- function(stics_version = "latest", numeric = TRUE) {
stics_version <- get_stics_versions_compat()$latest_version
}
- char_version <- gsub(pattern = "([V | v]{1})([0-9\\.]*)",
- x = stics_version,
- replacement = "\\2")
+ char_version <- gsub(
+ pattern = "([V | v]{1})([0-9\\.]*)",
+ x = stics_version,
+ replacement = "\\2"
+ )
if (!numeric) {
return(char_version)
}
- char_version <- gsub(pattern = "([0-9]*\\.[0-9]*)([\\.]{0,1})([0-9]{0,})",
- x = char_version,
- replacement = "\\1\\3")
+ char_version <- gsub(
+ pattern = "([0-9]*\\.[0-9]*)([\\.]{0,1})([0-9]{0,})",
+ x = char_version,
+ replacement = "\\1\\3"
+ )
as.numeric(char_version)
}
@@ -216,7 +219,7 @@ get_version_string <- function(stics_version) {
pattern <- "^[V | v]"
if (is.character(stics_version) &&
- grepl(pattern = pattern, x = stics_version)) {
+ grepl(pattern = pattern, x = stics_version)) {
return(toupper(stics_version))
}
@@ -238,4 +241,3 @@ get_version_string <- function(stics_version) {
get_versions_file_name <- function() {
return("stics_versions_info.csv")
}
-
diff --git a/R/get_used_param.R b/R/get_used_param.R
index 0b91ce87..41e5917a 100644
--- a/R/get_used_param.R
+++ b/R/get_used_param.R
@@ -11,20 +11,22 @@ get_used_param_xml <- function(file) {
get_base_used_param <- function(xml_doc) {
name <- get_attrs_values(xml_doc,
- path = "//formalisme/param",
- attr_list = "nom"
+ path = "//formalisme/param",
+ attr_list = "nom"
)
colnames(name) <- "name"
value <- get_values(xml_doc, path = "//formalisme/param")
- df <- data.frame(name = name,
- value = value,
- cultivar = "none",
- stringsAsFactors = FALSE)
+ df <- data.frame(
+ name = name,
+ value = value,
+ cultivar = "none",
+ stringsAsFactors = FALSE
+ )
# cultivar parameters
namev <- get_attrs_values(xml_doc,
- path = "//variete/param",
- attr_list = "nom"
+ path = "//variete/param",
+ attr_list = "nom"
)
parv_nb <- length(unique(namev))
cultivars <- as.vector(
@@ -36,10 +38,12 @@ get_base_used_param <- function(xml_doc) {
colnames(namev) <- "name"
valuev <- get_values(xml_doc, path = "//variete/param")
- dfv <- data.frame(name = namev,
- value = valuev,
- cultivar = cultivar,
- stringsAsFactors = FALSE)
+ dfv <- data.frame(
+ name = namev,
+ value = valuev,
+ cultivar = cultivar,
+ stringsAsFactors = FALSE
+ )
dplyr::bind_rows(df, dfv)
}
@@ -47,8 +51,8 @@ get_base_used_param <- function(xml_doc) {
get_options_used_param <- function(xml_doc, param_list = NULL) {
m_options <- unique(
get_attrs_values(xml_doc,
- path = "//formalisme/option",
- attr_list = c("choix", "nomParam")
+ path = "//formalisme/option",
+ attr_list = c("choix", "nomParam")
)
)
@@ -57,29 +61,34 @@ get_options_used_param <- function(xml_doc, param_list = NULL) {
}
if (is.null(dim(m_options))) {
- options_data <- data.frame(choix = m_options[1],
- nomParam = m_options[2],
- stringsAsFactors = FALSE)
+ options_data <- data.frame(
+ choix = m_options[1],
+ nomParam = m_options[2],
+ stringsAsFactors = FALSE
+ )
} else {
- options_data <- data.frame(choix = m_options[, 1],
- nomParam = m_options[, 2],
- stringsAsFactors = FALSE)
+ options_data <- data.frame(
+ choix = m_options[, 1],
+ nomParam = m_options[, 2],
+ stringsAsFactors = FALSE
+ )
}
nb_opt <- dim(options_data)[1]
for (opt in 1:nb_opt) {
-
# get param level 1 option
# boucle sur option_names
name <- options_data$nomParam[opt]
value <- options_data$choix[opt]
- path_param <- paste0("//option[@nomParam=", "'",
- name,
- "']/choix[@code=",
- "'",
- value,
- "']/param")
+ path_param <- paste0(
+ "//option[@nomParam=", "'",
+ name,
+ "']/choix[@code=",
+ "'",
+ value,
+ "']/param"
+ )
nodes_set <- get_nodes(xml_doc, path = path_param)
@@ -98,51 +107,58 @@ get_options_used_param <- function(xml_doc, param_list = NULL) {
# data.frame avec codeoption, noms param, valeurs param
}
- path_suboption <- paste0("//option[@nomParam=",
- "'",
- name,
- "']/choix[@code=",
- "'",
- value,
- "']/option")
+ path_suboption <- paste0(
+ "//option[@nomParam=",
+ "'",
+ name,
+ "']/choix[@code=",
+ "'",
+ value,
+ "']/option"
+ )
m_sub_options <- unique(
get_attrs_values(xml_doc,
- path = path_suboption,
- attr_list = c("choix", "nomParam")
+ path = path_suboption,
+ attr_list = c("choix", "nomParam")
)
)
if (is.null(m_sub_options)) next
if (is.null(dim(m_sub_options))) {
- sub_options_data <- data.frame(choix = m_sub_options[1],
- nomParam = m_sub_options[2],
- stringsAsFactors = FALSE)
+ sub_options_data <- data.frame(
+ choix = m_sub_options[1],
+ nomParam = m_sub_options[2],
+ stringsAsFactors = FALSE
+ )
} else {
- sub_options_data <- data.frame(choix = m_sub_options[, 1],
- nomParam = m_sub_options[, 2],
- stringsAsFactors = FALSE)
+ sub_options_data <- data.frame(
+ choix = m_sub_options[, 1],
+ nomParam = m_sub_options[, 2],
+ stringsAsFactors = FALSE
+ )
}
nb_sub_opt <- dim(sub_options_data)[1]
for (sub_opt in 1:nb_sub_opt) {
-
# get param level 1 option
# boucle sur option_names
sub_name <- sub_options_data$nomParam[sub_opt]
sub_value <- sub_options_data$choix[sub_opt]
- sub_path_param <- paste0(path_suboption,
- "[@nomParam=",
- "'",
- sub_name,
- "']/choix[@code=",
- "'",
- sub_value,
- "']/param")
+ sub_path_param <- paste0(
+ path_suboption,
+ "[@nomParam=",
+ "'",
+ sub_name,
+ "']/choix[@code=",
+ "'",
+ sub_value,
+ "']/param"
+ )
nodes_set <- get_nodes(xml_doc, path = sub_path_param)
@@ -178,12 +194,14 @@ get_options_used_param <- function(xml_doc, param_list = NULL) {
optionv_data <- data.frame(nom = m_optionsv[, 1], stringsAsFactors = FALSE)
m_all_options <- unique(get_attrs_values(xml_doc,
- path = "//option",
- attr_list = c("choix", "nomParam")
+ path = "//option",
+ attr_list = c("choix", "nomParam")
))
- all_options_data <- data.frame(choix = m_all_options[, 1],
- nomParam = m_all_options[, 2],
- stringsAsFactors = FALSE)
+ all_options_data <- data.frame(
+ choix = m_all_options[, 1],
+ nomParam = m_all_options[, 2],
+ stringsAsFactors = FALSE
+ )
idx <- all_options_data$nomParam %in% optionv_data$nom
optionv_codes <- all_options_data$choix[idx]
@@ -193,11 +211,13 @@ get_options_used_param <- function(xml_doc, param_list = NULL) {
for (v_opt in 1:nb_v_opt) {
v_name <- optionv_names[v_opt]
v_value <- optionv_codes[v_opt]
- v_path_param <- paste0("//optionv[@nom='",
- v_name,
- "']//param[@code='",
- v_value,
- "']")
+ v_path_param <- paste0(
+ "//optionv[@nom='",
+ v_name,
+ "']//param[@code='",
+ v_value,
+ "']"
+ )
nodes_set <- get_nodes(xml_doc, path = v_path_param)
diff --git a/R/get_usms_files.R b/R/get_usms_files.R
index 317c0405..14752e63 100644
--- a/R/get_usms_files.R
+++ b/R/get_usms_files.R
@@ -56,42 +56,51 @@ get_usms_files <- function(workspace,
df_output = FALSE,
workspace_path = lifecycle::deprecated(),
file_name = lifecycle::deprecated(),
- javastics_path = lifecycle::deprecated()
-) {
+ javastics_path = lifecycle::deprecated()) {
if (lifecycle::is_present(workspace_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_usms_files(workspace_path)",
- "get_usms_files(workspace)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_usms_files(workspace_path)",
+ "get_usms_files(workspace)"
+ )
} else {
workspace_path <- workspace # to remove when we update inside the function
}
if (lifecycle::is_present(file_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_usms_files(file_name)",
- "get_usms_files(usms_file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_usms_files(file_name)",
+ "get_usms_files(usms_file)"
+ )
} else {
file_name <- usms_file # to remove when we update inside the function
}
if (lifecycle::is_present(javastics_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "get_usms_files(javastics_path)",
- "get_usms_files(javastics)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "get_usms_files(javastics_path)",
+ "get_usms_files(javastics)"
+ )
} else {
javastics_path <- javastics # to remove when we update inside the function
}
# Types definition
- files_types <- c("fplt", "finit", "fclim1", "fclim2", "fstation", "ftec",
- "sols", "pargen", "parnew")
+ files_types <- c(
+ "fplt", "finit", "fclim1", "fclim2", "fstation", "ftec",
+ "sols", "pargen", "parnew"
+ )
if (is.null(file_type)) {
file_type <- files_types
} else {
# Checking if type(s) exist(s)
type_exists <- file_type %in% files_types
- if (!all(type_exists))
- warning("One or more file type(s) do(es) not exist : ",
- paste(file_type[!type_exists], collapse = ",")
+ if (!all(type_exists)) {
+ warning(
+ "One or more file type(s) do(es) not exist : ",
+ paste(file_type[!type_exists], collapse = ",")
)
+ }
file_type <- file_type[type_exists]
}
@@ -105,7 +114,7 @@ get_usms_files <- function(workspace,
ws_plt_path <- NULL
if (!base::is.null(javastics_path) &&
- dir.exists(file.path(javastics_path, "plant"))) {
+ dir.exists(file.path(javastics_path, "plant"))) {
javastics_plt_path <- suppressWarnings(
normalizePath(file.path(javastics_path, "plant"))
)
@@ -120,8 +129,10 @@ get_usms_files <- function(workspace,
plt_dir_path <- c(ws_plt_path, javastics_plt_path)
if (base::is.null(plt_dir_path)) {
- stop("not any plant folder found, please add javastics_path directory",
- " as function input argument or a workspace plant sub-directory !")
+ stop(
+ "not any plant folder found, please add javastics_path directory",
+ " as function input argument or a workspace plant sub-directory !"
+ )
}
check_plt <- TRUE
}
@@ -162,14 +173,15 @@ get_usms_files <- function(workspace,
# Loop over usms names
for (i in 1:usms_nb) {
-
usm_name <- usms_list[i]
nodeset <- XML::getNodeSet(
doc = xml_doc@content,
- path = paste0("//usm[@nom='",
- usm_name,
- "']//*[starts-with(name(), 'f')]")
+ path = paste0(
+ "//usm[@nom='",
+ usm_name,
+ "']//*[starts-with(name(), 'f')]"
+ )
)
node_names <- unlist(lapply(nodeset, XML::xmlName))
@@ -230,10 +242,11 @@ get_usms_files <- function(workspace,
normalizePath(file.path(workspace_path, "param_gen.xml"))
)
- if (!file.exists(pargen_file_path))
+ if (!file.exists(pargen_file_path)) {
pargen_file_path <- suppressWarnings(
normalizePath(file.path(javastics, "config", "param_gen.xml"))
)
+ }
pargen_file_exists <- file.exists(pargen_file_path)
}
@@ -246,10 +259,11 @@ get_usms_files <- function(workspace,
normalizePath(file.path(workspace_path, "param_newform.xml"))
)
- if (!file.exists(parnew_file_path))
+ if (!file.exists(parnew_file_path)) {
parnew_file_path <- suppressWarnings(
normalizePath(file.path(javastics, "config", "param_newform.xml"))
)
+ }
parnew_file_exists <- file.exists(parnew_file_path)
}
@@ -257,13 +271,17 @@ get_usms_files <- function(workspace,
#
# Adding the files lists
usms_files_list[[i]] <- list(
- paths = c(usm_files_path, plt_files_path, sols_file_path,
- pargen_file_path, parnew_file_path),
- all_exist = c(usm_files_exist,
- plt_files_exist,
- sols_file_exists,
- pargen_file_exists,
- parnew_file_exists)
+ paths = c(
+ usm_files_path, plt_files_path, sols_file_path,
+ pargen_file_path, parnew_file_path
+ ),
+ all_exist = c(
+ usm_files_exist,
+ plt_files_exist,
+ sols_file_exists,
+ pargen_file_exists,
+ parnew_file_exists
+ )
)
}
diff --git a/R/get_usms_list.R b/R/get_usms_list.R
index 366da9c8..c4bef65a 100644
--- a/R/get_usms_list.R
+++ b/R/get_usms_list.R
@@ -18,8 +18,10 @@
#'
#' usms_list <- get_usms_list(file = file.path(path, "usms.xml"))
#'
-#' usms_list <- get_usms_list(file = file.path(path, "usms.xml"),
-#' usm = c("usm1", "usm2"))
+#' usms_list <- get_usms_list(
+#' file = file.path(path, "usms.xml"),
+#' usm = c("usm1", "usm2")
+#' )
#'
#' @export
#'
@@ -27,7 +29,6 @@ get_usms_list <- function(file,
usm = NULL,
usm_path = lifecycle::deprecated(),
name = lifecycle::deprecated()) {
-
# TODO: add select key: i.e. get all usms names
# with the same soil, plant 1,...
if (lifecycle::is_present(usm_path)) {
@@ -65,7 +66,6 @@ get_usms_list <- function(file,
find_usms_soils_names <- function(xml_doc, xml_name, name = NULL) {
-
# Getting names usms/soils list
names_list <- unique(
unlist(
@@ -73,9 +73,9 @@ find_usms_soils_names <- function(xml_doc, xml_name, name = NULL) {
XML::getNodeSet(doc = xml_doc@content, path = paste0("//", xml_name)),
function(x) {
switch(xml_name,
- nomsol = XML::xmlValue(x),
- # default case handling xml_namevalues : sol, usm
- XML::xmlGetAttr(x, "nom")
+ nomsol = XML::xmlValue(x),
+ # default case handling xml_namevalues : sol, usm
+ XML::xmlGetAttr(x, "nom")
)
}
)
diff --git a/R/get_values_by_param.R b/R/get_values_by_param.R
index 61526fd9..bda56342 100644
--- a/R/get_values_by_param.R
+++ b/R/get_values_by_param.R
@@ -13,8 +13,10 @@
#'
#' @examples
#' \dontrun{
-#' download_usm_xl(file = "inputs_stics_example.xlsx",
-#' dest_dir = "/path/to/dest/dir")
+#' download_usm_xl(
+#' file = "inputs_stics_example.xlsx",
+#' dest_dir = "/path/to/dest/dir"
+#' )
#' xl_path <- file.path("/path/to/dest/dir", "inputs_stics_example.xlsx")
#' tec_param_df <- read_excel(xl_path, sheet = "Tec")
#' get_values_by_param(params_table = tec_param_df)
@@ -41,8 +43,8 @@ get_values_by_param <- function(params_table,
if (nrow(params_table) > 1) {
# Lines selection, if any id
if (!base::is.null(lines_id) &&
- base::is.numeric(lines_id) &&
- max(lines_id) <= nrow(params_table)) {
+ base::is.numeric(lines_id) &&
+ max(lines_id) <= nrow(params_table)) {
params_table <- params_table[lines_id, ]
}
@@ -51,7 +53,7 @@ get_values_by_param <- function(params_table,
params_table, 1,
function(x) {
get_values_by_param(as.data.frame(t(x), stringsAsFactors = FALSE),
- param_name = param_name
+ param_name = param_name
)
}
)
@@ -69,21 +71,27 @@ get_values_by_param <- function(params_table,
}
par_pattern <- paste0("(^", param_name, "$|", "^", param_name, "_)")
- param_names <- grep(pattern = par_pattern,
- x = names(params_table),
- value = TRUE)
+ param_names <- grep(
+ pattern = par_pattern,
+ x = names(params_table),
+ value = TRUE
+ )
# Sorting parameters names against a numeric suffix, if any
if (length(grep(pattern = "_[0-9]", x = param_names))) {
sorted_par_id <- sort(
- as.numeric(gsub(pattern = paste0(param_name, "_([0-9]+)"),
- replacement = "\\1",
- x = param_names))
- )
+ as.numeric(gsub(
+ pattern = paste0(param_name, "_([0-9]+)"),
+ replacement = "\\1",
+ x = param_names
+ ))
+ )
param_names <- unlist(
- lapply(as.character(sorted_par_id),
- function(x) paste(param_name, x, sep = "_"))
+ lapply(
+ as.character(sorted_par_id),
+ function(x) paste(param_name, x, sep = "_")
)
+ )
}
# converting from data.frame to vector
diff --git a/R/get_xml_base_doc.R b/R/get_xml_base_doc.R
index f30b1a78..a45126dd 100644
--- a/R/get_xml_base_doc.R
+++ b/R/get_xml_base_doc.R
@@ -28,7 +28,6 @@
#'
get_xml_base_doc <- function(xml_type = NULL,
stics_version = "latest") {
-
# types list
types <- c("sols", "usms", "ini", "tec", "sta")
# returning types if no args
diff --git a/R/get_xml_base_node.R b/R/get_xml_base_node.R
index f7cc139b..86ea8711 100644
--- a/R/get_xml_base_node.R
+++ b/R/get_xml_base_node.R
@@ -26,7 +26,6 @@
# TODO: under construction !!!!!!!!!!!!!!!!!
get_xml_base_node <- function(file_tag, form_name = NULL,
stics_version = "latest") {
-
# check/get STICS version
stics_version <- get_xml_stics_version(stics_version = stics_version)
@@ -99,7 +98,8 @@ get_xml_base_node <- function(file_tag, form_name = NULL,
# Template path in the library
xml_file <- file.path(
get_examples_path(file_type = "xml_tmpl", stics_version = stics_version),
- file_name)
+ file_name
+ )
# Loading the template into an xmDocument
xml_doc <- xmldocument(xml_file)
@@ -111,7 +111,8 @@ get_xml_base_node <- function(file_tag, form_name = NULL,
# Getting the node from a node set
new_node <- XML::getNodeSet(
XML::xmlParse(base_node_txt),
- paste0("//", node))[[1]]
+ paste0("//", node)
+ )[[1]]
delete(xml_doc)
diff --git a/R/get_xml_doc_example.R b/R/get_xml_doc_example.R
index 57bd6669..769edac8 100644
--- a/R/get_xml_doc_example.R
+++ b/R/get_xml_doc_example.R
@@ -21,14 +21,16 @@
#'
get_xml_doc_example <- function(xml_name = NULL,
stics_version = "latest") {
-
# check/get version
stics_version <- get_xml_stics_version(stics_version = stics_version)
# stics_xml_types
- files <- list.files(pattern = ".xml$",
- path = get_examples_path(file_type = "xml",
- stics_version = stics_version)
+ files <- list.files(
+ pattern = ".xml$",
+ path = get_examples_path(
+ file_type = "xml",
+ stics_version = stics_version
+ )
)
if (base::is.null(xml_name)) {
@@ -36,14 +38,19 @@ get_xml_doc_example <- function(xml_name = NULL,
}
if (!xml_name %in% files) {
- stop("File does not exist in package examples,",
- "run get_xml_example_doc() to get the list !")
+ stop(
+ "File does not exist in package examples,",
+ "run get_xml_example_doc() to get the list !"
+ )
}
# getting a default xmldocument object template
- xml_file <- file.path(get_examples_path(file_type = "xml",
- stics_version = stics_version),
- xml_name
+ xml_file <- file.path(
+ get_examples_path(
+ file_type = "xml",
+ stics_version = stics_version
+ ),
+ xml_name
)
xml_doc_object <- xmldocument(xml_file)
diff --git a/R/get_xml_files_param_df.R b/R/get_xml_files_param_df.R
index d653494d..bd72297e 100644
--- a/R/get_xml_files_param_df.R
+++ b/R/get_xml_files_param_df.R
@@ -75,26 +75,26 @@ get_xml_files_param_df <- function(file_path,
name = NULL,
param_names = NULL,
wide_shape = FALSE) {
-
-
# For managing a files list
if (length(file_path) > 1) {
files_exist <- file.exists(file_path)
- if (!all(files_exist))
+ if (!all(files_exist)) {
warning("Missing files: ", paste(file_path[!files_exist], collapse = ","))
+ }
- if (!any(files_exist))
+ if (!any(files_exist)) {
stop("Not any files exist !")
+ }
files_df <- lapply(
file_path[files_exist],
function(x) {
get_xml_files_param_df(x,
- select = select,
- name = name,
- param_names = param_names,
- wide_shape = FALSE
+ select = select,
+ name = name,
+ param_names = param_names,
+ wide_shape = FALSE
)
}
)
@@ -120,8 +120,9 @@ get_xml_files_param_df <- function(file_path,
# Getting usm or sol names vector
names_list <- NULL
- if (!base::is.null(select))
+ if (!base::is.null(select)) {
names_list <- get_param_xml(file_path, param = select)[[1]][[select]]
+ }
# Getting all usm or sol names from the file
select_name <- FALSE
@@ -139,8 +140,9 @@ get_xml_files_param_df <- function(file_path,
# for one name
param_values <- get_param_xml(file_path, param = param_names)[[1]]
- if (file_type == "initialisations")
+ if (file_type == "initialisations") {
param_values <- reformat_param_values_init(param_values)
+ }
# Checking if only one parameter, param_values == numerical vector
if (length(param_names) == 1) {
@@ -166,21 +168,24 @@ get_xml_files_param_df <- function(file_path,
values_per_par <- length(names_list)
- param_id <- unlist(lapply(values_nb, function(x) {
- l <- rep(NA, x)
- if (x > values_per_par) l <- rep(1:(x / values_per_par), values_per_par)
- return(l)
- }),
- use.names = FALSE
+ param_id <- unlist(
+ lapply(values_nb, function(x) {
+ l <- rep(NA, x)
+ if (x > values_per_par) l <- rep(1:(x / values_per_par), values_per_par)
+ return(l)
+ }),
+ use.names = FALSE
)
- name_col <- unlist(lapply(values_nb, function(x) {
- l <- names_list
- if (x > values_per_par)
- l <- unlist(lapply(names_list, function(y) rep(y, x / values_per_par)))
- return(l)
- }),
- use.names = FALSE
+ name_col <- unlist(
+ lapply(values_nb, function(x) {
+ l <- names_list
+ if (x > values_per_par) {
+ l <- unlist(lapply(names_list, function(y) rep(y, x / values_per_par)))
+ }
+ return(l)
+ }),
+ use.names = FALSE
)
}
@@ -234,7 +239,6 @@ df_wider <- function(df, convert_type = TRUE, string_as_factors = FALSE) {
get_params_id <- function(file_type, file_path, param_values) {
-
# files types
# "initialisations" "usms" "sols" "fichiertec" "fichiersta"
# "fichierplt" "fichierpar" "fichierparamgen"
@@ -249,7 +253,8 @@ get_params_id <- function(file_type, file_path, param_values) {
xml_doc <- xmldocument(file_path)
param_types_data <- get_param_type(
xml_doc,
- param_name = names(param_values))
+ param_name = names(param_values)
+ )
param$id <- unlist(lapply(param_types_data, function(x) {
l <- NA
@@ -278,15 +283,15 @@ get_params_id <- function(file_type, file_path, param_values) {
return(param)
-
}
reformat_param_values_init <- function(param_values) {
-
# change id => 1, plant param
- plt_init_names <- c("stade0", "lai0", "magrain0", "zrac0", "maperenne0",
- "QNperenne0", "masecnp0", "QNplantenp0", "masec0",
- "QNplante0", "restemp0", "code_acti_reserve")
+ plt_init_names <- c(
+ "stade0", "lai0", "magrain0", "zrac0", "maperenne0",
+ "QNperenne0", "masecnp0", "QNplantenp0", "masec0",
+ "QNplante0", "restemp0", "code_acti_reserve"
+ )
par_names <- names(param_values)
new_param_values <- param_values
@@ -295,25 +300,21 @@ reformat_param_values_init <- function(param_values) {
for (p in c(plt_init_names, "densinitial")) new_param_values[[p]] <- NULL
for (n in seq_along(par_names)) {
- par_name <- par_names[n]
+ par_name <- par_names[n]
idx <- grep(x = plt_init_names, pattern = paste0("^", par_name))
if (length(idx) > 0) {
-
new_param_values[[paste0(par_name, "_Crop1")]] <-
param_values[[par_name]][1]
new_param_values[[paste0(par_name, "_Crop2")]] <-
param_values[[par_name]][2]
-
}
}
# treating densinitial
id_start <- 0
for (i in 1:2) {
for (j in 1:5) {
-
new_param_values[[paste0("densinitial_", j, "_Crop", i)]] <-
param_values$densinitial[id_start + j]
-
}
id_start <- 5
}
diff --git a/R/get_xml_stics_version.R b/R/get_xml_stics_version.R
index fdf0f27f..f96dfbfe 100644
--- a/R/get_xml_stics_version.R
+++ b/R/get_xml_stics_version.R
@@ -24,7 +24,6 @@
#' @noRd
#'
get_xml_stics_version <- function(stics_version = "latest", xml_doc = NULL) {
-
# TODO: A renommer pour clarifier version des fichiers
# a generer et non pas version du modele exe.
# il n'y aura plus de pb des que les fontions seront ventilees
diff --git a/R/global.R b/R/global.R
index 2d399b59..3dc644bb 100644
--- a/R/global.R
+++ b/R/global.R
@@ -36,81 +36,100 @@ setGeneric("calc_type", function(object) standardGeneric("calc_type"))
# defined for xml_document
setGeneric("xmldocument", function(file) standardGeneric("xmldocument"))
-setGeneric("set_content<-",
- function(object, value) standardGeneric("set_content<-"))
+setGeneric(
+ "set_content<-",
+ function(object, value) standardGeneric("set_content<-")
+)
setGeneric("get_content", function(object) standardGeneric("get_content"))
setGeneric("load_content", function(object) standardGeneric("load_content"))
setGeneric("is_loaded", function(object) standardGeneric("is_loaded"))
-setGeneric("is.xml_document",
- function(object) standardGeneric("is.xml_document"))
+setGeneric(
+ "is.xml_document",
+ function(object) standardGeneric("is.xml_document")
+)
# xml manipulations
-setGeneric("get_nodes",
- function(object, path = NULL) standardGeneric("get_nodes"))
+setGeneric(
+ "get_nodes",
+ function(object, path = NULL) standardGeneric("get_nodes")
+)
setGeneric("get_attrs", function(object, path) standardGeneric("get_attrs"))
-setGeneric("get_attrs_names",
- function(object, path) standardGeneric("get_attrs_names"))
+setGeneric(
+ "get_attrs_names",
+ function(object, path) standardGeneric("get_attrs_names")
+)
-setGeneric("get_attrs_values",
- function(object,
- path,
- attr_list,
- nodes_ids = NULL) {
- standardGeneric("get_attrs_values")
- }
+setGeneric(
+ "get_attrs_values",
+ function(object,
+ path,
+ attr_list,
+ nodes_ids = NULL) {
+ standardGeneric("get_attrs_values")
+ }
)
-setGeneric("add_attrs",
- function(object, path, named_vector) standardGeneric("add_attrs"))
+setGeneric(
+ "add_attrs",
+ function(object, path, named_vector) standardGeneric("add_attrs")
+)
-setGeneric("remove_attrs",
- function(object, path, attr_names) standardGeneric("remove_attrs"))
+setGeneric(
+ "remove_attrs",
+ function(object, path, attr_names) standardGeneric("remove_attrs")
+)
-setGeneric("set_attrs_values",
- function(object,
- path, attr_name,
- values_list,
- nodes_ids = NULL) {
- standardGeneric("set_attrs_values")
- }
+setGeneric(
+ "set_attrs_values",
+ function(object,
+ path, attr_name,
+ values_list,
+ nodes_ids = NULL) {
+ standardGeneric("set_attrs_values")
+ }
)
-setGeneric("set_values",
- function(object,
- path,
- values_list,
- nodes_ids = NULL) {
- standardGeneric("set_values")
- }
+setGeneric(
+ "set_values",
+ function(object,
+ path,
+ values_list,
+ nodes_ids = NULL) {
+ standardGeneric("set_values")
+ }
)
-setGeneric("get_values",
- function(object,
- path,
- nodes_ids = NULL) {
- standardGeneric("get_values")
- }
+setGeneric(
+ "get_values",
+ function(object,
+ path,
+ nodes_ids = NULL) {
+ standardGeneric("get_values")
+ }
)
-setGeneric("save_xml_doc",
- function(object, xml_path) standardGeneric("save_xml_doc"))
+setGeneric(
+ "save_xml_doc",
+ function(object, xml_path) standardGeneric("save_xml_doc")
+)
setGeneric("clone_xml_doc", function(object) standardGeneric("clone_xml_doc"))
# adding and removing nodes to doc
-setGeneric("add_nodes",
- function(object,
- nodes_to_add,
- parent_path = NULL) {
- standardGeneric("add_nodes")
- }
+setGeneric(
+ "add_nodes",
+ function(object,
+ nodes_to_add,
+ parent_path = NULL) {
+ standardGeneric("add_nodes")
+ }
)
# removing nodes
diff --git a/R/init_javastics_pref.R b/R/init_javastics_pref.R
index fdedd069..0e72e704 100644
--- a/R/init_javastics_pref.R
+++ b/R/init_javastics_pref.R
@@ -54,7 +54,8 @@ init_javastics_pref <- function(javastics, overwrite = FALSE) {
"Couldn't add a {.val preference.xml}",
"file in the JavaSTICS installation. ",
"Please run {.pkg Javastics} once to create it."
- ))
+ )
+ )
return(FALSE)
}
}
diff --git a/R/is_os_name.R b/R/is_os_name.R
index 48a94cc0..d2a11803 100644
--- a/R/is_os_name.R
+++ b/R/is_os_name.R
@@ -26,8 +26,9 @@ is_os_name <- function(os_tag_name = character()) {
}
is_os_name <- FALSE
os_name <- tolower(Sys.info()["sysname"])
- if (is.element(os_name, os_names) && any(is.element(os_tag_name, os_name)))
+ if (is.element(os_name, os_names) && any(is.element(os_tag_name, os_name))) {
is_os_name <- TRUE
+ }
# Storing the OS name as name attribute value
attr(is_os_name, "name") <- os_name
diff --git a/R/is_stics_doc.R b/R/is_stics_doc.R
index c0df6434..35c6cca9 100644
--- a/R/is_stics_doc.R
+++ b/R/is_stics_doc.R
@@ -20,7 +20,6 @@
#' @noRd
#'
is_stics_doc <- function(xml_doc, doc_type = NULL, doc_types = NULL) {
-
# TODO : doc_types have been added as input arg, but not used yet,
# will be used when doc_types will be defined against STICS Version
# because they may change with versions ?
@@ -43,9 +42,11 @@ is_stics_doc <- function(xml_doc, doc_type = NULL, doc_types = NULL) {
}
if (!base::is.null(doc_type) && !(doc_type %in% doc_types)) {
- warning(paste0("Not any tag name \"",
- doc_type,
- "\" for STICS xml document!"))
+ warning(paste0(
+ "Not any tag name \"",
+ doc_type,
+ "\" for STICS xml document!"
+ ))
return(FALSE)
}
diff --git a/R/javastics_cmd_util.R b/R/javastics_cmd_util.R
index 4eff55c3..f6b0e764 100644
--- a/R/javastics_cmd_util.R
+++ b/R/javastics_cmd_util.R
@@ -37,7 +37,6 @@ get_javastics_cmd <- function(javastics,
type = c("generate", "run"),
workspace = NULL,
verbose = TRUE) {
-
# detecting JavaSTICS command exe name from javastics path
javastics_cmd <- file.path(javastics, "JavaSticsCmd.exe")
cmd <- check_javastics_cmd(
@@ -111,20 +110,23 @@ check_javastics_cmd <- function(javastics_cmd = "JavaSticsCmd.exe",
verbose = TRUE) {
if (is_windows()) {
help_test <- system2(javastics_cmd,
- c("--help"),
- stdout = TRUE, stderr = TRUE
+ c("--help"),
+ stdout = TRUE, stderr = TRUE
)
} else {
help_test <- system2(java_cmd,
- c("-jar", javastics_cmd, "--help"),
- stdout = TRUE, stderr = TRUE
+ c("-jar", javastics_cmd, "--help"),
+ stdout = TRUE, stderr = TRUE
)
}
# detecting invalid option for given JavaSTICS command line
help_status <- !length(
- grep(pattern = "Invalid option entered",
- help_test)) > 0
+ grep(
+ pattern = "Invalid option entered",
+ help_test
+ )
+ ) > 0
if (!is_windows()) {
ver <- get_java_version(java_cmd = java_cmd)
@@ -132,19 +134,23 @@ check_javastics_cmd <- function(javastics_cmd = "JavaSticsCmd.exe",
status <- attr(help_test, "status")
if (!is.null(status) && status > 0) {
- stop("The given or default java version ",
- ver,
- " is not usable with that version of",
- " JavaSTICS, use at least java version 11 !")
+ stop(
+ "The given or default java version ",
+ ver,
+ " is not usable with that version of",
+ " JavaSTICS, use at least java version 11 !"
+ )
}
if (is.null(status) &&
- !help_status &&
- ver > 1.8) {
- stop("The given or default java version ",
- ver,
- " is not usable with that version of",
- " JavaSTICS, use at most java version 1.8 !")
+ !help_status &&
+ ver > 1.8) {
+ stop(
+ "The given or default java version ",
+ ver,
+ " is not usable with that version of",
+ " JavaSTICS, use at most java version 1.8 !"
+ )
}
}
@@ -180,15 +186,15 @@ check_javastics_cmd <- function(javastics_cmd = "JavaSticsCmd.exe",
#' @noRd
#'
get_java_version <- function(java_cmd = "java") {
-
# java_cmd must contain a java executable path, if not known in the system
# environment
if (!is_windows()) {
java_path <- system2("which", java_cmd, stdout = TRUE, stderr = TRUE)
} else {
# for Windows: splitting command if java_cmd is a full path
- if (!basename(java_cmd) == java_cmd)
+ if (!basename(java_cmd) == java_cmd) {
java_cmd <- c("/R", dirname(java_cmd), basename(java_cmd))
+ }
java_path <- system2("where", java_cmd, stdout = TRUE, stderr = TRUE)
}
diff --git a/R/javastics_path.R b/R/javastics_path.R
index 210bb2fd..839961d7 100644
--- a/R/javastics_path.R
+++ b/R/javastics_path.R
@@ -9,9 +9,7 @@
#'
# @examples
get_javastics_path <- function() {
-
attr(exists_javastics_path(), "path")
-
}
@@ -28,7 +26,6 @@ get_javastics_path <- function() {
#'
# @examples
set_javastics_path <- function(javastics_path, write = FALSE) {
-
if (!dir.exists(javastics_path)) {
stop(javastics_path, ": is not an existing path, aborting !")
}
@@ -36,7 +33,6 @@ set_javastics_path <- function(javastics_path, write = FALSE) {
Sys.setenv(javastics_path = javastics_path)
if (write) write_javastics_path(javastics_path)
-
}
@@ -52,7 +48,6 @@ set_javastics_path <- function(javastics_path, write = FALSE) {
#'
# @examples
exists_javastics_path <- function() {
-
path <- Sys.getenv("javastics_path")
path_exists <- TRUE
@@ -62,7 +57,6 @@ exists_javastics_path <- function() {
attr(path_exists, "path") <- path
return(path_exists)
-
}
@@ -78,15 +72,16 @@ exists_javastics_path <- function() {
#'
# @examples
write_javastics_path <- function(javastics_path) {
-
renviron_path <- file.path(path.expand("~"), ".Renviron")
env_string <- paste0('javastics_path="', javastics_path, '"')
if (file.exists(renviron_path)) {
- content <- readLines(renviron_path)
- idx <- grep(pattern = "^javastics_path",
- x = content)
- content[idx] <- env_string
+ content <- readLines(renviron_path)
+ idx <- grep(
+ pattern = "^javastics_path",
+ x = content
+ )
+ content[idx] <- env_string
} else {
content <- env_string
}
diff --git a/R/manage_stics_versions.R b/R/manage_stics_versions.R
index 1f683cbf..5bd72d83 100644
--- a/R/manage_stics_versions.R
+++ b/R/manage_stics_versions.R
@@ -13,7 +13,6 @@
#' @noRd
#'
get_svn_identifiers <- function() {
-
# logged user identifiers !
# linux : ~/.subversion/auth/svn.simple/cf86c1bb672ad0bf1613d66194e04e91
@@ -42,8 +41,8 @@ get_svn_identifiers <- function() {
#' @examples
#' \dontrun{
#' download_csv_files(
-#' branch_url = "https://w3.avignon.inra.fr/svn/modulostics/branches/branch10",
-#' dest_dir = system.file("extdata", package = "SticsRFiles")
+#' branch_url = "https://w3.avignon.inra.fr/svn/modulostics/branches/branch10",
+#' dest_dir = system.file("extdata", package = "SticsRFiles")
#' )
#' }
download_csv_files <- function(branch_url,
@@ -87,8 +86,8 @@ download_csv_files <- function(branch_url,
file_path[[f]] <- try(
curl::curl_download(file_url[f],
- handle = h,
- destfile = dest_file
+ handle = h,
+ destfile = dest_file
),
TRUE
)
@@ -96,8 +95,9 @@ download_csv_files <- function(branch_url,
err_idx <- unlist(lapply(file_path, function(x) class(x) == "try-error"))
- if (any(err_idx) && verbose)
+ if (any(err_idx) && verbose) {
warning("A least one file does not exist on the server !")
+ }
file_path[err_idx] <- NA
@@ -147,7 +147,6 @@ add_stics_version <- function(version_name,
location = "install",
overwrite = FALSE,
verbose = TRUE) {
-
# Taking only into account adding or overwriting csv files :
# inputs.csv, outouts.csv
# and updating csv file stics_versions_info.csv gathering by version
@@ -176,10 +175,11 @@ add_stics_version <- function(version_name,
# Getting csv files from repos (branch or tag url) or overwriting them
download_csv_files(url,
- dir_path,
- file_name = file_name,
- overwrite = overwrite,
- verbose = verbose)
+ dir_path,
+ file_name = file_name,
+ overwrite = overwrite,
+ verbose = verbose
+ )
# Writing data updated with new version information (about csv files location)
@@ -190,11 +190,14 @@ add_stics_version <- function(version_name,
verbose = verbose
)
- if (verbose)
- message(paste0(version_name,
- " successfully set in SticsRFiles ",
- location,
- ".\n"))
+ if (verbose) {
+ message(paste0(
+ version_name,
+ " successfully set in SticsRFiles ",
+ location,
+ ".\n"
+ ))
+ }
}
@@ -232,7 +235,6 @@ remove_stics_version <- function(version_name,
delete_files = TRUE,
location = "install",
verbose = TRUE) {
-
# Getting existing data about versions
versions_info <- get_versions_info(location = location)
@@ -291,16 +293,20 @@ remove_stics_version <- function(version_name,
#' get_data_dir(location = "package")
#' }
get_data_dir <- function(location = "install") {
- if (location == "install")
+ if (location == "install") {
dest_dir <- system.file("extdata", package = "SticsRFiles")
+ }
if (location == "package") {
proj_dir <- rstudioapi::getActiveProject()
- pkg <- gsub(pattern = "\\.Rproj$",
- x = list.files(pattern = "\\.Rproj$", proj_dir),
- replacement = "")
- if (base::is.null(proj_dir) || pkg != "SticsRFiles")
+ pkg <- gsub(
+ pattern = "\\.Rproj$",
+ x = list.files(pattern = "\\.Rproj$", proj_dir),
+ replacement = ""
+ )
+ if (base::is.null(proj_dir) || pkg != "SticsRFiles") {
stop("Load the project SticsRFiles before proceeding !")
+ }
dest_dir <- file.path(proj_dir, "inst", "extdata")
}
@@ -328,9 +334,11 @@ get_data_dir <- function(location = "install") {
#' get_versions_file_path(location = "package")
#' }
get_versions_file_path <- function(location = "install") {
- file.path(get_data_dir(location = location),
- "versions",
- get_versions_file_name())
+ file.path(
+ get_data_dir(location = location),
+ "versions",
+ get_versions_file_name()
+ )
}
@@ -370,14 +378,13 @@ update_stics_version <- function(version_name,
file_name = "all",
location = "install",
verbose = FALSE) {
-
# Forcing csv files overwriting
add_stics_version(version_name,
- url,
- file_name = file_name,
- location = location,
- overwrite = TRUE,
- verbose = verbose
+ url,
+ file_name = file_name,
+ location = location,
+ overwrite = TRUE,
+ verbose = verbose
)
}
@@ -405,7 +412,6 @@ set_versions_info <- function(version_name,
location = "install",
overwrite = FALSE,
verbose = TRUE) {
-
# Setting file output flag
write_file <- TRUE
diff --git a/R/read_params_table.R b/R/read_params_table.R
index 36adb5bb..d2b7a174 100644
--- a/R/read_params_table.R
+++ b/R/read_params_table.R
@@ -31,9 +31,11 @@ read_params_table <- function(file, sheet_name = NULL,
char_na = "NA",
file_path = lifecycle::deprecated()) {
if (lifecycle::is_present(file_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "read_params_table(file_path)",
- "read_params_table(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "read_params_table(file_path)",
+ "read_params_table(file)"
+ )
} else {
file_path <- file # to remove when we update inside the function
}
@@ -84,9 +86,10 @@ read_params_table <- function(file, sheet_name = NULL,
},
{
out_table <- readxl::read_excel(file_path,
- sheet = sheet_name,
- trim_ws = TRUE,
- col_types = "text")
+ sheet = sheet_name,
+ trim_ws = TRUE,
+ col_types = "text"
+ )
}
)
@@ -138,10 +141,11 @@ replace_na <- function(in_df, replacement) {
return(in_df)
}
- idx_col_has_na <- unlist(lapply(in_df, function(x) {
- any(is.na(x))
- }),
- use.names = FALSE
+ idx_col_has_na <- unlist(
+ lapply(in_df, function(x) {
+ any(is.na(x))
+ }),
+ use.names = FALSE
)
to_be_treated <- which(idx_type_col & idx_col_has_na)
diff --git a/R/remove_node_from_doc.R b/R/remove_node_from_doc.R
index b5794f4c..4f0e4c6f 100644
--- a/R/remove_node_from_doc.R
+++ b/R/remove_node_from_doc.R
@@ -40,7 +40,6 @@ remove_node_from_doc <- function(xml_doc, param_name,
parent_name = NULL,
remove_parent = FALSE,
nodes_ids = NULL) {
-
# Getting the node xpath
xpath_node <- get_param_type(
xml_doc = xml_doc,
@@ -84,5 +83,4 @@ remove_node_from_doc <- function(xml_doc, param_name,
# Removing nodes from the document object
XML::removeNodes(xml_nodes[nodes_ids])
-
}
diff --git a/R/remove_parent_from_doc.R b/R/remove_parent_from_doc.R
index aed5e2f9..79a7c2f9 100644
--- a/R/remove_parent_from_doc.R
+++ b/R/remove_parent_from_doc.R
@@ -1,4 +1,3 @@
-
#' Remove parent node of a parameter
#'
#' @description Remove a parent node from an XML file.
@@ -15,7 +14,8 @@
#'
#' # removing all the parent nodes the parameter belongs to
#' remove_parent_from_doc(tec_doc,
-#' param_name = "julapI_or_sum_upvt")
+#' param_name = "julapI_or_sum_upvt"
+#' )
#'
#' # removing some of the parent nodes the parameter belongs to
#' remove_parent_from_doc(tec_doc,
@@ -37,5 +37,4 @@ remove_parent_from_doc <- function(xml_doc,
remove_parent = TRUE,
nodes_ids = nodes_ids
)
-
}
diff --git a/R/replace_string_in_file.R b/R/replace_string_in_file.R
index a020d323..4676d0a7 100644
--- a/R/replace_string_in_file.R
+++ b/R/replace_string_in_file.R
@@ -27,15 +27,17 @@ replace_string_in_file <- function(file_path,
in_place <- ""
redirect <- paste(" >", new_file_path)
}
- cmd <- paste0("perl -p",
- in_place,
- " -e 's/",
- target_string,
- "/",
- replace_string,
- "/g ' ",
- file_path,
- redirect)
+ cmd <- paste0(
+ "perl -p",
+ in_place,
+ " -e 's/",
+ target_string,
+ "/",
+ replace_string,
+ "/g ' ",
+ file_path,
+ redirect
+ )
system(cmd)
}
diff --git a/R/replace_txt_param_value.R b/R/replace_txt_param_value.R
index 49a81611..f040113f 100644
--- a/R/replace_txt_param_value.R
+++ b/R/replace_txt_param_value.R
@@ -17,7 +17,6 @@ replace_txt_param_value <- function(file_path,
param_tag,
param_value,
out_file_path = NULL) {
-
# default values for redirecting output to another file, or other files
# if several values and several output files !
redir <- paste0(" > ", out_file_path)
@@ -44,16 +43,18 @@ replace_txt_param_value <- function(file_path,
param_tag <- gsub(":", "", param_tag)
# character vector of system commands
- cmd <- paste0("sed ",
- opt,
- "'/\\b",
- param_tag,
- "\\b/{n;s/.*/",
- as.character(param_value),
- "/}'",
- " ",
- file_path,
- redir)
+ cmd <- paste0(
+ "sed ",
+ opt,
+ "'/\\b",
+ param_tag,
+ "\\b/{n;s/.*/",
+ as.character(param_value),
+ "/}'",
+ " ",
+ file_path,
+ redir
+ )
lapply(cmd, function(x) system(x, intern = TRUE))
@@ -61,14 +62,19 @@ replace_txt_param_value <- function(file_path,
# 1- in place against a temporary file
# 2- with one or several output files
# diff for a file or several files
- diff_files <- lapply(new,
- function(x) {
- system(paste("diff",
- old,
- x,
- "| wc -l"),
- intern = TRUE)
- }
+ diff_files <- lapply(
+ new,
+ function(x) {
+ system(
+ paste(
+ "diff",
+ old,
+ x,
+ "| wc -l"
+ ),
+ intern = TRUE
+ )
+ }
)
diff_files <- as.numeric(diff_files)
diff --git a/R/set_file_executable.R b/R/set_file_executable.R
index 023cf484..128d0a03 100644
--- a/R/set_file_executable.R
+++ b/R/set_file_executable.R
@@ -24,16 +24,18 @@ set_file_executable <- function(file_path) {
# if OS != windows, set chmod +x exe
ret <- suppressWarnings(system(paste("chmod +x", file_path),
- intern = TRUE,
- ignore.stdout = FALSE,
- ignore.stderr = FALSE
+ intern = TRUE,
+ ignore.stdout = FALSE,
+ ignore.stderr = FALSE
))
# Checking if any errors
status <- attr(ret, "status")
if (!base::is.null(status) && status) {
- warning(paste("A problem occurs when setting executable status on:",
- file_path))
+ warning(paste(
+ "A problem occurs when setting executable status on:",
+ file_path
+ ))
return(invisible(FALSE))
}
diff --git a/R/set_java_workspace.R b/R/set_java_workspace.R
index 6586860f..f93084cf 100644
--- a/R/set_java_workspace.R
+++ b/R/set_java_workspace.R
@@ -22,8 +22,6 @@
#'
set_java_workspace <- function(javastics, workspace) {
-
-
# checking javastics path
check_java_path(javastics)
@@ -58,12 +56,12 @@ set_java_workspace <- function(javastics, workspace) {
if (base::is.null(current_wd)) {
n <- XML::xmlParseString(
paste0("", workspace, "")
- )
+ )
add_nodes(xml_pref, n)
} else {
# if it's not different from the new one,
if (current_wd == workspace ||
- (dirname(workspace) == javastics) &&
+ (dirname(workspace) == javastics) &&
basename(workspace) == current_wd) {
return()
}
diff --git a/R/set_param_txt.R b/R/set_param_txt.R
index 3bf6a631..1bb8ded7 100644
--- a/R/set_param_txt.R
+++ b/R/set_param_txt.R
@@ -56,8 +56,10 @@
#' set_param_txt(workspace = path, param = "durvieF", value = 245)
#'
#' # Change the value of durvieF for another variety:
-#' set_param_txt(workspace = path, param = "durvieF",
-#' variety = "Nefer", value = 178)
+#' set_param_txt(
+#' workspace = path, param = "durvieF",
+#' variety = "Nefer", value = 178
+#' )
#' # Change the value of soil parameter "cailloux" for all layers
#' # or a specific one
#' set_param_txt(workspace = path, param = "cailloux", value = 1)
@@ -68,8 +70,6 @@
#' set_param_txt(workspace = path, param = "amount", value = 50)
#' set_param_txt(workspace = path, param = "amount", value_id = 2, value = 40)
#'
-#'
-#'
set_param_txt <- function(workspace,
param,
value,
@@ -82,7 +82,6 @@ set_param_txt <- function(workspace,
add = lifecycle::deprecated(),
plant = lifecycle::deprecated(),
layer = lifecycle::deprecated()) {
-
# dirpath
if (lifecycle::is_present(dirpath)) {
lifecycle::deprecate_warn(
@@ -133,14 +132,18 @@ set_param_txt <- function(workspace,
stics_version = stics_version
)
- if (length(param_val) == 0)
- stop("Unknown parameter: ", param, "\n",
- "Check case sensitivity or ",
- "use get_param_info for searching the exact name")
+ if (length(param_val) == 0) {
+ stop(
+ "Unknown parameter: ", param, "\n",
+ "Check case sensitivity or ",
+ "use get_param_info for searching the exact name"
+ )
+ }
file_param_list <- lapply(
strsplit(names(param_val), "\\$"), function(x) {
- x[1] }
+ x[1]
+ }
)
file_type <- file_param_list %>%
@@ -154,89 +157,97 @@ set_param_txt <- function(workspace,
)
}
switch(file_type,
- ini = {
- set_ini_txt(
- file = file.path(dirpath, "ficini.txt"),
- param = param, value = value, append = add,
- plant_id = plant, layer = value_id,
- stics_version = stics_version
- )
- },
- general = {
- set_general_txt(
- file = file.path(dirpath, "tempopar.sti"),
- param = param, value = value, append = add
- )
- },
- tmp = {
- set_tmp_txt(
- file = file.path(dirpath, "tempoparV6.sti"),
- param = param, value = value, append = add
- )
- },
- soil = {
- set_soil_txt(
- file = file.path(dirpath, "param.sol"),
- param = param,
- value = value,
- layer = value_id,
- stics_version = stics_version
- )
- },
- usm = {
- set_usm_txt(
- file = file.path(dirpath, "new_travail.usm"),
- param = param, value = value
- )
- },
- station = {
- set_station_txt(
- file = file.path(dirpath, "station.txt"),
- param = param, value = value, append = add
- )
- },
- tec = {
- lapply(plant, function(x) {
- set_tec_txt(
- file = file.path(dirpath, paste0("fictec", x, ".txt")),
- param = param, value = value, append = add,
- value_id = value_id
- )
- })
- },
- plant = {
- lapply(plant, function(x) {
- if (is.null(variety)) {
- variety <-
- unlist(get_param_txt(workspace = dirpath,
- param = "variete",
- exact = TRUE,
- stics_version = stics_version))[plant]
- } else {
- if (is.character(variety)) {
- varieties <-
- get_plant_txt(file = file.path(dirpath,
- paste0("ficplt",
- x,
- ".txt")))$codevar
- variety <- match(variety, varieties)
- if (is.na(variety)) {
- cli::cli_alert_danger(
- paste0("Variety not found in plant",
- "file. Possible varieties are: ",
- "{.val {varieties}}")
- )
- return()
- }
- }
- }
- set_plant_txt(
- file = file.path(dirpath, paste0("ficplt", x, ".txt")),
- param = param, value = value, append = add, variety = variety
- )
- })
- },
- stop("Parameter not found")
+ ini = {
+ set_ini_txt(
+ file = file.path(dirpath, "ficini.txt"),
+ param = param, value = value, append = add,
+ plant_id = plant, layer = value_id,
+ stics_version = stics_version
+ )
+ },
+ general = {
+ set_general_txt(
+ file = file.path(dirpath, "tempopar.sti"),
+ param = param, value = value, append = add
+ )
+ },
+ tmp = {
+ set_tmp_txt(
+ file = file.path(dirpath, "tempoparV6.sti"),
+ param = param, value = value, append = add
+ )
+ },
+ soil = {
+ set_soil_txt(
+ file = file.path(dirpath, "param.sol"),
+ param = param,
+ value = value,
+ layer = value_id,
+ stics_version = stics_version
+ )
+ },
+ usm = {
+ set_usm_txt(
+ file = file.path(dirpath, "new_travail.usm"),
+ param = param, value = value
+ )
+ },
+ station = {
+ set_station_txt(
+ file = file.path(dirpath, "station.txt"),
+ param = param, value = value, append = add
+ )
+ },
+ tec = {
+ lapply(plant, function(x) {
+ set_tec_txt(
+ file = file.path(dirpath, paste0("fictec", x, ".txt")),
+ param = param, value = value, append = add,
+ value_id = value_id
+ )
+ })
+ },
+ plant = {
+ lapply(plant, function(x) {
+ if (is.null(variety)) {
+ variety <-
+ unlist(get_param_txt(
+ workspace = dirpath,
+ param = "variete",
+ exact = TRUE,
+ stics_version = stics_version
+ ))[plant]
+ } else {
+ if (is.character(variety)) {
+ varieties <-
+ get_plant_txt(file = file.path(
+ dirpath,
+ paste0(
+ "ficplt",
+ x,
+ ".txt"
+ )
+ ))$codevar
+ variety <- match(variety, varieties)
+ if (is.na(variety)) {
+ cli::cli_alert_danger(
+ paste0(
+ "Variety not found in plant",
+ "file. Possible varieties are: ",
+ "{.val {varieties}}"
+ )
+ )
+ return()
+ }
+ }
+ }
+ set_plant_txt(
+ file = file.path(dirpath, paste0("ficplt", x, ".txt")),
+ param = param, value = value, append = add, variety = variety
+ )
+ })
+ },
+ stop("Parameter not found")
)
invisible()
}
@@ -250,7 +261,6 @@ set_usm_txt <- function(file = "new_travail.usm",
append = FALSE,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -281,7 +291,6 @@ set_station_txt <- function(file = "station.txt",
append = FALSE,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -316,7 +325,6 @@ set_ini_txt <- function(file = "ficini.txt",
stics_version = "latest",
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -337,9 +345,9 @@ set_ini_txt <- function(file = "ficini.txt",
}
set_file_txt(filepath, param, value, add,
- plant_id = plant_id,
- value_id = layer,
- stics_version = stics_version
+ plant_id = plant_id,
+ value_id = layer,
+ stics_version = stics_version
)
}
@@ -352,7 +360,6 @@ set_general_txt <- function(file = "tempopar.sti",
append = FALSE,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -384,7 +391,6 @@ set_tmp_txt <- function(file = "tempoparv6.sti",
append = FALSE,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -417,7 +423,6 @@ set_plant_txt <- function(file = "ficplt1.txt",
variety = NULL,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -449,7 +454,6 @@ set_tec_txt <- function(file = "fictec1.txt",
value_id = NULL,
filepath = lifecycle::deprecated(),
add = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -469,11 +473,13 @@ set_tec_txt <- function(file = "fictec1.txt",
add <- append # to remove when we update inside the function
}
- set_file_txt(file = filepath,
- param = param,
- value = value,
- append = add,
- value_id = value_id)
+ set_file_txt(
+ file = filepath,
+ param = param,
+ value = value,
+ append = add,
+ value_id = value_id
+ )
}
#' @rdname set_param_txt
@@ -484,7 +490,6 @@ set_soil_txt <- function(file = "param.sol",
layer = NULL,
stics_version = "latest",
filepath = lifecycle::deprecated()) {
-
# filepath
if (lifecycle::is_present(filepath)) {
lifecycle::deprecate_warn(
@@ -500,16 +505,20 @@ set_soil_txt <- function(file = "param.sol",
param <- paste0("^", param, "$")
if (!is.null(layer)) {
- check_param_dim(param = param,
- file_value = ref[[grep(param, names(ref))]],
- value_id = layer,
- value = value)
+ check_param_dim(
+ param = param,
+ file_value = ref[[grep(param, names(ref))]],
+ value_id = layer,
+ value = value
+ )
ref[[grep(param, names(ref))]][layer] <- format(value, scientific = FALSE)
} else {
- if(length(value) > 1) {
- check_param_dim(param = param,
- file_value = ref[[grep(param, names(ref))]],
- value = value)
+ if (length(value) > 1) {
+ check_param_dim(
+ param = param,
+ file_value = ref[[grep(param, names(ref))]],
+ value = value
+ )
}
ref[[grep(param, names(ref))]][] <- format(value, scientific = FALSE)
}
@@ -538,36 +547,39 @@ set_soil_txt <- function(file = "param.sol",
writeLines(line, filepath)
- write(paste(
- " ", " ", " ", ref$numsol[1], " ", " ", " ",
- ref$codecailloux, ref$codemacropor,
- ref$codefente, ref$codrainage, ref$coderemontcap,
- ref$codenitrif, ref$codedenit
- ),
- filepath,
- append = TRUE
- )
-
- write(paste(
- " ", " ", " ", ref$numsol[1], " ", " ", " ", ref$profimper,
- ref$ecartdrain, ref$ksol,
- ref$profdrain, ref$capiljour, ref$humcapil,
- ref$profdenit, ref$vpotdenit
- ),
- filepath,
- append = TRUE
+ write(
+ paste(
+ " ", " ", " ", ref$numsol[1], " ", " ", " ",
+ ref$codecailloux, ref$codemacropor,
+ ref$codefente, ref$codrainage, ref$coderemontcap,
+ ref$codenitrif, ref$codedenit
+ ),
+ filepath,
+ append = TRUE
)
- for (icou in 1:5) {
- write(paste(
- " ", " ", " ", ref$numsol[1], " ", " ", " ",
- ref$epc[icou], ref$hccf[icou],
- ref$hminf[icou], ref$DAF[icou], ref$cailloux[icou],
- ref$typecailloux[icou], ref$infil[icou],
- ref$epd[icou]
+ write(
+ paste(
+ " ", " ", " ", ref$numsol[1], " ", " ", " ", ref$profimper,
+ ref$ecartdrain, ref$ksol,
+ ref$profdrain, ref$capiljour, ref$humcapil,
+ ref$profdenit, ref$vpotdenit
),
filepath,
append = TRUE
+ )
+
+ for (icou in 1:5) {
+ write(
+ paste(
+ " ", " ", " ", ref$numsol[1], " ", " ", " ",
+ ref$epc[icou], ref$hccf[icou],
+ ref$hminf[icou], ref$DAF[icou], ref$cailloux[icou],
+ ref$typecailloux[icou], ref$infil[icou],
+ ref$epd[icou]
+ ),
+ filepath,
+ append = TRUE
)
}
}
@@ -623,130 +635,148 @@ set_file_txt <- function(file,
params <- readLines(file)
param_ <- paste0("^:{0,1}", param, "$")
switch(type,
- set_usm_txt = {
- ref <- get_usm_txt(file)
- if (grep(param_, names(ref)) < grep("fplt", names(ref))) {
- ref_index <- grep(param_, names(ref)) * 2
- } else {
- ref_index <- grep(param_, params) + 1
- }
- },
- set_station_txt = {
- ref <- get_station_txt(file)
- ref_index <- grep(param_, names(ref)) * 2
- },
- set_ini_txt = {
- ref <- get_ini_txt(file, stics_version = stics_version)
-
- # fix plant id if param is attached to a plant
- if (is.null(plant_id) &&
- (param %in% names(ref$plant$plant1))) {
- plant_id <- 1
- }
-
- # changing param value in ref
- if (is.null(plant_id)) {
- if (is.null(value_id)) {
- if (length(value) > 1){
- check_param_dim(param = param,
- file_value = ref[[param]],
- value = value)
- }
- # all values take the same now
- ref[[param]][] <- value
- } else {
- # check layers idx
- # and values number
- check_param_dim(param = param,
- file_value = ref[[param]],
- value_id = value_id,
- value = value)
- ref[[param]][[value_id]] <- value
- }
- } else {
- plt_tag <- paste0("plant", plant_id)
- if (is.null(value_id)) {
- if (length(value) > 1) {
- check_param_dim(param = param,
- file_value = ref$plant[[plt_tag]][[param]],
- value = value)
- }
- # all values take the same now
- ref$plant[[plt_tag]][[param]][] <- value
- } else {
- check_param_dim(param = param,
- file_value = ref$plant[[plt_tag]][[param]],
- value_id = value_id,
- value = value)
- ref$plant[[plt_tag]][[param]][value_id] <- value
- }
- }
-
- value <- list_to_character_vector(ref)
-
- # rows index according to version
- ref_index <- get_ini_val_idx(stics_version)
- },
- set_plant_txt = {
- ref_index <- grep(param_, params) + 1
- if (!is.null(variety) & length(ref_index) > 1) {
- if (length(ref_index) >= variety) {
- ref_index <- ref_index[variety]
- } else {
- stop("Variety number set in the tec file is superior",
- "to the number of varieties defined in the plant file.")
- }
- }
- },
- set_tec_txt = {
- ref <- get_tec_txt(file, stics_version = stics_version)
- # add treatment for getting lines
- # add index on the line for the parameters when several
- # (interventions)
- # question: replacing existing individual values and
- # modifying interventions plan (i.e. reduce irrigations nb )
-
- # getting sublist from ref, change values and
- # transform to text and replace using lines index !
- idx_lines <- grep(param, params)
-
- # Getting par names on one line
- line_param <- unlist(strsplit(params[idx_lines[1]], split = " "))
-
- lines_values <- ref[line_param]
-
- # replacing values
- # all values with a single
- if(is.null(value_id)) {
- if (length(value) > 1) {
- check_param_dim(param = param,
- file_value = lines_values[[param]],
- value = value)
- }
- lines_values[[param]][] <- value
- } else {
- # several values for specific ids
- check_param_dim(param = param,
- file_value = lines_values[[param]],
- value_id = value_id,
- value = value)
- lines_values[[param]][value_id] <- value
- }
-
- df_lines_values <- as.data.frame(
- lapply(lines_values, as.character), stringsAsFactors = FALSE)
-
- # Values of parameters to replace in params at idx_lines + 1
- value <- apply(df_lines_values,
- 1,
- function(x) paste(x, collapse = " "))
-
- ref_index <- idx_lines + 1
- },
- # Default here
- {
- ref_index <- grep(param_, params) + 1
- }
+ set_usm_txt = {
+ ref <- get_usm_txt(file)
+ if (grep(param_, names(ref)) < grep("fplt", names(ref))) {
+ ref_index <- grep(param_, names(ref)) * 2
+ } else {
+ ref_index <- grep(param_, params) + 1
+ }
+ },
+ set_station_txt = {
+ ref <- get_station_txt(file)
+ ref_index <- grep(param_, names(ref)) * 2
+ },
+ set_ini_txt = {
+ ref <- get_ini_txt(file, stics_version = stics_version)
+
+ # fix plant id if param is attached to a plant
+ if (is.null(plant_id) &&
+ (param %in% names(ref$plant$plant1))) {
+ plant_id <- 1
+ }
+
+ # changing param value in ref
+ if (is.null(plant_id)) {
+ if (is.null(value_id)) {
+ if (length(value) > 1) {
+ check_param_dim(
+ param = param,
+ file_value = ref[[param]],
+ value = value
+ )
+ }
+ # all values take the same now
+ ref[[param]][] <- value
+ } else {
+ # check layers idx
+ # and values number
+ check_param_dim(
+ param = param,
+ file_value = ref[[param]],
+ value_id = value_id,
+ value = value
+ )
+ ref[[param]][[value_id]] <- value
+ }
+ } else {
+ plt_tag <- paste0("plant", plant_id)
+ if (is.null(value_id)) {
+ if (length(value) > 1) {
+ check_param_dim(
+ param = param,
+ file_value = ref$plant[[plt_tag]][[param]],
+ value = value
+ )
+ }
+ # all values take the same now
+ ref$plant[[plt_tag]][[param]][] <- value
+ } else {
+ check_param_dim(
+ param = param,
+ file_value = ref$plant[[plt_tag]][[param]],
+ value_id = value_id,
+ value = value
+ )
+ ref$plant[[plt_tag]][[param]][value_id] <- value
+ }
+ }
+
+ value <- list_to_character_vector(ref)
+
+ # rows index according to version
+ ref_index <- get_ini_val_idx(stics_version)
+ },
+ set_plant_txt = {
+ ref_index <- grep(param_, params) + 1
+ if (!is.null(variety) & length(ref_index) > 1) {
+ if (length(ref_index) >= variety) {
+ ref_index <- ref_index[variety]
+ } else {
+ stop(
+ "Variety number set in the tec file is superior",
+ "to the number of varieties defined in the plant file."
+ )
+ }
+ }
+ },
+ set_tec_txt = {
+ ref <- get_tec_txt(file, stics_version = stics_version)
+ # add treatment for getting lines
+ # add index on the line for the parameters when several
+ # (interventions)
+ # question: replacing existing individual values and
+ # modifying interventions plan (i.e. reduce irrigations nb )
+
+ # getting sublist from ref, change values and
+ # transform to text and replace using lines index !
+ idx_lines <- grep(param, params)
+
+ # Getting par names on one line
+ line_param <- unlist(strsplit(params[idx_lines[1]], split = " "))
+
+ lines_values <- ref[line_param]
+
+ # replacing values
+ # all values with a single
+ if (is.null(value_id)) {
+ if (length(value) > 1) {
+ check_param_dim(
+ param = param,
+ file_value = lines_values[[param]],
+ value = value
+ )
+ }
+ lines_values[[param]][] <- value
+ } else {
+ # several values for specific ids
+ check_param_dim(
+ param = param,
+ file_value = lines_values[[param]],
+ value_id = value_id,
+ value = value
+ )
+ lines_values[[param]][value_id] <- value
+ }
+
+ df_lines_values <- as.data.frame(
+ lapply(lines_values, as.character),
+ stringsAsFactors = FALSE
+ )
+
+ # Values of parameters to replace in params at idx_lines + 1
+ value <- apply(
+ df_lines_values,
+ 1,
+ function(x) paste(x, collapse = " ")
+ )
+
+ ref_index <- idx_lines + 1
+ },
+ # Default here
+ {
+ ref_index <- grep(param_, params) + 1
+ }
)
if (!length(ref_index) > 0) {
@@ -831,7 +861,6 @@ check_param_dim <- function(param,
file_value,
value_id = NULL,
value = NULL) {
-
file_val_nb <- length(file_value)
if (is.null(value_id)) {
max_id <- file_val_nb
@@ -840,34 +869,41 @@ check_param_dim <- function(param,
max_id <- max(value_id)
}
- if (max_id > file_val_nb)
- stop("for ", param, " parameter values replacement\n",
- "the maximum number of values to be replaced in the file (",
- file_val_nb,
- ") ",
- "exceeds with the maximum of given id (",
- max_id,
- ")")
+ if (max_id > file_val_nb) {
+ stop(
+ "for ", param, " parameter values replacement\n",
+ "the maximum number of values to be replaced in the file (",
+ file_val_nb,
+ ") ",
+ "exceeds with the maximum of given id (",
+ max_id,
+ ")"
+ )
+ }
# no more checks
- if (is.null(value)) return(invisible())
+ if (is.null(value)) {
+ return(invisible())
+ }
# checking replacing value
replace_val_nb <- length(value)
- if (file_val_nb == replace_val_nb) return(invisible())
+ if (file_val_nb == replace_val_nb) {
+ return(invisible())
+ }
if (!is.null(value_id)) {
replace_val_id_nb <- length(value_id)
- if (replace_val_id_nb == replace_val_nb)
+ if (replace_val_id_nb == replace_val_nb) {
return(invisible())
-
+ }
}
- stop("for ", param, " parameter values replacement\n",
- "the number of values to be replaced in the file (", replace_val_nb, ") ",
- "is not consistent with the given values' ids (", replace_val_id_nb,
- ")")
-
+ stop(
+ "for ", param, " parameter values replacement\n",
+ "the number of values to be replaced in the file (", replace_val_nb, ") ",
+ "is not consistent with the given values' ids (", replace_val_id_nb,
+ ")"
+ )
}
-
diff --git a/R/set_param_value.R b/R/set_param_value.R
index 7fcd05c8..53b840cb 100644
--- a/R/set_param_value.R
+++ b/R/set_param_value.R
@@ -49,8 +49,6 @@ set_param_value <- function(xml_doc,
parent_name = NULL,
parent_sel_attr = NULL,
...) {
-
-
# Calling the for several parameters
param_nb <- length(param_name)
diff --git a/R/set_param_xml.R b/R/set_param_xml.R
index 9c3857f4..eedc69d7 100644
--- a/R/set_param_xml.R
+++ b/R/set_param_xml.R
@@ -49,13 +49,14 @@
#' # get_param_xml(sol_path, "argi")
#'
#' # Setting a specific value to "argi" for "solcanne" soil
-#' set_param_xml(file = sol_path, param = "argi", values = 56,
-#' select = "sol", select_value = "solcanne", overwrite = TRUE
+#' set_param_xml(
+#' file = sol_path, param = "argi", values = 56,
+#' select = "sol", select_value = "solcanne", overwrite = TRUE
#' )
#' # Getting changed values
#' # get_param_xml(sol_path, "argi",
#' # select = "sol", select_value = "solcanne"
-#' #)
+#' # )
#'
#'
#' # Setting a specific values to 2 parameters "argi" and
@@ -66,7 +67,7 @@
#' # Getting changed values
#' # get_param_xml(sol_path, c("argi", "norg"),
#' # select = "sol", select_value = "solcanne"
-#' #)
+#' # )
#'
#'
#' # For vector parameters per soil (5 values, one per soil layer)
@@ -88,9 +89,9 @@
#' select = "sol",
#' select_value = "solcanne",
#' values = c(46.8, 48.5, 50.1),
-#' value_id = c(1,3,5),
+#' value_id = c(1, 3, 5),
#' overwrite = TRUE
-#' )
+#' )
#'
#' # Getting changed values
#' # get_param_xml(sol_path, "HCCF",
@@ -110,7 +111,6 @@
#' # Getting changed values
#' # get_param_xml(tec_path, c("julapI_or_sum_upvt", "amount"))
#'
-#'
#' @export
set_param_xml <- function(file,
param,
@@ -126,40 +126,49 @@ set_param_xml <- function(file,
param_value = lifecycle::deprecated(),
value = lifecycle::deprecated(),
...) {
-
# ... argument for passing : ids, show_xpath to get_param_value
if (lifecycle::is_present(xml_file)) {
- lifecycle::deprecate_warn("1.0.0",
- "set_param_xml(xml_file)",
- "set_param_xml(file)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "set_param_xml(xml_file)",
+ "set_param_xml(file)"
+ )
} else {
xml_file <- file # to remove when we update inside the function
}
if (lifecycle::is_present(out_path)) {
- lifecycle::deprecate_warn("1.0.0",
- "set_param_xml(out_path)",
- "set_param_xml(save_as)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "set_param_xml(out_path)",
+ "set_param_xml(save_as)"
+ )
} else {
out_path <- save_as # to remove when we update inside the function
}
if (lifecycle::is_present(param_name)) {
- lifecycle::deprecate_warn("1.0.0",
- "set_param_xml(param_name)",
- "set_param_xml(param)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "set_param_xml(param_name)",
+ "set_param_xml(param)"
+ )
} else {
param_name <- param # to remove when we update inside the function
}
if (lifecycle::is_present(param_value)) {
- lifecycle::deprecate_warn("1.0.0",
- "set_param_xml(param_value)",
- "set_param_xml(values)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "set_param_xml(param_value)",
+ "set_param_xml(values)"
+ )
} else {
param_value <- values # to remove when we update inside the function
}
if (lifecycle::is_present(value)) {
- lifecycle::deprecate_warn("1.0.0",
- "set_param_xml(value)",
- "set_param_xml(select_value)")
+ lifecycle::deprecate_warn(
+ "1.0.0",
+ "set_param_xml(value)",
+ "set_param_xml(select_value)"
+ )
} else {
value <- select_value # to remove when we update inside the function
}
@@ -204,12 +213,12 @@ set_param_xml <- function(file,
# Setting parameters values in the xmlDoxument object
set_param_value(xml_doc,
- param_name = param_name,
- param_value = param_value,
- parent_name = select,
- parent_sel_attr = value,
- ids = value_id,
- ...
+ param_name = param_name,
+ param_value = param_value,
+ parent_name = select,
+ parent_sel_attr = value,
+ ids = value_id,
+ ...
)
diff --git a/R/set_sols_param_xml.R b/R/set_sols_param_xml.R
index 0e51d46a..71af7b73 100644
--- a/R/set_sols_param_xml.R
+++ b/R/set_sols_param_xml.R
@@ -11,8 +11,10 @@
#' xml_path <- file.path(get_examples_path(file_type = "xml"), "sols.xml")
#' sols_doc <- xmldocument(xml_path)
#'
-#' xl_path <- file.path(get_examples_path(file_type = "xl"),
-#' "inputs_stics_example.xlsx")
+#' xl_path <- file.path(
+#' get_examples_path(file_type = "xl"),
+#' "inputs_stics_example.xlsx"
+#' )
#' sols_df <- read_excel(xl_path, sheet = "Soils")
#'
#' # For updating an existing xml doc (using existing soils names)
@@ -120,7 +122,7 @@ set_sols_param_xml <- function(xml_doc, sols_param, overwrite = FALSE) {
# except for epc
sols_idx <- as.vector(
!grepl(pattern = "^999", par_values) & !is.na(par_values)
- )
+ )
# Filtering all parameters
if (!any(sols_idx)) next
@@ -148,5 +150,4 @@ set_sols_param_xml <- function(xml_doc, sols_param, overwrite = FALSE) {
for (p in other_params) {
set_param_value(xml_doc, p, sols_param[[p]])
}
-
}
diff --git a/R/set_usms_param_xml.R b/R/set_usms_param_xml.R
index 24073fdd..c1d5803a 100644
--- a/R/set_usms_param_xml.R
+++ b/R/set_usms_param_xml.R
@@ -10,8 +10,10 @@
#' xml_path <- file.path(get_examples_path(file_type = "xml"), "usms.xml")
#' usms_doc <- xmldocument(xml_path)
#'
-#' xl_path <- file.path(get_examples_path(file_type = "xl"),
-#' "inputs_stics_example.xlsx")
+#' xl_path <- file.path(
+#' get_examples_path(file_type = "xl"),
+#' "inputs_stics_example.xlsx"
+#' )
#' usms_df <- read_excel(xl_path, sheet = "USMs")
#'
#' # For updating an existing xml doc (using existing usms names)
diff --git a/R/stics_environment.R b/R/stics_environment.R
index 8dda630e..74da44e8 100644
--- a/R/stics_environment.R
+++ b/R/stics_environment.R
@@ -1,5 +1,3 @@
-
-
#' STICS env name
#'
#' Get the default STICS environment name
@@ -53,7 +51,7 @@ stics_env <- function(name = NULL, env_name = globalenv(), create = TRUE) {
# Checking a sub-env
exists_name <- exists(name, envir = local_stics, inherits = FALSE)
- if (exists_name) { # Returning .stics env object
+ if (exists_name) { # Returning .stics env object
return(local_stics[[name]])
}
@@ -367,7 +365,6 @@ stics_split_list <- function(name) {
#' stics_remove()
#' }
stics_remove <- function(name = NULL, env_name = sticsenv_name()) {
-
envir <- stics_get(name = env_name)
if (base::is.null(name)) {
@@ -407,7 +404,8 @@ stics_remove <- function(name = NULL, env_name = sticsenv_name()) {
list_var_names,
function(x) {
eval(parse(text = paste0("base::is.null(", x, " <- NULL)")),
- envir = envir)
+ envir = envir
+ )
}
))
ret <- all(ret)
diff --git a/R/stics_files_utils.R b/R/stics_files_utils.R
index f96f09c4..bd99e039 100644
--- a/R/stics_files_utils.R
+++ b/R/stics_files_utils.R
@@ -38,36 +38,44 @@ get_examples_path <- function(file_type, stics_version = "latest",
# If not any arguments : displaying files types list
if (missing(file_type)) {
- message("Available files types: ",
- paste(get_examples_types(), collapse = ","))
+ message(
+ "Available files types: ",
+ paste(get_examples_types(), collapse = ",")
+ )
return(invisible())
}
# Checking if all types in file_type exist
files_type_idx <- file_type %in% example_types
- if (!all(files_type_idx))
+ if (!all(files_type_idx)) {
stop("Unknown file_type: ", file_type[!files_type_idx])
+ }
# Validating the version string
version_name <- check_version_compat(version_name)
# Checking if files available for the given version
ver_data <- get_versions_info(stics_version = version_name)
- if (base::is.null(ver_data))
+ if (base::is.null(ver_data)) {
stop("No examples available for version: ", version_name)
+ }
# Getting files dir path for the given type
version_dirs <- unlist(dplyr::select(ver_data, dplyr::all_of(file_type)))
is_na_dirs <- is.na(version_dirs)
- if (any(is_na_dirs))
- stop("Not any data in examples for ",
- paste(file_type[is_na_dirs], collapse = ", "),
- " and version ", version_name)
+ if (any(is_na_dirs)) {
+ stop(
+ "Not any data in examples for ",
+ paste(file_type[is_na_dirs], collapse = ", "),
+ " and version ", version_name
+ )
+ }
files_str <- unlist(
- lapply(file_type,
- function(x) gsub(pattern = "(.*)_.*", x = x, replacement = "\\1")
+ lapply(
+ file_type,
+ function(x) gsub(pattern = "(.*)_.*", x = x, replacement = "\\1")
)
)
@@ -79,18 +87,22 @@ get_examples_path <- function(file_type, stics_version = "latest",
examples_path[i] <- ""
} else {
examples_path[i] <- normalizePath(file.path(base_path, version_dirs[i]),
- winslash = "/",
- mustWork = FALSE)
+ winslash = "/",
+ mustWork = FALSE
+ )
}
}
# Treating not existing directories for file_type
exist_ex_path <- !(examples_path == "")
- if (!all(exist_ex_path))
- warning("Not any available ",
- paste(file_type[!exist_ex_path], collapse = ", "),
- " examples for version: ",
- version_name)
+ if (!all(exist_ex_path)) {
+ warning(
+ "Not any available ",
+ paste(file_type[!exist_ex_path], collapse = ", "),
+ " examples for version: ",
+ version_name
+ )
+ }
# Returning the examples files dir path for the given type
return(invisible(examples_path))
@@ -100,21 +112,27 @@ get_examples_path <- function(file_type, stics_version = "latest",
list_examples_files <- function(file_type,
version_name = "latest",
full_names = TRUE) {
- examples_path <- get_examples_path(file_type = file_type,
- stics_version = version_name)
+ examples_path <- get_examples_path(
+ file_type = file_type,
+ stics_version = version_name
+ )
- files_list <- list.files(pattern = "\\.[a-zA-Z]+$",
- path = examples_path,
- full.names = full_names)
+ files_list <- list.files(
+ pattern = "\\.[a-zA-Z]+$",
+ path = examples_path,
+ full.names = full_names
+ )
return(files_list)
}
get_examples_types <- function() {
- file_types <- c("csv", "obs", "sti", "txt", "xml", "xl", "xml_tmpl",
- "xml_param", "xsl")
+ file_types <- c(
+ "csv", "obs", "sti", "txt", "xml", "xl", "xml_tmpl",
+ "xml_param", "xsl"
+ )
return(file_types)
}
@@ -134,18 +152,22 @@ get_examples_types <- function() {
#'
# @examples
unzip_examples <- function(files_type, version_dir, overwrite = FALSE) {
-
ex_path <- system.file("extdata",
- package = "SticsRFiles")
+ package = "SticsRFiles"
+ )
dir_path <- normalizePath(file.path(tempdir(), files_type),
- winslash = "/",
- mustWork = FALSE)
+ winslash = "/",
+ mustWork = FALSE
+ )
- if (dir.exists(dir_path) && !overwrite) return(dir_path)
+ if (dir.exists(dir_path) && !overwrite) {
+ return(dir_path)
+ }
- if (overwrite)
+ if (overwrite) {
unlink(x = dir_path, recursive = TRUE)
+ }
zip_path <- file.path(ex_path, paste0(files_type, ".zip"))
@@ -180,14 +202,15 @@ workspace_files_copy <- function(workspace,
out_dir,
overwrite = FALSE,
verbose = FALSE) {
-
# files types vector and associated regex
file_types <- c("mod", "obs", "lai", "meteo")
file_patt <- c("*.mod", "*.obs", "*.lai", "\\.[0-9]{4}$")
- file_desc <- c("output definition (*.mod)",
- "observation (*.obs)",
- "LAI dynamics (*.lai)",
- "weather data (*.YYYY)")
+ file_desc <- c(
+ "output definition (*.mod)",
+ "observation (*.obs)",
+ "LAI dynamics (*.lai)",
+ "weather data (*.YYYY)"
+ )
# if file_type is not given, all files type are processed
if (is.null(file_type)) file_type <- file_types
@@ -196,12 +219,13 @@ workspace_files_copy <- function(workspace,
if (length(file_type) > 1) {
stat_list <- vector(mode = "list", length(file_type))
for (i in seq_along(file_type)) {
- stat_list[[i]] <- workspace_files_copy(workspace = workspace,
- file_type = file_type[i],
- javastics = javastics,
- out_dir = out_dir,
- overwrite = overwrite,
- verbose = verbose
+ stat_list[[i]] <- workspace_files_copy(
+ workspace = workspace,
+ file_type = file_type[i],
+ javastics = javastics,
+ out_dir = out_dir,
+ overwrite = overwrite,
+ verbose = verbose
)
}
return(invisible(stat_list))
@@ -210,34 +234,38 @@ workspace_files_copy <- function(workspace,
# Just in case if the func is used outside of the workspace upgrade
type_idx <- file_types %in% file_type
- if (! any(type_idx)) {
+ if (!any(type_idx)) {
warning("The given file type does not exist: ", file_type, " nothing done!")
return()
}
# getting the file path list to copy
patt <- file_patt[type_idx]
- files_list <- list.files(path = workspace,
- full.names = TRUE,
- pattern = patt)
+ files_list <- list.files(
+ path = workspace,
+ full.names = TRUE,
+ pattern = patt
+ )
# Just for the *.mod files, looking in javastics if not found in the workspace
# TODO: combine both if partial match
if (length(files_list) == 0) {
if (file_type == "mod") {
-
if (is.null(javastics)) {
- warning(paste("No", "mod",
- "files in the source workspace",
- "the Javastics path must be given",
- "as input for copying files from it"))
+ warning(paste(
+ "No", "mod",
+ "files in the source workspace",
+ "the Javastics path must be given",
+ "as input for copying files from it"
+ ))
}
files_list <- list.files(
path = file.path(javastics, "example",
- full.names = TRUE,
- pattern = patt))
-
+ full.names = TRUE,
+ pattern = patt
+ )
+ )
}
}
@@ -259,12 +287,14 @@ workspace_files_copy <- function(workspace,
}
if (!all(stat)) {
- warning("Error when copying file(s): ",
- paste(basename(files_list[!stat]), collapse = ", "),
- "\nin\n",
- out_dir,
- "\n",
- "Consider to set as input: overwrite = TRUE")
+ warning(
+ "Error when copying file(s): ",
+ paste(basename(files_list[!stat]), collapse = ", "),
+ "\nin\n",
+ out_dir,
+ "\n",
+ "Consider to set as input: overwrite = TRUE"
+ )
}
return(invisible(stat))
}
diff --git a/R/upgrade_ini_xml.R b/R/upgrade_ini_xml.R
index 59e750ac..b47f3665 100644
--- a/R/upgrade_ini_xml.R
+++ b/R/upgrade_ini_xml.R
@@ -25,7 +25,7 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_ini_xml(
-#' file = file.path(dir_path,"file_ini.xml"),
+#' file = file.path(dir_path, "file_ini.xml"),
#' out_dir = tempdir(),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
#' )
@@ -38,8 +38,6 @@ upgrade_ini_xml <- function(file,
check_version = TRUE,
overwrite = FALSE,
...) {
-
-
# for verifying output dir existence
check_dir <- TRUE
args <- list(...)
@@ -57,8 +55,8 @@ upgrade_ini_xml <- function(file,
# extracting or detecting the STICS version corresponding to the xml file
# based on param_gen.xml file content
file_version <- check_xml_file_version(file[1],
- stics_version,
- param_gen_file = param_gen_file
+ stics_version,
+ param_gen_file = param_gen_file
)
@@ -112,8 +110,9 @@ upgrade_ini_xml <- function(file,
# Setting file STICS version
set_xml_file_version(old_doc,
- new_version = target_version,
- overwrite = overwrite)
+ new_version = target_version,
+ overwrite = overwrite
+ )
# Keeping old values
rm_names <- c("masec0", "QNplante0", "resperenne0")
@@ -134,10 +133,12 @@ upgrade_ini_xml <- function(file,
# (previously named resperennes0)
- str_1 <- paste0('
',
- addFinalizer = TRUE
+ addFinalizer = TRUE
)
prev_sibling <- get_nodes(
@@ -254,8 +259,9 @@ upgrade_param_newform_xml <- function(file,
# Writing to file param_newform.xml
write_xml_file(old_doc,
- file.path(out_dir, basename(file)),
- overwrite = overwrite)
+ file.path(out_dir, basename(file)),
+ overwrite = overwrite
+ )
XML::free(old_doc@content)
invisible(gc(verbose = FALSE))
diff --git a/R/upgrade_plt_xml.R b/R/upgrade_plt_xml.R
index f58a9b54..83e7eda3 100644
--- a/R/upgrade_plt_xml.R
+++ b/R/upgrade_plt_xml.R
@@ -27,7 +27,7 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_plt_xml(
-#' file = file.path(dir_path,"file_plt.xml"),
+#' file = file.path(dir_path, "file_plt.xml"),
#' out_dir = tempdir(),
#' param_newform_file = file.path(dir_path, "param_newform.xml"),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
@@ -42,9 +42,6 @@ upgrade_plt_xml <- function(file,
check_version = TRUE,
overwrite = FALSE,
...) {
-
-
-
# For verifying output dir existence
check_dir <- TRUE
args_list <- list(...)
@@ -62,8 +59,8 @@ upgrade_plt_xml <- function(file,
# extracting or detecting the STICS version corresponding to the xml file
# based on param_gen.xml file content
file_version <- check_xml_file_version(file[1],
- stics_version,
- param_gen_file = param_gen_file
+ stics_version,
+ param_gen_file = param_gen_file
)
@@ -120,8 +117,10 @@ upgrade_plt_xml <- function(file,
# Setting file STICS version
- set_xml_file_version(old_doc, new_version = target_version,
- overwrite = overwrite)
+ set_xml_file_version(old_doc,
+ new_version = target_version,
+ overwrite = overwrite
+ )
# Parameters to move to varietal parameters ----------------------------------
@@ -144,8 +143,10 @@ upgrade_plt_xml <- function(file,
nodes_to_rm <- lapply(param_names_to_varietal, function(x) {
get_nodes(
old_doc,
- path = paste0("//formalisme[@nom!='cultivar parameters']//param[@nom='",
- x, "']")
+ path = paste0(
+ "//formalisme[@nom!='cultivar parameters']//param[@nom='",
+ x, "']"
+ )
)
})
@@ -186,15 +187,21 @@ upgrade_plt_xml <- function(file,
)
# test if the node exists
- node_exists <- !is.null(get_nodes(old_doc,
- '//option[@nomParam="codephot_part"]'))
+ node_exists <- !is.null(get_nodes(
+ old_doc,
+ '//option[@nomParam="codephot_part"]'
+ ))
- if (node_exists) stop(
- "codephot_part already exists, not a v9.1 or 9.2 _plt.xml file")
+ if (node_exists) {
+ stop(
+ "codephot_part already exists, not a v9.1 or 9.2 _plt.xml file"
+ )
+ }
parent_node <- get_nodes(
old_doc,
- '//option[@nomParam="codephot"]/choix[@code="1"]')[[1]]
+ '//option[@nomParam="codephot"]/choix[@code="1"]'
+ )[[1]]
XML::addChildren(parent_node, XML::xmlClone(new_node))
@@ -211,34 +218,43 @@ upgrade_plt_xml <- function(file,
irazomax_calc <- calc_irazomax(
get_param_value(old_doc, "irmax")$irmax,
param_values_to_varietal$vitircarb,
- param_values_to_varietal$vitirazo)
+ param_values_to_varietal$vitirazo
+ )
new_node <- XML::xmlParseString(
- paste0('',
- irazomax_calc,
- ""),
+ paste0(
+ '',
+ irazomax_calc,
+ ""
+ ),
addFinalizer = TRUE
)
# adding irazomax node
parent_node <- get_nodes(old_doc,
- path = "//formalisme[@nom='yield formation']")[[1]]
+ path = "//formalisme[@nom='yield formation']"
+ )[[1]]
XML::addChildren(parent_node, new_node, at = 0)
- message(old_doc@name,
- ": be aware that irazomax is a new parameter and its value (",
- irazomax_calc,
- ")\nis estimated using some other parameters values.\n",
- paste0("But this value needs to be ajusted according to ",
- "species and varieties "), "\n")
+ message(
+ old_doc@name,
+ ": be aware that irazomax is a new parameter and its value (",
+ irazomax_calc,
+ ")\nis estimated using some other parameters values.\n",
+ paste0(
+ "But this value needs to be ajusted according to ",
+ "species and varieties "
+ ), "\n"
+ )
# moving irmax
node_to_move <- get_nodes(old_doc, path = "//param[@nom='irmax']")[[1]]
parent_node <- get_nodes(
old_doc,
- path = "//option[@nomParam='codeir']/choix[@code='1']")[[1]]
+ path = "//option[@nomParam='codeir']/choix[@code='1']"
+ )[[1]]
XML::addChildren(parent_node, node_to_move)
@@ -397,11 +413,13 @@ upgrade_plt_xml <- function(file,
# adding var nodes under each "variete" node
var_parent_nodes <- get_nodes(old_doc, path = "//variete")
- lapply(var_parent_nodes,
- function(x) {
- XML::addChildren(x,
- kids = XML::xmlChildren(XML::xmlClone(var_nodes)))
- }
+ lapply(
+ var_parent_nodes,
+ function(x) {
+ XML::addChildren(x,
+ kids = XML::xmlChildren(XML::xmlClone(var_nodes))
+ )
+ }
)
#
@@ -427,32 +445,36 @@ upgrade_plt_xml <- function(file,
load(
file.path(
- get_examples_path(file_type = "xml_param",
- stics_version = target_version
+ get_examples_path(
+ file_type = "xml_param",
+ stics_version = target_version
),
- "jvc_data.RData")
+ "jvc_data.RData"
+ )
)
# get varieties
current_var <- get_param_value(old_doc, "variete")
if (basename(file) %in% names(jvc_data)) {
-
common_var <-
jvc_data[[basename(file)]][["variete"]] %in% current_var$variete
if (any(common_var)) {
- values <- get_param_value(old_doc, param_name = "jvc",
- parent_name = "variete",
- parent_sel_attr = current_var[common_var])$jvc
+ values <- get_param_value(old_doc,
+ param_name = "jvc",
+ parent_name = "variete",
+ parent_sel_attr = current_var[common_var]
+ )$jvc
values_999_ids <- which(values == -999)
if (length(values_999_ids) > 0) {
jvc_values <- jvc_data[[basename(file)]]$jvc[common_var][values_999_ids]
set_param_value(old_doc,
- param_name = "jvc",
- param_value = jvc_values,
- ids = values_999_ids)
+ param_name = "jvc",
+ param_value = jvc_values,
+ ids = values_999_ids
+ )
}
}
}
@@ -461,11 +483,16 @@ upgrade_plt_xml <- function(file,
# Check if still any -999 values
values <- get_param_value(old_doc, "jvc")$jvc
values_999_ids <- which(values == -999)
- if (length(values_999_ids) > 0)
- message(old_doc@name,
- paste0(": be aware that jvc is from now a mandatory parameter",
- "and its value must be fixed !\n"),
- "for all varieties: \n", current_var[values_999_ids], "\n")
+ if (length(values_999_ids) > 0) {
+ message(
+ old_doc@name,
+ paste0(
+ ": be aware that jvc is from now a mandatory parameter",
+ "and its value must be fixed !\n"
+ ),
+ "for all varieties: \n", current_var[values_999_ids], "\n"
+ )
+ }
@@ -501,8 +528,10 @@ upgrade_plt_xml <- function(file,
addFinalizer = TRUE
)
- parent_node <- get_nodes(old_doc,
- "//*[@nomParam='codegdhdeb']/choix[@code='1']")[[1]]
+ parent_node <- get_nodes(
+ old_doc,
+ "//*[@nomParam='codegdhdeb']/choix[@code='1']"
+ )[[1]]
XML::addChildren(parent_node, new_node)
@@ -619,8 +648,9 @@ nomParam="codedyntalle">
param = c("rayon", "khaut")
)[[1]]
set_param_value(old_doc,
- param_name = c("rayon", "khaut"),
- param_value = param_gen_values)
+ param_name = c("rayon", "khaut"),
+ param_value = param_gen_values
+ )
# from param_newform.xml
@@ -630,12 +660,16 @@ nomParam="codedyntalle">
param = c("coefracoupe(1)", "coefracoupe(2)")
)[[1]]
- if (length(unique(unlist(param_newform_values))) > 1)
+ if (length(unique(unlist(param_newform_values))) > 1) {
stop(
- "Multiple values of coefracoupe in param_gen.xml file")
+ "Multiple values of coefracoupe in param_gen.xml file"
+ )
+ }
- set_param_value(old_doc, param_name = "coefracoupe",
- param_value = param_newform_values[[1]])
+ set_param_value(old_doc,
+ param_name = "coefracoupe",
+ param_value = param_newform_values[[1]]
+ )
# Updating other values than nodes values (i.e. nodes attributes values)
@@ -645,8 +679,10 @@ nomParam="codedyntalle">
# 0
nodes_to_change <- get_nodes(old_doc, path = "//param[@nom='hautbase']")
if (!is.null(nodes_to_change)) {
- set_attrs_values(old_doc, path = "//param[@nom='hautbase']",
- attr_name = "min", values_list = "0.1")
+ set_attrs_values(old_doc,
+ path = "//param[@nom='hautbase']",
+ attr_name = "min", values_list = "0.1"
+ )
}
#
# Changing options' "choix", "nom" attribute values
@@ -654,13 +690,17 @@ nomParam="codedyntalle">
# oui to yes, non to no
nodes_to_change <- get_nodes(old_doc, path = "//choix[@nom='oui']")
if (!is.null(nodes_to_change)) {
- set_attrs_values(old_doc, path = "//choix[@nom='oui']", attr_name = "nom",
- values_list = "yes")
+ set_attrs_values(old_doc,
+ path = "//choix[@nom='oui']", attr_name = "nom",
+ values_list = "yes"
+ )
}
nodes_to_change <- get_nodes(old_doc, path = "//choix[@nom='non']")
if (!is.null(nodes_to_change)) {
- set_attrs_values(old_doc, path = "//choix[@nom='non']", attr_name = "nom",
- values_list = "no")
+ set_attrs_values(old_doc,
+ path = "//choix[@nom='non']", attr_name = "nom",
+ values_list = "no"
+ )
}
@@ -680,7 +720,6 @@ nomParam="codedyntalle">
calc_irazomax <- function(irmax, vitircarb, vitirazo) {
-
irazomax <- (irmax / vitircarb) * vitirazo
irazomax <- pmin(1., irazomax)
diff --git a/R/upgrade_sols_xml.R b/R/upgrade_sols_xml.R
index d068357b..495aa2fb 100644
--- a/R/upgrade_sols_xml.R
+++ b/R/upgrade_sols_xml.R
@@ -24,7 +24,7 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_sols_xml(
-#' file = file.path(dir_path,"sols.xml" ),
+#' file = file.path(dir_path, "sols.xml"),
#' out_dir = tempdir(),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
#' )
@@ -36,8 +36,6 @@ upgrade_sols_xml <- function(file,
target_version = "V10.0",
check_version = TRUE,
overwrite = FALSE) {
-
-
# hecking output directory
if (!dir.exists(out_dir)) dir.create(out_dir)
@@ -84,15 +82,19 @@ upgrade_sols_xml <- function(file,
old_doc <- xmldocument(file = file)
# Setting file STICS version
- set_xml_file_version(old_doc, new_version = target_version,
- overwrite = overwrite)
+ set_xml_file_version(old_doc,
+ new_version = target_version,
+ overwrite = overwrite
+ )
# Checking if layer @nom are up to date (old @nom = horizon)
tableau_noms <- unlist(get_nodes(old_doc, "//tableau/@nom"))
if (any(grep(pattern = "horizon", tableau_noms))) {
- new_names <- unlist(lapply(tableau_noms,
- function(x) gsub(pattern = "horizon(.*)", x, replacement = "layer\\1")))
+ new_names <- unlist(lapply(
+ tableau_noms,
+ function(x) gsub(pattern = "horizon(.*)", x, replacement = "layer\\1")
+ ))
set_attrs_values(old_doc, "//tableau", "nom", new_names)
}
diff --git a/R/upgrade_sta_xml.R b/R/upgrade_sta_xml.R
index b8c17334..008184bb 100644
--- a/R/upgrade_sta_xml.R
+++ b/R/upgrade_sta_xml.R
@@ -25,7 +25,7 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_sta_xml(
-#' file = file.path(dir_path,"file_sta.xml" ),
+#' file = file.path(dir_path, "file_sta.xml"),
#' out_dir = tempdir(),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
#' )
@@ -38,7 +38,6 @@ upgrade_sta_xml <- function(file,
check_version = TRUE,
overwrite = FALSE,
...) {
-
# for verifying output dir existence
check_dir <- TRUE
args <- list(...)
@@ -110,8 +109,9 @@ upgrade_sta_xml <- function(file,
# Setting file STICS version
set_xml_file_version(old_doc,
- new_version = target_version,
- overwrite = overwrite)
+ new_version = target_version,
+ overwrite = overwrite
+ )
# Getting old concrr value
concrr <- get_param_xml(param_gen_file, "concrr")$param_gen.xml$concrr
diff --git a/R/upgrade_tec_xml.R b/R/upgrade_tec_xml.R
index 37f222fb..c4f9a4b6 100644
--- a/R/upgrade_tec_xml.R
+++ b/R/upgrade_tec_xml.R
@@ -27,13 +27,12 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_tec_xml(
-#' file = file.path(dir_path,"file_tec.xml"),
+#' file = file.path(dir_path, "file_tec.xml"),
#' out_dir = tempdir(),
#' param_newform_file = file.path(dir_path, "param_newform.xml"),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
#' )
#'
-#'
upgrade_tec_xml <- function(file,
out_dir,
param_newform_file,
@@ -43,7 +42,6 @@ upgrade_tec_xml <- function(file,
check_version = TRUE,
overwrite = FALSE,
...) {
-
# for verifying output dir existence
check_dir <- TRUE
args <- list(...)
@@ -61,8 +59,8 @@ upgrade_tec_xml <- function(file,
# extracting or detecting the STICS version corresponding to the xml file
# based on param_gen.xml file content
file_version <- check_xml_file_version(file,
- stics_version,
- param_gen_file = param_gen_file
+ stics_version,
+ param_gen_file = param_gen_file
)
if (!file_version && is.null(param_gen_file)) {
@@ -113,8 +111,8 @@ upgrade_tec_xml <- function(file,
# Setting file STICS version
set_xml_file_version(old_doc,
- new_version = target_version,
- overwrite = overwrite
+ new_version = target_version,
+ overwrite = overwrite
)
@@ -226,7 +224,7 @@ upgrade_tec_xml <- function(file,
# intervention , engrais
# -----------------------
new_node <- XML::xmlParseString('',
- addFinalizer = TRUE
+ addFinalizer = TRUE
)
parent_node <- get_nodes(
@@ -245,14 +243,17 @@ upgrade_tec_xml <- function(file,
path = "//formalisme[@nom='fertilisation']//ta/intervention"
)
if (!is.null(parent_nodes)) {
- lapply(parent_nodes,
- function(x) {
- XML::addChildren(x, XML::xmlClone(new_node))
- }
+ lapply(
+ parent_nodes,
+ function(x) {
+ XML::addChildren(x, XML::xmlClone(new_node))
+ }
+ )
+ set_param_value(
+ xml_doc = old_doc,
+ param_name = "engrais",
+ param_value = engrais
)
- set_param_value(xml_doc = old_doc,
- param_name = "engrais",
- param_value = engrais)
lapply(parent_nodes, function(x) XML::xmlAttrs(x)["nb_colonnes"] <- "3")
}
@@ -476,7 +477,7 @@ upgrade_tec_xml <- function(file,
"stage_start_irrigauto", "stage_end_irrigauto"
)
old_val <- get_param_xml(param_newform_file,
- param = param_names
+ param = param_names
)[[basename(param_newform_file)]]
# writing to file _tec.xml
diff --git a/R/upgrade_usms_xml.R b/R/upgrade_usms_xml.R
index d17eefd9..a0e48cf6 100644
--- a/R/upgrade_usms_xml.R
+++ b/R/upgrade_usms_xml.R
@@ -25,7 +25,7 @@
#' dir_path <- get_examples_path(file_type = "xml", stics_version = "V9.2")
#'
#' upgrade_usms_xml(
-#' file = file.path(dir_path,"usms.xml"),
+#' file = file.path(dir_path, "usms.xml"),
#' out_dir = tempdir(),
#' param_gen_file = file.path(dir_path, "param_gen.xml")
#' )
@@ -38,7 +38,6 @@ upgrade_usms_xml <- function(file,
target_version = "V10.0",
check_version = TRUE,
overwrite = FALSE) {
-
# Checking output directory
if (!dir.exists(out_dir)) dir.create(out_dir)
@@ -52,8 +51,8 @@ upgrade_usms_xml <- function(file,
# extracting or detecting the STICS version corresponding to the xml file
# based on param_gen.xml file content
file_version <- check_xml_file_version(file,
- stics_version,
- param_gen_file = param_gen_file
+ stics_version,
+ param_gen_file = param_gen_file
)
if (!file_version) {
@@ -86,8 +85,8 @@ upgrade_usms_xml <- function(file,
# setting file STICS version
set_xml_file_version(old_doc,
- new_version = target_version,
- overwrite = overwrite
+ new_version = target_version,
+ overwrite = overwrite
)
# checking if fobs exist
@@ -98,13 +97,14 @@ upgrade_usms_xml <- function(file,
# default behavior: no existing fobs fields
if (is.null(obs_nodes)) {
new_node <- XML::xmlParseString("null",
- addFinalizer = TRUE
+ addFinalizer = TRUE
)
parent_node <- get_nodes(old_doc, "//plante")
- lapply(parent_node,
- function(x) XML::addChildren(x, XML::xmlClone(new_node))
+ lapply(
+ parent_node,
+ function(x) XML::addChildren(x, XML::xmlClone(new_node))
)
}
@@ -121,10 +121,10 @@ upgrade_usms_xml <- function(file,
# Setting obs files names into fobs for existing files
set_param_value(old_doc,
- param_name = "fobs",
- param_value = obs_val,
- parent_name = "plante",
- parent_sel_attr = "1"
+ param_name = "fobs",
+ param_value = obs_val,
+ parent_name = "plante",
+ parent_sel_attr = "1"
)
diff --git a/R/upgrade_workspace_xml.R b/R/upgrade_workspace_xml.R
index 0140617b..7bd046b1 100644
--- a/R/upgrade_workspace_xml.R
+++ b/R/upgrade_workspace_xml.R
@@ -41,8 +41,6 @@ upgrade_workspace_xml <- function(workspace,
plant = FALSE,
overwrite = FALSE,
...) {
-
-
# For testing if files are upgradable
check_version <- FALSE
verbose <- TRUE
@@ -94,7 +92,7 @@ upgrade_workspace_xml <- function(workspace,
# Testing the workspace dir to be converted
if (!dir.exists(workspace) ||
- !file.exists(file.path(workspace, "usms.xml"))) {
+ !file.exists(file.path(workspace, "usms.xml"))) {
stop(
workspace,
": the directory does not exist or is not a JavaSTICS workspace !"
@@ -106,7 +104,7 @@ upgrade_workspace_xml <- function(workspace,
# Testing the JavaSTICS dir
if (!dir.exists(javastics) ||
- !file.exists(file.path(javastics, "JavaStics.exe"))) {
+ !file.exists(file.path(javastics, "JavaStics.exe"))) {
stop(
javastics,
" : the directory does nor exist or is not a JavaSTICS one !"
@@ -115,12 +113,15 @@ upgrade_workspace_xml <- function(workspace,
if (verbose) {
- message(paste(
- "Upgrading files from version", stics_version, "to",
- target_version, "\n"),
+ message(
+ paste(
+ "Upgrading files from version", stics_version, "to",
+ target_version, "\n"
+ ),
paste("From: ", workspace, "\n"),
paste("To: ", out_dir, "\n"),
- "-----------------------------------\n")
+ "-----------------------------------\n"
+ )
}
# Converting param_gen.xml
@@ -315,12 +316,14 @@ upgrade_workspace_xml <- function(workspace,
# for getting information on output variables
# (use get_var_info with the appropriate version string)
- workspace_files_copy(workspace = workspace,
- file_type = c("mod", "obs", "lai", "meteo"),
- javastics = javastics,
- out_dir = out_dir,
- overwrite = overwrite,
- verbose = verbose)
+ workspace_files_copy(
+ workspace = workspace,
+ file_type = c("mod", "obs", "lai", "meteo"),
+ javastics = javastics,
+ out_dir = out_dir,
+ overwrite = overwrite,
+ verbose = verbose
+ )
@@ -355,8 +358,9 @@ upgrade_workspace_xml <- function(workspace,
}
if (verbose) {
- message(paste0("-----------------------------------\n",
- "Files upgrade and copy is complete.\n")
- )
+ message(paste0(
+ "-----------------------------------\n",
+ "Files upgrade and copy is complete.\n"
+ ))
}
}
diff --git a/R/xml_document.R b/R/xml_document.R
index 11ba7c42..99317b16 100644
--- a/R/xml_document.R
+++ b/R/xml_document.R
@@ -13,7 +13,6 @@ setClass(
setMethod(
"valid_doc", signature(object = "xml_document"),
function(object) {
-
ext <- get_ext(object)
if (length(object@name) == 0 || object@name == "") {
@@ -29,7 +28,8 @@ setMethod(
return(paste("Error: file is empty:", object@name, "!"))
}
TRUE
- })
+ }
+)
# constructor
@@ -434,7 +434,6 @@ setMethod(
setMethod(
"load_content", signature(object = "xml_document"),
function(object) {
-
set_content(object) <- XML::xmlParse(get_path(object))
return(object)
}
@@ -494,6 +493,5 @@ setMethod(
rm(object)
invisible(gc(verbose = FALSE))
-
}
)
diff --git a/README.Rmd b/README.Rmd
index 5d7a1178..a26633d2 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -58,13 +58,13 @@ The best way to install the packages from `SticsRPacks`, from which `SticsRFiles
* With `devtools`
```{r eval=FALSE}
- devtools::install_github("SticsRPacks/SticsRPacks")
+devtools::install_github("SticsRPacks/SticsRPacks")
```
* With `remotes`
```{r eval=FALSE}
- remotes::install_github("SticsRPacks/SticsRPacks")
+remotes::install_github("SticsRPacks/SticsRPacks")
```
The package will install the packages for you at the latest release version.
@@ -73,15 +73,15 @@ The package will install the packages for you at the latest release version.
* From the CRAN
```{r eval=FALSE}
- install.packages("SticsRFiles")
+install.packages("SticsRFiles")
```
* From GitHub
```{r eval=FALSE}
- devtools::install_github("SticsRPacks/SticsRFiles@*release")
+devtools::install_github("SticsRPacks/SticsRFiles@*release")
- or
-
- remotes::install_github("SticsRPacks/SticsRFiles@*release")
+or
+
+remotes::install_github("SticsRPacks/SticsRFiles@*release")
```
Normally, all the package dependencies will be installed for CRAN packages.
diff --git a/tests/spelling.R b/tests/spelling.R
index 33ef2c73..13f77d96 100644
--- a/tests/spelling.R
+++ b/tests/spelling.R
@@ -1,3 +1,6 @@
-if (requireNamespace("spelling", quietly = TRUE))
- spelling::spell_check_test(vignettes = TRUE, error = FALSE,
- skip_on_cran = TRUE)
+if (requireNamespace("spelling", quietly = TRUE)) {
+ spelling::spell_check_test(
+ vignettes = TRUE, error = FALSE,
+ skip_on_cran = TRUE
+ )
+}
diff --git a/tests/testthat/test-col_names_to_var.R b/tests/testthat/test-col_names_to_var.R
index ef7577c2..4867cb3f 100644
--- a/tests/testthat/test-col_names_to_var.R
+++ b/tests/testthat/test-col_names_to_var.R
@@ -1,4 +1,3 @@
-
context("Convert snake case variables to Stics variables")
test_that("With numerical (2 digits) or text index", {
@@ -7,7 +6,6 @@ test_that("With numerical (2 digits) or text index", {
expect_equal(col_names_to_var("name_n"), "name(n)")
expect_equal(col_names_to_var("name.n."), "name(n)")
expect_false(col_names_to_var("name_100") == "name(100)")
-
})
test_that("With multiple numbers", {
@@ -17,11 +15,14 @@ test_that("With multiple numbers", {
test_that("With multiple underscores, index", {
expect_equal(col_names_to_var("msrec_fou_coupe"), "msrec_fou_coupe")
expect_equal(col_names_to_var("msrec.fou.coupe."), "msrec.fou.coupe.")
- expect_equal(col_names_to_var("SoilAvW_by_layers_5"),
- "SoilAvW_by_layers(5)")
- expect_equal(col_names_to_var("SoilAvW_by_layers.5."),
- "SoilAvW_by_layers(5)")
-
+ expect_equal(
+ col_names_to_var("SoilAvW_by_layers_5"),
+ "SoilAvW_by_layers(5)"
+ )
+ expect_equal(
+ col_names_to_var("SoilAvW_by_layers.5."),
+ "SoilAvW_by_layers(5)"
+ )
})
context("Convert all snake case variables to Stics variables")
@@ -29,9 +30,11 @@ context("Convert all snake case variables to Stics variables")
dir_csv <- get_examples_path("csv")
outputs_file <- file.path(dir_csv, "outputs.csv")
-df_outputs <- read.csv2(file = outputs_file,
- header = TRUE,
- stringsAsFactors = FALSE)
+df_outputs <- read.csv2(
+ file = outputs_file,
+ header = TRUE,
+ stringsAsFactors = FALSE
+)
snake_names <- gsub(pattern = "\\(", x = df_outputs$Name, replacement = "_")
snake_names <- gsub(pattern = "\\)", x = snake_names, replacement = "")
diff --git a/tests/testthat/test-compute_date.R b/tests/testthat/test-compute_date.R
index 91175b32..db77fcd5 100644
--- a/tests/testthat/test-compute_date.R
+++ b/tests/testthat/test-compute_date.R
@@ -1,4 +1,3 @@
-
context("Convert day numbers into calendar dates from a start year")
test_that("a-single-day", {
diff --git a/tests/testthat/test-compute_day_number.R b/tests/testthat/test-compute_day_number.R
index 4ef889c9..58f05676 100644
--- a/tests/testthat/test-compute_day_number.R
+++ b/tests/testthat/test-compute_day_number.R
@@ -1,4 +1,3 @@
-
context("Convert calendar dates days number from a start year")
test_that("same-year", {
@@ -17,18 +16,17 @@ test_that("same-year", {
observed <- compute_day_from_date(date = date, start_year = 2014)
expect_equal(observed, expected)
-
})
test_that("two-successive-years_first-noleap_second-noleap", {
date <- as.Date("2015-02-10")
expected <- 406
- observed <- compute_day_from_date(date=date, start_year = 2014)
+ observed <- compute_day_from_date(date = date, start_year = 2014)
expect_equal(observed, expected)
date <- as.Date(c("2015-02-10", "2015-02-20"))
expected <- c(406, 416)
- observed <- compute_day_from_date(date=date, start_year = 2014)
+ observed <- compute_day_from_date(date = date, start_year = 2014)
expect_equal(observed, expected)
})
diff --git a/tests/testthat/test-convert_xml2txt_int.R b/tests/testthat/test-convert_xml2txt_int.R
index 5790becd..c99f23c8 100644
--- a/tests/testthat/test-convert_xml2txt_int.R
+++ b/tests/testthat/test-convert_xml2txt_int.R
@@ -5,9 +5,11 @@ xml_plt <- file.path(get_examples_path(file_type = "xml"), "file_plt.xml")
xsl_file <- file.path(get_examples_path(file_type = "xsl"), "xml2txt.xsl")
out_dir <- file.path(tempdir(), "Test_Convert")
if (!dir.exists(out_dir)) dir.create(out_dir)
-convert_xml2txt_int(xml_file = xml_plt,
- style_file = xsl_file,
- file.path(out_dir, "ficplt.txt"))
+convert_xml2txt_int(
+ xml_file = xml_plt,
+ style_file = xsl_file,
+ file.path(out_dir, "ficplt.txt")
+)
context("Convert file type")
diff --git a/tests/testthat/test-exist_param.R b/tests/testthat/test-exist_param.R
index 029dd144..e08f7f13 100644
--- a/tests/testthat/test-exist_param.R
+++ b/tests/testthat/test-exist_param.R
@@ -10,6 +10,6 @@ context("Exist param ")
test_that("exist parameter", {
expect_true(exists_param(xml_doc, "cfes"))
expect_vector(exists_param(xml_doc, c("cfes", "mulchbat")),
- ptype = NULL, size = 2)
-
+ ptype = NULL, size = 2
+ )
})
diff --git a/tests/testthat/test-exist_param_xml.R b/tests/testthat/test-exist_param_xml.R
index 12afac5f..83b36bc0 100644
--- a/tests/testthat/test-exist_param_xml.R
+++ b/tests/testthat/test-exist_param_xml.R
@@ -1,4 +1,3 @@
-
stics_version <- get_stics_versions_compat()$latest_version
context("Exist param ")
@@ -9,5 +8,6 @@ test_that("exist parameter", {
expect_true(exist_param_xml("codephot", stics_version = stics_version))
expect_warning(exist_param_xml("codexxx", stics_version = stics_version))
expect_true(exist_param_xml("code_acti_reserve",
- stics_version = stics_version))
+ stics_version = stics_version
+ ))
})
diff --git a/tests/testthat/test-gen_general_param_xml.R b/tests/testthat/test-gen_general_param_xml.R
index 2b984978..27364b9f 100644
--- a/tests/testthat/test-gen_general_param_xml.R
+++ b/tests/testthat/test-gen_general_param_xml.R
@@ -1,4 +1,3 @@
-
context("Generating xml general parameters files")
gen_general_param_xml(out_dir = tempdir())
@@ -14,8 +13,10 @@ test_that("latest version", {
test_that("other version", {
- expect_no_error(gen_general_param_xml(out_dir = tempdir(),
- stics_version = "V10.0",
- overwrite = TRUE))
+ expect_no_error(gen_general_param_xml(
+ out_dir = tempdir(),
+ stics_version = "V10.0",
+ overwrite = TRUE
+ ))
expect_true(all(file.exists(file.path(tempdir(), files))))
})
diff --git a/tests/testthat/test-gen_ini_xml.R b/tests/testthat/test-gen_ini_xml.R
index 9c0bc3d2..a835dc07 100644
--- a/tests/testthat/test-gen_ini_xml.R
+++ b/tests/testthat/test-gen_ini_xml.R
@@ -35,17 +35,21 @@ ini_xml <- file.path(out_dir, ini_param[1, ]$Ini_name)
# For plante 1
-xl_plt1_values <- select(ini_param[1, ],
- ends_with("Crop1"),
- -starts_with("code"))
+xl_plt1_values <- select(
+ ini_param[1, ],
+ ends_with("Crop1"),
+ -starts_with("code")
+)
xl_params <- gsub(
pattern = "(.*)_(.*)", x = names(xl_plt1_values),
replacement = "\\1"
)
-xl_params <- gsub(pattern = "(.*)(\\_[0-9]*$)",
- x = xl_params,
- replacement = "\\1")
+xl_params <- gsub(
+ pattern = "(.*)(\\_[0-9]*$)",
+ x = xl_params,
+ replacement = "\\1"
+)
xl_plt1_values <- select(xl_plt1_values, starts_with(xl_params))
xml_plt1_values <- get_param_xml(
@@ -61,17 +65,21 @@ xml_plt2_values <- unlist(get_param_xml(
select_value = 2
)[[1]])
-xl_plt2_values <- select(ini_param[1, ],
- ends_with("Crop2"),
- -starts_with("code"))
+xl_plt2_values <- select(
+ ini_param[1, ],
+ ends_with("Crop2"),
+ -starts_with("code")
+)
xl_params <- gsub(
pattern = "(.*)_(.*)", x = names(xl_plt1_values),
replacement = "\\1"
)
-xl_params <- gsub(pattern = "(.*)(\\_[0-9]*$)",
- x = xl_params,
- replacement = "\\1")
+xl_params <- gsub(
+ pattern = "(.*)(\\_[0-9]*$)",
+ x = xl_params,
+ replacement = "\\1"
+)
xl_plt2_values <- select(xl_plt2_values, starts_with(xl_params))
xml_plt2_values <- get_param_xml(
diff --git a/tests/testthat/test-gen_paramsti.R b/tests/testthat/test-gen_paramsti.R
index 2cb4b51b..fd07b77a 100644
--- a/tests/testthat/test-gen_paramsti.R
+++ b/tests/testthat/test-gen_paramsti.R
@@ -12,6 +12,7 @@ test_that("Create a xml station file", {
expect_error(gen_paramsti(
file.path(workspace_path, "xxx"),
c("par1", "par2"),
- c(1, 2)))
+ c(1, 2)
+ ))
expect_false(gen_paramsti(workspace_path, c("par1", "par2"), c(1, 2, 3)))
})
diff --git a/tests/testthat/test-gen_tec_xml.R b/tests/testthat/test-gen_tec_xml.R
index 38f546f8..1fd6090b 100644
--- a/tests/testthat/test-gen_tec_xml.R
+++ b/tests/testthat/test-gen_tec_xml.R
@@ -39,7 +39,7 @@ xml_irr_values <- get_param_xml(
# renaming param according to table
names(xml_irr_values)[names(xml_irr_values) %in%
- c("julapI_or_sum_upvt", "amount")] <- c("julapI", "doseI")
+ c("julapI_or_sum_upvt", "amount")] <- c("julapI", "doseI")
# select columns with no NA values
@@ -48,23 +48,23 @@ xl_irr_values <- dplyr::select(
starts_with(sort(names(xml_irr_values)))
) %>%
dplyr::select(where(function(x) !is.na(x)) &
- where(function(x) {
- c <- x != "NA"
- if (is.na(c)) c <- TRUE
- return(c)
-
- }
- ))
+ where(function(x) {
+ c <- x != "NA"
+ if (is.na(c)) c <- TRUE
+ return(c)
+ }))
#
-xl_names <- sort(unique(gsub(pattern = "(.*)(\\_[0-9]*)",
- x = colnames(xl_irr_values), replacement = "\\1")))
+xl_names <- sort(unique(gsub(
+ pattern = "(.*)(\\_[0-9]*)",
+ x = colnames(xl_irr_values), replacement = "\\1"
+)))
common_names <- sort(intersect(names(xml_irr_values), xl_names))
xml_irr_values <- unlist(xml_irr_values[common_names],
- use.names = FALSE
+ use.names = FALSE
)
xl_irr_values <- dplyr::select(
@@ -72,13 +72,11 @@ xl_irr_values <- dplyr::select(
starts_with(common_names)
) %>%
dplyr::select(where(function(x) !is.na(x)) &
- where(function(x) {
- c <- x != "NA"
- if (is.na(c)) c <- TRUE
- return(c)
-
- }
- ))
+ where(function(x) {
+ c <- x != "NA"
+ if (is.na(c)) c <- TRUE
+ return(c)
+ }))
@@ -90,7 +88,7 @@ xml_fert_values <- get_param_xml(
# renaming param according to table (TODO: use param dict)
names(xml_fert_values)[names(xml_fert_values) %in%
- c("julapN_or_sum_upvt", "absolute_value/%")] <- c("julapN", "doseN")
+ c("julapN_or_sum_upvt", "absolute_value/%")] <- c("julapN", "doseN")
xl_fert_values <- dplyr::select(
tec_param[4, ],
@@ -99,14 +97,16 @@ xl_fert_values <- dplyr::select(
dplyr::select_if(~ !any(is.na(.)))
-xl_names <- sort(unique(gsub(pattern = "(.*)(\\_[0-9]*)",
- x = colnames(xl_fert_values),
- replacement = "\\1")))
+xl_names <- sort(unique(gsub(
+ pattern = "(.*)(\\_[0-9]*)",
+ x = colnames(xl_fert_values),
+ replacement = "\\1"
+)))
common_names <- sort(intersect(names(xml_fert_values), xl_names))
xml_fert_values <- unlist(xml_fert_values[common_names],
- use.names = FALSE
+ use.names = FALSE
)
xl_fert_values <- dplyr::select(
diff --git a/tests/testthat/test-gen_varmod.R b/tests/testthat/test-gen_varmod.R
index 93fba883..9e9b6b20 100644
--- a/tests/testthat/test-gen_varmod.R
+++ b/tests/testthat/test-gen_varmod.R
@@ -16,8 +16,10 @@ gen_varmod(out_dir, "hauteur", append = TRUE)
test_that("Add a new variable", {
expect_true(
- grep(pattern = "hauteur",
- readLines(file.path(out_dir, "var.mod"))) > 0)
+ grep(
+ pattern = "hauteur",
+ readLines(file.path(out_dir, "var.mod"))
+ ) > 0
+ )
expect_warning(gen_varmod(out_dir, ""))
-
- })
+})
diff --git a/tests/testthat/test-get_cultivars_list.R b/tests/testthat/test-get_cultivars_list.R
index 1e53c66d..ca4e7c34 100644
--- a/tests/testthat/test-get_cultivars_list.R
+++ b/tests/testthat/test-get_cultivars_list.R
@@ -1,4 +1,3 @@
-
stics_version <- get_stics_versions_compat()$latest_version
xml_plant <- file.path(
diff --git a/tests/testthat/test-get_cultivars_param.R b/tests/testthat/test-get_cultivars_param.R
index a3a3f91e..c1a3d031 100644
--- a/tests/testthat/test-get_cultivars_param.R
+++ b/tests/testthat/test-get_cultivars_param.R
@@ -1,4 +1,3 @@
-
stics_version <- get_stics_versions_compat()$latest_version
xml_plant <- file.path(
@@ -15,5 +14,5 @@ test_that("type, data.frame", {
context("Checking presence of row names")
test_that("rownames", {
- expect_identical(! is.null(rownames(cv_param_df)), TRUE)
+ expect_identical(!is.null(rownames(cv_param_df)), TRUE)
})
diff --git a/tests/testthat/test-get_is_os_name.R b/tests/testthat/test-get_is_os_name.R
index 73832fd5..ac093f8d 100644
--- a/tests/testthat/test-get_is_os_name.R
+++ b/tests/testthat/test-get_is_os_name.R
@@ -8,5 +8,4 @@ test_that("Is OS name", {
expect_type(is_os_name("windows"), "logical")
expect_type(is_os_name("linux"), "logical")
expect_type(is_os_name("mac"), "logical")
-
})
diff --git a/tests/testthat/test-get_obs.R b/tests/testthat/test-get_obs.R
index 43293008..033b3a5a 100644
--- a/tests/testthat/test-get_obs.R
+++ b/tests/testthat/test-get_obs.R
@@ -1,4 +1,4 @@
-options(warn=-1)
+options(warn = -1)
stics_version <- get_stics_versions_compat()$latest_version
@@ -12,9 +12,13 @@ path <- file.path(
"simple_example"
)
-path_mixed <- file.path(get_examples_path(file_type = "obs",
- stics_version = stics_version),
- "mixed")
+path_mixed <- file.path(
+ get_examples_path(
+ file_type = "obs",
+ stics_version = stics_version
+ ),
+ "mixed"
+)
# Get observations for all usms, but only banana has observations:
meas <- get_obs(workspace = path)
@@ -85,9 +89,13 @@ test_that(
test_that("reading mixed usms with usms_filename to usms.xml outside of folder,
and usms in different folders", {
- path <- file.path(get_examples_path(file_type = "obs",
- stics_version = stics_version),
- "usms_outside")
+ path <- file.path(
+ get_examples_path(
+ file_type = "obs",
+ stics_version = stics_version
+ ),
+ "usms_outside"
+ )
paths <- list.dirs(path)[-1]
meas_2 <- get_obs(workspace = paths, usms_file = file.path(path, "usms.xml"))
@@ -99,9 +107,13 @@ test_that("reading mixed usms with usms_filename to usms.xml outside of folder,
# Testing empty obs:
test_that("reading empty usms returns a 0 row data", {
- path_empty <- file.path(get_examples_path(file_type = "obs",
- stics_version = stics_version),
- "empty")
+ path_empty <- file.path(
+ get_examples_path(
+ file_type = "obs",
+ stics_version = stics_version
+ ),
+ "empty"
+ )
meas <- get_obs(workspace = path_empty)
expect_true(is.data.frame(meas$empty))
expect_length(meas$empty, 0)
diff --git a/tests/testthat/test-get_option_choice_param_values.R b/tests/testthat/test-get_option_choice_param_values.R
index 155bb6fc..ca3d04ae 100644
--- a/tests/testthat/test-get_option_choice_param_values.R
+++ b/tests/testthat/test-get_option_choice_param_values.R
@@ -11,6 +11,9 @@ test_that("Option choice", {
expect_equal(
length(
unlist(get_option_choice_param_values(xml_path, "codetemp", "2"),
- use.names = FALSE)),
- 14)
- })
+ use.names = FALSE
+ )
+ ),
+ 14
+ )
+})
diff --git a/tests/testthat/test-get_options_choices.R b/tests/testthat/test-get_options_choices.R
index 6581a0d5..f326a276 100644
--- a/tests/testthat/test-get_options_choices.R
+++ b/tests/testthat/test-get_options_choices.R
@@ -9,13 +9,18 @@ xml_path <- file.path(get_examples_path(file_type = "xml"), "file_plt.xml")
test_that("Option choice", {
expect_equal(
length(unlist(get_options_choices(xml_path), use.names = FALSE)),
- 93)
+ 93
+ )
expect_equal(
length(unlist(get_options_choices(xml_path, "codetemp"),
- use.names = FALSE)),
- 2)
+ use.names = FALSE
+ )),
+ 2
+ )
expect_equal(
length(unlist(get_options_choices(xml_path, c("codegdh", "codetemp")),
- use.names = FALSE)),
- 4)
+ use.names = FALSE
+ )),
+ 4
+ )
})
diff --git a/tests/testthat/test-get_options_names.R b/tests/testthat/test-get_options_names.R
index b0d71a18..7cae3dbe 100644
--- a/tests/testthat/test-get_options_names.R
+++ b/tests/testthat/test-get_options_names.R
@@ -8,8 +8,9 @@ context("Reaserching option names")
xml_path <- file.path(get_examples_path(file_type = "xml"), "file_plt.xml")
test_that("Reaserching option names", {
- expect_equal(length(get_options_names(xml_path)), 45)
- expect_equal(
- length(get_options_names(xml_path, c("codemonocot", "codlainet"))),
- 2)
+ expect_equal(length(get_options_names(xml_path)), 45)
+ expect_equal(
+ length(get_options_names(xml_path, c("codemonocot", "codlainet"))),
+ 2
+ )
})
diff --git a/tests/testthat/test-get_param_bounds.R b/tests/testthat/test-get_param_bounds.R
index 646995bd..9b21b340 100644
--- a/tests/testthat/test-get_param_bounds.R
+++ b/tests/testthat/test-get_param_bounds.R
@@ -5,18 +5,23 @@ stics_version <- get_stics_versions_compat()$latest_version
context("Reaserching parameter bounds")
-xml_file <- file.path(get_examples_path("xml", stics_version = stics_version),
- "sols.xml")
+xml_file <- file.path(
+ get_examples_path("xml", stics_version = stics_version),
+ "sols.xml"
+)
xml_doc <- xmldocument(xml_file)
test_that("Researching parameter bounds", {
- expect_equal(length(get_param_bounds(xml_doc, "profhum", "min")), 2)
- expect_equal(length(
- suppressWarnings(get_param_bounds(xml_doc, "profhum"))), 3)
- expect_warning(length(get_param_bounds(xml_doc, "profhum")))
- expect_equal(
- length(
- suppressWarnings(
- get_param_bounds(xml_doc, "profhum", c("min", "max")))
- ),
- 3)
+ expect_equal(length(get_param_bounds(xml_doc, "profhum", "min")), 2)
+ expect_equal(length(
+ suppressWarnings(get_param_bounds(xml_doc, "profhum"))
+ ), 3)
+ expect_warning(length(get_param_bounds(xml_doc, "profhum")))
+ expect_equal(
+ length(
+ suppressWarnings(
+ get_param_bounds(xml_doc, "profhum", c("min", "max"))
+ )
+ ),
+ 3
+ )
})
diff --git a/tests/testthat/test-get_param_bounds_xml.R b/tests/testthat/test-get_param_bounds_xml.R
index e257e29f..a49549a7 100644
--- a/tests/testthat/test-get_param_bounds_xml.R
+++ b/tests/testthat/test-get_param_bounds_xml.R
@@ -6,24 +6,34 @@ stics_version <- get_stics_versions_compat()$latest_version
context("Researching parameter bounds")
xml_file <- file.path(
- get_examples_path("xml", stics_version = stics_version),
- "sols.xml")
+ get_examples_path("xml", stics_version = stics_version),
+ "sols.xml"
+)
plt_file <- file.path(
- get_examples_path("xml", stics_version = stics_version),
- "file_plt.xml")
+ get_examples_path("xml", stics_version = stics_version),
+ "file_plt.xml"
+)
test_that("Researching parameter bounds", {
- expect_equal(length(
- suppressWarnings(get_param_bounds_xml(xml_file, "profhum", "min"))), 2)
- expect_equal(
- length(suppressWarnings(get_param_bounds_xml(xml_file, "profhum"))), 3)
+ expect_equal(length(
+ suppressWarnings(get_param_bounds_xml(xml_file, "profhum", "min"))
+ ), 2)
+ expect_equal(
+ length(suppressWarnings(get_param_bounds_xml(xml_file, "profhum"))), 3
+ )
- expect_equal(length(
- suppressWarnings(get_param_bounds_xml(c(xml_file, plt_file),
- c("profhum", "codemonocot")))),
- 2)
- expect_warning(length(get_param_bounds_xml(xml_file, "profhum")))
- expect_equal(length(
- suppressWarnings(
- get_param_bounds_xml(xml_file, "profhum", c("min", "max")))), 3
- )
+ expect_equal(
+ length(
+ suppressWarnings(get_param_bounds_xml(
+ c(xml_file, plt_file),
+ c("profhum", "codemonocot")
+ ))
+ ),
+ 2
+ )
+ expect_warning(length(get_param_bounds_xml(xml_file, "profhum")))
+ expect_equal(length(
+ suppressWarnings(
+ get_param_bounds_xml(xml_file, "profhum", c("min", "max"))
+ )
+ ), 3)
})
diff --git a/tests/testthat/test-get_param_info.R b/tests/testthat/test-get_param_info.R
index ac4e54e6..8948a07c 100644
--- a/tests/testthat/test-get_param_info.R
+++ b/tests/testthat/test-get_param_info.R
@@ -25,7 +25,7 @@ test_that("getting all parameters from inputs.csv", {
# Testing empty result
test_that("giving a unknown variable name returns a 0 row data", {
empty_df_var <- get_param_info("myunknownvariable",
- stics_version = stics_version
+ stics_version = stics_version
)
empty_df_keyword <- get_param_info(
keyword = "myunknownkeyword",
@@ -66,7 +66,7 @@ test_that("fuzzy name", {
)
}
testthat::expect_equal(get_param_info("lai",
- stics_version = stics_version
+ stics_version = stics_version
)$name, lai_params)
})
diff --git a/tests/testthat/test-get_param_ini.R b/tests/testthat/test-get_param_ini.R
index cbca3b61..12b55167 100644
--- a/tests/testthat/test-get_param_ini.R
+++ b/tests/testthat/test-get_param_ini.R
@@ -29,11 +29,12 @@ if (version_num < 10) {
result <- c("snu", "0", "0", "0", "0", "0", "0")
test_that("multiple param option value", {
- val <- unlist(get_param_xml(xml_path, par_list,
- select = "plante",
- select_value = 1
- ),
- use.names = FALSE
+ val <- unlist(
+ get_param_xml(xml_path, par_list,
+ select = "plante",
+ select_value = 1
+ ),
+ use.names = FALSE
)
diff --git a/tests/testthat/test-get_param_plt.R b/tests/testthat/test-get_param_plt.R
index 248f30c6..ca132865 100644
--- a/tests/testthat/test-get_param_plt.R
+++ b/tests/testthat/test-get_param_plt.R
@@ -1,4 +1,3 @@
-
stics_version <- get_stics_versions_compat()$latest_version
version_num <- get_version_num()
diff --git a/tests/testthat/test-get_param_sta.R b/tests/testthat/test-get_param_sta.R
index fe8b8d75..3d47d657 100644
--- a/tests/testthat/test-get_param_sta.R
+++ b/tests/testthat/test-get_param_sta.R
@@ -1,5 +1,3 @@
-
-
stics_version <- get_stics_versions_compat()$latest_version
version_num <- get_version_num()
diff --git a/tests/testthat/test-get_param_usms.R b/tests/testthat/test-get_param_usms.R
index 11ea392c..3f8a9252 100644
--- a/tests/testthat/test-get_param_usms.R
+++ b/tests/testthat/test-get_param_usms.R
@@ -1,5 +1,3 @@
-
-
stics_version <- get_stics_versions_compat()$latest_version
version_num <- get_version_num()
@@ -97,24 +95,27 @@ test_that("getting all param from an usm", {
test_that("Changing output type", {
-
-
- set_param_xml(xml_path, param = "fclim1",
- select = "usm",
- select_value = "potato",
- values = 12345.1997,
- overwrite = TRUE)
- fclim1 <- get_param_xml(xml_path, param = "fclim1",
- select = "usm",
- select_value = "potato")
+ set_param_xml(xml_path,
+ param = "fclim1",
+ select = "usm",
+ select_value = "potato",
+ values = 12345.1997,
+ overwrite = TRUE
+ )
+ fclim1 <- get_param_xml(xml_path,
+ param = "fclim1",
+ select = "usm",
+ select_value = "potato"
+ )
expect_type(object = fclim1$usms.xml$fclim1, type = "double")
- fclim1 <- get_param_xml(xml_path, param = "fclim1",
- select = "usm",
- select_value = "potato",
- to_num = FALSE)
+ fclim1 <- get_param_xml(xml_path,
+ param = "fclim1",
+ select = "usm",
+ select_value = "potato",
+ to_num = FALSE
+ )
expect_type(object = fclim1$usms.xml$fclim1, type = "character")
-
})
diff --git a/tests/testthat/test-get_sim.R b/tests/testthat/test-get_sim.R
index 9f2234f6..d9bcb5c8 100644
--- a/tests/testthat/test-get_sim.R
+++ b/tests/testthat/test-get_sim.R
@@ -1,4 +1,4 @@
-options(warn=-1)
+options(warn = -1)
stics_version <- get_stics_versions_compat()$latest_version
version_num <- get_version_num()
@@ -108,7 +108,6 @@ test_that("output is always list, without usms.xml, banana, wheat sub-dir", {
expect_true(is.list(outputs) && !is.data.frame(outputs))
outputs <- get_sim(path3, usm = c("banana", "wheat"))
expect_true(is.list(outputs) && !is.data.frame(outputs))
-
})
# Restoring usms.xml
@@ -117,7 +116,7 @@ if (file.exists(file.path(path, "usms.xml.ori"))) {
}
test_that("output is always list, with usms.xml, banana, wheat sub-dir", {
- outputs <- get_sim(path3, "banana",
+ outputs <- get_sim(path3, "banana",
usms_file = file.path(path, "usms_example.xml")
)
expect_true(is.list(outputs) && !is.data.frame(outputs))
@@ -126,7 +125,6 @@ test_that("output is always list, with usms.xml, banana, wheat sub-dir", {
usms_file = file.path(path, "usms_example.xml")
)
expect_true(is.list(outputs) && !is.data.frame(outputs))
-
})
unlink(file.path(path, "banana"))
diff --git a/tests/testthat/test-get_soils_list.R b/tests/testthat/test-get_soils_list.R
index 92716c4f..0dd558d2 100644
--- a/tests/testthat/test-get_soils_list.R
+++ b/tests/testthat/test-get_soils_list.R
@@ -51,7 +51,7 @@ test_that("with or without success", {
expect_equal(
get_soils_list(file = xml_usms, soil = c("soil_rice", "to")),
- c("soil_rice", "soltomate", "soltousol")
+ c("soil_rice", "soltomate", "soltousol")
)
expect_equal(get_soils_list(file = xml_usms, soil = "zzz"), character(0))
diff --git a/tests/testthat/test-get_usms_files.R b/tests/testthat/test-get_usms_files.R
index be34d292..3200996f 100644
--- a/tests/testthat/test-get_usms_files.R
+++ b/tests/testthat/test-get_usms_files.R
@@ -11,7 +11,7 @@ if (!dir.exists(studycase_path)) {
download_data(
example_dirs = "study_case_1",
stics_version = stics_version
- )
+ )
}
workspace_path <- file.path(studycase_path, "XmlFiles")
diff --git a/tests/testthat/test-get_var_info.R b/tests/testthat/test-get_var_info.R
index 94940e31..76aa8e6e 100644
--- a/tests/testthat/test-get_var_info.R
+++ b/tests/testthat/test-get_var_info.R
@@ -50,8 +50,10 @@ keyword_lai_df <- data.frame(
name = c("albedolai", "diftemp1intercoupe"),
definition = c(
"albedo of the crop including soil and vegetation",
- paste("mean difference between crop and air temperatures during",
- "the vegetative phase (emergence - maximum LAI)")
+ paste(
+ "mean difference between crop and air temperatures during",
+ "the vegetative phase (emergence - maximum LAI)"
+ )
),
unit = c("SD", "degreeC"),
type = c("real", "real"),
@@ -77,8 +79,6 @@ test_that("giving an existing partial variable name in var arg or keyword", {
testthat::expect_equivalent(var_df, common_var_lai_df)
testthat::expect_equivalent(keyword_df, common_keyword_lai_df)
-
-
})
var_etmetr_df <- data.frame(
diff --git a/tests/testthat/test-get_xml_doc_example.R b/tests/testthat/test-get_xml_doc_example.R
index 3929689d..e1fadaf5 100644
--- a/tests/testthat/test-get_xml_doc_example.R
+++ b/tests/testthat/test-get_xml_doc_example.R
@@ -1,4 +1,3 @@
-
stics_version <- get_stics_versions_compat()$latest_version
version_num <- get_version_num()
diff --git a/tests/testthat/test-is_param.R b/tests/testthat/test-is_param.R
index 0f560d34..8bab8e4e 100644
--- a/tests/testthat/test-is_param.R
+++ b/tests/testthat/test-is_param.R
@@ -6,18 +6,19 @@ test_that("error", {
context("One one more existing parameters ")
test_that("exist parameter(s)", {
expect_true(is_stics_param("cfes"))
- expect_vector(is_stics_param( param = c("cfes", "mulchbat")),
- ptype = NULL, size = 2)
- expect_true(all(is_stics_param( param = c("cfes", "mulchbat"))))
-
+ expect_vector(is_stics_param(param = c("cfes", "mulchbat")),
+ ptype = NULL, size = 2
+ )
+ expect_true(all(is_stics_param(param = c("cfes", "mulchbat"))))
})
context("Exist param ")
test_that("unknown parameter", {
expect_false(is_stics_param("unknown_parameter"))
- expect_vector(is_stics_param( param = c("cfes", "unknown_parameter")),
- ptype = NULL, size = 2)
- expect_false(all(is_stics_param( param = c("cfes", "unknown_parameter"))))
+ expect_vector(is_stics_param(param = c("cfes", "unknown_parameter")),
+ ptype = NULL, size = 2
+ )
+ expect_false(all(is_stics_param(param = c("cfes", "unknown_parameter"))))
})
context("Exist param for 2 versions")
@@ -25,4 +26,3 @@ test_that("existing parameter", {
expect_true(is_stics_param("cfes", stics_version = "V9.2"))
expect_true(is_stics_param("cfes", stics_version = "V8.5"))
})
-
diff --git a/tests/testthat/test-is_var.R b/tests/testthat/test-is_var.R
index 4d71038b..29744553 100644
--- a/tests/testthat/test-is_var.R
+++ b/tests/testthat/test-is_var.R
@@ -6,18 +6,19 @@ test_that("error", {
context("One one more existing variables ")
test_that("exist variable(s)", {
expect_true(is_stics_var("albedolai"))
- expect_vector(is_stics_var( var = c("albedolai", "exolai")),
- ptype = NULL, size = 2)
- expect_true(all(is_stics_var( var = c("albedolai", "exolai"))))
-
+ expect_vector(is_stics_var(var = c("albedolai", "exolai")),
+ ptype = NULL, size = 2
+ )
+ expect_true(all(is_stics_var(var = c("albedolai", "exolai"))))
})
context("Exist var ")
test_that("unknown variable", {
expect_false(is_stics_var("unknown_variable"))
- expect_vector(is_stics_var( var = c("albedolai", "unknown_variable")),
- ptype = NULL, size = 2)
- expect_false(all(is_stics_var( var = c("albedolai", "unknown_variable"))))
+ expect_vector(is_stics_var(var = c("albedolai", "unknown_variable")),
+ ptype = NULL, size = 2
+ )
+ expect_false(all(is_stics_var(var = c("albedolai", "unknown_variable"))))
})
context("Exist var for 2 versions")
@@ -25,4 +26,3 @@ test_that("existing variable", {
expect_true(is_stics_var("albedolai", stics_version = "V9.2"))
expect_true(is_stics_var("albedolai", stics_version = "V8.5"))
})
-
diff --git a/tests/testthat/test-set_get_param_txt.R b/tests/testthat/test-set_get_param_txt.R
index 67dc0442..ab9b830e 100644
--- a/tests/testthat/test-set_get_param_txt.R
+++ b/tests/testthat/test-set_get_param_txt.R
@@ -86,9 +86,11 @@ test_that("get for an existing plant id or not", {
# Using specific value_id, for existing id or not
# soil layer: soil, ini parameters
-set_param_txt(workspace = path,
- param = "cailloux",
- value = 2)
+set_param_txt(
+ workspace = path,
+ param = "cailloux",
+ value = 2
+)
tmp <- get_param_txt(
workspace = path,
@@ -96,43 +98,47 @@ tmp <- get_param_txt(
stics_version = stics_version
)$soil$cailloux
-set_param_txt(workspace = path,
- param = "cailloux",
- value = c(1, 3, 5),
- value_id = c(1, 3, 5))
+set_param_txt(
+ workspace = path,
+ param = "cailloux",
+ value = c(1, 3, 5),
+ value_id = c(1, 3, 5)
+)
tmp2 <- get_param_txt(
workspace = path,
param = "cailloux",
stics_version = stics_version
-)$soil$cailloux[c(1,3,5)]
+)$soil$cailloux[c(1, 3, 5)]
tmp3 <- get_param_txt(
workspace = path,
param = "cailloux",
stics_version = stics_version,
- value_id = c(1,3,5),
+ value_id = c(1, 3, 5),
exact = TRUE
)$soil$cailloux
test_that("get for layer id", {
- expect_equal(tmp, rep(2,5))
+ expect_equal(tmp, rep(2, 5))
expect_equal(tmp2, tmp3)
expect_error(
get_param_txt(
workspace = path,
param = "cailloux",
stics_version = stics_version,
- value_id = c(1,3,5),
+ value_id = c(1, 3, 5),
exact = FALSE
)$plant$plant1$stlevamf
)
})
# technical operations (irrigation)
-set_param_txt(workspace = path,
- param = "amount",
- value = 40)
+set_param_txt(
+ workspace = path,
+ param = "amount",
+ value = 40
+)
tmp <- get_param_txt(
workspace = path,
@@ -140,10 +146,12 @@ tmp <- get_param_txt(
stics_version = stics_version
)$tec$plant1$amount
-set_param_txt(workspace = path,
- param = "amount",
- value = c(50, 60, 70),
- value_id = c(1, 9, 16))
+set_param_txt(
+ workspace = path,
+ param = "amount",
+ value = c(50, 60, 70),
+ value_id = c(1, 9, 16)
+)
tmp2 <- get_param_txt(
workspace = path,
@@ -161,7 +169,7 @@ tmp3 <- get_param_txt(
test_that("get for layer id", {
- expect_equal(tmp, rep(40,16))
+ expect_equal(tmp, rep(40, 16))
expect_equal(tmp2, tmp3)
expect_error(
get_param_txt(
@@ -305,7 +313,8 @@ test_that("get for NO3init, for a wrong version", {
get_param_txt(
workspace = path,
param = "NO3init",
- stics_version = "V8.5")
+ stics_version = "V8.5"
+ )
)
})
path <- get_examples_path("txt", stics_version = "V8.5")
@@ -313,7 +322,8 @@ test_that("get for NO3init, for a wrong version", {
expect_error(
get_param_txt(
workspace = path,
- param = "NO3init")
+ param = "NO3init"
+ )
)
})
@@ -322,6 +332,7 @@ test_that("get for NO3init, for a wrong version", {
expect_error(
get_param_txt(
workspace = path,
- param = "NO3init")
+ param = "NO3init"
+ )
)
})
diff --git a/tests/testthat/test-set_get_param_xml.R b/tests/testthat/test-set_get_param_xml.R
index c6ef5ec9..49caa023 100644
--- a/tests/testthat/test-set_get_param_xml.R
+++ b/tests/testthat/test-set_get_param_xml.R
@@ -15,25 +15,25 @@ file.copy(
file <- file.path(tempdir(), "file_plt.xml")
tmp1 <- unlist(get_param_xml(file,
- param = "stlevamf",
- stics_version = stics_version
+ param = "stlevamf",
+ stics_version = stics_version
))
codevar <- unlist(get_param_xml(file,
- param = "codevar",
- stics_version = stics_version
+ param = "codevar",
+ stics_version = stics_version
))
tmp2 <- unlist(get_param_xml(file,
- param = "stlevamf",
- variety = codevar, stics_version = stics_version
+ param = "stlevamf",
+ variety = codevar, stics_version = stics_version
))
variete <- unlist(get_param_xml(file,
- param = "variete",
- stics_version = stics_version# )
- # path <- tempdir()
+ param = "variete",
+ stics_version = stics_version # )
+ # path <- tempdir()
))
tmp3 <- unlist(get_param_xml(file,
- param = "stlevamf",
- variety = variete, stics_version = stics_version
+ param = "stlevamf",
+ variety = variete, stics_version = stics_version
))
test_that("variety argument can take NULL, integer or characters", {
@@ -42,17 +42,17 @@ test_that("variety argument can take NULL, integer or characters", {
})
varieties <- get_param_xml(file,
- param = "variete",
- stics_version = stics_version
+ param = "variete",
+ stics_version = stics_version
)$file_plt.xml$variete[1:1]
tmp1 <- get_param_xml(file,
- param = "stlevamf",
- variety = varieties,
- stics_version = stics_version
+ param = "stlevamf",
+ variety = varieties,
+ stics_version = stics_version
)$file_plt.xml$stlevamf
tmp2 <- get_param_xml(file,
- stics_version = stics_version
+ stics_version = stics_version
)$file_plt.xml$stlevamf[1:1]
test_that("variety argument can be a vector of characters", {
expect_equal(tmp1, tmp2)
@@ -62,18 +62,18 @@ test_that("variety argument can be a vector of characters", {
# (another parameter has a similar name : rapforme ...)
tmp <- unlist(get_param_xml(file,
- param = "forme", exact = TRUE,
- stics_version = stics_version
+ param = "forme", exact = TRUE,
+ stics_version = stics_version
))
set_param_xml(file,
- param = "forme",
- values = tmp + 1,
- overwrite = TRUE
+ param = "forme",
+ values = tmp + 1,
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- param = "forme", exact = TRUE,
- stics_version = stics_version
+ param = "forme", exact = TRUE,
+ stics_version = stics_version
))
test_that("Set and get of a non-varietal parameter for a unique plant", {
expect_equal(length(tmp), 1)
@@ -82,86 +82,86 @@ test_that("Set and get of a non-varietal parameter for a unique plant", {
# Get and modify the varietal parameter "stlevamf" for the simulated variety
tmp <- unlist(get_param_xml(file,
- param = "stlevamf",
- stics_version = stics_version
+ param = "stlevamf",
+ stics_version = stics_version
))
set_param_xml(file,
- param = "stlevamf",
- values = tmp + 1,
- overwrite = TRUE
+ param = "stlevamf",
+ values = tmp + 1,
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- param = "stlevamf",
- stics_version = stics_version
+ param = "stlevamf",
+ stics_version = stics_version
))
test_that("Set and get of a varietal parameter for a unique plant
for the simulated variety", {
- expect_equal(tmp + 1, tmp2)
- })
+ expect_equal(tmp + 1, tmp2)
+})
# Get and modify the varietal parameter "stlevamf" for a given variety
tmp <- unlist(get_param_xml(file,
- param = "stlevamf", variety = 1,
- stics_version = stics_version
+ param = "stlevamf", variety = 1,
+ stics_version = stics_version
))
set_param_xml(file,
- param = "stlevamf",
- values = as.numeric(tmp) + 1,
- variety = 1,
- overwrite = TRUE
+ param = "stlevamf",
+ values = as.numeric(tmp) + 1,
+ variety = 1,
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- workspace = path, param = "stlevamf", variety = 1,
- stics_version = stics_version
+ workspace = path, param = "stlevamf", variety = 1,
+ stics_version = stics_version
))
test_that("Set and get of a varietal parameter for a unique plant
for a given variety", {
- expect_equal(tmp + 1, tmp2)
- })
+ expect_equal(tmp + 1, tmp2)
+})
# Get and modify the non-varietal parameter "forme" for the simulated variety
tmp <- unlist(get_param_xml(file,
- param = "forme", exact = TRUE,
- stics_version = stics_version
+ param = "forme", exact = TRUE,
+ stics_version = stics_version
))
set_param_xml(file,
- param = "forme",
- values = tmp + 1,
- overwrite = TRUE
+ param = "forme",
+ values = tmp + 1,
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- param = "forme", exact = TRUE,
- stics_version = stics_version
+ param = "forme", exact = TRUE,
+ stics_version = stics_version
))
test_that("Set and get of a non-varietal parameter for an intercrop
for the simulated variety", {
- expect_equal(tmp + 1, tmp2)
- })
+ expect_equal(tmp + 1, tmp2)
+})
# Get and modify the varietal parameter "stlevamf" for the simulated variety
tmp <- unlist(get_param_xml(file,
- param = "stlevamf",
- stics_version = stics_version
+ param = "stlevamf",
+ stics_version = stics_version
))
set_param_xml(file,
- param = "stlevamf",
- values = tmp + 1,
- overwrite = TRUE
+ param = "stlevamf",
+ values = tmp + 1,
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- param = "stlevamf",
- stics_version = stics_version
+ param = "stlevamf",
+ stics_version = stics_version
))
test_that("Set and get of a varietal parameter for an intercrop
for the simulated variety", {
- expect_equal(tmp + 1, tmp2)
- })
+ expect_equal(tmp + 1, tmp2)
+})
@@ -173,30 +173,29 @@ tmp <- get_param_xml(
file = file,
param = "HCCF",
select = "sol",
- select_value= "solcanne",
- value_id = c(1,3,5)
+ select_value = "solcanne",
+ value_id = c(1, 3, 5)
)
tmp <- unlist(tmp)
set_param_xml(file,
- param = "HCCF",
- values = tmp + 1,
- select = "sol",
- select_value= "solcanne",
- value_id = c(1,3,5),
- overwrite = TRUE
+ param = "HCCF",
+ values = tmp + 1,
+ select = "sol",
+ select_value = "solcanne",
+ value_id = c(1, 3, 5),
+ overwrite = TRUE
)
tmp2 <- unlist(get_param_xml(file,
- param = "HCCF",
- select = "sol",
- select_value= "solcanne",
- value_id = c(1,3,5))
-)
+ param = "HCCF",
+ select = "sol",
+ select_value = "solcanne",
+ value_id = c(1, 3, 5)
+))
test_that("Set and get of a varietal parameter for an intercrop
for the simulated variety", {
- expect_equal(tmp + 1, tmp2)
- })
-
+ expect_equal(tmp + 1, tmp2)
+})
diff --git a/vignettes/Generating_Stics_XML_files.Rmd b/vignettes/Generating_Stics_XML_files.Rmd
index 10ae888a..398988d9 100644
--- a/vignettes/Generating_Stics_XML_files.Rmd
+++ b/vignettes/Generating_Stics_XML_files.Rmd
@@ -77,12 +77,13 @@ usm_xl_file <- download_usm_xl(out_dir = xl_dir)
#> [1] "inputs_stics_example.xlsx has been copied in directory
#> "/path/to/xl/dir
-
```
```{r, eval=TRUE, echo = FALSE, results='hide'}
-usm_xl_file <- download_usm_xl(file = "inputs_stics_example.xlsx",
- out_dir = workspace_path)
+usm_xl_file <- download_usm_xl(
+ file = "inputs_stics_example.xlsx",
+ out_dir = workspace_path
+)
```
@@ -97,16 +98,20 @@ usm_csv_file <- download_usm_csv(file = "inputs_stics_example_USMs.csv")
# Getting the file in a specific directory
csv_dir <- "/path/to/csv/dir" # or something like C:/path/to/xl/dir" for Windows
-usm_csv_file <- download_usm_csv(file = "inputs_stics_example_USMs.csv",
- out_dir = csv_dir)
+usm_csv_file <- download_usm_csv(
+ file = "inputs_stics_example_USMs.csv",
+ out_dir = csv_dir
+)
#> [1] inputs_stics_example_USMs.csv has been copied in directory
#> "/path/to/csv/dir
```
```{r, eval=TRUE, echo = FALSE, results='hide'}
-usm_csv_file <- download_usm_csv(file = "inputs_stics_example_USMs.csv",
- out_dir = workspace_path)
+usm_csv_file <- download_usm_csv(
+ file = "inputs_stics_example_USMs.csv",
+ out_dir = workspace_path
+)
```
@@ -167,8 +172,10 @@ Here is the actual **correspondence table** of `keywords` to be used in paramete
```{r echo=FALSE, eval=TRUE, fig.align='center'}
l <- SticsRFiles:::get_params_dict()
-df <- data.frame(keyword = names(l), realname = unlist(l, use.names = FALSE),
- stringsAsFactors = FALSE)
+df <- data.frame(
+ keyword = names(l), realname = unlist(l, use.names = FALSE),
+ stringsAsFactors = FALSE
+)
rmarkdown::paged_table(df)
```
@@ -234,7 +241,6 @@ rmarkdown::paged_table(xl_param)
```{r gen_usms_file, eval = FALSE}
-
# Output file path
out_file <- "/path/to/file/usms.xml"
# or something like C:/path/to/file/usms.xml" for Windows
@@ -289,7 +295,6 @@ rmarkdown::paged_table(soils_param)
```{r gen_sols_file, eval = FALSE}
-
# Output file path
out_file <- "/path/to/file/sols.xml"
# or something like C:/path/to/file/usms.xml" for Windows
@@ -347,7 +352,6 @@ gen_tec_xml(param_df = tec_param, out_dir = workspace_path)
```{r eval_gen_tec_files, eval = TRUE, echo = FALSE}
-
# *_tec.xml files, one for each xl_param line
gen_tec_xml(param_df = tec_param, out_dir = workspace_path)
```
@@ -355,8 +359,10 @@ gen_tec_xml(param_df = tec_param, out_dir = workspace_path)
Example of a `tec` parameters file content sub-list:
```{r show_tec_file, eval = TRUE, echo = FALSE, class.output="xml"}
-l <- readLines(con = file.path(workspace_path,
- "BIN_CAN_05_SEC_220-0-0_34K_CANPC05T3_Q_tec.xml"))
+l <- readLines(con = file.path(
+ workspace_path,
+ "BIN_CAN_05_SEC_220-0-0_34K_CANPC05T3_Q_tec.xml"
+))
cat(paste(c(l[1:30], "...", l[length(l) - 1]), collapse = "\n"))
```
@@ -391,7 +397,6 @@ gen_ini_xml(param_df = ini_param, out_dir = workspace_path)
```{r eval_gen_ini_files, eval = TRUE, echo = FALSE}
-
# *_ini.xml files, one for each xl_param line
gen_ini_xml(param_df = ini_param, out_dir = workspace_path)
```
@@ -439,7 +444,6 @@ gen_sta_xml(param_df = sta_param, out_dir = workspace_path)
```{r eval_gen_sta_files, eval = TRUE, echo = FALSE}
-
# *_sta.xml files, one for each xl_param line
gen_sta_xml(param_df = sta_param, out_dir = workspace_path)
```
@@ -463,6 +467,5 @@ gen_general_param_xml(out_dir = workspace_path)
# or with a specific version
gen_general_param_xml(out_dir = workspace_path, stics_version = "V10.2.0")
-
```
diff --git a/vignettes/Generating_Stics_text_files.Rmd b/vignettes/Generating_Stics_text_files.Rmd
index 22217257..c5127872 100644
--- a/vignettes/Generating_Stics_text_files.Rmd
+++ b/vignettes/Generating_Stics_text_files.Rmd
@@ -33,7 +33,7 @@ javastics_path <- params$javastics_path
workspace_path <- params$workspace_path
output_path <- params$output_path
chunk_eval <- params$eval
-#java_cmd <- params$java_cmd
+# java_cmd <- params$java_cmd
gen_usms_xml2txt <- SticsRFiles::gen_usms_xml2txt
```
@@ -61,7 +61,6 @@ workspace_path <- "example"
# Specifying an output folder path
output_path <- "/path/to/output/folder"
-
```
## Converting files into separated folders (one per usm)
@@ -69,8 +68,10 @@ output_path <- "/path/to/output/folder"
## Generating files for all the usms contained in the workspace
# Into the workspace directory
-gen_usms_xml2txt(javastics_path,
- workspace_path)
+gen_usms_xml2txt(
+ javastics_path,
+ workspace_path
+)
#> ℹ USM 'SugarCane' successfully created
#> ℹ USM 'potato' successfully created
#> ℹ USM 'banana' successfully created
@@ -119,42 +120,43 @@ gen_usms_xml2txt(javastics_path,
#> ℹ USM 'cc_vetch' successfully created
#> ℹ USM 'cc_CrimsonClover' successfully created
#> ℹ USM 'proto_rice' successfully created
-
```
```{r convert_to_separate_2, eval = chunk_eval}
-
# Into a specific output folder, with verbose mode turned off
gen_usms_xml2txt(javastics_path,
- workspace_path,
- out_dir = output_path,
- verbose = FALSE)
+ workspace_path,
+ out_dir = output_path,
+ verbose = FALSE
+)
## Generating files for a subset of usms
# Into the workspace directory
gen_usms_xml2txt(javastics_path,
- workspace_path,
- usm = c("banana", "wheat"))
+ workspace_path,
+ usm = c("banana", "wheat")
+)
#> ℹ USM 'banana' successfully created
#> ℹ USM 'wheat' successfully created
# Into a specific folder
gen_usms_xml2txt(javastics_path,
- workspace_path,
- usm = c("banana", "wheat"),
- out_dir = output_path)
+ workspace_path,
+ usm = c("banana", "wheat"),
+ out_dir = output_path
+)
#> ℹ USM 'banana' successfully created
#> ℹ USM 'wheat' successfully created
-
```
```{r convert_to_separate_3, eval = chunk_eval}
## Getting returned information about files generation
gen_info <- gen_usms_xml2txt(javastics_path,
- workspace_path,
- usm = c("banana", "wheat"),
- out_dir = output_path)
+ workspace_path,
+ usm = c("banana", "wheat"),
+ out_dir = output_path
+)
#> ℹ USM 'banana' successfully created
#> ℹ USM 'wheat' successfully created
@@ -186,16 +188,18 @@ gen_info
# In this case the model files are overwritten at each gen_usms_xml2txt call !
# In the workspace
gen_usms_xml2txt(javastics_path,
- workspace_path,
- usm = "banana",
- dir_per_usm_flag = FALSE,
- verbose = FALSE)
+ workspace_path,
+ usm = "banana",
+ dir_per_usm_flag = FALSE,
+ verbose = FALSE
+)
# In a specific folder
gen_usms_xml2txt(javastics_path,
- workspace_path,
- usm = "banana",
- out_dir = output_path,
- dir_per_usm_flag = FALSE,
- verbose = FALSE)
+ workspace_path,
+ usm = "banana",
+ out_dir = output_path,
+ dir_per_usm_flag = FALSE,
+ verbose = FALSE
+)
```
diff --git a/vignettes/Manipulating_Stics_XML_files.Rmd b/vignettes/Manipulating_Stics_XML_files.Rmd
index 578f71b0..9624eaa6 100644
--- a/vignettes/Manipulating_Stics_XML_files.Rmd
+++ b/vignettes/Manipulating_Stics_XML_files.Rmd
@@ -29,7 +29,7 @@ suppressWarnings(library(tibble))
load_param_names <- function() {
tibble::as_tibble(
read.csv2(file = "param_names.csv", stringsAsFactors = FALSE)
- )
+ )
}
```
@@ -42,15 +42,16 @@ examples_path <- get_examples_path("xml", stics_version = stics_version)
xml_root <- normalizePath(tempdir(), winslash = "/", mustWork = FALSE)
xml_loc_dir <- file.path(xml_root, "XML")
if (!dir.exists(xml_loc_dir)) dir.create(xml_loc_dir)
-
```
```{r rm_files, results='hide', echo=FALSE}
-files_list <- list.files(path = xml_loc_dir, pattern = "\\.xml$",
- full.names = TRUE)
+files_list <- list.files(
+ path = xml_loc_dir, pattern = "\\.xml$",
+ full.names = TRUE
+)
files_list
-if (length(files_list)) {
+if (length(files_list)) {
print("Removing files")
file.remove(files_list)
}
@@ -161,7 +162,6 @@ In xml_dir, we store the directory path of the XML files available in the SticsR
```{r set_xml_dir, echo = FALSE}
xml_dir <- get_examples_path(file_type = "xml", stics_version = stics_version)
-
```
```{r, eval=FALSE}
@@ -174,13 +174,11 @@ xml_dir <- get_examples_path(file_type = "xml", stics_version = stics_version)
# For windows
#> "C:/Users/username/Documents/R/win-lib/3.6/SticsRFiles/
#> extdata/xml/examples/V10.2.0"
-
```
## Examples files
```{r}
-
xml_files <- list.files(path = xml_dir, pattern = ".xml$", full.names = TRUE)
# Listing only the first three files of the entire list
@@ -200,24 +198,23 @@ xml_files <- list.files(path = xml_dir, pattern = ".xml$", full.names = TRUE)
#> examples/V10.2.0/file_plt.xml"
#> [3] "C:/Users/username/Documents/R/win-lib/3.6/SticsRFiles/extdata/xml/
#> examples/V10.2.0/file_sta.xml"
-
```
``` {r, echo=FALSE, results="hide"}
files_list <- list.files(path = xml_dir, pattern = ".xml$")
-legend <- c("initializations", "plant", "station", "crop management",
- "general", "general (new formalisms)", "soils", "usms")
+legend <- c(
+ "initializations", "plant", "station", "crop management",
+ "general", "general (new formalisms)", "soils", "usms"
+)
dt <- data.frame(files = files_list, groups = legend)
-
```
The corresponding files types to file names is given in the above table:
``` {r, echo = FALSE}
knitr::kable(dt)
-#, caption = "Correspondence between XML example files names
+# , caption = "Correspondence between XML example files names
# and parameters groups")
-
```
## Copying files in a local directory
@@ -228,14 +225,15 @@ knitr::kable(dt)
# Setting a local directory path
# xml_loc_dir <- "/path/to/local/directory"
-file.copy(from = file.path(xml_dir, "sols.xml"),
- to = file.path(xml_loc_dir, "sols.xml"), overwrite = TRUE)
+file.copy(
+ from = file.path(xml_dir, "sols.xml"),
+ to = file.path(xml_loc_dir, "sols.xml"), overwrite = TRUE
+)
```
### All files
```{r}
-
file.copy(from = xml_files, to = xml_loc_dir)
```
@@ -278,11 +276,9 @@ Using the `get_param_info` function without any argument, or with specifying the
In the above code block, an extract of the returned information table is shown:
```{r, eval = FALSE}
-
param_names <- get_param_info()
head(param_names)
-
```
```{r echo = FALSE}
param_names <- get_param_info()
@@ -303,11 +299,9 @@ rmarkdown::paged_table(param_names)
If parameters names are known and are given with the right syntax, information can be retrieved as follows
```{r, eval = FALSE}
-
get_param_info(param = "albedo")
get_param_info(param = c("albedo", "latitude", "humcapil"))
-
```
```{r echo = FALSE}
param_names[grep("albedo", param_names$name), ]
@@ -317,7 +311,6 @@ idx <- grepl("albedo", param_names$name) |
grepl("humcapil", param_names$name)
param_names[idx, ]
-
```
### Getting parameters information using partial names matching
@@ -325,12 +318,10 @@ param_names[idx, ]
A search with incomplete names may be done as follows
```{r}
-
get_param_info(param = "hum")
param_names <- get_param_info(param = c("alb", "hum"))
-
```
The found parameters data.frame content is presented in the above paged table.
@@ -346,17 +337,13 @@ rmarkdown::paged_table(param_names)
The `keyword` argument (one or several possible strings) may be used to search in all textual columns as `name` or `description`.
```{r, warning = FALSE, eval = FALSE}
-
get_param_info(keyword = "hum")
param_names <- get_param_info(keyword = c("alb", "hum"))
-
-
```
```{r echo = FALSE}
param_names <- get_param_info(keyword = c("alb", "hum"))
-
```
The found parameters data.frame content is presented in the above paged table.
@@ -364,7 +351,6 @@ The found parameters data.frame content is presented in the above paged table.
```{r, warning=FALSE, echo = FALSE}
# Displaying the returned data as a paged table
rmarkdown::paged_table(param_names)
-
```
# Getting parameters values from XML files
@@ -395,15 +381,15 @@ get_param_xml(par_gen, param = "codeactimulch")
get_param_xml(par_gen, param = "tnitopt")
# Using a conditional selection
-get_param_xml(sols, param = "argi", select = "sol",
- select_value = "solcanne")
-
+get_param_xml(sols,
+ param = "argi", select = "sol",
+ select_value = "solcanne"
+)
```
* For one parameter and several occurences
```{r}
-
# For all soils
get_param_xml(sols, param = "argi")
@@ -412,7 +398,6 @@ get_param_xml(sols, param = "argi")
* For several parameters and several occurrences
```{r}
-
# For all soils
get_param_xml(sols, param = c("argi", "pH"))
```
@@ -420,10 +405,11 @@ get_param_xml(sols, param = c("argi", "pH"))
* For several parameters and one occurrence (conditional selection)
```{r}
-
# For one soil
-get_param_xml(sols, param = c("argi", "pH"), select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = c("argi", "pH"), select = "sol",
+ select_value = "solcanne"
+)
```
## Vector parameters extraction
@@ -441,30 +427,31 @@ get_param_xml(sols, param = c("epc", "infil"))
```{r}
# For all soil layers
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- value = "solcanne")
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ value = "solcanne"
+)
```
```{r}
# For all irrigation supplies
tec <- file.path(xml_loc_dir, "file_tec.xml")
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"))
-
```
* Selecting with values index (among 5 soil layers, several irrigations supply)
```{r}
# For soil layers 1 to 3
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- select_value = "solcanne", ids = 1:3)
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ select_value = "solcanne", ids = 1:3
+)
```
```{r}
-
# For irrigation operations 1 to 5
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"), ids = 1:5)
-
```
## Getting all parameters values from files
@@ -476,7 +463,6 @@ tec_param_values <- get_param_xml(tec)[[1]]
#
# Displaying only a subset of the list
head(tec_param_values, n = 10)
-
```
A files list may be used also to get all parameters as follows in the same list
@@ -510,8 +496,6 @@ In the following examples, the original file is always overwritten. Before and a
* For one parameter and one occurrence
```{r}
-
-
## An option parameter
# Initial value
@@ -540,17 +524,22 @@ get_param_xml(par_gen, param = "tnitopt")
## Using a conditional selection
# Initial value
-get_param_xml(sols, param = "argi", select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = "argi", select = "sol",
+ select_value = "solcanne"
+)
# Setting a new one
-set_param_xml(sols, param = "argi", values = 33, select = "sol",
- select_value = "solcanne", overwrite = TRUE)
+set_param_xml(sols,
+ param = "argi", values = 33, select = "sol",
+ select_value = "solcanne", overwrite = TRUE
+)
# Controlling written value
-get_param_xml(sols, param = "argi", select = "sol",
- select_value = "solcanne")
-
+get_param_xml(sols,
+ param = "argi", select = "sol",
+ select_value = "solcanne"
+)
```
* For one parameter and several occurences
@@ -558,7 +547,6 @@ get_param_xml(sols, param = "argi", select = "sol",
For passing several parameters values (for one or more parameters) or single values for several parameters, the `param_value` argument must contain a list of vectors of values with the same length as `param` vector.
```{r}
-
## For all soils
soils_number <- length(get_soils_list(sols))
@@ -566,8 +554,10 @@ soils_number <- length(get_soils_list(sols))
get_param_xml(sols, param = "argi")
# One value per occurence
-set_param_xml(sols, param = "argi", values = list(1:soils_number),
- overwrite = TRUE)
+set_param_xml(sols,
+ param = "argi", values = list(1:soils_number),
+ overwrite = TRUE
+)
# Controlling written values
get_param_xml(sols, param = "argi")
@@ -577,54 +567,58 @@ set_param_xml(sols, param = "argi", values = 40, overwrite = TRUE)
# Controlling written values
get_param_xml(sols, param = "argi")
-
-
```
* For several parameters and several occurrences
```{r}
-
## For all soils
soils_number <- length(get_soils_list(sols))
# Initial values
# Setting one value per parameters occurence
-set_param_xml(sols, param = list("argi", "pH"),
- values = list(1:soils_number, soils_number:1),
- overwrite = TRUE)
+set_param_xml(sols,
+ param = list("argi", "pH"),
+ values = list(1:soils_number, soils_number:1),
+ overwrite = TRUE
+)
# Controlling written values
get_param_xml(sols, param = c("argi", "pH"))
# Setting the same value for all occurences
-set_param_xml(sols, param = c("argi", "pH"), values = list(50, 8),
- overwrite = TRUE)
+set_param_xml(sols,
+ param = c("argi", "pH"), values = list(50, 8),
+ overwrite = TRUE
+)
# Controlling written values
get_param_xml(sols, param = c("argi", "pH"))
-
-
```
* For several parameters and one occurrence (conditional selection)
```{r}
-
## For one soil
# Initial values
-get_param_xml(sols, param = c("argi", "pH"), select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = c("argi", "pH"), select = "sol",
+ select_value = "solcanne"
+)
# Setting new values
-set_param_xml(sols, param = c("argi", "pH"), values = list(50, 8),
- select = "sol", select_value = "solcanne", overwrite = TRUE)
+set_param_xml(sols,
+ param = c("argi", "pH"), values = list(50, 8),
+ select = "sol", select_value = "solcanne", overwrite = TRUE
+)
# Controlling written values
-get_param_xml(sols, param = c("argi", "pH"), select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = c("argi", "pH"), select = "sol",
+ select_value = "solcanne"
+)
```
## Vector parameters
@@ -635,16 +629,22 @@ get_param_xml(sols, param = c("argi", "pH"), select = "sol",
## For all soil layers
# Initial values
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ select_value = "solcanne"
+)
# Setting new values
-set_param_xml(sols, param = c("epc", "infil"), values = list(18:22, 48:52),
- select = "sol", select_value = "solcanne", overwrite = TRUE)
+set_param_xml(sols,
+ param = c("epc", "infil"), values = list(18:22, 48:52),
+ select = "sol", select_value = "solcanne", overwrite = TRUE
+)
# Controlling written values
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- select_value = "solcanne")
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ select_value = "solcanne"
+)
```
```{r}
@@ -655,12 +655,13 @@ tec <- file.path(xml_loc_dir, "file_tec.xml")
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"))
# Setting new values
-set_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"),
- values = list(200:215, 20:35), overwrite = TRUE)
+set_param_xml(tec,
+ param = c("julapI_or_sum_upvt", "amount"),
+ values = list(200:215, 20:35), overwrite = TRUE
+)
# Controlling written values
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"))
-
```
* Some values
@@ -673,30 +674,37 @@ A vector of logical values may be used instead of position values for queries or
## For soil layers 1 to 3
# Initial values
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- select_value = "solcanne", ids = 1:3)
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ select_value = "solcanne", ids = 1:3
+)
# Setting new values
-set_param_xml(sols, param = c("epc", "infil"), values = list(20:18, 50:48),
- select = "sol", select_value = "solcanne", overwrite = TRUE,
- ids = 1:3)
+set_param_xml(sols,
+ param = c("epc", "infil"), values = list(20:18, 50:48),
+ select = "sol", select_value = "solcanne", overwrite = TRUE,
+ ids = 1:3
+)
# Controlling written values
-get_param_xml(sols, param = c("epc", "infil"), select = "sol",
- select_value = "solcanne", ids = 1:3)
+get_param_xml(sols,
+ param = c("epc", "infil"), select = "sol",
+ select_value = "solcanne", ids = 1:3
+)
```
```{r}
-
## For irrigation operations 1 to 5 (same indices for all parameters)
# Initial values
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"))
# Setting new values
-set_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"),
- values = list(204:200, 24:20), overwrite = TRUE, ids = 1:5)
+set_param_xml(tec,
+ param = c("julapI_or_sum_upvt", "amount"),
+ values = list(204:200, 24:20), overwrite = TRUE, ids = 1:5
+)
# Controlling written values
get_param_xml(tec, param = c("julapI_or_sum_upvt", "amount"))
diff --git a/vignettes/Manipulating_Stics_text_files.Rmd b/vignettes/Manipulating_Stics_text_files.Rmd
index 3fb8ce48..696ee018 100644
--- a/vignettes/Manipulating_Stics_text_files.Rmd
+++ b/vignettes/Manipulating_Stics_text_files.Rmd
@@ -101,13 +101,17 @@ A particular search in plant parameters for specific varieties, can be done usin
* either using names,
```{r}
-get_param_txt(workspace = example_txt_dir, param = "stlevamf",
- variety = c("Pactol", "Cecilia", "clarica"))
+get_param_txt(
+ workspace = example_txt_dir, param = "stlevamf",
+ variety = c("Pactol", "Cecilia", "clarica")
+)
```
* or using varieties indexes in plant file,
```{r}
-get_param_txt(workspace = example_txt_dir, param = "stlevamf",
- variety = c(1, 2, 5))
+get_param_txt(
+ workspace = example_txt_dir, param = "stlevamf",
+ variety = c(1, 2, 5)
+)
```
@@ -191,11 +195,13 @@ get_param_txt(workspace = example_txt_dir, param = "densinitial")
* The values for the plant 1 and layers 1 and 4 are replaced as follows:
```{r}
-set_param_txt(workspace = example_txt_dir,
- param = "densinitial",
- plant_id = 1,
- layer = c(1, 4),
- value = c(0.5, 0.1))
+set_param_txt(
+ workspace = example_txt_dir,
+ param = "densinitial",
+ plant_id = 1,
+ layer = c(1, 4),
+ value = c(0.5, 0.1)
+)
```
* The final values in the file are:
diff --git a/vignettes/SticsRFiles.Rmd b/vignettes/SticsRFiles.Rmd
index 2d2d1200..3b5af54b 100644
--- a/vignettes/SticsRFiles.Rmd
+++ b/vignettes/SticsRFiles.Rmd
@@ -85,15 +85,19 @@ All the example data used in this article are available from the [`data` reposit
SticsRFiles provides a function to download it from the command line. Please execute the following command in R:
```{r include=FALSE}
-example_data <- SticsRFiles::download_data(out_dir = tempdir(),
- example_dirs = "study_case_1",
- "V10.0")
+example_data <- SticsRFiles::download_data(
+ out_dir = tempdir(),
+ example_dirs = "study_case_1",
+ "V10.0"
+)
```
```{r eval=FALSE}
library(SticsRFiles)
-example_data <- SticsRFiles::download_data(example_dirs = "study_case_1",
- "V10.0")
+example_data <- SticsRFiles::download_data(
+ example_dirs = "study_case_1",
+ "V10.0"
+)
```
The example data is downloaded by default in a temporary folder.
@@ -148,8 +152,10 @@ dlaimax
But this function is way more powerful than just that. You can also get the values for all parameters in a given formalism (`formalisme` in French, yes some variables are still written in French in STICS). To do so, use the `select` argument like so:
```{r}
-values <- get_param_xml(plant_file, select = "formalisme",
- select_value = "radiation interception")
+values <- get_param_xml(plant_file,
+ select = "formalisme",
+ select_value = "radiation interception"
+)
unlist(values) # For pretty-printing
```
@@ -177,8 +183,10 @@ We can generate observation files from a `data.frame` using `gen_obs()`.
Lets create some dummy `data.frame` first:
```{r}
-obs_df <- data.frame(usm_name = "Test", ian = 2021, mo = 3:10, jo = 1,
- `masec(n)` = 0.1 * 3:10)
+obs_df <- data.frame(
+ usm_name = "Test", ian = 2021, mo = 3:10, jo = 1,
+ `masec(n)` = 0.1 * 3:10
+)
```
Then we can write the data to a file using `gen_obs()`:
diff --git a/vignettes/Upgrading_STICS_XML_files.Rmd b/vignettes/Upgrading_STICS_XML_files.Rmd
index 1b35e08b..a9dace71 100644
--- a/vignettes/Upgrading_STICS_XML_files.Rmd
+++ b/vignettes/Upgrading_STICS_XML_files.Rmd
@@ -14,7 +14,6 @@ knitr::opts_chunk$set(
comment = "#>",
tidy = TRUE
)
-
```
```{r eval=FALSE}
@@ -38,15 +37,19 @@ One can either transform a complete workspace directory at once or each kind of
```{r, include = FALSE, eval=FALSE}
-example_data <- SticsRFiles::download_data(out_dir = tempdir(),
- example_dirs = "study_case_1", "V9.2")
+example_data <- SticsRFiles::download_data(
+ out_dir = tempdir(),
+ example_dirs = "study_case_1", "V9.2"
+)
workspace <- file.path(example_data, "XmlFiles")
out_dir <- file.path(tempdir(), "XmlFiles_V10.2.0")
if (!dir.exists(out_dir)) dir.create(out_dir)
javastics <-
"/home/plecharpent/tmp/TEST_UPDATE_XML_V9_V10/JavaSTICS-1.41-stics-9.2"
-upgrade_workspace_xml(workspace = workspace, javastics = javastics,
- out_dir = out_dir, overwrite = TRUE)
+upgrade_workspace_xml(
+ workspace = workspace, javastics = javastics,
+ out_dir = out_dir, overwrite = TRUE
+)
```
## Upgrading a whole workspace
@@ -59,8 +62,10 @@ So, apart from the XML files, some other files as outputs definition files (*.mo
workspace <- "/path/to/workspace/dir/V9.2"
out_dir <- "/path/to/out/dir/V10.2.0"
javastics <- "/path/to/JavaSTICS-1.41-stics-9.2"
-upgrade_workspace_xml(workspace = workspace, javastics = javastics,
- out_dir = out_dir)
+upgrade_workspace_xml(
+ workspace = workspace, javastics = javastics,
+ out_dir = out_dir
+)
```
Here is the output display indicating the treated files:
@@ -110,16 +115,20 @@ For example, the **`usms.xml`** file is to be upgraded as follows:
usms_path <- file.path(example_data, "XmlFiles", "usms.xml")
out_dir <- file.path(tempdir(), "XmlFiles_V10.2.0")
param_gen_path <- file.path(javastics, "config", "param_gen.xml")
-upgrade_usms_xml(file = usms_path, param_gen_file = param_gen_path,
- out_dir = out_dir, overwrite = TRUE)
+upgrade_usms_xml(
+ file = usms_path, param_gen_file = param_gen_path,
+ out_dir = out_dir, overwrite = TRUE
+)
```
```{r, eval = FALSE}
usms_path <- "/path/to/workspace/dir/V9.2/usms.xml"
out_dir <- "/path/to/workspace/dir/V10.2.0"
param_gen_path <- "/path/to/JavaSTICS-1.41-stics-9.2/config/param_gen.xml"
-upgrade_usms_xml(file = usms_path, param_gen_file = param_gen_path,
- out_dir = out_dir)
+upgrade_usms_xml(
+ file = usms_path, param_gen_file = param_gen_path,
+ out_dir = out_dir
+)
```