###############################################################################
#rSOILWAT2
# Copyright (C) {2009-2018} {Ryan Murphy, Daniel Schlaepfer,
# William Lauenroth, John Bradford}
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
###############################################################################
#--- Topic: weather data ------
#' `rSOILWAT2` weather data functionality
#'
#' @param wd A list of elements of class [`swWeatherData-class`]
#' that each hold daily weather data for one calendar year.
#' @param weatherData A list of elements of class [`swWeatherData-class`]
#' that each hold daily weather data for one calendar year.
#' @param dailySW A list of elements of class [`swWeatherData-class`]
#' that each hold daily weather data for one calendar year.
#'
#' @param weatherDF A `data.frame`. Daily weather data where rows represent
#' days and columns represent the weather variables
#' (see `weatherDF_dataColumns`).
#' @param weatherDF_dataColumns A vector of character strings. The column
#' names of `weatherDF` in the correct order for `SOILWAT2` including
#' calendar year `year` (optional) and day of year `DOY`, see
#' [weather_dataColumns()].
#'
#'
#' @param years A numeric vector. The calendar years.
#' @param digits An integer value. The number of decimal places for rounding
#' weather values (or `TRUE` but no rounding if `FALSE` or not finite).
#' @param round An integer value. The number of decimal places for rounding
#' weather values (or `TRUE` but no rounding if `FALSE` or not finite).
#'
#' @param weather_tag A character string. The base file name without extension
#' for `SOILWAT2`-formatted input files; default is `"weath"`
#'
#' @name sw_weather_data
#' @md
NULL
#--- Topic: weather data base ------
#' Weather data base structure
#'
#' @param dbFilePath A character string. The file path of the weather database.
#' This will be a file of type `sqlite3`. In-memory databases are not
#' supported.
#' @param site_data A data.frame. The site data with column names
#' `Longitude`, `Latitude`, and `Label`.
#' @param Site_id An integer value. The IDs/database key of the queried site.
#' @param site_id An integer value. The IDs/database key of the queried site.
#' @param Site_ids An integer vector. The IDs/database keys of the queried sites
#' @param site_ids An integer vector. The IDs/database keys of the queried sites
#' @param Labels A vector of character strings. The names/labels of
#' queried sites.
#' @param Label A character string. The name/label of the queried site.
#' @param site_labels A vector of character string. The names/labels of
#' queried sites.
#' @param site_label A character string. The name/label of the queried site.
#' @param lat A numeric vector or `NULL`. The latitude in decimal degrees
#' of `WGS84`. Northern latitude are positive, sites on the southern
#' hemisphere have negative values.
#' @param long A numeric vector or `NULL`. The longitude in decimal degrees
#' of `WGS84`. Eastern longitudes are positive, sites on the western
#' hemisphere have negative values.
#' @param Scenario_ids An integer vector. The IDs/database keys of the queried
#' scenario.
#' @param scen_ids An integer vector. The IDs/database keys of the queried
#' scenario.
#' @param Scenario_id An integer value The ID/database key of the queried
#' scenario.
#' @param scenario_id An integer value The ID/database key of the queried
#' scenario.
#' @param Scenarios A vector of character strings. The climate scenarios of
#' which the first one is enforced to be `scen_ambient`.
#' @param scen_labels A vector of character strings. The climate scenarios of
#' which the first one is enforced to be `scen_ambient`.
#' @param Scenario A character string. The name/label of a climate scenario.
#' @param scenario A character string. The name/label of a climate scenario.
#' @param scen_ambient A character string. The first/default climate scenario.
#' @param startYear A numeric value. First calendar year of the weather data.
#' @param endYear A numeric value. Last calendar year of the weather data.
#' @param ignore.case A logical value.
#' @param verbose A logical value.
#'
#' @name sw_weather_database
#' @md
NULL
## ------SQLite weather database functions
# Daily weather data is stored in database as SQL-blob of a list of R objects
# of class \code{\linkS4class{swWeatherData}}
#' Insistently interacting with the weather database
#'
#' This is particularly suitable for [DBI::dbGetQuery()] and [DBI::dbExecute()].
#'
#' @param fun A function.
#' The function must have arguments `conn`, `statement`, and `params` or
#' silently ignore them via `...`.
#'
#' @noRd
#' @md
dbW_InsistInteract <- function(
fun,
statement,
params = NULL,
...,
max_attempts = 10L,
wait = 0.1
) {
stopifnot(dbW_IsValid())
res <- NULL
k <- 1
repeat {
# Capture errors in case database is busy
res <- try(
fun(rSW2_glovars$con, statement = statement, params = params, ...),
silent = TRUE
)
if (inherits(res, "try-error")) {
if (k <= max_attempts) {
# Prepare next attempt
k <- k + 1
# Set busy handler to time out after 10 seconds
# (in milliseconds) of retries
# It's reported that SQLite may reset the busy handler
# https://github.com/r-dbi/RSQLite/issues/280#issuecomment-751441914
try(DBI::dbExecute(rSW2_glovars$con, "PRAGMA busy_timeout = 10000"))
# Wait a bit before next attempt
Sys.sleep(wait)
} else {
stop("`dbGetQuery` failed after ", k, " attempts: ", shQuote(res))
}
} else {
# success
break
}
}
res
}
#' Check whether registered weather database connection is valid
#' @return A logical value.
#' @export
dbW_IsValid <- function() {
!is.null(rSW2_glovars$con) && DBI::dbIsValid(rSW2_glovars$con)
}
#' Query version number of registered weather database
#' @return A numeric version number.
#' @export
dbW_version <- function() {
res <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = "SELECT Value FROM Meta WHERE Desc=\'Version\'"
)
numeric_version(as.character(res[1, 1]))
}
#' Check that version of registered weather database is up-to-date
#' @param dbW_min_version A numeric version number.
#' @return A logical value.
#' @export
dbW_check_version <- function(dbW_min_version = NULL) {
v_dbW <- dbW_version()
if (is.null(dbW_min_version)) {
dbW_min_version <- rSW2_glovars[["dbW_version"]]
}
success <- v_dbW >= dbW_min_version
if (!success) {
message(
"The version ", shQuote(v_dbW), " of the weather database ",
shQuote(basename(slot(rSW2_glovars$con, "dbname"))), " is outdated; ",
"minimal suggested version is ", shQuote(dbW_min_version),
" -- please update."
)
}
success
}
#' Query compression type of registered weather database
#' @return A character string.
#' @export
dbW_compression <- function() {
res <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = "SELECT Value FROM Meta WHERE Desc=\'Compression_type\'"
)
as.character(res[1, 1])
}
#--- Topic: check_content ------
#' Check availability of content in registered weather database
#'
#' @name check_content
NULL
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details: \code{dbW_has_siteIDs} checks whether sites are available.
#' @return \code{dbW_has_siteIDs} returns a logical vector of the length of
#' queried sites.
#' @export
dbW_has_sites <- function(Labels, ignore.case = FALSE) {
# "EXPLAIN QUERY PLAN":
# SEARCH Sites USING COVERING INDEX sqlite_autoindex_Sites_1 (Label=?)
dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste(
"SELECT COUNT(*) FROM Sites WHERE Label=:x",
if (ignore.case) "COLLATE NOCASE"
),
params = list(x = Labels)
)[, 1] > 0
}
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details: \code{dbW_has_siteIDs} checks whether sites are available.
#' @return \code{dbW_has_siteIDs} returns a logical vector of the length of
#' queried sites.
#' @export
dbW_has_siteIDs <- function(Site_ids) {
# "EXPLAIN QUERY PLAN ":
# SEARCH Sites USING INTEGER PRIMARY KEY (rowid=?)
dbW_InsistInteract(
DBI::dbGetQuery,
statement = "SELECT COUNT(*) FROM Sites WHERE Site_id=:x",
params = list(x = Site_ids)
)[, 1] > 0
}
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details: \code{dbW_has_scenarioIDs} checks whether scenarios are
#' available.
#' @return \code{dbW_has_scenarios} returns a logical vector of the length of
#' queried Scenarios.
#' @export
dbW_has_scenarioIDs <- function(Scenario_ids) {
# "EXPLAIN QUERY PLAN ":
# SEARCH Scenarios USING INTEGER PRIMARY KEY (rowid=?)
dbW_InsistInteract(
DBI::dbGetQuery,
statement = "SELECT COUNT(*) FROM Scenarios WHERE id=:x",
params = list(x = Scenario_ids)
)[, 1] > 0
}
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details: \code{dbW_has_scenarios} checks whether scenarios are
#' available.
#' @return \code{dbW_has_scenarios} returns a logical vector of the length of
#' queried Scenarios.
#' @export
dbW_has_scenarios <- function(Scenarios, ignore.case = FALSE) {
# "EXPLAIN QUERY PLAN ":
# SEARCH Scenarios USING COVERING INDEX
# sqlite_autoindex_Scenarios_1 (Scenario=?)
dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste(
"SELECT COUNT(*) FROM Scenarios WHERE Scenario=:x",
if (ignore.case) "COLLATE NOCASE"
),
params = list(x = Scenarios)
)[, 1] > 0
}
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details: \code{dbW_has_weatherData} checks whether weather data are
#' available but ignores \code{start_year} and \code{end_year}.
#'
#' @return \code{dbW_has_weatherData} returns a logical matrix with rows
#' corresponding to queried sites and columns to queried scenarios.
#' @export
dbW_has_weatherData <- function(Site_ids, Scenario_ids) {
sites_N <- length(Site_ids)
scen_N <- length(Scenario_ids)
# Count distinct entries because there could be duplicate weather data ...
# "EXPLAIN QUERY PLAN":
# SEARCH WeatherData USING COVERING INDEX wdindex (Site_id=? AND Scenario=?)
if (sites_N > scen_N) {
# Loop over scenarios: count distinct sites for each scenario
sql <- paste(
"SELECT COUNT(DISTINCT Site_id) FROM WeatherData",
"WHERE Site_id IN (:x1) AND Scenario = :x2"
)
res <- lapply(
Scenario_ids,
function(x) {
dbW_InsistInteract(
DBI::dbGetQuery,
statement = sql,
params = list(x1 = Site_ids, x2 = rep(x, sites_N))
)[, 1] == 1L
}
)
res <- do.call(cbind, res)
} else {
# Loop over sites: count distinct scenarios for each site
sql <- paste(
"SELECT COUNT(DISTINCT Scenario) FROM WeatherData",
"WHERE Site_id = :x1 AND Scenario IN (:x2)"
)
res <- lapply(
Site_ids,
function(x) {
dbW_InsistInteract(
DBI::dbGetQuery,
statement = sql,
params = list(x1 = rep(x, scen_N), x2 = Scenario_ids)
)[, 1] == 1L
}
)
res <- do.call(rbind, res)
}
dimnames(res) <- list(
paste("Site", Site_ids, sep = "_"),
paste("Scenario", Scenario_ids, sep = "_")
)
res
}
#' @rdname check_content
#'
#' @inheritParams sw_weather_database
#'
#' @section Details:
#' \code{dbW_have_sites_all_weatherData} checks whether weather data are
#' available but ignores \code{start_year} and \code{end_year}.
#'
#' @return
#' \code{dbW_have_sites_all_weatherData} returns a logical vector
#' of length of queried sites;
#' a \code{TRUE} element indicates that weather data
#' for each queried scenarios is available for that queried site.
#'
#' @export
dbW_have_sites_all_weatherData <- function(
site_labels = NULL,
site_ids = NULL,
scen_labels = NULL,
scen_ids = NULL,
verbose = FALSE
) {
# Check arguments
# Either `site_labels` or `site_ids` or at least the same length
si_ltemp <- c(length(site_labels), length(site_ids))
si_ntemp <- c(is.null(site_labels), is.null(site_ids))
stopifnot(
!(si_ntemp[1] && si_ntemp[2]),
si_ntemp[1] || si_ntemp[2] || identical(si_ltemp[1], si_ltemp[2])
)
# Either `scen_labels` or `scen_ids` or at least the same length
sc_ltemp <- c(length(scen_labels), length(scen_ids))
sc_ntemp <- c(is.null(scen_labels), is.null(scen_ids))
stopifnot(
!(sc_ntemp[1] && sc_ntemp[2]),
sc_ntemp[1] || sc_ntemp[2] || identical(sc_ltemp[1], sc_ltemp[2])
)
#--- Collect `site_ids` and `scen_ids` if not provided
if (is.null(site_ids)) {
site_ids <- rSOILWAT2::dbW_getSiteId(Labels = site_labels)
}
if (anyNA(site_ids)) {
stop("Not all sites available in weather database.")
}
if (is.null(scen_ids)) {
scen_ids <- rSOILWAT2::dbW_getScenarioId(Scenario = scen_labels)
}
if (anyNA(scen_ids)) {
stop("Not all scenarios available in weather database.")
}
#--- Query database
# Count distinct entries because there could be duplicate weather data ...
# "EXPLAIN QUERY PLAN ":
# 1 USE TEMP B-TREE FOR count(DISTINCT)
# 2 SEARCH WeatherData USING COVERING INDEX wdindex (Site_id=? AND Scenario=?)
res <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste0(
"SELECT COUNT(DISTINCT Scenario) AS scenN, Site_id FROM WeatherData ",
"WHERE ",
"Site_id IN (?) AND ",
"Scenario IN (", paste(scen_ids, collapse = ","), ") "
),
params = list(site_ids)
)
# Good: all requested scenarios are available
res[, "scenN"] == length(scen_ids)
}
#--- Topic: extract data from weather data base ------
#' Extract table keys to connect sites with weather data in the registered
#' weather database
#'
#' @details The key(s) (\var{Site_id}) can be located by either providing a
#' \code{Labels} or by providing \code{lat} and \code{long} of the requested
#' site(s).
#'
#' @inheritParams sw_weather_database
#' @param tol_xy A numeric value. The tolerance used to match requested
#' longitude and latitude values.
#'
#' @return An integer vector with the values of the keys or \code{NA} if not
#' located.
#' @export
dbW_getSiteId <- function(
lat = NULL, long = NULL, tol_xy = 1e-4,
Labels = NULL,
ignore.case = FALSE,
verbose = FALSE
) {
if (!is.null(Labels) && !all(is.na(Labels))) {
#--- Determine which Labels exists
Labels <- as.character(Labels)
# "EXPLAIN QUERY PLAN "
# SEARCH Sites USING COVERING INDEX sqlite_autoindex_Sites_1 (Label=?)
tmp <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste0(
"SELECT COUNT(*) AS n, Site_id FROM Sites WHERE Label=:x",
if (ignore.case) " COLLATE NOCASE"
),
params = list(x = Labels)
)
res <- rep(NA, length(Labels))
ids_label_exists <- tmp[, "n"] > 0
res[ids_label_exists] <- tmp[ids_label_exists, "Site_id"]
} else if (!is.null(lat) && !is.null(long)) {
stopifnot(identical(length(lat), length(long)))
lat <- as.numeric(lat)
long <- as.numeric(long)
# Find the latitude and longitude with the minimum difference if
# deviating by less than tolerance
sql <- paste(
"SELECT COUNT(*) AS n, dxy2.Site_id",
"FROM (",
"SELECT",
"Site_id,",
"dxy.adlat AS adlat,",
"dxy.adlon AS adlon,",
"MIN(dxy.adlat) AS min_adlat,",
"MIN(dxy.adlon) AS min_adlon",
"FROM (",
"SELECT",
"Site_id,",
"ABS(Latitude - :lat) AS adlat,",
"ABS(Longitude - :lon) AS adlon",
"FROM Sites",
"WHERE",
"Latitude BETWEEN :lat - :tol AND :lat + :tol AND",
"Longitude BETWEEN :lon - :tol AND :lon + :tol",
") AS dxy",
") AS dxy2",
"WHERE",
"dxy2.adlat = dxy2.min_adlat AND",
"dxy2.adlon = dxy2.min_adlon"
)
# "EXPLAIN QUERY PLAN "
# id parent notused detail
# 1 2 0 0 CO-ROUTINE dxy2
# 2 5 2 0 SCAN Sites
# 3 52 0 0 SCAN dxy2
tmp <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = sql,
params = list(lat = lat, lon = long, tol = rep_len(tol_xy, length(lat)))
)
res <- rep(NA, length(lat))
ids_label_exists <- tmp[, "n"] > 0
res[ids_label_exists] <- tmp[ids_label_exists, "Site_id"]
} else {
if (verbose) {
message("'dbW_getSiteId': not enough information to obtain site IDs")
}
res <- rep(NA, max(length(Labels), length(long)))
}
as.integer(res)
}
#' Extract table keys to connect scenario(s) with weather data in the registered
#' weather database
#'
#' @inheritParams sw_weather_database
#'
#' @return An integer vector with the values of the keys or \code{NA} if not
#' located.
#' @export
dbW_getScenarioId <- function(Scenario, ignore.case = FALSE, verbose = FALSE) {
# "EXPLAIN QUERY PLAN "
# SEARCH Scenarios USING COVERING INDEX
# sqlite_autoindex_Scenarios_1 (Scenario=?)
sql <- paste0(
"SELECT id FROM Scenarios WHERE Scenario = :x",
if (ignore.case) " COLLATE NOCASE"
)
x <- sapply(
Scenario,
function(x) {
tmp <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = sql,
params = list(x = x)
)[, 1]
if (is.null(tmp)) NA else tmp
}
)
as.integer(x)
}
#' Locate keys for weather database tables in the registered weather database
#'
#' Obtain database table keys 'Site_id' and 'Scenario_id' using alternative
#' information and optionally add missing sites and scenarios.
#' A site will be identified alternatively
#' by \itemize{
#' \item its identification number \code{site_id},
#' \item its name \code{site_label}, or
#' \item its geographic location \code{long} and \code{lat}.
#' }
#' A scenario will be identified alternatively
#' by \itemize{
#' \item its identification number \code{scenario_id}, or
#' \item its name \code{scenario}.
#' }
#'
#'
#' @inheritParams sw_weather_database
#' @inheritParams dbW_getSiteId
#' @param add_if_missing A logical value. Should site entries in the data base
#' be created if they are queried and do not exist in the data base?
#'
#' @return A list with two elements \code{site_id} and \code{scenario_id}.
#'
#' @export
dbW_getIDs <- function(
site_id = NULL,
site_label = NULL,
long = NULL,
lat = NULL,
tol_xy = 1e-4,
scenario = NULL,
scenario_id = NULL,
add_if_missing = FALSE,
ignore.case = FALSE,
verbose = FALSE
) {
#--- Prepare output
n_sites <- if (!is.null(site_id)) {
length(site_id)
} else if (!is.null(site_label)) {
length(site_label)
} else {
length(long)
}
n_scens <- if (!is.null(scenario_id)) {
length(scenario_id)
} else {
length(scenario)
}
res <- list(
site_id = if (!is.null(site_id)) {
as.integer(site_id)
} else {
rep(NA, n_sites)
},
scenario_id = if (!is.null(scenario_id)) {
as.integer(scenario_id)
} else {
rep(NA, n_scens)
}
)
#--- Check site IDs ------
needs_siteID <- !dbW_has_siteIDs(res[["site_id"]])
if (any(needs_siteID)) {
# Use information of `site_label` or `lat`/`long` to retrieve `site_id`
site_label <- as.character(site_label)
lat <- as.numeric(lat)
long <- as.numeric(long)
stopifnot(
length(site_label) %in% c(0, n_sites),
length(long) %in% c(0, n_sites),
length(lat) == length(long)
)
res[["site_id"]][needs_siteID] <- dbW_getSiteId(
Labels = site_label[needs_siteID],
lat = lat[needs_siteID],
long = long[needs_siteID],
tol_xy = tol_xy,
ignore.case = ignore.case,
verbose = verbose
)
iadd <- which(is.na(res[["site_id"]]))
if (length(iadd) > 0 && isTRUE(add_if_missing)) {
# Some `site_id` do not exist -> attempt to create new entries
iaddok <-
(!is.na(site_label[iadd]) & nchar(site_label[iadd]) > 0) |
(!is.na(lat[iadd]) & !is.na(long[iadd]))
iadd2 <- iadd[which(iaddok)]
tmp <- if (length(iadd2) > 0) {
df <- data.frame(
Latitude = lat[iadd2],
Longitude = long[iadd2],
Label = site_label[iadd2],
stringsAsFactors = FALSE
)
try(
dbW_addSites(site_data = df, ignore.case = ignore.case),
silent = TRUE
)
}
if (!inherits(tmp, "try-error") && isTRUE(tmp)) {
res[["site_id"]][iadd2] <- dbW_getSiteId(
Labels = site_label[iadd2],
lat = lat[iadd2],
long = long[iadd2],
ignore.case = ignore.case,
verbose = verbose
)
}
}
}
#--- Check scenario IDs ------
needs_scenID <- !dbW_has_scenarioIDs(res[["scenario_id"]])
if (any(needs_scenID)) {
# Use information of `scenario` to retrieve `scenario_id`
scenario <- as.character(scenario)
stopifnot(length(scenario) %in% c(0, n_scens))
res[["scenario_id"]][needs_scenID] <- dbW_getScenarioId(
Scenario = scenario[needs_scenID],
ignore.case = ignore.case,
verbose = verbose
)
iadd <- which(is.na(res[["scenario_id"]]))
if (length(iadd) > 0 && isTRUE(add_if_missing)) {
# Some `scenario_id` do not exist -> attempt to create new entries
iaddok <- !is.na(scenario[iadd]) & nchar(site_label[iadd]) > 0
iadd2 <- iadd[which(iaddok)]
tmp <- if (length(iadd2) > 0) {
try(
dbW_addScenarios(
Scenarios = scenario[iadd2],
ignore.case = ignore.case
),
silent = TRUE
)
}
if (!inherits(tmp, "try-error") && isTRUE(tmp)) {
res[["scenario_id"]][iadd2] <- dbW_getScenarioId(
Scenario = scenario[iadd2],
ignore.case = ignore.case,
verbose = verbose
)
}
}
}
res
}
#' Read entire table of sites from the registered weather database
#'
#' @return A data.frame.
#' @export
dbW_getSiteTable <- function() {
dbW_InsistInteract(DBI::dbReadTable, name = "Sites")
}
#' Read entire table of Scenarios from the registered weather database
#'
#' @return A data.frame.
#' @export
dbW_getScenariosTable <- function() {
dbW_InsistInteract(DBI::dbReadTable, name = "Scenarios")
}
#' Extracts daily weather data from a registered weather database
#'
#' Weather data for the soil water simulation run can be stored in the input
#' data or it can be separate to keep the input data size down for multiple
#' variations of the same site. This function is used to return the weather
#' data from a predefined weather database. Using the database was faster then
#' reading in multiple weather files from disk.
#'
#' If there is missing data, then impute or use the built-in Markov
#' weather generator (see examples for \code{\link{sw_exec}}).
#'
#' @inheritParams sw_weather_database
#' @inheritParams dbW_getSiteId
#' @param stop_if_missing A logical value. If \code{TRUE}, then throws an
#' error if at least one requested weather data object is not available
#' in the current weather database. If \code{FALSE}, then returns \code{NULL}
#' for those requested site scenario combinations.
#'
#' @return
#' If one site and one scenario were requested, then returns
#' weather data as list. Each element is an object of class
#' \code{\linkS4class{swWeatherData}} and contains data for one year.
#' If more than one site or more than scenario were requested, then returns
#' a list of such weather data lists.
#' Elements of the returned list may be \code{NULL} if there is no
#' weather data object for the requested site scenario combination and if
#' \code{stop_if_missing} is \code{FALSE}.
#'
#' @section Notes:
#' This function returns the first record of weather data for a
#' site x scenario combination even if duplicate entries match the query.
#'
#' @seealso \code{\link{getWeatherData_folders}}
#'
#' @export
#' @md
dbW_getWeatherData <- function(
Site_id = NULL,
lat = NULL,
long = NULL,
tol_xy = 1e-4,
Label = NULL,
startYear = NULL,
endYear = NULL,
Scenario = "Current",
Scenario_id = NULL,
ignore.case = FALSE,
stop_if_missing = TRUE,
verbose = FALSE
) {
IDs <- dbW_getIDs(
site_id = Site_id,
site_label = Label,
long = long,
lat = lat,
tol_xy = tol_xy,
scenario = Scenario,
scenario_id = Scenario_id,
add_if_missing = FALSE,
ignore.case = ignore.case,
verbose = verbose
)
n_sites <- length(IDs[["site_id"]])
n_scens <- length(IDs[["scenario_id"]])
if (n_sites == 1 && n_scens > 1) {
IDs[["site_id"]] <- rep(IDs[["site_id"]], n_scens)
} else if (n_sites > 1 && n_scens == 1) {
IDs[["scenario_id"]] <- rep(IDs[["scenario_id"]], n_sites)
}
stopifnot(
length(IDs[["site_id"]]) == length(IDs[["scenario_id"]])
)
res <- vector("list", length = length(IDs[["site_id"]]))
idsnotna <- which(!is.na(IDs[["site_id"]]) & !is.na(IDs[["scenario_id"]]))
for (k in idsnotna) {
# "EXPLAIN QUERY PLAN ":
# SEARCH WeatherData USING INDEX wdindex (Site_id=? AND Scenario=?)
x <- dbW_InsistInteract(
DBI::dbGetQuery,
statement =
"SELECT data FROM WeatherData WHERE Site_id = :x1 AND Scenario = :x2",
params = list(x1 = IDs[["site_id"]][k], x2 = IDs[["scenario_id"]][k])
)
if (NROW(x) > 1) {
warning(
"More than one weather data object exists for site ",
shQuote(IDs[["site_id"]][k]),
" and scenario ", shQuote(IDs[["scenario_id"]][k]),
": processing only the first one."
)
x <- x[1, , drop = FALSE]
}
if (is.na(x) || all(lengths(x) == 0)) {
msg <- c(
"Weather data for site ", shQuote(IDs[["site_id"]][k]),
" and scenario ", shQuote(IDs[["scenario_id"]][k]),
" does not exist in weather database."
)
if (stop_if_missing) stop(msg) else warning(msg)
next
}
wd <- try(
dbW_blob_to_weatherData(
x[1, 1],
rSW2_glovars$blob_compression_type
)
)
if (inherits(wd, "try-error")) {
msg <- c(
"Weather data for site ", shQuote(IDs[["site_id"]][k]),
" and scenario ", shQuote(IDs[["scenario_id"]][k]), " is corrupted."
)
if (stop_if_missing) stop(msg) else warning(msg)
next
}
tmp <- class(wd[[1]])
if (!(attr(tmp, "package") == "rSOILWAT2")) {
message(
"WARNING: The class of the extracted weather data object is ",
shQuote(tmp), " from package ", shQuote(attr(tmp, "package")),
" which is outdated. Please, upgrade weather database with function ",
"'dbW_upgrade_to_rSOILWAT2'."
)
}
years <- get_years_from_weatherData(wd)
ids <- select_years(years, startYear, endYear)
res[[k]] <- wd[ids]
}
if (length(idsnotna) == 0) {
msg <- c(
"Weather data for all sites ",
toString(shQuote(IDs[["site_id"]])),
" and scenarios ",
toString(shQuote(IDs[["scenario_id"]])),
" does not exist in weather database."
)
if (stop_if_missing) stop(msg) else warning(msg)
}
if (length(IDs[["site_id"]]) == 1) res[[1]] else res
}
#' Registers/connects a SQLite weather database with the package
#'
#' @inheritParams sw_weather_database
#' @param create_if_missing A logical value. If \code{TRUE} and file
#' \code{dbFilePath} does not exist then create a new database file.
#' @param check_version A logical value. If \code{TRUE} then check database
#' version against currently implemented version by the package.
#'
#' @return An invisible logical value indicating success/failure.
#'
#' @export
dbW_setConnection <- function(
dbFilePath,
create_if_missing = FALSE,
check_version = FALSE,
verbose = FALSE
) {
rSW2_glovars$con <- NULL
dbFilePath <- try(normalizePath(dbFilePath, mustWork = FALSE), silent = TRUE)
if (inherits(dbFilePath, "try-error") || !file.exists(dbFilePath)) {
if (verbose) {
message(
"'dbW_setConnection': ", shQuote(basename(dbFilePath)),
" does not exist."
)
}
if (create_if_missing) {
if (verbose) {
message("'dbW_setConnection': creating a new database.")
}
} else {
return(invisible(FALSE))
}
}
# Check if 'dbFilePath' can be created
tmp1 <- try(
suppressWarnings(
DBI::dbConnect(RSQLite::SQLite(), dbname = dbFilePath)
),
silent = TRUE
)
if (inherits(tmp1, "try-error")) {
if (verbose) {
message(
"'dbW_setConnection': ", shQuote(dbFilePath),
" cannot be created likely because the path does not exist."
)
}
return(invisible(FALSE))
}
# Check if 'dbFilePath' is likely a good SQLite-database
tmp2 <- try(
DBI::dbExecute(tmp1, "PRAGMA synchronous = off"),
silent = TRUE
)
if (inherits(tmp2, "try-error")) {
if (verbose) {
message(
"'dbW_setConnection': ", shQuote(basename(dbFilePath)),
" exists but is likely not a SQLite-database."
)
}
return(invisible(FALSE))
}
# Check that foreign key constraints are supported or at least accepted
tmp3 <- try(
DBI::dbExecute(tmp1, "PRAGMA foreign_keys = ON"),
silent = TRUE
)
if (inherits(tmp3, "try-error")) {
if (verbose) {
message("'dbW_setConnection': foreign keys are not supported.")
}
return(invisible(FALSE))
}
# Set busy handler to time out after 10 seconds (in milliseconds) of retries
try(DBI::dbExecute(tmp1, "PRAGMA busy_timeout = 10000"))
# Set up package-level connection variable
rSW2_glovars$con <- tmp1
has_meta <- DBI::dbExistsTable(rSW2_glovars$con, "Meta")
rSW2_glovars$blob_compression_type <- if (has_meta) {
dbW_compression()
} else {
rSW2_glovars$default_blob_compression_type
}
if (check_version) {
dbW_check_version()
}
invisible(dbW_IsValid())
}
#' @rdname dbW_setConnection
#'
#' @section Details:
#' [.dbW_setConnection()] is a bare-bones version of [dbW_setConnection()].
#' It doesn't carry out any checks that make sure the database works
#' correctly.
#'
#' @md
#' @export
.dbW_setConnection <- function(dbFilePath) {
rSW2_glovars$con <- suppressWarnings(
DBI::dbConnect(RSQLite::SQLite(), dbname = dbFilePath)
)
rSW2_glovars$blob_compression_type <- dbW_compression()
invisible(dbW_IsValid())
}
#' Disconnects a SQLite weather database from the package
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#' @export
dbW_disconnectConnection <- function() {
res <- try(DBI::dbDisconnect(rSW2_glovars$con), silent = TRUE)
rSW2_glovars$con <- NULL
rSW2_glovars$blob_compression_type <- NULL
invisible(!inherits(res, "try-error"))
}
#--- Topic: Add data to database ------
#' Adds new sites to a registered weather database
#'
#' @inheritParams sw_weather_database
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#'
#' @section Details:
#' `site_data` requires columns `Longitude`, `Latitude`, and `Label`.
#'
#' @export
#' @md
dbW_addSites <- function(site_data, ignore.case = FALSE, verbose = FALSE) {
req_cols <- c("Latitude", "Longitude", "Label")
if (!all(req_cols %in% colnames(site_data))) {
stop("'dbW_addSites': argument misses required columns.")
}
has_sites <- dbW_has_sites(site_data[, "Label"], ignore.case = ignore.case)
dos_add <- !has_sites
if (any(dos_add)) {
dbW_InsistInteract(
DBI::dbExecute,
statement =
"INSERT INTO Sites VALUES(NULL, :Latitude, :Longitude, :Label)",
params = as.list(site_data[dos_add, req_cols])
)
}
if (any(has_sites) && verbose) {
message(
"'dbW_addSites': sites are already in database, labels = ",
toString(shQuote(site_data[has_sites, "Label"]))
)
}
invisible(TRUE)
}
#' Updates existing sites or adds new sites to a registered weather database
#'
#' @inheritParams sw_weather_database
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#' @export
dbW_updateSites <- function(
Site_ids,
site_data,
ignore.case = FALSE,
verbose = FALSE
) {
dos_update <- dbW_has_siteIDs(Site_ids)
dos_add <- !dos_update
if (any(dos_update)) {
dbW_InsistInteract(
DBI::dbExecute,
statement = paste(
"UPDATE Sites SET Latitude=:Latitude, Longitude=:Longitude, ",
"Label=:Label WHERE Site_id=:id"
),
params = c(
as.list(site_data[dos_update, c("Latitude", "Longitude", "Label")]),
list(id = Site_ids[dos_update])
)
)
}
if (any(dos_add)) {
stopifnot(
dbW_addSites(
site_data[dos_add, ],
ignore.case = ignore.case,
verbose = verbose
)
)
}
invisible(TRUE)
}
#' Adds new Scenarios to a registered weather database
#'
#' @inheritParams sw_weather_database
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#' @export
dbW_addScenarios <- function(Scenarios, ignore.case = FALSE, verbose = FALSE) {
has_scenarios <- dbW_has_scenarios(Scenarios, ignore.case = ignore.case)
dos_add <- !has_scenarios
if (any(dos_add)) {
dbW_InsistInteract(
DBI::dbExecute,
statement = "INSERT INTO Scenarios VALUES(NULL, :sc)",
params = list(sc = unlist(Scenarios[dos_add]))
)
}
if (any(has_scenarios) && verbose) {
message(
"'dbW_addScenarios': Scenarios are already in database,",
"Scenarios =", toString(shQuote(Scenarios[has_scenarios]))
)
}
invisible(TRUE)
}
#' @section Notes:
#' This function does not prevent inserting duplicate entries if asked to do.
#'
#' @noRd
dbW_addWeatherDataNoCheck <- function(
Site_id,
Scenario_id,
StartYear,
EndYear,
weather_blob
) {
res <- dbW_InsistInteract(
DBI::dbExecute,
statement = paste(
"INSERT INTO",
"WeatherData (Site_id, Scenario, StartYear, EndYear, data)",
"VALUES (:Site_id, :Scenario_id, :StartYear, :EndYear, :weather_blob)"
),
params = list(
Site_id = Site_id,
Scenario_id = Scenario_id,
StartYear = StartYear,
EndYear = EndYear,
weather_blob = weather_blob
)
)
invisible(res)
}
#' Adds daily weather data to a registered weather database
#'
#' @inheritParams sw_weather_data
#' @inheritParams sw_weather_database
#' @inheritParams dbW_getSiteId
#' @param weatherFolderPath A character string. The path to the parent folder.
#' @param overwrite A logical value. Should weather data that already exists
#' in the data base be overwritten?
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#'
#' @export
dbW_addWeatherData <- function(
Site_id = NULL,
lat = NULL,
long = NULL,
tol_xy = 1e-4,
weatherFolderPath = NULL,
weatherData = NULL,
Label = NULL,
Scenario_id = NULL,
Scenario = "Current",
weather_tag = "weath",
ignore.case = FALSE,
overwrite = FALSE,
verbose = FALSE
) {
stopifnot(dbW_IsValid())
has_weatherFolderPath <-
!is.null(weatherFolderPath) &&
file.exists(weatherFolderPath)
has_weatherData <-
!is.null(weatherData) &&
is.list(weatherData) &&
inherits(weatherData[[1]], "swWeatherData")
if (!has_weatherFolderPath && !has_weatherData) {
stop("'dbW_addWeatherData' requires either a folder path or weatherData.")
}
if (!is.null(weatherFolderPath) && is.null(Label)) {
Label <- basename(weatherFolderPath)
}
IDs <- dbW_getIDs(
site_id = Site_id,
site_label = Label,
long = long,
lat = lat,
tol_xy = tol_xy,
scenario = Scenario,
scenario_id = Scenario_id,
add_if_missing = TRUE,
ignore.case = ignore.case,
verbose = verbose
)
if (!all(sapply(IDs, function(x) length(x) > 0 && is.finite(x)))) {
stop(
"'dbW_addWeatherData': insufficient information to generate ",
"site/scenario."
)
}
if (dbW_has_weatherData(IDs[["site_id"]], IDs[["scenario_id"]])) {
tmp <- paste(
"'dbW_addWeatherData': weather data for site",
IDs[["site_id"]], "and scenario", IDs[["scenario_id"]], "already exists."
)
if (overwrite) {
if (verbose) {
message(tmp, "Previous data will be overwritten with new data.")
}
tmp2 <- dbW_deleteSiteData(IDs[["site_id"]], IDs[["scenario_id"]])
if (!tmp2) {
stop(tmp, " Overwritting previous data failed.")
}
} else {
stop(tmp)
}
}
if (is.null(weatherData)) {
weatherData <- getWeatherData_folders(
LookupWeatherFolder = weatherFolderPath,
filebasename = weather_tag
)
}
years <- get_years_from_weatherData(weatherData)
blob <- dbW_weatherData_to_blob(
weatherData,
rSW2_glovars$blob_compression_type
)
dbW_addWeatherDataNoCheck(
Site_id = IDs[["site_id"]],
Scenario_id = IDs[["scenario_id"]],
StartYear = years[1],
EndYear = years[length(years)],
weather_blob = blob
)
invisible(TRUE)
}
.create_dbW <- function(site_data, Scenarios, scen_ambient) {
sql <- "CREATE TABLE 'Meta' ('Desc' TEXT PRIMARY KEY, 'Value' TEXT)"
DBI::dbExecute(rSW2_glovars$con, sql)
sql <- "INSERT INTO 'Meta' VALUES(:Desc, :Value)"
DBI::dbExecute(
rSW2_glovars$con,
sql,
params = list(
Desc = c("Version", "Compression_type"),
Value = c(rSW2_glovars$dbW_version, rSW2_glovars$blob_compression_type)
)
)
# Table of sites
sql <- paste0(
"CREATE TABLE 'Sites' (",
"'Site_id' INTEGER PRIMARY KEY AUTOINCREMENT,",
"'Latitude' REAL,",
"'Longitude' REAL,",
"'Label' TEXT UNIQUE",
")"
)
DBI::dbExecute(rSW2_glovars$con, sql)
# Table of scenario names
sql <- paste0(
"CREATE TABLE 'Scenarios' (",
"'id' INTEGER PRIMARY KEY AUTOINCREMENT,",
"'Scenario' TEXT UNIQUE NOT NULL",
")"
)
DBI::dbExecute(rSW2_glovars$con, sql)
# Table for weather data
DBI::dbExecute(rSW2_glovars$con, "PRAGMA foreign_keys = ON")
sql <- paste0(
"CREATE TABLE 'WeatherData' (",
"'wdid' INTEGER PRIMARY KEY AUTOINCREMENT,",
"'Site_id' INTEGER,",
"'Scenario' INTEGER,",
"'StartYear' INTEGER NOT NULL,",
"'EndYear' INTEGER NOT NULL,",
"'data' BLOB,",
"FOREIGN KEY(Site_id) REFERENCES Sites(Site_id),",
"FOREIGN KEY(Scenario) REFERENCES Scenarios(id)",
")"
)
DBI::dbExecute(rSW2_glovars$con, sql)
DBI::dbExecute(rSW2_glovars$con,
"CREATE INDEX wdindex ON WeatherData(Site_id, Scenario)"
)
# View all data
sql <- paste(
"CREATE VIEW wd_all AS",
"SELECT",
"Sites.Site_id, Sites.Latitude, Sites.Longitude,",
"Sites.Label AS Site_Label, Scenarios.id AS Scenario_id,",
"Scenarios.Scenario, WeatherData.StartYear, WeatherData.EndYear,",
"WeatherData.data",
"FROM",
"Sites, Scenarios, WeatherData",
"WHERE",
"WeatherData.Site_id=Sites.Site_id AND",
"WeatherData.Scenario=Scenarios.id"
)
DBI::dbExecute(rSW2_glovars$con, sql)
#---Add sites
if (NROW(site_data)) {
stopifnot(dbW_addSites(site_data))
}
#---Add Scenarios
Scenarios <- c(scen_ambient, Scenarios[!(Scenarios == scen_ambient)])
stopifnot(dbW_addScenarios(Scenarios, ignore.case = FALSE))
invisible(TRUE)
}
#' Add an index on four data columns of table "WeatherData" if not present
#'
#' @noRd
.wdindex4 <- function(verbose = FALSE) {
res <- dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste(
"SELECT name FROM sqlite_master",
"WHERE type = 'index' AND tbl_name = 'WeatherData'"
)
)
if (!("wdindex4" %in% res[, "name"])) {
if (verbose) {
message("Building dbW index on site, scenario, start year, end year.")
}
dbW_InsistInteract(
DBI::dbExecute,
statement = paste(
"CREATE INDEX wdindex4 ON ",
"WeatherData(Site_id, Scenario, StartYear, EndYear)"
)
)
}
}
#' Create a weather database
#'
#' @section Details: A \pkg{rSOILWAT2} weather database has the following
#' format: \describe{
#' \item{Table \var{Meta}}{contains two fields \var{Desc} and \var{Value}
#' which contain \itemize{
#' \item the records \var{Version} and \var{Compression_type}}}
#' \item{Table \var{Sites}}{contains four fields \var{Site_id},
#' \var{Latitude}, \var{Longitude}, and \var{Label}}
#' \item{Table \var{WeatherData}}{contains six fields \var{wdid}
#' (the ID of the weather data record), \var{Site_id}, \var{Scenario}
#' (i.e., the ID of the scenario), \var{StartYear}, \var{EndYear}, and
#' \var{data}}
#' \item{Table \var{Scenarios}}{contains two fields \var{id} and
#' \var{Scenario} (i.e., the scenario name)}
#' }
#'
#' @inheritParams sw_weather_database
#' @param compression_type A character string. The type of compression for
#' the weather blob. See \code{\link[base]{memCompress}} for the available
#' choices.
#' @param ... Additional/deprecated arguments which are currently ignored.
#'
#' @return \code{TRUE} on success; \code{FALSE} otherwise. If the file
#' \code{dbFilePath} didn't already exist, but creating it failed, then the
#' attempt will be disconnected and removed.
#'
#' @section Details:
#' `site_data` requires columns `Longitude`, `Latitude`, and `Label`.
#'
#' @export
dbW_createDatabase <- function(
dbFilePath = "dbWeatherData.sqlite3",
site_data = data.frame(
Label = NA_character_,
Longitude = NA_real_,
Latitude = NA_real_,
stringsAsFactors = FALSE
)[0, , drop = FALSE],
Scenarios = NULL,
scen_ambient = "Current",
compression_type = "gzip",
verbose = FALSE,
...
) {
dbFilePath <- file.path(
normalizePath(dirname(dbFilePath)),
basename(dbFilePath)
)
rm_file <- FALSE
on.exit({
if (rm_file && file.exists(dbFilePath)) {
if (verbose) {
message("'dbW_createDatabase': deletes db-file due to failure.")
}
tmp <- dbW_disconnectConnection()
if (!tmp) {
message(
"'dbW_createDatabase': attempted to disconnect from db-file ",
"but failed."
)
}
# sqlite3 on Windows OS may not be releasing the file until
# garbage collection
gc()
tmp <- unlink(dbFilePath)
if (tmp != 0) {
message(
"'dbW_createDatabase': attempted to delete db-file but ",
"'unlink' suggests a failure."
)
}
if (file.exists(dbFilePath)) {
message(
"'dbW_createDatabase': attempted to delete db-file with ",
"'unlink' but db-file is still present."
)
file.remove(dbFilePath)
}
if (file.exists(dbFilePath)) {
message(
"'dbW_createDatabase': attempted to delete db-file with ",
"'file.remove' but db-file is still present."
)
}
}},
add = TRUE
)
dots <- list(...)
if (length(dots)) {
message(
"'dbW_createDatabase': arguments ignored/deprecated ",
toString(shQuote(names(dots)))
)
}
if (file.exists(dbFilePath)) {
if (verbose) {
message(
"'dbW_createDatabase': cannot create a new database ",
"because the file ", shQuote(basename(dbFilePath)),
" does already exist."
)
}
return(FALSE)
}
tmp <- dbW_setConnection(
dbFilePath,
create_if_missing = TRUE,
verbose = verbose
)
if (!tmp) {
if (verbose) {
message(
"'dbW_createDatabase': was not able to create a new ",
"database and connect to the file ", shQuote(basename(dbFilePath)), "."
)
}
rm_file <- TRUE
return(FALSE)
}
# Meta information
tmp <- eval(formals(memCompress)[[2]])
if (missing(compression_type) || !(compression_type %in% tmp)) {
compression_type <- rSW2_glovars$default_blob_compression_type
}
rSW2_glovars$blob_compression_type <- compression_type
# Create tables
tmp <- try(.create_dbW(site_data, Scenarios, scen_ambient), silent = TRUE)
res <- !inherits(tmp, "try-error")
if (!res) {
if (verbose) {
message(
"'dbW_createDatabase': was not able to create a new ",
"database ", shQuote(basename(dbFilePath)),
" because of errors in the table data."
)
}
rm_file <- TRUE
}
res
}
#' Read `SOILWAT2`-style weather data from disk and store in weather database
#'
#' @param MetaData A data frame. If not missing, then must contain columns
#' (in that order) (name of site weather data) `folder`,
#' `lat` (site latitude),
#' `long` (site longitude),
#' `label` (name of site).
#' @param FoldersPath A character string. The path to the folder that contains
#' the site weather data folders.
#' @param ScenarioName A character string. The scenario name represented by
#' the data.
#' @param weather_tag A character string. The file name tag that identifies
#' the individual weather data files inside the site weather data folders.
#'
#'
#' @export
#' @md
dbW_addFromFolders <- function(
MetaData = NULL,
FoldersPath = ".",
ScenarioName = "Current",
weather_tag = "weath"
) {
if (!is.null(MetaData)) {
tmp <- apply(
MetaData,
MARGIN = 1,
function(x) {
dbW_addWeatherData(
Site_id = NULL,
lat = x[2],
long = x[3],
weatherFolderPath = file.path(FoldersPath, x[1]),
weatherData = NULL,
Label = x[4],
Scenario = ScenarioName,
weather_tag = weather_tag
)
}
)
} else {
files <- list.files(path = FoldersPath, pattern = weather_tag)
tmp <- lapply(
files,
function(x) {
dbW_addWeatherData(
Site_id = NULL,
lat = NULL,
long = NULL,
weatherFolderPath = file.path(FoldersPath, x),
weatherData = NULL,
Scenario = ScenarioName,
weather_tag = weather_tag
)
}
)
}
invisible(TRUE)
}
#--- Topic: Delete/remove data from database ------
#' Delete a site and all associated weather data from a registered weather
#' database
#'
#' @inheritParams sw_weather_database
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#' @export
dbW_deleteSite <- function(Site_ids) {
# First delete all weather data (so that foreign key constraint is not
# violated)
stopifnot(dbW_deleteSiteData(Site_ids, Scenario_id = NULL))
# Delete site entry in Sites table
dbW_InsistInteract(
DBI::dbExecute,
statement = "DELETE FROM \"Sites\" WHERE Site_id=:x",
params = list(x = Site_ids)
)
invisible(TRUE)
}
#' Delete a weather data record from a registered weather database
#'
#' @inheritParams sw_weather_database
#'
#' @return An invisible logical value indicating success with \code{TRUE} and
#' failure with \code{FALSE}.
#' @export
dbW_deleteSiteData <- function(Site_id, Scenario_id = NULL) {
stopifnot(dbW_IsValid())
if (is.null(Scenario_id)) {
#Remove all data for this site
sql <- "DELETE FROM \"WeatherData\" WHERE Site_id=:x"
tmp_params <- list(x = Site_id)
} else {
# Remove data for specific scenario
sql <- "DELETE FROM \"WeatherData\" WHERE Site_id=:x1 AND Scenario=:x2"
tmp_params <- list(x1 = Site_id, x2 = Scenario_id)
}
dbW_InsistInteract(DBI::dbExecute, statement = sql, params = tmp_params)
invisible(TRUE)
}
#' Remove duplicated weather data records
#'
#' @param site_id A numeric value.
#' If `NULL`, then duplicates of any sites are deleted.
#' Otherwise, duplicates for the requested site only are deleted.
#' @param check_values A logical value. See details.
#' @param carefully A logical value. If `TRUE` and `site_id` is specified,
#' then first count all and unique weather data records to determine
#' if there could be duplicate records before attempting to delete them.
#' Counting instead of identifying duplicates can be faster in certain
#' situations.
#' @param verbose A logical value.
#'
#' @section Details:
#' A weather data record is considered a duplicate if `site_id`, `scenario_id`,
#' `start_year`, and `end_year` agree; if `check_values` is `TRUE`, then
#' the daily weather values must also exactly agree (checked as blobs)
#' to be considered a duplicate entry.
#'
#' @return The number of deleted records
#'
#' @export
#' @md
dbW_delete_duplicated_weatherData <- function( # nolint: object_length_linter.
site_id = NULL,
check_values = TRUE,
carefully = FALSE,
verbose = FALSE
) {
do_duplicates <- TRUE
if (!is.null(site_id)) {
if (length(site_id) != 1) {
message("`site_id` has multiple values; only the first is considered.")
site_id <- site_id[1]
}
if (carefully) {
# If there are duplicates for `site_id`, then
# there are more total than unique weather data objects for `site_id`
# Count all weather data objects
n_all <- as.integer(dbW_InsistInteract(
DBI::dbGetQuery,
statement = "SELECT COUNT(*) FROM WeatherData WHERE Site_id = :x",
params = list(x = site_id)
))
# Count unique weather data objects
n_unique <- sum(as.integer(dbW_InsistInteract(
DBI::dbGetQuery,
statement = paste(
"SELECT Scenario, COUNT(DISTINCT Site_id) FROM WeatherData ",
"WHERE Site_id = :x",
"GROUP BY Scenario"
),
params = list(x = site_id)
)[, 2]))
do_duplicates <- n_all > n_unique
if (verbose) {
message(
"Site ", site_id,
": n(total) = ", n_all,
" and estimated n(unique) = ", n_unique,
" weather data entries."
)
}
}
}
if (do_duplicates) {
# Delete duplicates by keeping the lowest rowid per unit
# Note: this can be expensive, particularly without an appropriate index
if (!check_values) {
# Add index to avoid using a temporary b-tree for the 'group by'
.wdindex4(verbose = verbose)
}
# "EXPLAIN QUERY PLAN":
# * if `check_values = FALSE`
# SCAN WeatherData
# LIST SUBQUERY 1
# SCAN WeatherData USING COVERING INDEX wdindex4
#
# * if `check_values = TRUE`
# SCAN WeatherData
# LIST SUBQUERY 1
# SCAN WeatherData USING COVERING INDEX wdindex4
# USE TEMP B-TREE FOR GROUP BY
# --> this still uses a temporary b-tree because `data` is not indexed
# --> todo: should we include `data` in an index?
dbW_InsistInteract(
DBI::dbExecute,
statement = paste(
"DELETE FROM WeatherData",
"WHERE",
if (!is.null(site_id)) "Site_id = :x AND",
"rowid NOT IN (",
"SELECT min(rowid) FROM WeatherData ",
if (!is.null(site_id)) "WHERE Site_id = :x",
"GROUP BY",
if (is.null(site_id)) "Site_id, ",
"Scenario, StartYear, EndYear",
if (check_values) ", data",
")"
),
params = if (!is.null(site_id)) list(x = site_id)
)
}
}
#--- Topic: manipulate weather data objects ------
# Index along years to narrow the start and/or end year if not NULL
select_years <- function(years, start_year = NULL, end_year = NULL) {
if (!is.null(start_year) || !is.null(end_year)) {
start_year <- as.integer(start_year)
use_start <- !is.na(start_year)
end_year <- as.integer(end_year)
use_end <- !is.na(end_year)
if (
use_start && use_end &&
(start_year >= end_year || start_year < 0 || end_year < 0)
) {
warning(
"'select_years': wrong value for argument 'start_year' ",
"and/or 'end_year'"
)
}
} else {
use_start <- use_end <- FALSE
}
idx_start_year <- 1L
if (use_start) {
tmp <- match(start_year, years)
if (!is.na(tmp)) {
idx_start_year <- tmp
}
}
idx_end_year <- length(years)
if (use_end) {
tmp <- match(end_year, years)
if (!is.na(tmp)) {
idx_end_year <- tmp
}
}
idx_start_year:idx_end_year
}
#' Conversion: (Compressed) raw vector (e.g., SQL-retrieved blob) to
#' (uncompressed) object
#'
#' The \pkg{rSOILWAT2} SQLite-DB which manages daily weather data (each as a
#' list of elements of class \code{\linkS4class{swWeatherData}}), uses
#' internally (compressed) blobs. This function is used to convert the blob
#' object to the object used by \pkg{rSOILWAT2}'s simulation functions.
#'
#' @param data_blob A raw vector
#' @param type A character string. One of \code{c("gzip", "bzip2", "xz",
#' "none")}.
#'
#' @seealso \code{\link{memDecompress}}, \code{\link{unserialize}}
#' @export
dbW_blob_to_weatherData <- function(data_blob, type = "gzip") {
# RSQLite versions < 2.0 return a list of 'raw'; starting with v >= 2.0,
# the class changed to 'blob'
if (
(inherits(data_blob, "list") || inherits(data_blob, "blob")) &&
inherits(data_blob[[1]], "raw") && length(data_blob) == 1
) {
data_blob <- data_blob[[1]]
}
unserialize(memDecompress(data_blob, type = type))
}
#' Conversion: R object to (compressed) \var{SQL-blob-ready} character vector
#'
#' The \pkg{rSOILWAT2} database which manages daily weather data (each as a
#' list of elements of class \code{\linkS4class{swWeatherData}}), uses
#' internally (compressed) blobs. This function is used to a list of daily
#' weather data used by \pkg{rSOILWAT2}'s simulation functions to a blob object
#' which can be inserted into a SQLite DB.
#'
#' @inheritParams sw_weather_data
#' @inheritParams dbW_blob_to_weatherData
#'
#' @seealso \code{\link[base]{memCompress}}, \code{\link{serialize}}
#' @export
dbW_weatherData_to_blob <- function(weatherData, type = "gzip") {
blob::as_blob(memCompress(
serialize(weatherData, connection = NULL),
type = type
))
}
#----- Conversion: reading of SOILWAT input text files to object of class
# \code{\linkS4class{swWeatherData}}
#' Reads daily weather data from files
#'
#' \pkg{SOILWAT2} does not handle missing weather data. If you have missing
#' data, then you have to impute yourself or use the built-in Markov weather
#' generator (see examples for \code{\link{sw_exec}}).
#'
#' @param LookupWeatherFolder A character string. The path to the parent folder
#' of \code{weatherDirName}.
#' @param weatherDirName String. Name of the folder with the daily weather data
#' files.
#' @param filebasename String. File prefix for weather data. Usually
#' \var{weath}.
#' @param startYear Numeric. Extracted weather data will start with this year.
#' @param endYear Numeric. Extracted weather data will end with this year.
#' @param dailyInputFlags A logical vector of length `MAX_INPUT_COLUMNS`,
#' see `"weathsetup.in"`.
#' @param method A character string. `"R"` uses code in `R` to read files as-is
#' whereas `"C"` uses `"SOILWAT2"` code to read and process files.
#'
#' @return A list of elements of class \code{\linkS4class{swWeatherData}}.
#'
#' @section Details:
#' [dbW_weather_to_SOILWATfiles()] offers the inverse operation, i.e.,
#' writing weather data to disk files.
#'
#' @seealso \code{\link{dbW_getWeatherData}}
#'
#' @examples
#'
#' path_demo <- system.file("extdata", "example1", package = "rSOILWAT2")
#'
#' ## ------ Simulation with data prepared beforehand and separate weather data
#' ## Read inputs from files on disk (via SOILWAT2)
#' sw_in3 <- sw_inputDataFromFiles(dir = path_demo, files.in = "files.in")
#'
#' ## Read forcing weather data from files on disk (via SOILWAT2)
#' sw_weath3c <- getWeatherData_folders(
#' LookupWeatherFolder = file.path(path_demo, "Input"),
#' weatherDirName = "data_weather",
#' filebasename = "weath",
#' startYear = 1979,
#' endYear = 2010,
#' method = "C"
#' )
#'
#' ## Read forcing weather data from files on disk (via R)
#' sw_weath3r <- getWeatherData_folders(
#' LookupWeatherFolder = file.path(path_demo, "Input"),
#' weatherDirName = "data_weather",
#' filebasename = "weath",
#' startYear = 1979,
#' endYear = 2010,
#' method = "R"
#' )
#'
#' ## Weather data (for the non-calculated variables) should be identical
#' identical(
#' sw_weath3c[[1L]]@data[, 1:4],
#' rSOILWAT2::get_WeatherHistory(sw_in3)[[1L]]@data[, 1:4]
#' )
#' identical(
#' sw_weath3r[[1L]]@data[, 1:4],
#' rSOILWAT2::get_WeatherHistory(sw_in3)[[1L]]@data[, 1:4]
#' )
#'
#' ## List of the slots of the input objects of class 'swWeatherData'
#' utils::str(sw_weath3c, max.level = 1)
#' utils::str(sw_weath3r, max.level = 1)
#'
#' ## Execute the simulation run
#' sw_out3c <- sw_exec(inputData = sw_in3, weatherList = sw_weath3c)
#' sw_out3r <- sw_exec(inputData = sw_in3, weatherList = sw_weath3r)
#'
#' all.equal(sw_out3c, sw_out3r)
#'
#' @export
#' @md
getWeatherData_folders <- function(
LookupWeatherFolder,
weatherDirName = NULL,
filebasename = "weath",
startYear = NULL,
endYear = NULL,
dailyInputFlags = c(rep(TRUE, 3L), rep(FALSE, 11L)),
method = c("R", "C")
) {
method <- match.arg(method)
if (is.null(LookupWeatherFolder) || is.null(filebasename)) {
stop(
"Need 'LookupWeatherFolder' and 'filebasename' ",
"to locate weather data"
)
}
stopifnot(
identical(
length(dailyInputFlags),
rSW2_glovars[["kSOILWAT2"]][["kINT"]][["MAX_INPUT_COLUMNS"]]
)
)
dir_weather <- if (is.null(weatherDirName)) {
LookupWeatherFolder
} else {
file.path(LookupWeatherFolder, weatherDirName)
}
fweath <- tryCatch(
list.files(dir_weather, pattern = filebasename),
warning = function(w) {
stop("Path to weather data bad or filebasename not correct.")
}
)
if (endsWith(filebasename, ".")) {
# remove trailing "."
filebasename <- sub("\\.$", "", filebasename)
}
years <- as.integer(
sub(pattern = paste0(filebasename, "."), replacement = "", fweath)
)
stopifnot(!anyNA(years))
ids <- select_years(years, startYear, endYear)
used_years <- years[ids]
if (method == "C") {
.Call(
C_rSW2_readAllWeatherFromDisk,
dir_weather,
filebasename,
used_years[[1L]],
used_years[[length(used_years)]],
dailyInputFlags,
rSOILWAT2::sw_exampleData
)
} else if (method == "R") {
ids_cols <- c(1L, 1L + which(dailyInputFlags))
res <- mapply(
function(fname, yr) {
object <- new("swWeatherData")
object@year <- yr
data <- utils::read.table(
fname,
header = FALSE,
comment.char = "#",
blank.lines.skip = TRUE,
sep = "\t"
)
stopifnot(ncol(data) %in% (0:1 + sum(dailyInputFlags)))
object@data <- object@data[seq_len(nrow(data)), , drop = FALSE]
object@data[, ids_cols] <- as.matrix(data)
object
},
file.path(dir_weather, fweath[ids]),
used_years,
SIMPLIFY = FALSE
)
stats::setNames(res, as.character(used_years))
}
}
#' Deal with missing weather values: convert to NAs
#'
#' Missing weather values may be coded with \code{NA},
#' with the corresponding \var{SOILWAT2} value (i.e.,
#' \code{rSOILWAT2:::rSW2_glovars[["kSOILWAT2"]][["kNUM"]][["SW_MISSING"]]}),
#' or with the value of the argument \code{valNA}.
#'
#' @param data A numerical object.
#' @param valNA The (numerical) value of missing weather data.
#' If \code{NULL}, then default values are interpreted as missing.
#'
#' @return \code{data} where \pkg{SOILWAT2} missing values are converted to
#' R-compatible \code{NA}s.
#' @export
set_missing_weather <- function(data, valNA = NULL) {
if (is.null(valNA)) {
# missing values coded as NA or in SOILWAT2' format
data[data == rSW2_glovars[["kSOILWAT2"]][["kNUM"]][["SW_MISSING"]]] <- NA
} else if (is.finite(valNA)) {
# missing values coded as 'valNA'
data[data == valNA] <- NA
}
data
}
#' Check which weather values are missing
#'
#' @param x A two-dimensional numeric object.
#'
#' @return A logical object with same dimensions as `x`
#'
#' @examples
#' x <- data.frame(
#' Tmax = c(-1.5, 2, NA, 999),
#' Tmin = c(-5, NaN, 999, -5)
#' )
#'
#' is_missing_weather(x)
#'
#' @md
#' @export
is_missing_weather <- function(x) {
x <- as.matrix(x)
vals_missing <- c(
NA,
NaN,
rSW2_glovars[["kSOILWAT2"]][["kNUM"]][["SW_MISSING"]]
)
array(
data = x %in% vals_missing,
dim = dim(x),
dimnames = dimnames(x)
)
}
#' Convert an object of class \code{\linkS4class{swWeatherData}} to a data.frame
#'
#' @inheritParams sw_weather_data
#' @inheritParams set_missing_weather
#'
#' @export
dbW_weatherData_to_dataframe <- function(weatherData, valNA = NULL) {
do.call(
rbind,
lapply(
weatherData,
FUN = function(x) {
tmp <- set_missing_weather(x@data, valNA = valNA)
Year <- rep(x@year, times = nrow(tmp))
cbind(Year, tmp)
}
)
)
}
#' Round weather data
#'
#' @inheritParams sw_weather_data
#'
#' @section Notes:
#' `weatherDF_dataColumns` lists the columns of `weatherData` to be rounded.
#'
#' @return A list with class [`swWeatherData`] elements or
#' a data frame where columns represent weather variables
#' (depending on `weatherData`).
#'
#' @export
#' @md
dbW_weatherData_round <- function(
weatherData,
digits = 4L,
weatherDF_dataColumns = weather_dataColumns()
) {
if (isFALSE(is.na(digits)) && isTRUE(is.logical(digits))) {
digits <- if (isTRUE(as.logical(digits))) 4L else NA
}
if (!isTRUE(is.finite(digits))) return(weatherData)
if (dbW_check_weatherData(weatherData, check_all = FALSE)) {
lapply(
weatherData,
function(x) {
slot(x, "data")[, weatherDF_dataColumns] <- round(
slot(x, "data")[, weatherDF_dataColumns],
digits = digits
)
x
}
)
} else {
weatherData[, weatherDF_dataColumns] <- round(
weatherData[, weatherDF_dataColumns],
digits = digits
)
weatherData
}
}
#' Summarize daily weather to weekly, monthly, or yearly values
#'
#' @inheritParams sw_weather_data
#' @inheritParams set_missing_weather
#' @param time_step A character string.
#' @param na.rm A logical value. Should missing daily values be removed before
#' calculating monthly temperature and precipitation.
#' @param funs A named vector of functions. The names must match column names
#' in `dailySW` and the function are used to summarize daily weather values.
#'
#' @md
#' @name dbW_temporal_summaries
NULL
#' @rdname dbW_temporal_summaries
#' @export
dbW_weatherData_to_monthly <- function(
dailySW,
na.rm = FALSE,
valNA = NULL,
funs = weather_dataAggFun()
) {
vars <- names(funs)
monthly <- matrix(
nrow = length(dailySW) * 12,
ncol = 2 + length(vars),
dimnames = list(NULL, c("Year", "Month", vars))
)
for (y in seq_along(dailySW)) {
weath <- dailySW[[y]]
month <- as.POSIXlt(
paste(weath@year, weath@data[, "DOY"], sep = "-"),
format = "%Y-%j", tz = "UTC"
)$mon + 1
tmp <- set_missing_weather(weath@data, valNA = valNA)
ids <- 1:12 + 12 * (y - 1)
monthly[ids, "Year"] <- weath@year
monthly[ids, "Month"] <- seq_len(12L)
for (var in vars) {
monthly[ids, var] <- as.vector(
tapply(tmp[, var], month, FUN = funs[[var]], na.rm = na.rm)
)
}
}
monthly
}
#' @rdname dbW_temporal_summaries
#' @export
dbW_dataframe_aggregate <- function(
dailySW,
time_step = c("Year", "Month", "Week", "Day"),
na.rm = FALSE,
funs = weather_dataAggFun()
) {
time_step <- match.arg(time_step)
if (time_step == "Day") {
return(dailySW)
}
icol_day <- grep(
"DOY|Day",
colnames(dailySW),
ignore.case = TRUE,
value = TRUE
)
tmp <- apply(dailySW[, c("Year", icol_day)], 1, paste, collapse = "-")
tmp <- as.POSIXlt(tmp, format = "%Y-%j", tz = "UTC")
tmpy <- 1900L + unique(tmp$year)
if (time_step == "Year") {
idaggs <- list(dailySW[, "Year"])
hout <- data.frame(Year = tmpy)
} else if (time_step == "Month") {
idaggs <- list(1L + tmp$mon, dailySW[, "Year"])
hout <- data.frame(
Year = rep(tmpy, each = 12),
Month = rep(seq_len(12), times = length(tmpy))
)
} else if (time_step == "Week") {
idaggs <- list(1L + floor(tmp$yday / 7), dailySW[, "Year"])
hout <- data.frame(
Year = rep(tmpy, each = 53),
Week = rep(seq_len(53), times = length(tmpy))
)
}
vars <- names(funs)
res <- as.matrix(
cbind(
hout,
matrix(ncol = length(vars), dimnames = list(NULL, vars))
)
)
for (var in vars) {
res[, var] <- as.vector(
tapply(dailySW[, var], INDEX = idaggs, FUN = funs[[var]], na.rm = na.rm)
)
}
res
}
#' @rdname dbW_temporal_summaries
#' @export
dbW_dataframe_to_monthly <- function(dailySW, na.rm = FALSE) {
dbW_dataframe_aggregate(dailySW, time_step = "Month", na.rm = na.rm)
}
#' Extract years from a \var{weatherData} object
#' @inheritParams sw_weather_data
#' @export
get_years_from_weatherData <- function(wd) {
as.integer(unlist(lapply(wd, FUN = slot, "year")))
}
#' Extract years to weather data.frame
#'
#' @inheritParams sw_weather_data
#' @param years A numeric or integer vector or \code{NULL}. Vector of year data
#' where length is equal to either the number of years in the weather data.frame
#' or the number of rows in the data.frame.
#'
#' @section Notes:
#' The first element of `weatherDF_dataColumns` (only the first is used) must
#' contain the column name for day of year.
#'
#' @return A named list of length 2.
#' \itemize{
#' \item \code{years} a vector of unique year values.
#' \item \code{year_ts} a vector of time series values for each row/day of the
#' data.frame.
#' }
#'
#' @export
#' @md
get_years_from_weatherDF <- function(weatherDF, years, weatherDF_dataColumns) {
if (!is.null(years)) {
if (length(years) == nrow(weatherDF)) {
year_ts <- years
} else if (
length(years) == sum(weatherDF[, weatherDF_dataColumns[1]] == 1)
) {
year_ts <- rep(
years,
times = diff(c(
which(weatherDF[, weatherDF_dataColumns[1]] == 1),
nrow(weatherDF) + 1)
))
} else {
stop(
"Not sufficient year information was provided with the ",
"'weatherDF' object"
)
}
} else {
tmp <- grepl("year", colnames(weatherDF), ignore.case = TRUE)
if (any(tmp)) {
year_ts <- weatherDF[, which(tmp)[1]]
} else {
stop("No year information was provided with the 'weatherDF' object")
}
}
return(list(years = sort(unique(year_ts)), year_ts = year_ts))
}
#' Conversion: data.frame to object of class \code{\linkS4class{swWeatherData}}
#'
#' @inheritParams sw_weather_data
#'
#' @section Notes:
#' `weatherDF_dataColumns` consists of a vector with
#' (1) the variable name for day of year, e.g., `"DOY"`, and
#' (2) weather variables, see [weather_dataColumns()],
#' or `NULL` which attempts to guess relevant columns.
#'
#' @export
#' @md
dbW_dataframe_to_weatherData <- function(
weatherDF,
years = NULL,
weatherDF_dataColumns = NULL,
round = NA
) {
if (isTRUE(is.finite(round))) {
.Deprecated(
msg = paste(
"Argument 'round' is deprecated.
Please call `dbW_weatherData_round()` instead."
)
)
}
if (is.null(weatherDF_dataColumns)) {
weatherDF_dataColumns <- intersect(
colnames(weatherDF),
c("DOY", weather_dataColumns())
)
}
if (
!all(weatherDF_dataColumns %in% colnames(weatherDF))
) {
stop(
"Not every weatherDF_dataColumns is available in the ",
"'weatherDF' object"
)
}
ylist <- get_years_from_weatherDF(weatherDF, years, weatherDF_dataColumns)
# Remove call to `dbW_weatherData_round()` once argument `round` is removed.
if (isTRUE(is.finite(round))) {
weatherDF <- dbW_weatherData_round(weatherDF, digits = round)
}
template <- new("swWeatherData")
weatherData <- list()
for (i in seq_along(ylist$years)) {
ydata <- as.matrix(
weatherDF[
ylist$year_ts == ylist$years[i],
weatherDF_dataColumns
]
)
weatherData[[i]] <- upgrade_swWeatherData(
data = ydata,
year = ylist$years[i],
template = template
)
}
names(weatherData) <- ylist$years
weatherData
}
#' Conversion: object of class \code{\linkS4class{swWeatherData}} or
#' data.frame to \pkg{SOILWAT} input text files
#'
#' @param path A character string. Path on disk to where to write files.
#' @param site.label A character string. Site identification name added to
#' comment on first line of each file.
#' @inheritParams sw_weather_data
#' @param weatherDF A data.frame. Weather data, see details.
#'
#' @section Notes:
#' `weatherDF_dataColumns` must exactly contain entries for day of year and
#' the three weather variables.
#'
#' @section Details:
#' The weather data must be provided either via `weatherData` or `weatherDF`.
#' See [dbW_weatherData_to_dataframe()] and [dbW_weatherData_to_dataframe()]
#' for conversions between formats of `weatherData` and `weatherDF`.
#'
#' @section Details:
#' [getWeatherData_folders()] offers the inverse operation, i.e.,
#' reading weather data from disk files.
#'
#' @export
#' @md
dbW_weather_to_SOILWATfiles <- function(
path,
site.label,
weatherData = NULL,
weatherDF = NULL,
years = NULL,
weatherDF_dataColumns = c("DOY", weather_dataColumns()),
digits = 4L
) {
stopifnot(is.null(weatherData) || is.null(weatherDF))
dir.create(path, recursive = TRUE, showWarnings = FALSE)
if (!is.null(weatherData)) {
years <- sapply(weatherData, FUN = function(x) x@year)
} else if (!is.null(weatherDF)) {
if (
!all(weatherDF_dataColumns %in% colnames(weatherDF))
) {
stop(
"Not every weatherDF_dataColumns is available in the ",
"'weatherDF' object"
)
}
tmp <- get_years_from_weatherDF(weatherDF, years, weatherDF_dataColumns)
years <- tmp$years
year_ts <- tmp$year_ts
} else {
stop(
"Provide daily weather data either as 'weatherData' or ",
"'weatherDF' object"
)
}
for (y in seq_along(years)) {
data.sw <- if (!is.null(weatherData)) {
weatherData[[y]]@data
} else {
weatherDF[year_ts == years[y], weatherDF_dataColumns]
}
sw.filename <- file.path(path, paste0("weath.", years[y]))
sw.comments <- c(
paste("# weather for site", site.label, "year = ", years[y]),
paste0("# ", toString(weatherDF_dataColumns))
)
utils::write.table(
sw.comments,
file = sw.filename,
sep = "\t",
eol = "\r\n",
quote = FALSE,
row.names = FALSE,
col.names = FALSE
)
tmp <- data.frame(
data.sw[, 1],
matrix(
data = NA_character_,
ncol = length(weatherDF_dataColumns) - 1L
),
stringsAsFactors = FALSE
)
for (kv in seq_along(weatherDF_dataColumns)[-1]) {
tmp[, kv] <- formatC(data.sw[, kv], digits = digits, format = "f")
}
utils::write.table(
tmp,
file = sw.filename,
append = TRUE,
sep = "\t",
eol = "\r\n",
quote = FALSE,
row.names = FALSE,
col.names = FALSE
)
}
invisible(years)
}
#' Transfer existing weather data to a different (Gregorian) calendar (period)
#'
#' This function can transfer from existing weather data to, e.g.,
#' different years / a subset of years (partially overlapping or not), or
#' can convert from a non-leap to a Gregorian calendar.
#'
#' @inheritParams sw_weather_data
#' @inheritParams dbW_estimate_WGen_coefs
#' @param new_startYear An integer value. The first Calendar year of the new
#' time period. If \code{NULL}, then the first year of \code{weatherData}.
#' @param new_endYear An integer value. The last Calendar year of the new
#' time period. If \code{NULL}, then the last year of \code{weatherData}.
#' @param type A string that affects how years of \code{weatherData} are
#' used for transfer. If \code{"asis"}, then years of are used as is.
#' If \code{"sequential"}, then years are re-coded to start with
#' \code{new_startYear}.
#' @param name_year A string. Column name of the weather data that corresponds
#' to year.
#' @param name_DOY A string. Column name of the weather data that corresponds
#' to day of year.
#' @param name_data A vector of strings. Column names of the weather data.
#' @inheritParams set_missing_weather
#'
#' @return A data.frame formatted as a return object from function
#' \code{\link{dbW_weatherData_to_dataframe}} with column names as given by
#' \code{name_year}, \code{name_DOY}, and \code{name_data}.
#'
#' @section Note: The returned object may contain \code{NA}, e.g., for
#' leap days that were added. Use function \code{\link{dbW_generateWeather}}
#' to fill in.
#'
#' @examples
#' wdata <- rSOILWAT2::weatherData
#'
#' ## Transfer to different years (partially overlapping)
#' wnew <- dbW_convert_to_GregorianYears(
#' wdata,
#' new_startYear = 2000,
#' new_endYear = 2020
#' )
#' all.equal(unique(wnew[, "Year"]), 2000:2020)
#' anyNA(wnew) # --> use `dbW_generateWeather`
#'
#' ## Transfer to a subset of years (i.e., subset)
#' wnew <- dbW_convert_to_GregorianYears(
#' wdata,
#' new_startYear = 2000,
#' new_endYear = 2005
#' )
#' all.equal(unique(wnew[, "Year"]), 2000:2005)
#' anyNA(wnew)
#'
#' ## Correct/convert from a non-leap to a Gregorian calendar
#' wempty <- data.frame(
#' dbW_weatherData_to_dataframe(weatherHistory())
#' )[1:365, ]
#'
#' wnew <- dbW_convert_to_GregorianYears(
#' wempty,
#' new_startYear = 2016,
#' new_endYear = 2016
#' )
#' all.equal(unique(wnew[, "Year"]), 2016:2016)
#' all.equal(nrow(wnew), 366) # leap year
#'
#' @export
dbW_convert_to_GregorianYears <- function(
weatherData,
new_startYear = NULL,
new_endYear = NULL,
type = c("asis", "sequential"),
name_year = "Year",
name_DOY = "DOY",
name_data = weather_dataColumns(),
valNA = NULL
) {
# daily weather data
if (
inherits(weatherData, "list") &&
all(sapply(weatherData, inherits, what = "swWeatherData"))
) {
wdata <- data.frame(
dbW_weatherData_to_dataframe(weatherData, valNA = valNA)
)
} else {
wdata <- data.frame(set_missing_weather(weatherData, valNA = valNA))
}
# new Calendar years
if (is.null(new_startYear)) {
new_startYear <- min(wdata[, name_year])
}
if (is.null(new_endYear)) {
new_endYear <- max(wdata[, name_year])
}
# Relabel input years (if requested)
type <- match.arg(type)
if (type == "sequential") {
old_startYear <- min(wdata[, name_year])
if (old_startYear != new_startYear) {
delta <- new_startYear - old_startYear
wdata[, name_year] <- wdata[, name_year] + delta
}
}
# Create data.frame for new Calendar years
tdays <- rSW2utils::days_in_years(
start_year = new_startYear,
end_year = new_endYear
)
tdays1 <- as.POSIXlt(tdays)
wdata2 <- data.frame(
Year = 1900 + tdays1$year,
DOY = 1 + tdays1$yday,
matrix(ncol = length(name_data)),
stringsAsFactors = FALSE
)
colnames(wdata2) <- c(name_year, name_DOY, name_data)
# Transfer existing values
tmp <- apply(
wdata[, c(name_year, name_DOY), drop = FALSE],
MARGIN = 1,
FUN = paste,
collapse = "/"
)
id_xdf <- format(as.Date(tmp, format = "%Y/%j"))
id_xdf2 <- format(as.Date(tdays))
id_match <- match(id_xdf2, id_xdf, nomatch = 0)
wdata2[id_match > 0, name_data] <- wdata[id_match, name_data, drop = FALSE]
wdata2
}
#' Check that weather data is well-formed
#'
#' Check that weather data is organized in a list
#' where each element is of class \code{\linkS4class{swWeatherData}}, and
#' represents daily data for one Gregorian year
#'
#' @param x An object.
#' @param check_all A logical value
#'
#' @return A logical value.
#'
#' @examples
#' dbW_check_weatherData(rSOILWAT2::weatherData)
#' dbW_check_weatherData(weatherHistory())
#' dbW_check_weatherData(weatherHistory(), check_all = FALSE)
#'
#'
#' @export
dbW_check_weatherData <- function(x, check_all = TRUE) {
res <-
length(x) > 0 &&
inherits(x, "list") &&
all(vapply(x, inherits, what = "swWeatherData", FUN.VALUE = NA)) &&
all(
vapply(
x,
FUN = function(object) {
isTRUE(is.logical(validObject(object, test = TRUE)))
},
FUN.VALUE = NA
)
)
if (res) {
yrs <- vapply(x, slot, name = "year", FUN.VALUE = NA_integer_)
ids_check <- !is.na(yrs)
if (isTRUE(check_all) || sum(ids_check) > 0) {
if (isTRUE(check_all)) {
ids_check <- seq_along(x)
}
has_days <- vapply(
x[ids_check],
function(xyr) nrow(slot(xyr, "data")),
FUN.VALUE = NA_integer_
)
expected_days <- 365L + as.integer(rSW2utils::isLeapYear(yrs[ids_check]))
res <- res && identical(unname(has_days), expected_days)
}
}
res
}
#' Determine used weather variables based on values
#'
#' @param x Weather data, i.e.,
#' a list where each element is of class [`swWeatherData`], or
#' a data frame with appropriate columns (see [dbW_weatherData_to_dataframe()]).
#' @param name_data A vector of character strings. The column names of `x`
#' with weather variables.
#'
#' @return A logical vector for each of the possible input variables with
#' `TRUE` if at least one value is not missing.
#'
#' @examples
#' calc_dailyInputFlags(rSOILWAT2::weatherData)
#' calc_dailyInputFlags(dbW_weatherData_to_dataframe(rSOILWAT2::weatherData))
#'
#'
#' @md
#' @export
calc_dailyInputFlags <- function(x, name_data = weather_dataColumns()) {
if (isTRUE(dbW_check_weatherData(x, check_all = FALSE))) {
x <- dbW_weatherData_to_dataframe(x)
}
apply(
!is_missing_weather(x[, name_data, drop = FALSE]),
MARGIN = 2L,
FUN = any
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.