R/sw_dbW_WeatherDatabase.R

In Burke-Lauenroth-Lab/Rsoilwat: An Ecohydrological Ecosystem-Scale Water Balance Simulation Model

###############################################################################
#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
    )

  } 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
  )
}