## downscaleChunk.R Downscaling method calibration in cross validation mode.
##
## Copyright (C) 2018 Santander Meteorology Group (http://www.meteo.unican.es)
##
## 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
## (at your option) 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/>.
#' @title Downscaling by chunks
#' @description Downscale climate data by splitting it in chunks, where there are as many chunks as latitudes.
#' This function encapsulates \code{\link[downscaleR]{downscaleTrain}}
#' @param x The input grid (admits both single and multigrid, see \code{\link[transformeR]{makeMultiGrid}}). It should be an object as returned by \pkg{loadeR}.
#' @param y The observations dataset. It should be an object as returned by \pkg{loadeR}.
#' @param newdata New datasets where to apply the model infered. It should be a list of objects as returned by \pkg{loadeR},
#' containing the new dataset/s.
#' @param method A string value. Type of transer function. Currently implemented options are \code{"analogs"}, \code{"GLM"} and \code{"NN"}.
#' @param simulate A logic value indicating whether we want to simulate or not based on the GLM distributional parameters. Only relevant when perdicting with a GLM. Default to FALSE.
#' @param prepareData.args A list with the arguments of the \code{\link[downscaleR]{prepareData}} function. Please refer to \code{\link[downscaleR]{prepareData}} help for
#' more details about this parameter.
#' @param condition Inequality operator to be applied considering the given threshold.
#' \code{"GT"} = greater than the value of \code{threshold}, \code{"GE"} = greater or equal,
#' \code{"LT"} = lower than, \code{"LE"} = lower or equal than. We only train with the days that satisfy the condition.
#' @param threshold Numeric value. Threshold used as reference for the condition. Default is NULL. If a threshold value is supplied with no specification of the parameter \code{condition}. Then condition is set to \code{"GE"}.
#' @param predict A logic value. Should the prediction on the training set should be returned? Default is TRUE.
#' @param ... Optional parameters. These parameters are different depending on the method selected.
#' Every parameter has a default value set in the atomic functions in case that no selection is wanted.
#' Everything concerning these parameters is explained in the section \code{Details} of the function \code{\link[downscaleR]{downscaleTrain}}. However, if wanted, the atomic functions can be seen here:
#' \code{\link[downscaleR]{glm.train}} and \code{\link[deepnet]{nn.train}}.
#' @param path A string indicating the path where to save the prediction.
#' @return Saves the prediction where specified.
#' @seealso
#' downscaleTrain for training a downscaling model
#' downscalePredict for prediction for a a test dataset with a trained model for
#' \href{https://github.com/SantanderMetGroup/downscaleR/wiki/training-downscaling-models}{downscaleR Wiki} for downscaling seasonal forecasting and climate projections.
#' @family downscaling.functions
#' @author J. Bano-Medina
#' @export
downscaleChunk <- function(x, y, newdata, simulate = FALSE,
method, ...,
prepareData.args = list("global.vars" = NULL, "combined.only" = TRUE, "spatial.predictors" = NULL, "local.predictors" = NULL, "extended.predictors" = NULL),
condition = NULL, threshold = NULL, predict = TRUE,
path = getwd()) {
if (!exists("global.vars",prepareData.args)) prepareData.args$global.vars <- NULL
if (!exists("combined.only",prepareData.args)) prepareData.args$combined.only <- TRUE
if (!exists("spatial.predictors",prepareData.args)) prepareData.args$spatial.predictors <- NULL
if (!exists("local.predictors",prepareData.args)) prepareData.args$local.predictors <- NULL
if (!exists("extended.predictors",prepareData.args)) prepareData.args$extended.predictors <- NULL
x <- getTemporalIntersection(x,y,which.return = "obs")
y <- getTemporalIntersection(x,y,which.return = "prd")
latitudes <- getCoordinates(y)$y
chunks <- length(latitudes)
lapply(1:chunks,FUN = function(z){
print(paste("Training chunk:",z,"out of",chunks))
y_chunk <- subsetDimension(y,dimension = "lat", indices = z)
xyT <- prepareData(x = x, y = y_chunk, global.vars = prepareData.args$global.vars, combined.only = prepareData.args$combined.only, spatial.predictors = prepareData.args$spatial.predictors, local.predictors = prepareData.args$local.predictors, extended.predictors = prepareData.args$extended.predictors)
model <- downscaleTrain(xyT, method = method, condition = condition, threshold = threshold, predict = predict, model.verbose = FALSE, ...)
p <- lapply(simulate, function(sim) {
lapply(newdata, function(zz) {
xyt <- prepareNewData(zz,xyT)
downscalePredict(newdata = xyt,model, simulate = sim)
})
}) %>% unlist(recursive = FALSE)
if (z < 10) {zn <- paste0("00",z)}
else if (z < 100 & z >= 10) {zn <- paste0("0",z)}
else{zn <- z}
ini <- ifelse(isTRUE(predict),length(p)+1,length(p))
lapply(1:ini, function(zzz) {
if (ini == (length(p)+1) & zzz == 1) {
grid <- model$pred
} else if (ini == (length(p)+1) & zzz != 1) {
grid <- p[[zzz-1]]
} else if (ini == (length(p))) {
grid <- p[[zzz]]
}
save(grid, file = paste0(path,"/dataset",zzz,"_chunk",zn,".rda"))
})
p <- NULL
})
ini <- ifelse(isTRUE(predict),(length(newdata)*length(simulate))+1,length(newdata)*length(simulate))
pred <- list()
for (i in 1:ini) {
lf <- list.files("./", pattern = paste0("dataset",i), full.names = TRUE)
chunk.list <- lapply(lf, function(x) get(load(x)))
pred[[i]] <- bindGrid(chunk.list, dimension = "lat") %>% redim(drop = TRUE)
file.remove(lf)
}
if (ini == 1) pred <- pred[[1]] %>% redim(drop = TRUE)
return(pred)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.