diff --git a/.Rhistory b/.Rhistory index 7608519..eb71327 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,397 +1,7 @@ -#' -#' \item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957 -#' -#' \item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192 -#' -#' \item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529 -#' } -getBiasFactor_core <- function(hindcast, obs, method , scaleType, preci, prThreshold, extrapolate){ -# If the variable is precipitation, some further process needs to be added. -# The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration. -# check if frc, hindcast or obs are all na values -if (!any(!is.na(obs)) | !any(!is.na(hindcast))) { -warning('In this cell, hindcast or obs data is missing. No biasCorrection for this cell.') -return(NA) -} -if (preci == TRUE) { -preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold) -hindcast <- preprocessHindcast_res[[1]] -minHindcastPreci <- preprocessHindcast_res[[2]] -} -# default is the simplest method in biascorrection, just do simple addition and subtraction. -if (method == 'delta') { -biasFactor <- getBiasFactor_core_delta(hindcast) -} else if (method == 'scaling') { -biasFactor <- getBiasFactor_core_scaling(hindcast, obs, scaleType) -} else if (method == 'eqm') { -# In this method, the value is bounded by the observation -# Preci or not both have the same biasFactor -if (preci == FALSE) { -biasFactor <- getBiasFactor_core_eqm_nonPreci(hindcast, obs, extrapolate) -} else { -biasFactor <- getBiasFactor_core_eqm_preci(hindcast, obs, minHindcastPreci, extrapolate, prThreshold) -} -} else if (method == 'gqm') { -if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T') -biasFactor <- getBiasFactor_core_gqm(hindcast, obs, prThreshold, minHindcastPreci) -} -if (preci == TRUE) biasFactor$minHindcastPreci <- minHindcastPreci -return(biasFactor) -} -applyBiasFactor_core <- function(frc, biasFactor, method, preci, prThreshold, scaleType, -extrapolate, obs = NULL) { -if (!any(!is.na(biasFactor))) { -warning('In this cell, biasFactor is missing.No biasCorrection for this cell.') -# here return NA or return the unprocessed frc, both are OK. But return NA is more -# obvious for user. -return(NA) -} -if (method == 'delta') { -if (is.null(obs)) stop('This method needs obs input.') -if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.') -frc <- applyBiasFactor_core_delta(frc = frc, biasFactor = biasFactor, obs = obs) -} else if (method == 'scaling') { -frc <- applyBiasFactor_core_scaling(frc = frc, biasFactor = biasFactor, scaleType = scaleType) -} else if (method == 'eqm') { -if (is.null(obs)) stop('This method needs obs input.') -if (preci == FALSE) { -frc <- applyBiasFactor_core_eqm_nonPreci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, -obs = obs) -} else { -frc <- applyBiasFactor_core_eqm_preci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, -prThreshold = prThreshold, obs = obs) -} -} else if (method == 'gqm') { -frc <- applyBiasFactor_core_gqm(frc = frc, biasFactor = biasFactor) -} -return(frc) -} -getBiasFactor_core_delta <- function(hindcast) { -biasFactor <- list() -biasFactor$hindcastMean <- mean(hindcast, na.rm = TRUE) -return(biasFactor) -} -applyBiasFactor_core_delta <- function(frc, biasFactor, obs) { -hindcastMean <- biasFactor$hindcastMean -frcMean <- mean(frc, na.rm = TRUE) -return(obs - hindcastMean + frcMean) -} -getBiasFactor_core_scaling <- function(hindcast, obs, scaleType) { -biasFactor <- list() -hindcastMean <- mean(hindcast, na.rm = TRUE) -obsMean <- mean(obs, na.rm = TRUE) -if (scaleType == 'multi') { -biasFactor$scale <- obsMean / hindcastMean -} else if (scaleType == 'add') { -biasFactor$scale <- obsMean - hindcastMean -} -return(biasFactor) -} -applyBiasFactor_core_scaling <- function(frc, biasFactor, scaleType) { -if (scaleType == 'multi') { -frc <- frc * biasFactor$scale -} else if (scaleType == 'add') { -frc <- frc + biasFactor$scale -} -return(frc) -} -getBiasFactor_core_eqm_nonPreci <- function(hindcast, obs, extrapolate) { -biasFactor <- list() -biasFactor$ecdfHindcast <- ecdf(hindcast) -if (extrapolate == 'constant') { -biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE) -biasFactor$minHindcast <- min(hindcast, na.rm = TRUE) -biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE) -biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, na.rm = TRUE) -} -return(biasFactor) -} -getBiasFactor_core_eqm_preci <- function(hindcast, obs, minHindcastPreci, extrapolate, -prThreshold) { -biasFactor <- list() -biasFactor$ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci]) -if (extrapolate == 'constant') { -biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE) -biasFactor$minHindcast <- min(hindcast, na.rm = TRUE) -biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE) -biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, nna.rm = TRUE) -} -biasFactor$availableHindcastLength <- length(which(hindcast > minHindcastPreci)) -# drizzle parameter 1 -biasFactor$drizzleP1 <- min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) -# biasFactor$prThreshold <- prThreshold -return(biasFactor) -} -applyBiasFactor_core_eqm_nonPreci <- function(frc, biasFactor, extrapolate, obs) { -ecdfHindcast <- biasFactor$ecdfHindcast -if (extrapolate == 'constant') { -higherIndex <- which(frc > biasFactor$maxHindcast) -lowerIndex <- which(frc < biasFactor$minHindcast) -extrapolateIndex <- c(higherIndex, lowerIndex) -non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex) -# In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards -# So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will -# return 1:length(sim) -if (length(higherIndex) > 0) { -frc[higherIndex] <- frc[higherIndex] - biasFactor$higherIndex_dif -} -if (length(lowerIndex) > 0) { -frc[lowerIndex] <- frc[lowerIndex] - biasFactor$lowerIndex_dif -} -frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), -na.rm = TRUE, type = 4) -} else { -frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4) -} -return(frc) -} -#' @importFrom stats quantile -applyBiasFactor_core_eqm_preci <- function(frc, biasFactor, extrapolate, prThreshold, obs) { -# Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be -# always hindcast > minHindcastPreci exists. -# Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci -if (biasFactor$availableHindcastLength > 0) { -ecdfHindcast <- biasFactor$ecdfHindcast -noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc)) -rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc)) -# drizzle is to see whether there are some precipitation between the min frc (over threshold) and -# min hindcast (over threshold). -drizzle <- which(frc > biasFactor$minHindcastPreci & frc <= biasFactor$drizzleP1 & !is.na(frc)) -if (length(rain) > 0) { -ecdfFrc <- ecdf(frc[rain]) -if (extrapolate == 'constant') { -# This higher and lower index mean the extrapolation part -higherIndex <- which(frc[rain] > biasFactor$maxHindcast) -lowerIndex <- which(frc[rain] < biasFactor$minHindcast) -extrapolateIndex <- c(higherIndex, lowerIndex) -non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex) -if (length(higherIndex) > 0) { -frc[rain[higherIndex]] <- frc[higherIndex] - biasFactor$higherIndex_dif -} -if (length(lowerIndex) > 0) { -frc[rain[lowerIndex]] <- frc[lowerIndex] - biasFactor$lowerIndex_dif -} -# Here the original function doesn't accout for the situation that extraploateIndex is 0 -# if it is 0, rain[-extraploateIndex] would be nothing -# Above has been solved by using setdiff. -frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], -probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), -na.rm = TRUE, type = 4) -} else { -frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], -probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4) -} -} -if (length(drizzle) > 0){ -# drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to -# biascorrect the original drizzle part -frc[drizzle] <- quantile(frc[which(frc > biasFactor$drizzleP1 & !is.na(frc))], -probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, -type = 4) -} -frc[noRain] <- 0 -} else { -# in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci -# And frc distribution is used then. -noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc)) -rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc)) -if (length(rain) > 0) { -ecdfFrc <- ecdf(frc[rain]) -frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), -na.rm = TRUE, type = 4) -} -frc[noRain]<-0 -} -return(frc) -} -#' @importFrom MASS fitdistr -getBiasFactor_core_gqm <- function(hindcast, obs, prThreshold, minHindcastPreci) { -if (any(obs > prThreshold)) { -biasFactor <- list() -ind <- which(obs > prThreshold & !is.na(obs)) -obsGamma <- fitdistr(obs[ind],"gamma") -biasFactor$obsShape <- obsGamma$estimate[1] -biasFactor$obsRate <- obsGamma$estimate[2] -ind <- which(hindcast > 0 & !is.na(hindcast)) -hindcastGamma <- fitdistr(hindcast[ind],"gamma") -biasFactor$hindcastShape <- hindcastGamma$estimate[1] -biasFactor$hindcastRate <- hindcastGamma$estimate[2] -biasFactor$minHindcastPreci <- minHindcastPreci -} else { -warning('All the observations of this cell(station) are lower than the threshold, -no biasFactor returned.') -biasFactor <- NA -} -return(biasFactor) -} -#' @importFrom stats pgamma qgamma -applyBiasFactor_core_gqm <- function(frc, biasFactor) { -rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc)) -noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc)) -probF <- pgamma(frc[rain], biasFactor$hindcastShape, rate = biasFactor$hindcastRate) -frc[rain] <- qgamma(probF, biasFactor$obsShape, rate = biasFactor$obsRate) -frc[noRain] <- 0 -return(frc) -} -biasFactor <- getBiasFactor(hindcast, obs) -frc_new <- applyBiasFactor(frc, biasFactor) -frc_new1 <- biasCorrect(frc, hindcast, obs) -frc_new1 <- biasCorrect(frc, hindcast, obs, input = 'TS') -identical(frc_new, frc_new1) -frc_new - frc_new1 -ploTS(frc_new, frc_new1) -ploTS(frc_new, frc_new1) -?plotTS -plot.ts(frc_new) -plot.ts(frc_new, frc_new1) -plot.ts(frc_new1, add = T) -plot(frc_new1) -plotTS(frc_new1) -plotTS(frc_new1, frc_new) -plotTS(frc_new1, frc_new, plot='cu') -plotTS(frc_new1, frc_new, plot='cum') -biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE) -#' @importFrom MASS fitdistr -#' @importFrom stats rgamma -preprocessHindcast <- function(hindcast, obs, prThreshold) { -lowerIndex <- length(which(obs < prThreshold)) -# In the original function, this minHindcastPreci is Pth[,i,j] in downscaleR, and it is originally -# set to NA, which is not so appropriate for all the precipitations. -# In the original function, there are only two conditions, 1. all the obs less than threshold -# 2. there are some obs less than threshold. -# While, if we set threshold to 0, there could be a 3rd condition, all the obs no less than threshold. -# Here I set this situation, firstly set minHindcastPreci to the min of the hindcast. Because in future -# use, 'eqm' method is going to use this value. -# The problem above has been solved. -if (lowerIndex >= 0 & lowerIndex < length(obs)) { -index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix -hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA) -# minHindcastPreci is the min preci over threshold FOR ***HINDCAST*** -# But use obs to get the lowerIndex, so obs_sorted[lowerIndex + 1] > prThreshold, but -# hindcast_sorted[lowerIndex + 1] may greater than or smaller than ptThreshold -# It would be better to understand if you draw two lines: hindcast_sorted and obs_sorted -# with y = prThreshold, you will find the difference of the two. -# In principle, the value under the threshold needs to be replaced by some other reasonable value. -# simplest way -minHindcastPreci <- hindcast_sorted[lowerIndex + 1] -# Also here if minHindcastPreci is 0 and prThreshold is 0, will cause problem, bettter set -# I set it prThreshold != 0 -if (minHindcastPreci <= prThreshold & prThreshold != 0) { -obs_sorted <- sort(obs, decreasing = FALSE, na.last = NA) -# higherIndex is based on hindcast -higherIndex <- which(hindcast_sorted > prThreshold & !is.na(hindcast_sorted)) -if (length(higherIndex) == 0) { -higherIndex <- max(which(!is.na(hindcast_sorted))) -higherIndex <- min(length(obs_sorted), higherIndex) -} else { -higherIndex <- min(higherIndex) -} -# here I don't know why choose 6. -# Written # [Shape parameter Scale parameter] in original package -# according to the reference and gamma distribution, at least 6 values needed to fit gamma -# distribution. -if (length(unique(obs_sorted[(lowerIndex + 1):higherIndex])) < 6) { -hindcast_sorted[(lowerIndex + 1):higherIndex] <- mean(obs_sorted[(lowerIndex + 1):higherIndex], -na.rm = TRUE) -} else { -obsGamma <- fitdistr(obs_sorted[(lowerIndex + 1):higherIndex], "gamma") -# this is to replace the original hindcast value between lowerIndex and higherIndex with -# some value taken from gamma distribution just generated. -hindcast_sorted[(lowerIndex + 1):higherIndex] <- rgamma(higherIndex - lowerIndex, obsGamma$estimate[1], -rate = obsGamma$estimate[2]) -} -hindcast_sorted <- sort(hindcast_sorted, decreasing = FALSE, na.last = NA) -} -minIndex <- min(lowerIndex, length(hindcast)) -hindcast_sorted[1:minIndex] <- 0 -hindcast[index] <- hindcast_sorted -} else if (lowerIndex == length(obs)) { -index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix -hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA) -minHindcastPreci <- hindcast_sorted[lowerIndex] -# here is to compare with hindcast, not obs -minIndex <- min(lowerIndex, length(hindcast)) -hindcast_sorted[1:minIndex] <- 0 -hindcast[index] <- hindcast_sorted -} -return(list(hindcast, minHindcastPreci)) -} -biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE) -frc_new <- applyBiasFactor(frc, biasFactor) -frc_new1 <- biasCorrect(frc, hindcast, obs, input = 'TS', preci = TRUE) -plotTS(frc_new1, frc_new, plot='cum') -frc_new == frc_new1 -biasFactor <- getBiasFactor(hindcast, obs, method = 'delta') -frc_new <- applyBiasFactor(frc, biasFactor, obs = obs) -frc_new1 <- biasCorrect(frc, hindcast, obs, method = 'delta', input = 'TS') -plotTS(frc_new1, frc_new, plot='cum') -frc_new == frc_new1 -any(frc_new != frc_new1) -biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE) -frc_new <- applyBiasFactor(frc, biasFactor, obs = obs) -frc_new1 <- biasCorrect(frc, hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE) -any(frc_new != frc_new1) -any(frc_new != frc_new1, na.rm=T) -biasFactor <- getBiasFactor(hindcast, obs, sclaeType = 'add', preci = TRUE) -biasFactor <- getBiasFactor(hindcast, obs, scaleType = 'add', preci = TRUE) -frc_new <- applyBiasFactor(frc, biasFactor, obs = obs) -frc_new <- applyBiasFactor(frc, biasFactor) -frc_new1 <- biasCorrect(frc, hindcast, obs, scaleType = 'add', input = 'TS', preci = TRUE) -any(frc_new != frc_new1, na.rm=T) -plotTS(frc_new1, frc_new, plot='cum') -biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE) -library(MASS) -biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE) -frc_new <- applyBiasFactor(frc, biasFactor) -frc_new1 <- biasCorrect(frc, hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE) -any(frc_new != frc_new1, na.rm=T) -biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm',extrapolate = 'constant', preci = TRUE) -frc_new <- applyBiasFactor(frc, biasFactor) -frc_new <- applyBiasFactor(frc, biasFactor, obs = obs) -frc_new1 <- biasCorrect(frc, hindcast, obs, method = 'eqm',extrapolate = 'constant', input = 'TS', preci = TRUE) -any(frc_new != frc_new1, na.rm=T) -str(nc) -nc1 <- nc -nc1$Data <- chooseDim(nc$Data, dim = 4, value = 1, drop = T) -str(nc1) -nc$Members <- NULL -nc1 -str(nc1) -nc$Members <- NULL -str(nc1) -nc1$Members <- NULL -nc$Members <- c(1,2) -str(nc1) -str(nc) -biasFactor <- getBiasFactor(nc, tgridData) -newFrc <- applyBiasFactor(nc, biasFactor) -newFrc1 <- biasCorrect(nc, nc, tgridData) -identical(newFrc, newFrc1) -biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant', -preci = TRUE) -# This method needs obs input. -newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData) -newFrc1 <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', -preci = TRUE) -identical(newFrc, newFrc1) -str(newFrc) -biasFactor <- getBiasFactor(nc1, tgridData, method = 'gqm', preci = TRUE) -str(biasFactor) -newFrc <- applyBiasFactor(nc, biasFactor) -newFrc <- applyBiasFactor(nc1, biasFactor) -str(newFrc) -newFrc1 <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) -identical(newFrc, newFrc1) -newFrc1 <- biasCorrect(nc1, nc1, tgridData, method = 'gqm', preci = TRUE) -identical(newFrc, newFrc1) -devtools::document() -devtools::document() -devtools::document() -devtools::document() -devtools::document() -devtools::document() devtools::document() +devtools::check() devtools::document() +devtools::check() devtools::document() devtools::document() devtools::document() @@ -402,44 +12,46 @@ devtools::document() devtools::document() devtools::document() devtools::document() +devtools::check() devtools::document() +devtools::check() devtools::document() +devtools::check() devtools::document() devtools::check() +devtools::document() devtools::check() devtools::document() devtools::check() devtools::document() devtools::document() -devtools::check() devtools::document() devtools::check() devtools::document() -?setAs -devtools::check() +?size +?size +??size +?size +class(biasFactor) +size(frc) devtools::document() -devtools::check() devtools::document() devtools::check() +show(biasFactor) devtools::document() -devtools::check() devtools::document() devtools::check() +method(biasFactor) +methods('biasFactor') +methods(biasFactor) devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() devtools::check() -?method -??method -devtools::check() devtools::document() devtools::check() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() devtools::document() devtools::document() @@ -450,63 +62,451 @@ devtools::document() devtools::document() devtools::document() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() devtools::document() devtools::document() devtools::check() -devtools::document() -?size -?size -??size -?size -class(biasFactor) -size(frc) +devtools::build() +?applyBiasFactor +library(hyfo) +?applyBiasFactor devtools::document() devtools::document() -devtools::check() -show(biasFactor) +?setGeneric devtools::document() devtools::document() -devtools::check() -method(biasFactor) -methods('biasFactor') -methods(biasFactor) devtools::document() devtools::document() devtools::document() -devtools::check() devtools::document() -devtools::check() devtools::document() devtools::document() +devtools::check() devtools::document() +devtools::check() devtools::document() +devtools::check() +?resample +??resample devtools::document() +devtools::check() +install.packages('gridExtra') +data(testdl) +datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') +frc <- datalist[[1]] +hindcast <- datalist[[2]] +obs <- datalist[[3]] +frc_new <- biasCorrect(frc, hindcast, obs, input = 'TS') +frc_new <- biasCorrect(frc, hindcast, obs) +frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE) +frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add') +frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum') +TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4) +names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm') +plotTS(list = TSlist, plot = 'cum') +biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE) +frc_new33 <- applyBiasFactor(frc, biasFactor, obs = obs) +identical(frc_new3, frc_new33) +str(biasFactor) devtools::document() devtools::document() +devtools::check() devtools::document() +devtools::check() devtools::document() devtools::document() +devtools::check() +AAA <- data.frame( +# date column +Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1), +# value column +AAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE)) +BBB <- data.frame( +Date = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), +BBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE)) +CCC <- data.frame( +Date = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), +CCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) +list <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file. +list_com <- extractPeriod(list, commonPeriod = TRUE) +list_com1 <- extractPeriod(list, commonPeriod = TRUE) +identical(list_com, list_com1) +data(testdl) +datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') +datalist_com2 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') +identical(datalist_com1, datalist_com2) +dataframe <- list2Dataframe(datalist_com1) +dataframe_new <- extractPeriod(dataframe, month = c(1,2,3)) +dataframe_new1 <- extractPeriod(dataframe = dataframe, month = c(1,2,3)) +dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995) +#' Extract period from list or dataframe. +#' +#' Extract common period or certain period from a list of different dataframes of time series, or from a +#' dataframe. +#' NOTE: all the dates in the datalist should follow the format in ?as.Date{base}. +#' @param datalist A list of different dataframes of time series . +#' @param startDate A Date showing the start of the extract period, default as NULL, check details. +#' @param endDate A Date showing the end of the extract period, default as NULL, check details. +#' @param commonPeriod A boolean showing whether the common period is extracted. If chosen, startDate and endDate +#' should be NULL. +#' @param dataframe A dataframe with first column Date, the rest columns value. If your input is a +#' dataframe, not time series list, you can put \code{dataframe = yourdataframe}. And certain period will be +#' extracted. Note: if your input is a time series, that means all the columns share the same period of date. +#' @param year extract certain year in the entire time series. if you want to extract year 2000, set \code{year = 2000} +#' @param month extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, +#' set \code{month = c(1, 2)}. +#' @details +#' \strong{startDate and endDate} +#' +#' If startDate and endDate are assigned, then certain period between startDate and endDate will be returned, +#' for both datalist input and dataframe input. +#' +#' If startDate and endDate are NOT assigned, then, +#' +#' if input is a datalist, the startDate and endDate of the common period of different datalists will be assigned +#' to the startDate and endDate. +#' +#' if input is a dataframe, the startDate and endDate of the input dataframe will be assigned to the startDate +#' and endDate . Since different value columns share a common Date column in a dataframe input. +#' +#' \strong{year and month} +#' +#' For year crossing month input, hyfo will take from the year before. E.g. if \code{month = c(10, 11, 12, 1)}, +#' and \code{year = 1999}, hyfo will take month 10, 11 and 12 from year 1998, and month 1 from 1999.You DO NOT +#' have to set \code{year = 1998 : 1999}. +#' +#' Well, if you set \code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998, +#' then, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year. +#' +#' +#' +#' @return A list or a dataframe with all the time series inside containing the same period. +#' @examples +#' # Generate timeseries datalist. Each data frame consists of a Date and a value. +#' +#' AAA <- data.frame( +#' # date column +#' Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1), +#' # value column +#' AAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE)) +#' +#' BBB <- data.frame( +#' Date = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), +#' BBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE)) +#' +#' CCC <- data.frame( +#' Date = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), +#' CCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) +#' +#' list <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file. +#' +#' list_com <- extractPeriod(list, commonPeriod = TRUE) +#' +#' # list_com is the extracted datalist. +#' str(list_com) +#' +#' # If startDate and endDate is provided, the record between them will be extracted. +#' # make sure startDate is later than any startDate in each dataframe and endDate is +#' # earlier than any endDate in each dataframe. +#' +#' data(testdl) +#' datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') +#' +#' +#' dataframe <- list2Dataframe(datalist_com1) +#' # now we have a dataframe to extract certain months and years. +#' dataframe_new <- extractPeriod(dataframe = dataframe, month = c(1,2,3)) +#' dataframe_new <- extractPeriod(dataframe = dataframe, month = c(12,1,2), year = 1995) +#' +#' +#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' +#' @importFrom zoo as.Date +#' @references +#' +#' \itemize{ +#' \item Achim Zeileis and Gabor Grothendieck (2005). zoo: S3 Infrastructure for Regular and Irregular Time +#' Series. Journal of Statistical Software, 14(6), 1-27. URL http://www.jstatsoft.org/v14/i06/ +#' } +#' +#' @export +extractPeriod <- function(datalist, startDate = NULL, endDate = NULL, commonPeriod = FALSE, +dataframe = NULL, year = NULL, month = NULL) { +if (!is.null(dataframe)) { +dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year, +month = month) +} else { +if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) { +dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, +month = month) +} else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) { +Dates <- lapply(datalist, extractPeriod_getDate) +Dates <- do.call('rbind', Dates) +startDate <- as.Date(max(Dates[, 1])) +endDate <- as.Date(min(Dates[, 2])) +dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, +month = month) +} else { +stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE') +} +} +return(dataset) +} +extractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, month = NULL) { +# to check whether first column is a date format +if (!grepl('-|/', dataframe[1, 1])) { +stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} +and use as.Date to convert.') +} +dataframe[, 1] <- as.Date(dataframe[, 1]) +if (is.null(startDate)) startDate <- dataframe[1, 1] +if (is.null(endDate)) endDate <- tail(dataframe[, 1], 1) +startIndex <- which(dataframe[, 1] == startDate) +endIndex <- which(dataframe[, 1] == endDate) +if (length(startIndex) == 0 | length(endIndex) == 0) { +stop('startDate and endDate exceeds the date limits in dataframe. Check datalsit please.') +} +output <- dataframe[startIndex:endIndex, ] +if (!is.null(year)) { +Date <- as.POSIXlt(output[, 1]) +yea <- Date$year + 1900 +mon <- Date$mon + 1 +if (is.null(month) || !any(sort(month) != month)) { +DateIndex <- which(yea %in% year) +if (length(DateIndex) == 0) stop('No input years in the input ts, check your input.') +output <- output[DateIndex, ] +# if year crossing than sort(month) != month, in this case we need to +# take months from last year. +} else { +startIndex <- intersect(which(yea == year[1] - 1), which(mon == month[1]))[1] +endIndex <- tail(intersect(which(yea == tail(year, 1)), which(mon == tail(month, 1))), 1) +if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) { +stop('Cannot find input months and input years in the input time series.') +} +output <- output[startIndex:endIndex, ] +if (any(diff(year) != 1)) { +# if year is not continuous, like 1999, 2003, 2005, than we have to sift again. +Date <- as.POSIXlt(output[, 1]) +yea <- Date$year + 1900 +mon <- Date$mon + 1 +DateIndex <- unlist(sapply(year, function(x) { +startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1] +endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1) +index <- startIndex:endIndex +return(index) +})) +output <- output[DateIndex, ] +# cannot directly return output here, because sometimes, month can be incontinuous, +# we still need the next process to sift month. +} +} +} +if (!is.null(month)) { +Date <- as.POSIXlt(output[, 1]) +mon <- Date$mon + 1 +# %in% can deal with multiple equalities +DateIndex <- which(mon %in% month) +if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.') +output <- output[DateIndex, ] +} +return(output) +} +#' @importFrom utils tail +#' @references +#' +#' \itemize{ +#' \item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for +#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/. +#' } +#' +#' +extractPeriod_getDate <- function(dataset) { +if (!grepl('-|/', dataset[1, 1])) { +stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base}, +and use as.Date to convert.') +} +start <- as.Date(dataset[1, 1]) +end <- as.Date(tail(dataset[, 1], 1)) +return(c(start, end)) +} +dataframe_new1 <- extractPeriod(dataframe = dataframe, month = c(12,1,2), year = 1995) +identical(dataframe_new1, dataframe_new) devtools::document() devtools::document() +devtools::check() +data(tgridData) +getSpatialMap(tgridData, method = 'meanAnnual') +getSpatialMap(tgridData, method = 'winter') +getSpatialMap(tgridData, method = 'winter', catchment = testCat) +a1 <- getSpatialMap(tgridData, method = 'mean') +a2 <- getSpatialMap(tgridData, method = 'max') +a3 <- getSpatialMap(tgridData, method = 'winter') +a4 <- getSpatialMap(tgridData, method = 'summer') +a5 <- a2 - a1 +getSpatialMap_mat(a4) +a1 <- getSpatialMap(tgridData, method = 'summer', output = 'ggplot', name = 'a1') +a2 <- getSpatialMap(tgridData, method = 'winter', output = 'ggplot', name = 'a2') +# a3 <- getSpatialMap(tgridData, method = 'mean', output = 'ggplot', name = 'a3') +# a4 <- getSpatialMap(tgridData, method = 'max', output = 'ggplot', name = 'a4') +getSpatialMap_comb(a1, a2) devtools::document() +devtools::check() devtools::document() +devtools::check() +nc +filePath <- system.file("extdata", "tnc.nc", package = "hyfo") +varname <- getNcdfVar(filePath) +nc <- loadNcdf(filePath, varname) +hyfo <- nc +checkHyfo(hyfo) +str(hyfo) +data(testdl) +TS <- testdl[[2]] # Get daily data +TS +TS_new <- resample(TS, method = 'day2mon') +TS_new +hyfoData <- hyfo$Data +str(hyfoData) +memberIndex <- match('member', attributes(hyfoData)$dimensions) +memberIndex +hyfoData <- adjustDim(hyfoData, ref = c('lon', 'lat', 'time', 'member')) +str(hyfoData) +timeIndex <- match('time', attributes(hyfoData)$dimensions) +timeIndex +Date <- hyfo$Dates +str(Date) +Date <- as.POSIXlt(hyfo$Dates) +Date <- as.POSIXlt(hyfo$Dates$start) +mon <- Date$mon +mon +year <- Date$year +year +year <- Date$year + 1900 +year +mon <- Date$mon + 1 +mon +dimIndex <- 1:length(attributes(hyfoData)$dimensions) +dimIndex +dimArray <- 1:length(attributes(hyfoData)$dimensions) +dimArray[-timeIndex] +debug(resample) +TS_new <- resample(TS, method = 'day2mon') devtools::document() +devtools::check() devtools::document() devtools::document() +devtools::check() +debug(biasCorrect.TS) +frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE) +debug(resample.TS) +TS_new <- resample(TS, method = 'mon2day') +TS_new <- resample(TS, method = 'day2mon') +TS +data +?tapply +tapply(TS, INDEX = list(year, mon)) +str(year) +str(mon) +tapply(TS, INDEX = list(year, mon), FUN = mean) +TS +year +mon +a <- tapply(TS, INDEX = list(year, mon), FUN = mean) +list(year, mon) +str(list(year, mon)) +Date <- as.POSIXlt(TS[,1]) +year <- Date$year + 1900 +year +mon <- Date$mon + 1 +mon +a <- tapply(TS, INDEX = list(year, mon), FUN = mean) +str(list(year, mon)) +a <- tapply(TS, INDEX = list(year, mon), FUN = mean) +traceback +traceback() +aa <- aggregate(TS, by = list(year, mon), FUN = mean, na.rm = TRUE) +str(a) +str(aa) +aa <- aggregate(TS[,2], by = list(year, mon), FUN = mean, na.rm = TRUE) +str(aa) +a <- tapply(TS[, 2], INDEX = list(year, mon), FUN = mean) +a +a <- getMeanPreci(TS[, 2], yearIndex = year, monthIndex = mon) +a <- getMeanPreci(TS[, 2], yearIndex = year, monthIndex = mon, method = 'meanMonthly') +str(year) +str(mon) +str(TS) +str(TS[,2]) +year <- as.POSIXlt(TS[,1])$year + 1900 +year +mon <- as.POSIXlt(TS[,1])$mon + 1 +a <- getMeanPreci(TS[, 2], yearIndex = year, monthIndex = mon, method = 'meanMonthly') +a +a <- getMeanPreci(TS[, 2], yearIndex = year, monthIndex = mon, method = 'meanMonthly', fullR = T) +A +a +a <- aggregate(TS[, 2], list(year, mon)) +a +a <- aggregate(TS[, 2], list(year, mon), FUN = mean, na.rm = T) +a +str(a) +aa <- aggregate(TS[, 2], list(mon, year), FUN = mean, na.rm = T) +str(aa) +debug(resample.TS) +TS_new <- resample(TS, method = 'day2mon') +undebug(resample) +TS_new <- resample(TS, method = 'day2mon') +a <- aggregate(TS, by = list(mon, year), FUN = mean, na.rm = TRUE) +data +a +data == a [,3:4] +order(data$Date) +A <- aggregate(TS, by = list(year, mon), FUN = mean, na.rm = TRUE) +A +order(A$Date) +a$Date +aa <- aggregate(TS[, 2], list(mon, year), FUN = mean, na.rm = T) +aa +aa <- aggregate(TS[, 2], list(mon, year), FUN = mean, na.rm = T)[, 3] +aa +dim(TS) +aa <- aggregate(TS, list(mon, year), FUN = mean, na.rm = T)[, 3] +aa +?aggregate +str(hyfo) devtools::document() +devtools::check() +str(nc) +nc_new <- resample(nc, 'day2mon') devtools::document() +devtools::check() +nc_new <- resample(nc, 'day2mon') +debug(resample.list) +nc_new <- resample(nc, 'day2mon') +dimArray[-timeIndex] +apply(hyfoData, MARGIN = dimArray[-timeIndex], +function(x) aggregate(x, by = list(mon, year), FUN = mean, na.rm = TRUE))[, 3] +str(hyfoData) +apply(hyfoData, MARGIN = dimArray[-timeIndex], +function(x) aggregate(x, by = list(mon, year), FUN = mean, na.rm = TRUE)Q) devtools::document() devtools::check() +debug(resample.list) +nc_new <- resample(nc, 'day2mon') +nn +str(hyfoData) +str(hyfoData) +Date +Date +str(nc_new) +nc_new <- resample(nc, 'day2mon') +str(nc_new) +?resample devtools::build() diff --git a/.Rproj.user/D53FD3E6/pcs/files-pane.pper b/.Rproj.user/D53FD3E6/pcs/files-pane.pper index d81e1b1..9db65cf 100644 --- a/.Rproj.user/D53FD3E6/pcs/files-pane.pper +++ b/.Rproj.user/D53FD3E6/pcs/files-pane.pper @@ -1,5 +1,5 @@ { - "path" : "E:/1/R/hyfo/R", + "path" : "E:/1/R/hyfo", "sortOrder" : [ { "ascending" : true, diff --git a/.Rproj.user/D53FD3E6/pcs/source-pane.pper b/.Rproj.user/D53FD3E6/pcs/source-pane.pper index fa6ffa7..f53e558 100644 --- a/.Rproj.user/D53FD3E6/pcs/source-pane.pper +++ b/.Rproj.user/D53FD3E6/pcs/source-pane.pper @@ -1,3 +1,3 @@ { - "activeTab" : 7 + "activeTab" : 4 } \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 b/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 new file mode 100644 index 0000000..c705a2c --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 @@ -0,0 +1,17 @@ +{ + "contents" : "hyfo 1.3.0\n==========\nDate: 2015.11.2\n\n- new generic function biasCorrect, extractPeriod, resample added, \n No need to designate inputtype any more, R will detect automatically.\n- new user manual added.\n\n\n\nhyfo 1.2.9\n==========\nDate: 2015.10.30\n\n- new biasFactor S4 class added, to avoid set the input type every time.\n- operational bias correction has been changed to generic function.\n- news file added.\n\n\n\nhyfo 1.2.8\n==========\nDate: 2015.10.10\n\n- operational bias correction added, in normal function.", + "created" : 1446423165783.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4276368824", + "id" : "222F1822", + "lastKnownWriteTime" : 1446426050, + "path" : "E:/1/R/hyfo/NEWS", + "project_path" : "NEWS", + "properties" : { + }, + "relative_order" : 5, + "source_on_save" : false, + "type" : "text" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/2345FC5F b/.Rproj.user/D53FD3E6/sdb/per/t/2345FC5F deleted file mode 100644 index 268273c..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/2345FC5F +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "# Generated by roxygen2 (4.1.1): do not edit by hand\n\nexport(applyBiasFactor)\nexport(biasCorrect)\nexport(checkBind)\nexport(collectData)\nexport(collectData_csv_anarbe)\nexport(collectData_excel_anarbe)\nexport(collectData_txt_anarbe)\nexport(downscaleNcdf)\nexport(extractPeriod)\nexport(fillGap)\nexport(getAnnual)\nexport(getBiasFactor)\nexport(getEnsem_comb)\nexport(getFrcEnsem)\nexport(getHisEnsem)\nexport(getLMom)\nexport(getMoment)\nexport(getNcdfVar)\nexport(getPreciBar)\nexport(getPreciBar_comb)\nexport(getSpatialMap)\nexport(getSpatialMap_comb)\nexport(getSpatialMap_mat)\nexport(list2Dataframe)\nexport(loadNcdf)\nexport(monDay)\nexport(plotTS)\nexport(plotTS_comb)\nexport(shp2cat)\nexport(writeNcdf)\nexportClasses(biasFactor)\nimport(ggplot2)\nimport(maps)\nimport(maptools)\nimport(ncdf)\nimport(plyr)\nimport(rgdal)\nimport(rgeos)\nimportFrom(MASS,fitdistr)\nimportFrom(grDevices,rainbow)\nimportFrom(lmom,samlmu)\nimportFrom(methods,new)\nimportFrom(methods,setClass)\nimportFrom(methods,setMethod)\nimportFrom(moments,kurtosis)\nimportFrom(moments,skewness)\nimportFrom(reshape2,melt)\nimportFrom(stats,aggregate)\nimportFrom(stats,coef)\nimportFrom(stats,cor)\nimportFrom(stats,ecdf)\nimportFrom(stats,lm)\nimportFrom(stats,median)\nimportFrom(stats,na.omit)\nimportFrom(stats,pgamma)\nimportFrom(stats,qgamma)\nimportFrom(stats,quantile)\nimportFrom(stats,rgamma)\nimportFrom(stats,var)\nimportFrom(utils,choose.dir)\nimportFrom(utils,combn)\nimportFrom(utils,packageDescription)\nimportFrom(utils,read.csv)\nimportFrom(utils,read.fwf)\nimportFrom(utils,tail)\nimportFrom(zoo,as.Date)\n", - "created" : 1446242206157.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2467207366", - "id" : "2345FC5F", - "lastKnownWriteTime" : 1446409855, - "path" : "E:/1/R/hyfo/NAMESPACE", - "project_path" : "NAMESPACE", - "properties" : { - }, - "relative_order" : 10, - "source_on_save" : false, - "type" : "r_namespace" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/243E5DD6 b/.Rproj.user/D53FD3E6/sdb/per/t/243E5DD6 new file mode 100644 index 0000000..57f1687 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/243E5DD6 @@ -0,0 +1,17 @@ +{ + "contents" : "#' plot time series, with marks on missing value.\n#' \n#' @param ... input time series.\n#' @param type A string representing the type of the time series, e.g. 'line' or 'bar'.\n#' @param output A string showing which type of output you want. Default is \"data\", if \"ggplot\", the \n#' data that can be directly plotted by ggplot2 will be returned, which is easier for you to make series\n#' plots afterwards. \n#' @param name If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\n#' different outputs in the later multiplot using \\code{plotTS_comb}.\n#' @param plot representing the plot type, there are two types, \"norm\" and \"cum\", \"norm\" gives an normal\n#' plot, and \"cum\" gives a cumulative plot. Default is \"norm\".\n#' @param x label for x axis.\n#' @param y label for y axis.\n#' @param title plot title.\n#' @param list If your input is a list of time series, then use \\code{list = your time sereis list}\n#' @return A plot of the input time series.\n#' @details \n#' If your input has more than one time series, the program will only plot the common period of \n#' different time series.\n#' @examples\n#' plotTS(testdl[[1]])\n#' plotTS(testdl[[1]], x = 'xxx', y = 'yyy', title = 'aaa')\n#' \n#' # If input is a datalist\n#' plotTS(list = testdl)\n#' \n#' # Or if you want to input time series one by one\n#' # If plot = 'cum' then cumulative curve will be plotted.\n#' plotTS(testdl[[1]], testdl[[2]], plot = 'cum')\n#' \n#' # You can also directly plot multicolumn dataframe\n#' dataframe <- list2Dataframe(extractPeriod(testdl, commonPeriod = TRUE))\n#' plotTS(dataframe, plot = 'cum')\n#' \n#' # Sometimes you may want to process the dataframe and compare with the original one\n#' dataframe1 <- dataframe\n#' dataframe1[, 2:4] <- dataframe1[, 2:4] + 3\n#' plotTS(dataframe, dataframe1, plot = 'cum')\n#' # But note, if your input is a multi column dataframe, it's better to plot one using plotTS,\n#' # and compare them using plotTS_comb. If all data are in one plot, there might be too messy.\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' }\n#' \n#' @import ggplot2\n#' @importFrom reshape2 melt\n#' @export\nplotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, x = NULL, \n y = NULL, title = NULL, list = NULL) {\n ## arrange input TS or TS list.\n if (is.null(list)) {\n list <- list(...)\n if (!class(list[[1]]) == 'data.frame') {\n warning('Your input is probably a list, but you forget to add \"list = \" before it.\n Try again, or check help for more information.')\n }\n# Following part is for plot different time series with different date, but too complicated\n# using ggplot. and normal use doesn't need such process. So save it as backup.\n# listNames <- names(list)\n# # in order to be used later to differentiate lists, there should be a name for each element.\n# # Then assign the name column to each list element.\n# if (is.null(listNames)) listNames <- 1:length(list)\n# \n# giveName <- function(x, y) {\n# colnames(x) <- NULL\n# x$TSname <- rep(listNames[y], nrow(x))\n# return(x)\n# }\n# list1 <- mapply(FUN = giveName, x = list, y = 1:length(list), SIMPLIFY = FALSE)\n# \n# checkBind(list1, 'rbind')\n# \n# TS <- do.call('rbind', list1)\n }\n \n list_common <- extractPeriod(list, commonPeriod = TRUE)\n TS <- list2Dataframe(list_common)\n \n if (!is.null(names(list)) & (ncol(TS) - 1) == length(list)) colnames(TS)[2:(length(list) + 1)] <- names(list)\n \n # Check input, only check the first column and first row.\n if (!grepl('-|/', TS[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.')\n }\n \n TS[, 1] <- as.Date(TS[, 1])\n colnames(TS)[1] <- 'Date'\n \n # first column's name may not be Date, so change its name to Date\n \n data_plot <- melt(TS, id.var = 'Date')\n NAIndex <- which(is.na(data_plot$value))\n \n # assign 0 to NA values\n if (plot == 'norm') {\n data_plot$value[NAIndex] <- 0\n lineSize <- 0.7\n } else if (plot == 'cum') {\n TS[is.na(TS)] <- 0\n cum <- cbind(data.frame(Date = TS[, 1]), cumsum(TS[2:ncol(TS)]))\n \n data_plot <- melt(cum, id.var = 'Date')\n lineSize <- 1\n }\n \n \n # Assigning x, y and title\n if (is.null(x)) x <- colnames(TS)[1]\n # y aixs cannot decide if it's a multi column dataframe\n #if (is.null(y)) y <- names[2]\n \n theme_set(theme_bw())\n mainLayer <- with(data_plot, {\n ggplot(data = data_plot) +\n # It's always better to use colname to refer to\n aes(x = Date, y = value, color = variable) +\n theme(plot.title = element_text(size = rel(1.8), face = 'bold'),\n axis.text.x = element_text(size = rel(1.8)),\n axis.text.y = element_text(size = rel(1.8)),\n axis.title.x = element_text(size = rel(1.8)),\n axis.title.y = element_text(size = rel(1.8))) +\n labs(x = x, y = y, title = title)\n })\n \n \n# color <- 'dodgerblue4'\n if (type == 'bar') {\n secondLayer <- with(data_plot, {\n geom_bar(stat = 'identity')\n })\n } else if (type == 'line') {\n secondLayer <- with(data_plot, {\n geom_line(size = lineSize)\n })\n } else {\n stop(\"No such plot type.\")\n }\n \n \n missingVLayer <- with(TS, {\n geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black')\n })\n \n plotLayer <- mainLayer + secondLayer + missingVLayer\n \n print(plotLayer) \n \n if (output == 'ggplot') {\n if (is.null(name)) stop('\"name\" argument not found, \n If you choose \"ggplot\" as output, please assign a name.')\n \n data_plot$name <- rep(name, nrow(data_plot)) \n data_plot$nav <- rep(0, nrow(data_plot))\n data_plot$nav[NAIndex] <- 1\n return(data_plot)\n }\n}\n\n\n\n\n#' Combine time seires plot together\n#' @param ... different time series plots generated by \\code{plotTS(, output = 'ggplot')}, refer to details.\n#' @details\n#' ..., representing different ouput file generated by \\code{plotTS(, output = 'ggplot'), name = yourname}, \n#' different names must be assigned when generating different output.\n#' \n#' e.g.\n#' a1, a2, a3 are different files generated by \\code{plotTS(, output = 'ggplot'), name = yourname}, you can\n#' set \\code{plotTS(a1,a2,a3)} or \\code{plotTS(list = list(a1,a2,a3))}\n#' \n#' @param nrow A number showing the number of rows.\n#' @param type A string showing 'line' or 'bar'.\n#' @param list If input is a list containing different ggplot data, use l\\code{list = inputlist}.\n#' @param x A string of x axis name.\n#' @param y A string of y axis name.\n#' @param title A string of the title.\n#' @param output A boolean, if chosen TRUE, the output will be given.\n#' NOTE: yOU HAVE TO PUT A \\code{list = }, before your list.\n#' @return A combined time series plot.\n#' @examples\n#' a1 <- plotTS(testdl[[1]], output = 'ggplot', name = 1)\n#' a2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2)\n#' \n#' plotTS_comb(a1, a2)\n#' plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' }\n#' @export\n#' @import ggplot2\nplotTS_comb <- function(..., nrow = 1, type = 'line', list = NULL, x = 'Date', y = '', title = '', \n output = FALSE){\n # In ploting the time series, since the data comes from outside of hyfo, \n # It's more complicated, since they don't always have the same\n # column name, if not, there is not possible to do rbind.\n # So we need to first save the name, and rbind, and put back the name.\n \n if (!is.null(list)) {\n checkBind(list, 'rbind')\n data_ggplot <- do.call('rbind', list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n data_ggplot <- do.call('rbind', bars)\n }\n \n if (!class(data_ggplot) == 'data.frame') {\n warning('Your input is probably a list, but you forget to add \"list = \" before it.\n Try again, or check help for more information.')\n } else if (is.null(data_ggplot$name)) {\n stop('No \"name\" column in the input data, check the arguments in getPreciBar(), if \n output = \"ggplot\" is assigned, more info please check ?getPreciBar.')\n }\n\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n # It's always better to use colname to refer to\n aes(x = Date, y = value, color = variable) +\n theme(plot.title = element_text(size = rel(1.8), face = 'bold'),\n axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.8)),\n axis.text.y = element_text(size = rel(1.8)),\n axis.title.x = element_text(size = rel(1.8)),\n axis.title.y = element_text(size = rel(1.8))) +\n geom_point(data = data_ggplot[data_ggplot$nav == 1, ], size = 2, shape = 4, color = 'red') +\n facet_wrap( ~ name, nrow = nrow) +\n labs(x = x, y = y, title = title)\n \n })\n \n \n if (type == 'bar') {\n secondLayer <- with(data_ggplot, {\n geom_bar(stat = 'identity', size = 1)\n })\n } else if (type == 'line') {\n secondLayer <- with(data_ggplot, {\n geom_line(size = 1)\n })\n } else {\n stop(\"No such plot type.\")\n }\n \n print(mainLayer + secondLayer)\n \n if (output == TRUE) return(data_ggplot)\n}\n\n\n\n\n#' get L moment analysis of the input distribution\n#' \n#' @param dis A distribution, for hydrology usually a time series with only data column without time.\n#' @return The mean, L-variation, L-skewness and L-kurtosis of the input distribution\n#' @examples\n#' dis <- seq(1, 100)\n#' getLMom(dis)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @references \n#' \n#' \\itemize{\n#' \\item J. R. M. Hosking (2015). L-moments. R package, version 2.5. URL:\n#' http://CRAN.R-project.org/package=lmom.\n#' }\n#' \n#' \n#' @importFrom lmom samlmu\n#' \ngetLMom <- function(dis){\n \n LMom <- samlmu(dis, nmom = 4, ratios = TRUE)\n \n mean <- LMom[1]\n LCV <- LMom[2]/LMom[1]\n Lskew <- LMom[3]\n Lkur <- LMom[4]\n \n output <- data.frame(mean = mean, Lcv = LCV, Lskew = Lskew, Lkur = Lkur)\n return(output)\n}\n\n#' get moment analysis of the input distribution\n#' \n#' @param dis A distribution, for hydrology usually a time series with only data column without time.\n#' @return The mean, variation, skewness and kurtosis of the input distribution\n#' @examples\n#' dis <- seq(1, 100)\n#' getMoment(dis)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @references \n#' \n#' \\itemize{\n#' \\item Lukasz Komsta and Frederick Novomestky (2015). moments: Moments, cumulants, skewness, kurtosis and\n#' related tests. R package version 0.14. http://CRAN.R-project.org/package=moments\n#' \n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \n#' @importFrom moments skewness kurtosis\n#' @importFrom stats var\ngetMoment <- function(dis) {\n mean <- mean(dis, na.rm = TRUE)\n variance <- var(dis, na.rm = TRUE)\n skewness <- skewness(dis, na.rm = TRUE)\n kurtosis <- kurtosis(dis, na.rm = TRUE)\n \n output <- data.frame(mean=mean, Variance = variance, Skewness = skewness, Kurtosis = kurtosis)\n \n return(output)\n}\n", + "created" : 1446423452048.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4083939771", + "id" : "243E5DD6", + "lastKnownWriteTime" : 1443830746, + "path" : "E:/1/R/hyfo/R/analyzeTS.R", + "project_path" : "R/analyzeTS.R", + "properties" : { + }, + "relative_order" : 7, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/2F56DEAB b/.Rproj.user/D53FD3E6/sdb/per/t/2F56DEAB deleted file mode 100644 index 67e2ddc..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/2F56DEAB +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "\n\n#' Biascorrect the input timeseries or hyfo dataset\n#' \n#' Biascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\n#' observation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\n#' will be returned. If the input is a time series, first column should be date column and rest columns should be \n#' the value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\n#' file with the same format.\n#' \n#' @param frc a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the forecast to be calibrated.\n#' @param hindcast a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the hindcast data. This data will be used in the calibration of the forecast, so it's better to have the same date period as\n#' observation data. Check details for more information.\n#' @param obs a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data.\n#' @param method bias correct method, including 'delta', 'scaling'..., default is 'scaling'\n#' @param scaleType only when the method \"scaling\" is chosen, scaleType will be available. Two different types\n#' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \n#' details. Default scaleType is 'multi'.\n#' @param input If input is a time series, \\code{input = 'TS'} needs to be assigned, or hyfo will take it as \n#' an hyfo output grid file. Default is hyfo output grid file, where in most of the cases we prefer.\n#' @param preci If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\n#' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \n#' Default is FALSE, refer to details.\n#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).\n#' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\n#' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.\n#' @details \n#' \n#' Since climate forecast is based on global condition, when downscaling to different regions, it may include\n#' some bias, biascorrection is used then to fix the bias.\n#' \n#' \\strong{Hindcast}\n#' \n#' In order to bias correct, we need to pick up some data from the forecast to train with\n#' the observation, which is called hindcast in this function. Using hindcast and observation, \n#' the program can analyze the bias and correct the bias in the forecast. \n#' \n#' Hindcast should have \\strong{EVERY} attributes that forecast has.\n#' \n#' Hindcast is also called re-forecast, is the forecast of the past. E.g. you have a forecast from year 2000-2010, assuming now you are in 2005. So from 2000-2005, this period\n#' is the hindcast period, and 2005-2010, this period is the forecast period.\n#'\n#' Hindcast can be the same as forecast, i.e., you can use forecast itself as hindcast to train the bias correction.\n#'\n#'\n#' \\strong{How it works}\n#' \n#' Forecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \n#' forecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \n#' data (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n#' \n#' E.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \n#' period (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\n#' The program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \n#' modification to the forecast data.\n#' \n#' The more categorized input, the more accurate result you will get. E.g., if you want to \n#' bias correct a forecast for winter season. So you'd better to extract all the winter period\n#' in the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n#' \n#' \\strong{method}\n#' \n#' Different methods used in the bias correction. Among which, delta, scaling can be applied\n#' to different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\n#' it needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\n#' designed for rainfall data, so \\code{preci = TRUE} needs to be set.\n#' \n#' \\strong{delta}\n#' \n#' This method consists on adding to the observations the mean change signal (delta method). \n#' This method is applicable to any kind of variable but it is preferable to avoid it for bounded variables\n#' (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained \n#' (e.g. negative wind speeds...)\n#' \n#' \\strong{scaling}\n#' \n#' This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \n#' between the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\n#' correction is defined by parameter \\code{scaling.type} (default is \\code{additive}).\n#' The additive version is preferably applicable to unbounded variables (e.g. temperature) \n#' and the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n#' \n#' \\strong{eqm}\n#' \n#' Empirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \n#' by adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \n#' This method is applicable to any kind of variable.\n#' \n#' It can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\n#' that the extreme value is an error.\n#' \n#' \\strong{gqm}\n#' \n#' Gamma Quantile Mapping. This method is described in Piani et al. 2010 and is applicable only to precipitation. It is based on the initial assumption that both observed\n#' and simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \n#' that uses the theorical instead of the empirical distribution. \n#' \n#' It can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\n#' Better have a long period of training, and the if the forecast system is relatively stable.\n#' \n#' \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' newFrc <- biasCorrect(nc, nc, tgridData) \n#' newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \n#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \n#' preci = TRUE) \n#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is scaling, with 'multi' scaleType\n#' frc_new <- biasCorrect(frc, hindcast, obs, input = 'TS')\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program that it is a precipitation data.\n#' \n#' frc_new1 <- biasCorrect(frc, hindcast, obs, input = 'TS', preci = TRUE)\n#' \n#' # You can use other scaling methods to biascorrect.\n#' frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add', input = 'TS')\n#' \n#' # \n#' frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE)\n#' frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\n\nbiasCorrect <- function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', input = 'hyfo', \n preci = FALSE, prThreshold = 0, extrapolate = 'no'){\n \n if (input == 'TS') {\n # First check if the first column is Date\n if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1]) | !grepl('-|/', frc[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # if condition only accepts one condition, for list comparison, there are a lot of conditions, better\n # further process it, like using any.\n if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) {\n warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in \n the calibration.')\n }\n n <- ncol(frc)\n \n # For every column, it's biascorrected respectively.\n frc_data <- lapply(2:n, function(x) biasCorrect_core(frc[, x], hindcast[, x], obs[, 2], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate))\n frc_data <- do.call('cbind', frc_data)\n rownames(frc_data) <- NULL\n \n names <- colnames(frc)\n frc_new <- data.frame(frc[, 1], frc_data)\n colnames(frc_new) <- names\n \n } else if (input == 'hyfo') {\n ## Check if the data is a hyfo grid data.\n checkHyfo(frc, hindcast, obs)\n \n hindcastData <- hindcast$Data\n obsData <- obs$Data\n frcData <- frc$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n frcDim <- attributes(frcData)$dimensions\n \n ## ajust the dimension into general dimension order.\n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time'))\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n checkDimLength(frcData, hindcastData, obsData, dim = c('lon', 'lat'))\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n # check if frcData and hindcastData has the same dimension and length.\n checkDimLength(frcData, hindcastData, dim = 'member')\n \n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n# for (member in 1:dim(frcData)[4]) {\n# totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n# dim = c(dim(frcData)[1], dim(frcData)[2], \n# dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n# }\n \n \n for (member in 1:dim(frcData)[4]) {\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,, member] <- biasCorrect_core(frcData[lon, lat,,member], hindcastData[lon, lat,, member], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n } else {\n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time'))\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,] <- biasCorrect_core(frcData[lon, lat,], hindcastData[lon, lat,], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n \n frcData <- adjustDim(frcData, ref = frcDim)\n frc$Data <- frcData\n frc$biasCorrected_by <- method\n frc_new <- frc\n }\n \n return(frc_new)\n}\n\n\n\n\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats ecdf quantile pgamma qgamma rgamma\n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' \n#' \n# this is only used to calculate the value column, \nbiasCorrect_core <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate){\n # If the variable is precipitation, some further process needs to be added.\n # The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration.\n \n \n # check if frc, hindcast or obs are all na values\n if (!any(!is.na(obs)) | !any(!is.na(frc)) | !any(!is.na(hindcast))) {\n warning('In this cell, frc, hindcast or obs data is missing. No biasCorrection for this cell.')\n return(NA)\n }\n \n \n if (preci == TRUE) {\n preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold)\n hindcast <- preprocessHindcast_res[[1]]\n minHindcastPreci <- preprocessHindcast_res[[2]]\n }\n\n # default is the simplest method in biascorrection, just do simple addition and subtraction.\n if (method == 'delta') {\n if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.')\n # comes from downscaleR biascorrection method\n frcMean <- mean(frc, na.rm = TRUE)\n hindcastMean <- mean(hindcast, na.rm = TRUE)\n frc <- obs - hindcastMean + frcMean\n \n } else if (method == 'scaling') {\n obsMean <- mean(obs, na.rm = TRUE)\n hindcastMean <- mean(hindcast, na.rm = TRUE)\n \n if (scaleType == 'multi') {\n frc <- frc / hindcastMean * obsMean\n \n } else if (scaleType == 'add') {\n frc <- frc - hindcastMean + obsMean\n }\n \n \n } else if (method == 'eqm') {\n if (preci == FALSE) {\n frc <- biasCorrect_core_eqm_nonPreci(frc, hindcast, obs, extrapolate, prThreshold)\n } else {\n frc <- biasCorrect_core_eqm_preci(frc, hindcast, obs, minHindcastPreci, extrapolate,\n prThreshold)\n }\n \n } else if (method == 'gqm') {\n if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T')\n frc <- biasCorrect_core_gqm(frc, hindcast, obs, prThreshold, minHindcastPreci)\n }\n \n \n return(frc)\n}\n\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats rgamma\npreprocessHindcast <- function(hindcast, obs, prThreshold) {\n lowerIndex <- length(which(obs < prThreshold))\n \n # In the original function, this minHindcastPreci is Pth[,i,j] in downscaleR, and it is originally\n # set to NA, which is not so appropriate for all the precipitations.\n # In the original function, there are only two conditions, 1. all the obs less than threshold\n # 2. there are some obs less than threshold. \n # While, if we set threshold to 0, there could be a 3rd condition, all the obs no less than threshold.\n # Here I set this situation, firstly set minHindcastPreci to the min of the hindcast. Because in future\n # use, 'eqm' method is going to use this value.\n \n # The problem above has been solved.\n \n \n if (lowerIndex >= 0 & lowerIndex < length(obs)) {\n index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix\n hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA)\n # minHindcastPreci is the min preci over threshold FOR ***HINDCAST***\n # But use obs to get the lowerIndex, so obs_sorted[lowerIndex + 1] > prThreshold, but\n # hindcast_sorted[lowerIndex + 1] may greater than or smaller than ptThreshold\n \n \n # It would be better to understand if you draw two lines: hindcast_sorted and obs_sorted\n # with y = prThreshold, you will find the difference of the two.\n \n # In principle, the value under the threshold needs to be replaced by some other reasonable value.\n # simplest way \n minHindcastPreci <- hindcast_sorted[lowerIndex + 1]\n \n # Also here if minHindcastPreci is 0 and prThreshold is 0, will cause problem, bettter set \n # I set it prThreshold != 0 \n if (minHindcastPreci <= prThreshold & prThreshold != 0) {\n obs_sorted <- sort(obs, decreasing = FALSE, na.last = NA)\n \n # higherIndex is based on hindcast\n higherIndex <- which(hindcast_sorted > prThreshold & !is.na(hindcast_sorted))\n \n if (length(higherIndex) == 0) {\n higherIndex <- max(which(!is.na(hindcast_sorted)))\n higherIndex <- min(length(obs_sorted), higherIndex)\n } else {\n higherIndex <- min(higherIndex)\n }\n # here I don't know why choose 6.\n # Written # [Shape parameter Scale parameter] in original package\n # according to the reference and gamma distribution, at least 6 values needed to fit gamma\n # distribution.\n if (length(unique(obs_sorted[(lowerIndex + 1):higherIndex])) < 6) {\n hindcast_sorted[(lowerIndex + 1):higherIndex] <- mean(obs_sorted[(lowerIndex + 1):higherIndex], \n na.rm = TRUE)\n } else {\n obsGamma <- fitdistr(obs_sorted[(lowerIndex + 1):higherIndex], \"gamma\")\n \n # this is to replace the original hindcast value between lowerIndex and higherIndex with \n # some value taken from gamma distribution just generated.\n hindcast_sorted[(lowerIndex + 1):higherIndex] <- rgamma(higherIndex - lowerIndex, obsGamma$estimate[1], \n rate = obsGamma$estimate[2])\n }\n hindcast_sorted <- sort(hindcast_sorted, decreasing = FALSE, na.last = NA)\n \n } \n minIndex <- min(lowerIndex, length(hindcast))\n hindcast_sorted[1:minIndex] <- 0\n hindcast[index] <- hindcast_sorted\n \n } else if (lowerIndex == length(obs)) {\n \n index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix\n hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA)\n minHindcastPreci <- hindcast_sorted[lowerIndex]\n \n # here is to compare with hindcast, not obs\n minIndex <- min(lowerIndex, length(hindcast))\n hindcast_sorted[1:minIndex] <- 0\n hindcast[index] <- hindcast_sorted\n \n }\n return(list(hindcast, minHindcastPreci))\n}\n\nbiasCorrect_core_eqm_nonPreci <- function(frc, hindcast, obs, extrapolate, prThreshold) {\n ecdfHindcast <- ecdf(hindcast)\n \n if (extrapolate == 'constant') {\n higherIndex <- which(frc > max(hindcast, na.rm = TRUE))\n lowerIndex <- which(frc < min(hindcast, na.rm = TRUE))\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex)\n \n # In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards\n # So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will\n # return 1:length(sim)\n \n if (length(higherIndex) > 0) {\n maxHindcast <- max(hindcast, na.rm = TRUE)\n dif <- maxHindcast - max(obs, na.rm = TRUE)\n frc[higherIndex] <- frc[higherIndex] - dif\n }\n \n if (length(lowerIndex) > 0) {\n minHindcast <- min(hindcast, na.rm = TRUE)\n dif <- minHindcast - min(obs, nna.rm = TRUE)\n frc[lowerIndex] <- frc[lowerIndex] - dif\n }\n \n frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), \n na.rm = TRUE, type = 4)\n } else {\n frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4)\n }\n return(frc)\n}\n\nbiasCorrect_core_eqm_preci <- function(frc, hindcast, obs, minHindcastPreci, extrapolate, \n prThreshold) {\n \n # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be\n # always hindcast > minHindcastPreci exists.\n # Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci\n if (length(which(hindcast > minHindcastPreci)) > 0) {\n \n ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci])\n \n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n \n # drizzle is to see whether there are some precipitation between the min frc (over threshold) and \n # min hindcast (over threshold).\n drizzle <- which(frc > minHindcastPreci & frc <= min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) \n & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n \n if (extrapolate == 'constant') {\n \n # This higher and lower index mean the extrapolation part\n higherIndex <- which(frc[rain] > max(hindcast, na.rm = TRUE))\n lowerIndex <- which(frc[rain] < min(hindcast, na.rm = TRUE))\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex)\n \n if (length(higherIndex) > 0) {\n maxHindcast <- max(hindcast, na.rm = TRUE)\n dif <- maxHindcast - max(obs, na.rm = TRUE)\n frc[rain[higherIndex]] <- frc[higherIndex] - dif\n }\n \n if (length(lowerIndex) > 0) {\n minHindcast <- min(hindcast, na.rm = TRUE)\n dif <- minHindcast - min(obs, nna.rm = TRUE)\n frc[rain[lowerIndex]] <- frc[lowerIndex] - dif\n }\n \n # Here the original function doesn't accout for the situation that extraploateIndex is 0\n # if it is 0, rain[-extraploateIndex] would be nothing\n \n # Above has been solved by using setdiff.\n frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), \n na.rm = TRUE, type = 4)\n } else {\n \n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4)\n }\n }\n if (length(drizzle) > 0){\n \n # drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to \n # biascorrect the original drizzle part\n frc[drizzle] <- quantile(frc[which(frc > min(hindcast[which(hindcast > minHindcastPreci)], na.rm = TRUE) & \n !is.na(frc))], probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, \n type = 4)\n }\n \n frc[noRain] <- 0\n \n } else {\n # in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci\n # And frc distribution is used then.\n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), \n na.rm = TRUE, type = 4)\n }\n frc[noRain]<-0\n }\n return(frc)\n}\n\nbiasCorrect_core_gqm <- function(frc, hindcast, obs, prThreshold, minHindcastPreci) {\n if (any(obs > prThreshold)) {\n \n ind <- which(obs > prThreshold & !is.na(obs))\n obsGamma <- fitdistr(obs[ind],\"gamma\")\n ind <- which(hindcast > 0 & !is.na(hindcast))\n hindcastGamma <- fitdistr(hindcast[ind],\"gamma\")\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n \n probF <- pgamma(frc[rain], hindcastGamma$estimate[1], rate = hindcastGamma$estimate[2])\n frc[rain] <- qgamma(probF,obsGamma$estimate[1], rate = obsGamma$estimate[2])\n frc[noRain] <- 0\n } else {\n warning('All the observations of this cell(station) are lower than the threshold, \n no bias correction applied.')\n }\n return(frc)\n}\n", - "created" : 1443835712399.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2759143513", - "id" : "2F56DEAB", - "lastKnownWriteTime" : 1446074483, - "path" : "E:/1/R/hyfo/R/biasCorrect.R", - "project_path" : "R/biasCorrect.R", - "properties" : { - }, - "relative_order" : 2, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/45E75BB3 b/.Rproj.user/D53FD3E6/sdb/per/t/45E75BB3 new file mode 100644 index 0000000..ba2279d --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/45E75BB3 @@ -0,0 +1,17 @@ +{ + "contents" : "\n\n\n\n#' Get bias factor for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param hindcast a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the hindcast data. This data will be used in the calibration of the forecast, so it's better to have the same date period as\n#' observation data. Check details for more information.\n#' @param obs a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data.\n#' @param method bias correct method, including 'delta', 'scaling'...,default method is 'scaling'.\n#' @param scaleType only when the method \"scaling\" is chosen, scaleType will be available. Two different types\n#' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method, default is 'multi'. More info check \n#' details.\n#' @param preci If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\n#' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \n#' Default is FALSE, refer to details.\n#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).\n#' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\n#' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.\n#' \n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction.\n#' \\code{\\link{applyBiasFactor}}, for the second part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs)\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @importFrom methods setMethod\n#' @export\n#' \n#' \n# debug by trace(\"getBiasFactor\", browser, exit=browser, signature = c(\"list\", \"list\"))\nsetGeneric('getBiasFactor', function(hindcast, obs, method = 'scaling', scaleType = 'multi', \n preci = FALSE, prThreshold = 0, extrapolate = 'no') {\n standardGeneric('getBiasFactor')\n})\n\n#' @describeIn getBiasFactor\nsetMethod('getBiasFactor', signature('data.frame', 'data.frame'), \n function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n result <- getBiasFactor.TS(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate)\n return(result)\n })\n\n\n# This is for the grid file from downscaleR\n#' @describeIn getBiasFactor\n#' @importFrom methods new\nsetMethod('getBiasFactor', signature('list', 'list'), \n function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n result <- getBiasFactor.list(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate)\n return(result)\n })\n\n\n\n\n#' Apply bias factor to different forecasts for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param frc a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the frc data. Check details for more information.\n#' @param biasFactor a file containing all the information of the calibration, will be\n#' applied to different forecasts.\n#' @param obs for some methods, observation input is necessary. obs is a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data. Default value is NULL.\n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction. \n#' \\code{\\link{getBiasFactor}}, for the first part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs)\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\nsetGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) {\n standardGeneric('applyBiasFactor')\n})\n\n#' @describeIn applyBiasFactor\n#' @importFrom methods setMethod\nsetMethod('applyBiasFactor', signature('data.frame', 'biasFactor'), \n function(frc, biasFactor, obs) {\n result <- applyBiasFactor.TS(frc, biasFactor, obs)\n return(result)\n })\n \n#' @describeIn applyBiasFactor\n#' @importFrom methods setMethod\nsetMethod('applyBiasFactor', signature('list', 'biasFactor.hyfo'), \n function(frc, biasFactor, obs) {\n result <- applyBiasFactor.list(frc, biasFactor, obs)\n return(result)\n })\n\n\n### generic functions\ngetBiasFactor.TS <- function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n \n if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n \n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # if condition only accepts one condition, for list comparison, there are a lot of conditions, better\n # further process it, like using any.\n if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) {\n warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in \n the calibration.')\n }\n n <- ncol(hindcast)\n \n # For every column, it's biascorrected respectively.\n biasFactor <- lapply(2:n, function(x) getBiasFactor_core(hindcast[, x], obs[, 2], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate))\n if (n - 1 > 1) {\n biasFactor_all <- new('biasFactor.multiMember', biasFactor = biasFactor, memberDim = n - 1,\n method = method, preci = preci, prThreshold = prThreshold, scaleType = scaleType, \n extrapolate = extrapolate)\n \n } else {\n biasFactor_all <- new('biasFactor', biasFactor = biasFactor, method = method, \n preci = preci, prThreshold = prThreshold, scaleType = scaleType, \n extrapolate = extrapolate)\n }\n \n return(biasFactor_all)\n}\n\ngetBiasFactor.list <- function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n \n ## Check if the data is a hyfo grid data.\n checkHyfo(hindcast, obs)\n \n hindcastData <- hindcast$Data\n obsData <- obs$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n hindcastDim <- attributes(hindcastData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n checkDimLength(hindcastData, obsData, dim = c('lon', 'lat'))\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(hindcastData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n biasFactor_all <- vector(mode = \"list\", length = dim(hindcastData)[4])\n for (member in 1:dim(hindcastData)[4]) {\n biasFactor_all[[member]] <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[member]][[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2])\n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[member]][[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,, member], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n \n biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci,\n prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, \n lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')),\n memberDim = calcuDim(hindcastData, dim = 'member'))\n } else {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time'))\n \n biasFactor_all <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) \n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci,\n prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, \n lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')))\n \n }\n \n return(biasFactor)\n}\n\napplyBiasFactor.TS <- function(frc, biasFactor, obs) {\n method <- biasFactor@method\n preci <- biasFactor@preci\n prThreshold <- biasFactor@prThreshold\n scaleType <- biasFactor@scaleType\n extrapolate <- biasFactor@extrapolate\n memberDim <- biasFactor@memberDim\n biasFactor <- biasFactor@biasFactor\n \n \n # First check if the first column is Date\n if (!grepl('-|/', frc[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # In this case more than one value columns exist in the dataset, both frc and hindcast.\n \n n <- ncol(frc)\n if (n-1 != memberDim) stop('frc and biasFactor have different members.')\n \n \n # For every column, it's biascorrected respectively.\n frc_data <- lapply(2:n, function(x) applyBiasFactor_core(frc[, x], biasFactor = biasFactor[[x - 1]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obs[, 2]))\n frc_data <- do.call('cbind', frc_data)\n rownames(frc_data) <- NULL\n \n names <- colnames(frc)\n frc_new <- data.frame(frc[, 1], frc_data)\n colnames(frc_new) <- names\n \n return(frc_new)\n \n}\n\napplyBiasFactor.list <- function(frc, biasFactor, obs) {\n method <- biasFactor@method\n preci <- biasFactor@preci\n prThreshold <- biasFactor@prThreshold\n scaleType <- biasFactor@scaleType\n extrapolate <- biasFactor@extrapolate\n lonLatDim <- biasFactor@lonLatDim\n memberDim <- biasFactor@memberDim\n biasFactor <- biasFactor@biasFactor\n \n ## Check if the data is a hyfo grid data.\n checkHyfo(frc)\n \n \n obsData <- obs$Data\n frcData <- frc$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n frcDim <- attributes(frcData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n if (!identical(calcuDim(frcData, dim = c('lon', 'lat')), lonLatDim)) {\n stop('frc data has different lon and lat from hindcast data.')\n }\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n # check if frcData and hindcastData has the same dimension and length.\n if (calcuDim(frcData, dim = 'member') != memberDim) {\n stop('frc data has different member number from hindcast.')\n } \n \n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n \n for (member in 1:dim(frcData)[4]) {\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,, member] <- applyBiasFactor_core(frcData[lon, lat,,member], biasFactor = biasFactor[[member]][[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n } else {\n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time'))\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,] <- applyBiasFactor_core(frcData[lon, lat,], biasFactor = biasFactor[[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n \n frcData <- adjustDim(frcData, ref = frcDim)\n frc$Data <- frcData\n frc$biasCorrected_by <- method\n frc_new <- frc\n \n return(frc_new)\n}\n\n\n#################\n################# core functions for multi bias correction.\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats ecdf quantile pgamma qgamma rgamma\n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\ngetBiasFactor_core <- function(hindcast, obs, method , scaleType, preci, prThreshold, extrapolate){\n # If the variable is precipitation, some further process needs to be added.\n # The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration.\n \n \n # check if frc, hindcast or obs are all na values\n if (!any(!is.na(obs)) | !any(!is.na(hindcast))) {\n warning('In this cell, hindcast or obs data is missing. No biasCorrection for this cell.')\n return(NA)\n } \n \n if (preci == TRUE) {\n preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold)\n hindcast <- preprocessHindcast_res[[1]]\n minHindcastPreci <- preprocessHindcast_res[[2]]\n }\n \n # default is the simplest method in biascorrection, just do simple addition and subtraction.\n if (method == 'delta') {\n biasFactor <- getBiasFactor_core_delta(hindcast)\n } else if (method == 'scaling') {\n biasFactor <- getBiasFactor_core_scaling(hindcast, obs, scaleType)\n } else if (method == 'eqm') {\n # In this method, the value is bounded by the observation\n # Preci or not both have the same biasFactor\n if (preci == FALSE) {\n biasFactor <- getBiasFactor_core_eqm_nonPreci(hindcast, obs, extrapolate)\n } else {\n biasFactor <- getBiasFactor_core_eqm_preci(hindcast, obs, minHindcastPreci, extrapolate, prThreshold)\n }\n \n \n } else if (method == 'gqm') {\n if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T')\n biasFactor <- getBiasFactor_core_gqm(hindcast, obs, prThreshold, minHindcastPreci)\n }\n \n if (preci == TRUE) biasFactor$minHindcastPreci <- minHindcastPreci\n \n return(biasFactor)\n}\n\n\napplyBiasFactor_core <- function(frc, biasFactor, method, preci, prThreshold, scaleType,\n extrapolate, obs = NULL) {\n \n if (!any(!is.na(biasFactor))) {\n warning('In this cell, biasFactor is missing.No biasCorrection for this cell.')\n # here return NA or return the unprocessed frc, both are OK. But return NA is more\n # obvious for user.\n return(NA)\n }\n \n if (method == 'delta') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.')\n frc <- applyBiasFactor_core_delta(frc = frc, biasFactor = biasFactor, obs = obs)\n } else if (method == 'scaling') {\n frc <- applyBiasFactor_core_scaling(frc = frc, biasFactor = biasFactor, scaleType = scaleType)\n } else if (method == 'eqm') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (preci == FALSE) {\n frc <- applyBiasFactor_core_eqm_nonPreci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n obs = obs)\n } else {\n frc <- applyBiasFactor_core_eqm_preci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n prThreshold = prThreshold, obs = obs)\n }\n } else if (method == 'gqm') {\n frc <- applyBiasFactor_core_gqm(frc = frc, biasFactor = biasFactor)\n }\n \n return(frc)\n}\n\n\ngetBiasFactor_core_delta <- function(hindcast) {\n biasFactor <- list()\n biasFactor$hindcastMean <- mean(hindcast, na.rm = TRUE)\n return(biasFactor)\n}\napplyBiasFactor_core_delta <- function(frc, biasFactor, obs) {\n hindcastMean <- biasFactor$hindcastMean\n frcMean <- mean(frc, na.rm = TRUE)\n return(obs - hindcastMean + frcMean)\n}\n\ngetBiasFactor_core_scaling <- function(hindcast, obs, scaleType) {\n biasFactor <- list()\n \n hindcastMean <- mean(hindcast, na.rm = TRUE)\n obsMean <- mean(obs, na.rm = TRUE)\n \n if (scaleType == 'multi') {\n biasFactor$scale <- obsMean / hindcastMean\n \n } else if (scaleType == 'add') {\n biasFactor$scale <- obsMean - hindcastMean\n }\n \n return(biasFactor)\n}\n\napplyBiasFactor_core_scaling <- function(frc, biasFactor, scaleType) {\n \n if (scaleType == 'multi') {\n frc <- frc * biasFactor$scale\n \n } else if (scaleType == 'add') {\n frc <- frc + biasFactor$scale\n }\n return(frc)\n}\n\ngetBiasFactor_core_eqm_nonPreci <- function(hindcast, obs, extrapolate) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast)\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, na.rm = TRUE)\n }\n \n return(biasFactor)\n}\n\ngetBiasFactor_core_eqm_preci <- function(hindcast, obs, minHindcastPreci, extrapolate,\n prThreshold) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci])\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, nna.rm = TRUE)\n }\n biasFactor$availableHindcastLength <- length(which(hindcast > minHindcastPreci))\n \n # drizzle parameter 1\n biasFactor$drizzleP1 <- min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE)\n # biasFactor$prThreshold <- prThreshold\n return(biasFactor)\n}\n\napplyBiasFactor_core_eqm_nonPreci <- function(frc, biasFactor, extrapolate, obs) {\n ecdfHindcast <- biasFactor$ecdfHindcast\n \n if (extrapolate == 'constant') {\n higherIndex <- which(frc > biasFactor$maxHindcast)\n lowerIndex <- which(frc < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex)\n \n # In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards\n # So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will\n # return 1:length(sim)\n \n if (length(higherIndex) > 0) {\n \n frc[higherIndex] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n \n frc[lowerIndex] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), \n na.rm = TRUE, type = 4)\n } else {\n frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4)\n }\n return(frc)\n}\n\n#' @importFrom stats quantile\napplyBiasFactor_core_eqm_preci <- function(frc, biasFactor, extrapolate, prThreshold, obs) {\n \n # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be\n # always hindcast > minHindcastPreci exists.\n # Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci\n if (biasFactor$availableHindcastLength > 0) {\n \n ecdfHindcast <- biasFactor$ecdfHindcast\n \n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n # drizzle is to see whether there are some precipitation between the min frc (over threshold) and \n # min hindcast (over threshold).\n drizzle <- which(frc > biasFactor$minHindcastPreci & frc <= biasFactor$drizzleP1 & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n \n if (extrapolate == 'constant') {\n \n # This higher and lower index mean the extrapolation part\n higherIndex <- which(frc[rain] > biasFactor$maxHindcast)\n lowerIndex <- which(frc[rain] < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex)\n \n if (length(higherIndex) > 0) {\n frc[rain[higherIndex]] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n frc[rain[lowerIndex]] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n \n # Here the original function doesn't accout for the situation that extraploateIndex is 0\n # if it is 0, rain[-extraploateIndex] would be nothing\n \n # Above has been solved by using setdiff.\n frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), \n na.rm = TRUE, type = 4)\n \n } else {\n \n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4)\n }\n }\n if (length(drizzle) > 0){\n \n # drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to \n # biascorrect the original drizzle part \n frc[drizzle] <- quantile(frc[which(frc > biasFactor$drizzleP1 & !is.na(frc))], \n probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, \n type = 4)\n }\n \n frc[noRain] <- 0\n \n } else {\n # in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci\n # And frc distribution is used then.\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), \n na.rm = TRUE, type = 4)\n }\n frc[noRain]<-0\n }\n return(frc)\n}\n\n#' @importFrom MASS fitdistr\ngetBiasFactor_core_gqm <- function(hindcast, obs, prThreshold, minHindcastPreci) {\n if (any(obs > prThreshold)) {\n biasFactor <- list()\n ind <- which(obs > prThreshold & !is.na(obs))\n obsGamma <- fitdistr(obs[ind],\"gamma\")\n biasFactor$obsShape <- obsGamma$estimate[1]\n biasFactor$obsRate <- obsGamma$estimate[2]\n \n ind <- which(hindcast > 0 & !is.na(hindcast))\n hindcastGamma <- fitdistr(hindcast[ind],\"gamma\")\n biasFactor$hindcastShape <- hindcastGamma$estimate[1]\n biasFactor$hindcastRate <- hindcastGamma$estimate[2]\n biasFactor$minHindcastPreci <- minHindcastPreci\n \n } else {\n warning('All the observations of this cell(station) are lower than the threshold, \n no biasFactor returned.')\n biasFactor <- NA\n }\n return(biasFactor)\n}\n\n#' @importFrom stats pgamma qgamma\napplyBiasFactor_core_gqm <- function(frc, biasFactor) {\n \n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n \n probF <- pgamma(frc[rain], biasFactor$hindcastShape, rate = biasFactor$hindcastRate)\n frc[rain] <- qgamma(probF, biasFactor$obsShape, rate = biasFactor$obsRate)\n frc[noRain] <- 0\n \n return(frc)\n}", + "created" : 1446430537289.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2075301236", + "id" : "45E75BB3", + "lastKnownWriteTime" : 1446432440, + "path" : "E:/1/R/hyfo/R/multi-biasCorrect(generic).R", + "project_path" : "R/multi-biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 12, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/46447358 b/.Rproj.user/D53FD3E6/sdb/per/t/46447358 deleted file mode 100644 index 5da036a..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/46447358 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "\n\n#' Get bias factor for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param hindcast a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the hindcast data. This data will be used in the calibration of the forecast, so it's better to have the same date period as\n#' observation data. Check details for more information.\n#' @param obs a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data.\n#' @param method bias correct method, including 'delta', 'scaling'...,default method is 'scaling'.\n#' @param scaleType only when the method \"scaling\" is chosen, scaleType will be available. Two different types\n#' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method, default is 'multi'. More info check \n#' details.\n#' @param input If input is a time series, \\code{input = 'TS'} needs to be assigned, or hyfo will take it as \n#' an hyfo output grid file. Default is hyfo output grid file, where in most of the cases we prefer.\n#' @param preci If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\n#' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \n#' Default is FALSE, refer to details.\n#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).\n#' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\n#' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.\n#' \n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction.\n#' \\code{\\link{applyBiasFactor}}, for the second part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs, input = 'TS')\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, input = 'TS', preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta', input = 'TS')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\n\ngetBiasFactor <- function(hindcast, obs, method = 'scaling', scaleType = 'multi', input = 'hyfo', \n preci = FALSE, prThreshold = 0, extrapolate = 'no'){\n \n if (input == 'TS') {\n # First check if the first column is Date\n if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # if condition only accepts one condition, for list comparison, there are a lot of conditions, better\n # further process it, like using any.\n if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) {\n warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in \n the calibration.')\n }\n \n if (ncol(hindcast) == 2) {\n biasFactor_all <- list()\n biasFactor_all$biasFactor <- getBiasFactor_core(hindcast[, 2], obs[, 2], method = method, \n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n } else if (ncol(hindcast) > 2) {\n # In this case more than one value columns exist in the dataset, both frc and hindcast.\n \n n <- ncol(hindcast)\n \n # For every column, it's biascorrected respectively.\n biasFactor_all <- lapply(2:n, function(x) getBiasFactor_core(hindcast[, x], obs[, 2], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate))\n biasFactor_all$memberDim <- n - 1\n \n } else stop('Wrong TS input, check your TS dimension.')\n \n \n } else if (input == 'hyfo') {\n ## Check if the data is a hyfo grid data.\n checkHyfo(hindcast, obs)\n \n hindcastData <- hindcast$Data\n obsData <- obs$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n hindcastDim <- attributes(hindcastData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n checkDimLength(hindcastData, obsData, dim = c('lon', 'lat'))\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(hindcastData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n biasFactor_all <- vector(mode = \"list\", length = dim(hindcastData)[4])\n for (member in 1:dim(hindcastData)[4]) {\n biasFactor_all[[member]] <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[member]][[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2])\n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[member]][[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,, member], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n biasFactor_all$memberDim <- calcuDim(hindcastData, dim = 'member')\n } else {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time'))\n \n biasFactor_all <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) \n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n biasFactor_all$lonLatDim <- calcuDim(hindcastData, dim = c('lon', 'lat'))\n }\n \n biasFactor_all$method <- method\n biasFactor_all$preci <- preci\n biasFactor_all$prThreshold <- prThreshold\n biasFactor_all$scaleType <- scaleType\n biasFactor_all$extrapolate <- extrapolate\n biasFactor_all$input <- input\n \n return(biasFactor_all)\n}\n\n\n\n\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats ecdf quantile pgamma qgamma rgamma\n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' \n#' \n# Because in multi biascorrection, getBiasFactor and applyBiasFactor is seperated. \n# Especially in the process to generate bias factor, different lists are generated\n# in each loop, then, it could be very slow.\ngetBiasFactor_core <- function(hindcast, obs, method , scaleType, preci, prThreshold, extrapolate){\n # If the variable is precipitation, some further process needs to be added.\n # The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration.\n \n \n # check if frc, hindcast or obs are all na values\n if (!any(!is.na(obs)) | !any(!is.na(hindcast))) {\n warning('In this cell, hindcast or obs data is missing. No biasCorrection for this cell.')\n return(NA)\n } \n \n if (preci == TRUE) {\n preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold)\n hindcast <- preprocessHindcast_res[[1]]\n minHindcastPreci <- preprocessHindcast_res[[2]]\n }\n \n # default is the simplest method in biascorrection, just do simple addition and subtraction.\n if (method == 'delta') {\n biasFactor <- getBiasFactor_core_delta(hindcast)\n } else if (method == 'scaling') {\n biasFactor <- getBiasFactor_core_scaling(hindcast, obs, scaleType)\n } else if (method == 'eqm') {\n # In this method, the value is bounded by the observation\n # Preci or not both have the same biasFactor\n if (preci == FALSE) {\n biasFactor <- getBiasFactor_core_eqm_nonPreci(hindcast, obs, extrapolate)\n } else {\n biasFactor <- getBiasFactor_core_eqm_preci(hindcast, obs, minHindcastPreci, extrapolate, prThreshold)\n }\n \n \n } else if (method == 'gqm') {\n if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T')\n biasFactor <- getBiasFactor_core_gqm(hindcast, obs, prThreshold, minHindcastPreci)\n }\n \n if (preci == TRUE) biasFactor$minHindcastPreci <- minHindcastPreci\n \n return(biasFactor)\n}\n\n\n\n\n#' Apply bias factor to different forecasts for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param frc a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the frc data. Check details for more information.\n#' @param biasFactor a file containing all the information of the calibration, will be\n#' applied to different forecasts.\n#' @param obs for some methods, observation input is necessary. obs is a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data. Default value is NULL.\n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction. \n#' \\code{\\link{getBiasFactor}}, for the first part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs, input = 'TS')\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, input = 'TS', preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta', input = 'TS')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\napplyBiasFactor <- function(frc, biasFactor, obs = NULL) {\n \n method <- biasFactor$method\n preci <- biasFactor$preci\n prThreshold <- biasFactor$prThreshold\n scaleType <- biasFactor$scaleType\n extrapolate <- biasFactor$extrapolate\n input <- biasFactor$input\n \n if (input == 'TS') {\n # First check if the first column is Date\n if (!grepl('-|/', frc[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n\n \n if (ncol(frc) == 2) {\n frc_data <- applyBiasFactor_core(frc = frc[, 2], biasFactor = biasFactor, method = method, \n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obs[, 2])\n } else if (ncol(frc) > 2) {\n # In this case more than one value columns exist in the dataset, both frc and hindcast.\n \n n <- ncol(frc)\n \n # For every column, it's biascorrected respectively.\n frc_data <- lapply(2:n, function(x) applyBiasFactor_core(frc[, x], biasFactor = biasFactor[[x - 1]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obs[, 2]))\n frc_data <- do.call('cbind', frc_data)\n rownames(frc_data) <- NULL\n \n } else stop('Wrong TS input, check your TS dimension.')\n \n names <- colnames(frc)\n frc_new <- data.frame(frc[, 1], frc_data)\n colnames(frc_new) <- names\n \n } else if (input == 'hyfo') {\n ## Check if the data is a hyfo grid data.\n checkHyfo(frc)\n \n \n obsData <- obs$Data\n frcData <- frc$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n frcDim <- attributes(frcData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n if (!identical(calcuDim(frcData, dim = c('lon', 'lat')), biasFactor$lonLatDim)) {\n stop('frc data has different lon and lat from hindcast data.')\n }\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n # check if frcData and hindcastData has the same dimension and length.\n if (calcuDim(frcData, dim = 'member') != biasFactor$memberDim) {\n stop('frc data has different member number from hindcast.')\n } \n \n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n \n for (member in 1:dim(frcData)[4]) {\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,, member] <- applyBiasFactor_core(frcData[lon, lat,,member], biasFactor = biasFactor[[member]][[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n } else {\n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time'))\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,] <- applyBiasFactor_core(frcData[lon, lat,], biasFactor = biasFactor[[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n \n frcData <- adjustDim(frcData, ref = frcDim)\n frc$Data <- frcData\n frc$biasCorrected_by <- method\n frc_new <- frc\n }\n \n return(frc_new)\n}\n\napplyBiasFactor_core <- function(frc, biasFactor, method, preci, prThreshold, scaleType,\n extrapolate, obs = NULL) {\n \n if (!any(!is.na(biasFactor))) {\n warning('In this cell, biasFactor is missing.No biasCorrection for this cell.')\n # here return NA or return the unprocessed frc, both are OK. But return NA is more\n # obvious for user.\n return(NA)\n }\n \n if (method == 'delta') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.')\n frc <- applyBiasFactor_core_delta(frc = frc, biasFactor = biasFactor, obs = obs)\n } else if (method == 'scaling') {\n frc <- applyBiasFactor_core_scaling(frc = frc, biasFactor = biasFactor, scaleType = scaleType)\n } else if (method == 'eqm') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (preci == FALSE) {\n frc <- applyBiasFactor_core_eqm_nonPreci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n obs = obs)\n } else {\n frc <- applyBiasFactor_core_eqm_preci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n prThreshold = prThreshold, obs = obs)\n }\n } else if (method == 'gqm') {\n frc <- applyBiasFactor_core_gqm(frc = frc, biasFactor = biasFactor)\n }\n \n return(frc)\n}\n\n\ngetBiasFactor_core_delta <- function(hindcast) {\n biasFactor <- list()\n biasFactor$hindcastMean <- mean(hindcast, na.rm = TRUE)\n return(biasFactor)\n}\napplyBiasFactor_core_delta <- function(frc, biasFactor, obs) {\n hindcastMean <- biasFactor$hindcastMean\n frcMean <- mean(frc, na.rm = TRUE)\n return(obs - hindcastMean + frcMean)\n}\n\ngetBiasFactor_core_scaling <- function(hindcast, obs, scaleType) {\n biasFactor <- list()\n \n hindcastMean <- mean(hindcast, na.rm = TRUE)\n obsMean <- mean(obs, na.rm = TRUE)\n \n if (scaleType == 'multi') {\n biasFactor$scale <- obsMean / hindcastMean\n \n } else if (scaleType == 'add') {\n biasFactor$scale <- obsMean - hindcastMean\n }\n \n return(biasFactor)\n}\n\napplyBiasFactor_core_scaling <- function(frc, biasFactor, scaleType) {\n \n if (scaleType == 'multi') {\n frc <- frc * biasFactor$scale\n \n } else if (scaleType == 'add') {\n frc <- frc + biasFactor$scale\n }\n return(frc)\n}\n\ngetBiasFactor_core_eqm_nonPreci <- function(hindcast, obs, extrapolate) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast)\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, na.rm = TRUE)\n }\n \n return(biasFactor)\n}\n\ngetBiasFactor_core_eqm_preci <- function(hindcast, obs, minHindcastPreci, extrapolate,\n prThreshold) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci])\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, nna.rm = TRUE)\n }\n biasFactor$availableHindcastLength <- length(which(hindcast > minHindcastPreci))\n \n # drizzle parameter 1\n biasFactor$drizzleP1 <- min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE)\n # biasFactor$prThreshold <- prThreshold\n return(biasFactor)\n}\n\napplyBiasFactor_core_eqm_nonPreci <- function(frc, biasFactor, extrapolate, obs) {\n ecdfHindcast <- biasFactor$ecdfHindcast\n \n if (extrapolate == 'constant') {\n higherIndex <- which(frc > biasFactor$maxHindcast)\n lowerIndex <- which(frc < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex)\n \n # In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards\n # So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will\n # return 1:length(sim)\n \n if (length(higherIndex) > 0) {\n \n frc[higherIndex] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n \n frc[lowerIndex] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), \n na.rm = TRUE, type = 4)\n } else {\n frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4)\n }\n return(frc)\n}\n\n#' @importFrom stats quantile\napplyBiasFactor_core_eqm_preci <- function(frc, biasFactor, extrapolate, prThreshold, obs) {\n \n # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be\n # always hindcast > minHindcastPreci exists.\n # Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci\n if (biasFactor$availableHindcastLength > 0) {\n \n ecdfHindcast <- biasFactor$ecdfHindcast\n \n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n # drizzle is to see whether there are some precipitation between the min frc (over threshold) and \n # min hindcast (over threshold).\n drizzle <- which(frc > biasFactor$minHindcastPreci & frc <= biasFactor$drizzleP1 & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n \n if (extrapolate == 'constant') {\n \n # This higher and lower index mean the extrapolation part\n higherIndex <- which(frc[rain] > biasFactor$maxHindcast)\n lowerIndex <- which(frc[rain] < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex)\n \n if (length(higherIndex) > 0) {\n frc[rain[higherIndex]] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n frc[rain[lowerIndex]] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n \n # Here the original function doesn't accout for the situation that extraploateIndex is 0\n # if it is 0, rain[-extraploateIndex] would be nothing\n \n # Above has been solved by using setdiff.\n frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), \n na.rm = TRUE, type = 4)\n \n } else {\n \n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4)\n }\n }\n if (length(drizzle) > 0){\n \n # drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to \n # biascorrect the original drizzle part \n frc[drizzle] <- quantile(frc[which(frc > biasFactor$drizzleP1 & !is.na(frc))], \n probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, \n type = 4)\n }\n \n frc[noRain] <- 0\n \n } else {\n # in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci\n # And frc distribution is used then.\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), \n na.rm = TRUE, type = 4)\n }\n frc[noRain]<-0\n }\n return(frc)\n}\n\n#' @importFrom MASS fitdistr\ngetBiasFactor_core_gqm <- function(hindcast, obs, prThreshold, minHindcastPreci) {\n if (any(obs > prThreshold)) {\n biasFactor <- list()\n ind <- which(obs > prThreshold & !is.na(obs))\n obsGamma <- fitdistr(obs[ind],\"gamma\")\n biasFactor$obsShape <- obsGamma$estimate[1]\n biasFactor$obsRate <- obsGamma$estimate[2]\n \n ind <- which(hindcast > 0 & !is.na(hindcast))\n hindcastGamma <- fitdistr(hindcast[ind],\"gamma\")\n biasFactor$hindcastShape <- hindcastGamma$estimate[1]\n biasFactor$hindcastRate <- hindcastGamma$estimate[2]\n biasFactor$minHindcastPreci <- minHindcastPreci\n \n } else {\n warning('All the observations of this cell(station) are lower than the threshold, \n no biasFactor returned.')\n biasFactor <- NA\n }\n return(biasFactor)\n}\n\n#' @importFrom stats pgamma qgamma\napplyBiasFactor_core_gqm <- function(frc, biasFactor) {\n\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n \n probF <- pgamma(frc[rain], biasFactor$hindcastShape, rate = biasFactor$hindcastRate)\n frc[rain] <- qgamma(probF, biasFactor$obsShape, rate = biasFactor$obsRate)\n frc[noRain] <- 0\n \n return(frc)\n}", - "created" : 1446061074602.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1773555799", - "id" : "46447358", - "lastKnownWriteTime" : 1446075586, - "path" : "E:/1/R/multi-biasCorrect.R", - "project_path" : null, - "properties" : { - }, - "relative_order" : 3, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/4A436C01 b/.Rproj.user/D53FD3E6/sdb/per/t/4A436C01 new file mode 100644 index 0000000..232afbf --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/4A436C01 @@ -0,0 +1,18 @@ +{ + "contents" : "\n\n\n#' Biascorrect the input timeseries or hyfo dataset\n#' \n#' Biascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\n#' observation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\n#' will be returned. If the input is a time series, first column should be date column and rest columns should be \n#' the value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\n#' file with the same format.\n#' \n#' @param frc a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the forecast to be calibrated.\n#' @param hindcast a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the hindcast data. This data will be used in the calibration of the forecast, so it's better to have the same date period as\n#' observation data. Check details for more information.\n#' @param obs a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data.\n#' @param method bias correct method, including 'delta', 'scaling'..., default is 'scaling'\n#' @param scaleType only when the method \"scaling\" is chosen, scaleType will be available. Two different types\n#' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \n#' details. Default scaleType is 'multi'.\n#' @param preci If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\n#' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \n#' Default is FALSE, refer to details.\n#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).\n#' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\n#' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.\n#' @details \n#' \n#' Since climate forecast is based on global condition, when downscaling to different regions, it may include\n#' some bias, biascorrection is used then to fix the bias.\n#' \n#' \\strong{Hindcast}\n#' \n#' In order to bias correct, we need to pick up some data from the forecast to train with\n#' the observation, which is called hindcast in this function. Using hindcast and observation, \n#' the program can analyze the bias and correct the bias in the forecast. \n#' \n#' Hindcast should have \\strong{EVERY} attributes that forecast has.\n#' \n#' Hindcast is also called re-forecast, is the forecast of the past. E.g. you have a forecast from year 2000-2010, assuming now you are in 2005. So from 2000-2005, this period\n#' is the hindcast period, and 2005-2010, this period is the forecast period.\n#'\n#' Hindcast can be the same as forecast, i.e., you can use forecast itself as hindcast to train the bias correction.\n#'\n#'\n#' \\strong{How it works}\n#' \n#' Forecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \n#' forecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \n#' data (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n#' \n#' E.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \n#' period (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\n#' The program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \n#' modification to the forecast data.\n#' \n#' The more categorized input, the more accurate result you will get. E.g., if you want to \n#' bias correct a forecast for winter season. So you'd better to extract all the winter period\n#' in the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n#' \n#' \\strong{method}\n#' \n#' Different methods used in the bias correction. Among which, delta, scaling can be applied\n#' to different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\n#' it needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\n#' designed for rainfall data, so \\code{preci = TRUE} needs to be set.\n#' \n#' \\strong{delta}\n#' \n#' This method consists on adding to the observations the mean change signal (delta method). \n#' This method is applicable to any kind of variable but it is preferable to avoid it for bounded variables\n#' (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained \n#' (e.g. negative wind speeds...)\n#' \n#' \\strong{scaling}\n#' \n#' This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \n#' between the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\n#' correction is defined by parameter \\code{scaling.type} (default is \\code{additive}).\n#' The additive version is preferably applicable to unbounded variables (e.g. temperature) \n#' and the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n#' \n#' \\strong{eqm}\n#' \n#' Empirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \n#' by adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \n#' This method is applicable to any kind of variable.\n#' \n#' It can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\n#' that the extreme value is an error.\n#' \n#' \\strong{gqm}\n#' \n#' Gamma Quantile Mapping. This method is described in Piani et al. 2010 and is applicable only to precipitation. It is based on the initial assumption that both observed\n#' and simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \n#' that uses the theorical instead of the empirical distribution. \n#' \n#' It can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\n#' Better have a long period of training, and the if the forecast system is relatively stable.\n#' \n#' \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' newFrc <- biasCorrect(nc, nc, tgridData) \n#' newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \n#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \n#' preci = TRUE) \n#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is scaling, with 'multi' scaleType\n#' frc_new <- biasCorrect(frc, hindcast, obs)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program that it is a precipitation data.\n#' \n#' frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n#' \n#' # You can use other scaling methods to biascorrect.\n#' frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n#' \n#' # \n#' frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\n#' frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' @importFrom methods setMethod\n#' @export\n#' \nsetGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', \n preci = FALSE, prThreshold = 0, extrapolate = 'no') {\n standardGeneric('biasCorrect')\n})\n\n#' @describeIn biasCorrect\nsetMethod('biasCorrect', signature('data.frame', 'data.frame', 'data.frame'),\n function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n result <- biasCorrect.TS(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate)\n return(result)\n })\n\n#' @describeIn biasCorrect\nsetMethod('biasCorrect', signature('list', 'list', 'list'), \n function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n result <- biasCorrect.list(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate)\n return(result)\n })\n\n\nbiasCorrect.TS <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n # First check if the first column is Date\n if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1]) | !grepl('-|/', frc[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # if condition only accepts one condition, for list comparison, there are a lot of conditions, better\n # further process it, like using any.\n if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) {\n warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in \n the calibration.')\n }\n n <- ncol(frc)\n \n # For every column, it's biascorrected respectively.\n frc_data <- lapply(2:n, function(x) biasCorrect_core(frc[, x], hindcast[, x], obs[, 2], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate))\n frc_data <- do.call('cbind', frc_data)\n rownames(frc_data) <- NULL\n \n names <- colnames(frc)\n frc_new <- data.frame(frc[, 1], frc_data)\n colnames(frc_new) <- names\n return(frc_new)\n}\n\nbiasCorrect.list <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n ## Check if the data is a hyfo grid data.\n checkHyfo(frc, hindcast, obs)\n \n hindcastData <- hindcast$Data\n obsData <- obs$Data\n frcData <- frc$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n frcDim <- attributes(frcData)$dimensions\n \n ## ajust the dimension into general dimension order.\n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time'))\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n checkDimLength(frcData, hindcastData, obsData, dim = c('lon', 'lat'))\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n # check if frcData and hindcastData has the same dimension and length.\n checkDimLength(frcData, hindcastData, dim = 'member')\n \n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n \n for (member in 1:dim(frcData)[4]) {\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,, member] <- biasCorrect_core(frcData[lon, lat,,member], hindcastData[lon, lat,, member], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n } else {\n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time'))\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,] <- biasCorrect_core(frcData[lon, lat,], hindcastData[lon, lat,], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n \n frcData <- adjustDim(frcData, ref = frcDim)\n frc$Data <- frcData\n frc$biasCorrected_by <- method\n frc_new <- frc\n return(frc_new)\n}\n\n\n\n\n\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats ecdf quantile pgamma qgamma rgamma\n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' \n#' \n# this is only used to calculate the value column, \nbiasCorrect_core <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate){\n # If the variable is precipitation, some further process needs to be added.\n # The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration.\n \n \n # check if frc, hindcast or obs are all na values\n if (!any(!is.na(obs)) | !any(!is.na(frc)) | !any(!is.na(hindcast))) {\n warning('In this cell, frc, hindcast or obs data is missing. No biasCorrection for this cell.')\n return(NA)\n }\n \n \n if (preci == TRUE) {\n preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold)\n hindcast <- preprocessHindcast_res[[1]]\n minHindcastPreci <- preprocessHindcast_res[[2]]\n }\n \n # default is the simplest method in biascorrection, just do simple addition and subtraction.\n if (method == 'delta') {\n if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.')\n # comes from downscaleR biascorrection method\n frcMean <- mean(frc, na.rm = TRUE)\n hindcastMean <- mean(hindcast, na.rm = TRUE)\n frc <- obs - hindcastMean + frcMean\n \n } else if (method == 'scaling') {\n obsMean <- mean(obs, na.rm = TRUE)\n hindcastMean <- mean(hindcast, na.rm = TRUE)\n \n if (scaleType == 'multi') {\n frc <- frc / hindcastMean * obsMean\n \n } else if (scaleType == 'add') {\n frc <- frc - hindcastMean + obsMean\n }\n \n \n } else if (method == 'eqm') {\n if (preci == FALSE) {\n frc <- biasCorrect_core_eqm_nonPreci(frc, hindcast, obs, extrapolate, prThreshold)\n } else {\n frc <- biasCorrect_core_eqm_preci(frc, hindcast, obs, minHindcastPreci, extrapolate,\n prThreshold)\n }\n \n } else if (method == 'gqm') {\n if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T')\n frc <- biasCorrect_core_gqm(frc, hindcast, obs, prThreshold, minHindcastPreci)\n }\n \n \n return(frc)\n}\n\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats rgamma\npreprocessHindcast <- function(hindcast, obs, prThreshold) {\n lowerIndex <- length(which(obs < prThreshold))\n \n # In the original function, this minHindcastPreci is Pth[,i,j] in downscaleR, and it is originally\n # set to NA, which is not so appropriate for all the precipitations.\n # In the original function, there are only two conditions, 1. all the obs less than threshold\n # 2. there are some obs less than threshold. \n # While, if we set threshold to 0, there could be a 3rd condition, all the obs no less than threshold.\n # Here I set this situation, firstly set minHindcastPreci to the min of the hindcast. Because in future\n # use, 'eqm' method is going to use this value.\n \n # The problem above has been solved.\n \n \n if (lowerIndex >= 0 & lowerIndex < length(obs)) {\n index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix\n hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA)\n # minHindcastPreci is the min preci over threshold FOR ***HINDCAST***\n # But use obs to get the lowerIndex, so obs_sorted[lowerIndex + 1] > prThreshold, but\n # hindcast_sorted[lowerIndex + 1] may greater than or smaller than ptThreshold\n \n \n # It would be better to understand if you draw two lines: hindcast_sorted and obs_sorted\n # with y = prThreshold, you will find the difference of the two.\n \n # In principle, the value under the threshold needs to be replaced by some other reasonable value.\n # simplest way \n minHindcastPreci <- hindcast_sorted[lowerIndex + 1]\n \n # Also here if minHindcastPreci is 0 and prThreshold is 0, will cause problem, bettter set \n # I set it prThreshold != 0 \n if (minHindcastPreci <= prThreshold & prThreshold != 0) {\n obs_sorted <- sort(obs, decreasing = FALSE, na.last = NA)\n \n # higherIndex is based on hindcast\n higherIndex <- which(hindcast_sorted > prThreshold & !is.na(hindcast_sorted))\n \n if (length(higherIndex) == 0) {\n higherIndex <- max(which(!is.na(hindcast_sorted)))\n higherIndex <- min(length(obs_sorted), higherIndex)\n } else {\n higherIndex <- min(higherIndex)\n }\n # here I don't know why choose 6.\n # Written # [Shape parameter Scale parameter] in original package\n # according to the reference and gamma distribution, at least 6 values needed to fit gamma\n # distribution.\n if (length(unique(obs_sorted[(lowerIndex + 1):higherIndex])) < 6) {\n hindcast_sorted[(lowerIndex + 1):higherIndex] <- mean(obs_sorted[(lowerIndex + 1):higherIndex], \n na.rm = TRUE)\n } else {\n obsGamma <- fitdistr(obs_sorted[(lowerIndex + 1):higherIndex], \"gamma\")\n \n # this is to replace the original hindcast value between lowerIndex and higherIndex with \n # some value taken from gamma distribution just generated.\n hindcast_sorted[(lowerIndex + 1):higherIndex] <- rgamma(higherIndex - lowerIndex, obsGamma$estimate[1], \n rate = obsGamma$estimate[2])\n }\n hindcast_sorted <- sort(hindcast_sorted, decreasing = FALSE, na.last = NA)\n \n } \n minIndex <- min(lowerIndex, length(hindcast))\n hindcast_sorted[1:minIndex] <- 0\n hindcast[index] <- hindcast_sorted\n \n } else if (lowerIndex == length(obs)) {\n \n index <- sort(hindcast, decreasing = FALSE, na.last = NA, index.return = TRUE)$ix\n hindcast_sorted <- sort(hindcast, decreasing = FALSE, na.last = NA)\n minHindcastPreci <- hindcast_sorted[lowerIndex]\n \n # here is to compare with hindcast, not obs\n minIndex <- min(lowerIndex, length(hindcast))\n hindcast_sorted[1:minIndex] <- 0\n hindcast[index] <- hindcast_sorted\n \n }\n return(list(hindcast, minHindcastPreci))\n}\n\nbiasCorrect_core_eqm_nonPreci <- function(frc, hindcast, obs, extrapolate, prThreshold) {\n ecdfHindcast <- ecdf(hindcast)\n \n if (extrapolate == 'constant') {\n higherIndex <- which(frc > max(hindcast, na.rm = TRUE))\n lowerIndex <- which(frc < min(hindcast, na.rm = TRUE))\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex)\n \n # In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards\n # So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will\n # return 1:length(sim)\n \n if (length(higherIndex) > 0) {\n maxHindcast <- max(hindcast, na.rm = TRUE)\n dif <- maxHindcast - max(obs, na.rm = TRUE)\n frc[higherIndex] <- frc[higherIndex] - dif\n }\n \n if (length(lowerIndex) > 0) {\n minHindcast <- min(hindcast, na.rm = TRUE)\n dif <- minHindcast - min(obs, nna.rm = TRUE)\n frc[lowerIndex] <- frc[lowerIndex] - dif\n }\n \n frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), \n na.rm = TRUE, type = 4)\n } else {\n frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4)\n }\n return(frc)\n}\n\nbiasCorrect_core_eqm_preci <- function(frc, hindcast, obs, minHindcastPreci, extrapolate, \n prThreshold) {\n \n # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be\n # always hindcast > minHindcastPreci exists.\n # Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci\n if (length(which(hindcast > minHindcastPreci)) > 0) {\n \n ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci])\n \n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n \n # drizzle is to see whether there are some precipitation between the min frc (over threshold) and \n # min hindcast (over threshold).\n drizzle <- which(frc > minHindcastPreci & frc <= min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) \n & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n \n if (extrapolate == 'constant') {\n \n # This higher and lower index mean the extrapolation part\n higherIndex <- which(frc[rain] > max(hindcast, na.rm = TRUE))\n lowerIndex <- which(frc[rain] < min(hindcast, na.rm = TRUE))\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex)\n \n if (length(higherIndex) > 0) {\n maxHindcast <- max(hindcast, na.rm = TRUE)\n dif <- maxHindcast - max(obs, na.rm = TRUE)\n frc[rain[higherIndex]] <- frc[higherIndex] - dif\n }\n \n if (length(lowerIndex) > 0) {\n minHindcast <- min(hindcast, na.rm = TRUE)\n dif <- minHindcast - min(obs, nna.rm = TRUE)\n frc[rain[lowerIndex]] <- frc[lowerIndex] - dif\n }\n \n # Here the original function doesn't accout for the situation that extraploateIndex is 0\n # if it is 0, rain[-extraploateIndex] would be nothing\n \n # Above has been solved by using setdiff.\n frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), \n na.rm = TRUE, type = 4)\n } else {\n \n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4)\n }\n }\n if (length(drizzle) > 0){\n \n # drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to \n # biascorrect the original drizzle part\n frc[drizzle] <- quantile(frc[which(frc > min(hindcast[which(hindcast > minHindcastPreci)], na.rm = TRUE) & \n !is.na(frc))], probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, \n type = 4)\n }\n \n frc[noRain] <- 0\n \n } else {\n # in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci\n # And frc distribution is used then.\n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), \n na.rm = TRUE, type = 4)\n }\n frc[noRain]<-0\n }\n return(frc)\n}\n\nbiasCorrect_core_gqm <- function(frc, hindcast, obs, prThreshold, minHindcastPreci) {\n if (any(obs > prThreshold)) {\n \n ind <- which(obs > prThreshold & !is.na(obs))\n obsGamma <- fitdistr(obs[ind],\"gamma\")\n ind <- which(hindcast > 0 & !is.na(hindcast))\n hindcastGamma <- fitdistr(hindcast[ind],\"gamma\")\n rain <- which(frc > minHindcastPreci & !is.na(frc))\n noRain <- which(frc <= minHindcastPreci & !is.na(frc))\n \n probF <- pgamma(frc[rain], hindcastGamma$estimate[1], rate = hindcastGamma$estimate[2])\n frc[rain] <- qgamma(probF,obsGamma$estimate[1], rate = obsGamma$estimate[2])\n frc[noRain] <- 0\n } else {\n warning('All the observations of this cell(station) are lower than the threshold, \n no bias correction applied.')\n }\n return(frc)\n }\n", + "created" : 1446431643330.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3817473432", + "id" : "4A436C01", + "lastKnownWriteTime" : 1446431675, + "path" : "E:/1/R/hyfo/R/biasCorrect(generic).R", + "project_path" : "R/biasCorrect(generic).R", + "properties" : { + "tempName" : "Untitled1" + }, + "relative_order" : 13, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/4B970497 b/.Rproj.user/D53FD3E6/sdb/per/t/4B970497 new file mode 100644 index 0000000..b25a196 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/4B970497 @@ -0,0 +1,17 @@ +{ + "contents" : "#' Get mean rainfall data.\n#' \n#' Get mean rainfall data, e.g. mean annual rainfall, mean monthly rainfall and mean winter rainfall.\n#' \n#' @param inputTS A time series with only data column (1 column).\n#' @param method A string showing the method used to calculate mean value, e.g., \"annual\".\n#' more information please refer to details.\n#' @param yearIndex A NUMERIC ARRAY showing the year index of the time series.\n#' @param monthIndex A NUMERIC ARRAY showing the month index of the time series.\n#' @param fullResults A boolean showing whether the full results are shown, default is FALSE. If \n#' FALSE, only mean value will be returned, if TRUE, the sequence of values will be returned.\n#' @param omitNA A boolean showing in the calculation, whether NA is omitted, default is FALSE.\n#' @param plot A boolean showing whether the results will be plotted.\n#' @param ..., \\code{title, x, y} showing the title and x and y axis of the plot, shoud be a string.\n#' @details\n#' There are following methods to be selected, \n#' \"annual\": annual rainfall of each year is plotted. \n#' \"winter\", \"spring\", \"autumn\", \"summer\": seasonal rainfall of each year is plotted.\n#' Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfall of each year.\n#' \"meanMonthly\": the mean monthly rainfall of each month over the whole period.\n#' \n#' Since \"winter\" is a crossing year, 12, 1, 2, 12 is in former year, and 1, 2 are in latter year.\n#' so winter belongs to the latter year.\n#' \n#' @return The mean value of the input time series or the full results before calculating mean.\n#' \n# data(testdl)\n# TS <- testdl[[1]]\n# year = as.numeric(format(TS[, 1], '%Y'))\n# month = as.numeric(format(TS[, 1], '%m'))\n# \n# # Get the mean spring precipitation.\n# a <- getMeanPreci(TS[, 2], method = 'spring', yearIndex = year, monthIndex = month)\n# a\n# \n# # Get the series of spring precipitation, set fullResults = TRUE.\n# a <- getMeanPreci(TS[, 2], method = 'spring', yearIndex = year, monthIndex = month,\n# fullResults = TRUE)\n# a\n# \n# # If missing value is excluded, set omitNA = TRUE.\n# a <- getMeanPreci(TS[, 2], method = 'winter', yearIndex = year, monthIndex = month,\n# omitNA = TRUE, fullResults = TRUE)\n# a\n# \n# # Get special month precipitation, e.g. march.\n# a <- getMeanPreci(TS[, 2], method = 3, yearIndex = year, monthIndex = month,\n# fullResults = TRUE)\n# a\n# \n# # We can also get annual precipitation.\n# a <- getMeanPreci(TS[, 2], method = 'annual', yearIndex = year, monthIndex = month,\n# fullResults = TRUE)\n\ngetMeanPreci <- function(inputTS, method = NULL, yearIndex = NULL, monthIndex = NULL,\n fullResults = FALSE, omitNA = TRUE, plot = FALSE, ...) {\n # First check if all the records are NA.\n if (any(!is.na(inputTS))) {\n #converting daily preci to the wanted preci.\n if (method == 'annual') {\n ###yearIndex <- startTime$year + 1900\n annualPreci <- tapply(inputTS, INDEX = yearIndex, FUN = sum, na.rm = omitNA)#ggplot is able not to show NA, so choose TRUE\n if (fullResults == TRUE) output <- annualPreci else output <- mean(annualPreci, na.rm = TRUE)\n \n } else if (method == 'meanMonthly') {\n \n monthlypreci <- tapply(inputTS, INDEX = list(yearIndex, monthIndex), FUN = sum, na.rm = omitNA)\n meanMonthlyPreci <- apply(monthlypreci, MARGIN = 2, FUN = mean, na.rm = TRUE)\n \n if (fullResults == TRUE) output <- meanMonthlyPreci else output <- mean(meanMonthlyPreci, na.rm = TRUE)\n \n }else if (method == 'winter') {\n# #winter is the most tricky part, because it starts from Dec to Feb next year, it's a year-crossing season,\n# #so we have to make some changes to the monthIndex\n# #e.g.data from 1950.1.1 - 2008.3.31 if we want to calculate the mean winter preci, to calculate winter month\n# #December, we have to move the yearIndex one month forwards or two months backwards, to make 12,1,2 in one year \n# ###yearIndex <- startTime$year + 1900\n# ###monthIndex <- startTime$mon + 1\n# \n# #we move the yearIndex one month backwards\n# yearIndex_new <- c(yearIndex[32:length(yearIndex)], rep(tail(yearIndex, 1), 31))\n# \n# winterIndex <- which(monthIndex == 12 | monthIndex == 1 | monthIndex == 2)\n# winterYear <- yearIndex_new[winterIndex]#this index is used for calculation\n# \n# #because we don't have 1949.Dec, so the first winter is not intact, so first two months are elemenated\n# \n# startIndex <- length(which(winterYear == yearIndex[1])) + 1\n# winterOfLastYear <- length(which(winterYear == tail(yearIndex, 1)))\n# if (winterOfLastYear > 91) {\n# endIndex <- length(winterYear) - 31 #in case the data set ends at Dec.31\n# \n# } else if (winterOfLastYear < 90) { # incase the data ends at Jan 31\n# endIndex <- length(winterYear) - length(which(winterYear == tail(yearIndex, 1)))\n# \n# } else {\n# endIndex <- length(winterYear)\n# }\n# \n# inputTS <- inputTS[winterIndex][startIndex:endIndex]#needs two process with inputPreci, first, extract\n# #the winter preci, second, delete first two month of 1950\n# \n# winterYear <- winterYear[startIndex:endIndex]#needs one process, delete two months \n# seasonalPreci <- tapply(inputTS,INDEX = winterYear, FUN = sum, na.rm = omitNA)\n \n # upper part is the older method saved as backup.\n \n matrix <- tapply(inputTS, INDEX = list(monthIndex, yearIndex), FUN = sum, na.rm = omitNA)\n col <- colnames(matrix)\n dec <- matrix['12',] # extract December.\n dec <- c(NA, dec[1:length(dec) - 1]) # rearrange December order to push it to next year.\n names(dec) <- col\n matrix <- rbind(dec, matrix[rownames(matrix) != '12', ]) \n seasonalPreci <- apply(matrix, MARGIN = 2, function(x) sum(x[c('dec', '1', '2')]))\n \n if (fullResults == TRUE) output <- seasonalPreci else output <- mean(seasonalPreci, na.rm = TRUE) \n \n } else if (method == 'spring') {\n \n# springIndex <- which(monthIndex == 3 | monthIndex == 4 | monthIndex == 5)\n# springYear <- yearIndex[springIndex]\n# inputTS <- inputTS[springIndex]\n# seasonalPreci <- tapply(inputTS, INDEX = springYear, FUN = sum, na.rm = omitNA)\n \n \n matrix <- tapply(inputTS, INDEX = list(monthIndex, yearIndex), FUN = sum, na.rm = omitNA)\n seasonalPreci <- apply(matrix, MARGIN = 2, function(x) sum(x[c('3', '4', '5')]))\n \n if (fullResults == TRUE) output <- seasonalPreci else output <- mean(seasonalPreci, na.rm = TRUE)\n \n } else if (method == 'summer') {\n \n matrix <- tapply(inputTS, INDEX = list(monthIndex, yearIndex), FUN = sum, na.rm = omitNA)\n seasonalPreci <- apply(matrix, MARGIN = 2, function(x) sum(x[c('6', '7', '8')]))\n \n if (fullResults == TRUE) output <- seasonalPreci else output <- mean(seasonalPreci, na.rm = TRUE)\n \n } else if (method == 'autumn') {\n \n matrix <- tapply(inputTS, INDEX = list(monthIndex, yearIndex), FUN = sum, na.rm = omitNA)\n seasonalPreci <- apply(matrix, MARGIN = 2, function(x) sum(x[c('9', '10', '11')]))\n\n if (fullResults == TRUE) output <- seasonalPreci else output <- mean(seasonalPreci, na.rm = TRUE)\n \n } else if (is.numeric(method)) {\n \n month <- method\n \n #check if month exist \n e <- match(month, unique(monthIndex))\n if (is.na(e)) {\n e1 <- paste(unique(monthIndex), collapse = ',')\n m <- paste('No input month exists in the dataset, choose among', e1)\n stop(m)\n }\n \n monthlyPreci <- tapply(inputTS, INDEX = list(yearIndex, monthIndex), \n FUN = sum, na.rm = omitNA)[, toString(month)]\n \n if (fullResults == TRUE) output <- monthlyPreci else output <- mean(monthlyPreci, na.rm = TRUE)\n }\n \n } else {\n output <- NA\n }\n\n if (plot == TRUE) {\n a <- data.frame(Date = names(output), value = output)\n \n theme_set(theme_bw())\n mainLayer <- with(a, {\n ggplot(a) +\n geom_bar(aes(x = Date, y = value), stat = 'identity', fill = 'cyan') +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = rel(1.3), face = 'bold'),\n axis.title.x = element_text(size = rel(1.2)),\n axis.title.y = element_text(size = rel(1.2))) + \n theme(axis.text.x = element_text(angle = 90, hjust = 1))\n })\n \n print (mainLayer)\n }\n \n return(output)\n}\n", + "created" : 1446424240843.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1620316423", + "id" : "4B970497", + "lastKnownWriteTime" : 1446467132, + "path" : "E:/1/R/hyfo/R/getMeanPreci.R", + "project_path" : "R/getMeanPreci.R", + "properties" : { + }, + "relative_order" : 8, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/6706EE48 b/.Rproj.user/D53FD3E6/sdb/per/t/6706EE48 new file mode 100644 index 0000000..dc27285 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/6706EE48 @@ -0,0 +1,18 @@ +{ + "contents" : "##### Prepared for future use, when hyfo becomes a class.\n\n\n# # change to hyfo\n# setGeneric('as.hyfo', function(x) {\n# standardGeneric('as.hyfo')\n# })\n# \n# setMethod('as.hyfo', signature('list'),\n# function(x) {\n# \n# if (!is.null(x$Members)) {\n# hyfo <- new(\"hyfo.multiMember\", varName = x$Variable$varName, xyCoords = x$xyCoords, Dates = x$Dates, Data = x$Data,\n# Members = x$Members)\n# } else {\n# hyfo <- new(\"hyfo\", varName = x$Variable$varName, xyCoords = x$xyCoords, Dates = x$Dates, Data = x$Data)\n# \n# }\n# return(hyfo) \n# \n# })\n# \n", + "created" : 1446430652514.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1692451895", + "id" : "6706EE48", + "lastKnownWriteTime" : 1446430869, + "path" : "E:/1/R/hyfo/R/generics.R", + "project_path" : "R/generics.R", + "properties" : { + "tempName" : "Untitled1" + }, + "relative_order" : 13, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/6D3B375E b/.Rproj.user/D53FD3E6/sdb/per/t/6D3B375E new file mode 100644 index 0000000..1d2ca48 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/6D3B375E @@ -0,0 +1,17 @@ +{ + "contents" : "chooseDim <- function(array, dim, value, drop = FALSE) { \n # Create list representing arguments supplied to [\n # bquote() creates an object corresponding to a missing argument\n dimnames <- attributes(array)$dimensions\n \n indices <- rep(list(bquote()), length(dim(array)))\n indices[[dim]] <- value\n \n if (dim(array)[dim] < max(value)) {\n stop('Chosen member exceeds the member range of the dataset.')\n }\n \n # Generate the call to [\n call <- as.call(c(\n list(as.name(\"[\"), quote(array)),\n indices,\n list(drop = drop)))\n # Print it, just to make it easier to see what's going on\n # Print(call)\n \n # Finally, evaluate it\n output <- eval(call)\n \n if (length(dim(output)) == length(dimnames)) {\n attributes(output)$dimensions <- dimnames\n } else if (length(dim(output)) < length(dimnames)){\n \n # In this case, one dimension is dropped, if value is a number \n # and drop == T, this situation can appear. So the dropped dimemsion\n # should be the chosen dimension.\n i <- 1:length(dimnames)\n # get rid of the dropped dimensin\n i <- i[-dim]\n attributes(output)$dimensions <- dimnames[i]\n }\n \n return(output)\n}\n\n\nadjustDim <- function(data, ref = 'no') {\n # input data is an array\n # ref is the Data part of a hyfo file, used as reference\n # Further may be arranged into a seperate function\n # the input reference will be put at first, then the rest \n if (is.null(data)) return(NULL)\n if (identical(ref, 'no')) {\n # Default\n refOrder <- c('lon', 'lat', 'time')\n } else if (is.character(ref)) {\n refOrder <- ref\n } else {\n # Get dimension from input\n refOrder <- attributes(ref)$dimensions\n }\n \n att <- attributes(data)$dimensions\n if (is.null(att)) stop('No dimnames in the input data attributes, please use loadNcdf to load data.')\n if (identical(att, refOrder)) return(data)\n \n dimIndex <- seq(1, length(att))\n dimIndex1 <- na.omit(match(refOrder, att))# match can apply to simple cases\n \n \n # for array this works, or setdiff can be used here to find the nomatch element.\n dimIndex2 <- dimIndex[-dimIndex1]# choose nomatch\n \n \n data <- aperm(data, c(dimIndex1, dimIndex2))\n attributes(data)$dimensions <- att[c(dimIndex1, dimIndex2)]\n \n return(data)\n}\n\n# Belong to checkDimLength\ncalcuDim <- function(data, dim) {\n dimIndex <- match(dim, attributes(data)$dimensions)\n dimLength <- dim(data)[dimIndex]\n return(dimLength)\n}\n", + "created" : 1446430022323.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3136326352", + "id" : "6D3B375E", + "lastKnownWriteTime" : 1446430243, + "path" : "E:/1/R/hyfo/R/array_dimension.R", + "project_path" : "R/array_dimension.R", + "properties" : { + }, + "relative_order" : 11, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/76FD9DF7 b/.Rproj.user/D53FD3E6/sdb/per/t/76FD9DF7 deleted file mode 100644 index a6518ff..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/76FD9DF7 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Get spatial map of the input dataset.\n#' \n#' @param dataset A list containing different information, should be the result of reading netcdf file using\n#' \\code{library(ecomsUDG.Raccess)}.\n#' @param method A string showing different calculating method for the map. More information please refer to\n#' details.\n#' @param member A number showing which member is selected to get, if the dataset has a \"member\" dimension. Default\n#' is NULL, if no member assigned, and there is a \"member\" in dimensions, the mean value of the members will be\n#' taken.\n#' @param ... several arguments including x, y, title, catchment, point, output, name, info, scale, color, \n#' type in \\code{?getSpatialMap_mat} for details.\n#' @return A matrix representing the raster map is returned, and the map is plotted.\n#' @details\n#' There are following methods to be selected, \n#' \"meanAnnual\": annual rainfall of each year is plotted. \n#' \"winter\", \"spring\", \"autumn\", \"summer\": MEAN seasonal rainfall of each year is plotted.\n#' Month(number 1 to 12): MEAN month rainfall of each year is plotted, e.g. MEAN march rainfall of each year.\n#' \"mean\", \"max\", \"min\": mean daily, maximum daily, minimum daily precipitation.\n#' @examples\n#' \n#' #gridData provided in the package is the result of \\code {loadGridData{ecomsUDG.Raccess}}\n#' data(tgridData)\n#' getSpatialMap(tgridData, method = 'meanAnnual')\n#' getSpatialMap(tgridData, method = 'winter')\n#' \n#' \n#' getSpatialMap(tgridData, method = 'winter', catchment = testCat)\n#' \n#' file <- system.file(\"extdata\", \"point.txt\", package = \"hyfo\")\n#' point <- read.table(file, header = TRUE, sep = ',' )\n#' getSpatialMap(tgridData, method = 'winter', catchment = testCat, point = point)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\ngetSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) {\n\n #check input dataset\n checkHyfo(dataset)\n \n #range of the dataset just loaded \n lon <- dataset$xyCoords$x\n lat <- dataset$xyCoords$y\n startTime <- as.POSIXlt(dataset$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <-startTime$mon + 1\n data <- dataset$Data\n \n # Dimension needs to be arranged. Make sure first and second dimension is lat and lon.\n # Further may be arranged into a seperate function\n att <- attributes(data)$dimensions\n if (is.null(att)) stop('No dimnames for the input data, please use loadNcdf to load data.')\n dimIndex <- seq(1, length(att))\n dimIndex1 <- match(c('lon', 'lat', 'time'), att)# match can apply to simple cases\n \n # for array this works, or setdiff can be used here to find the nomatch element.\n dimIndex2 <- dimIndex[-dimIndex1]# choose nomatch\n \n \n data <- aperm(data, c(dimIndex1, dimIndex2))\n attributes(data)$dimensions <- att[c(dimIndex1, dimIndex2)]\n \n # Because in the following part, only 3 dimensions are allowed, so data has to be processed.\n if (member == 'mean' & any(attributes(data)$dimensions == 'member')) {\n dimIndex3 <- which(attributes(data)$dimensions != 'member')\n data <- apply(data, MARGIN = dimIndex3, FUN = mean, na.rm = TRUE)\n message('Mean value of the members are returned.')\n \n } else if (member != 'mean' & any(attributes(data)$dimensions == 'member')) {\n dimIndex3 <- which(attributes(data)$dimensions == 'member')\n data <- chooseDim(data, dimIndex3, member, drop = TRUE)\n \n } else if (member != 'mean' & !any(attributes(data)$dimensions == 'member')){\n stop('There is no member part in the dataset, but you choose one, check the input\n dataset or change your arguments.')\n }\n \n \n \n \n if (is.null(method)) {\n \n warning('You should shoose a method, unless input is a matrix directly to be plotted.')\n #in case the dataset is ready to plot and no need to calculate\n \n } else if (method == 'meanAnnual') { \n #mean value of the annual precipitation over the period of the data \n #time <- proc.time()\n if (length(unique(monthIndex)) < 12) {\n warning ('There are less than 12 months in a year, the results may be inaccurate.')\n }\n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, method = 'annual')\n #newTime <- proc.time() - time\n title_d <- 'Mean Annual Precipitation (mm / year)'\n \n } else if (method == 'winter') {\n #mean value of the seasonal precipitation, in this case, winter \n #time <- proc.time()\n wm <- match(c(12, 1, 2), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop ('Winter has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, monthIndex = monthIndex, \n method = 'winter')\n #newTime <- proc.time() - time\n title_d <- 'Mean Winter Precipitation (mm / winter)'\n \n } else if (method == 'spring') {\n wm <- match(c(3, 4, 5), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop ('Spring has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, monthIndex = monthIndex, \n method = 'spring') \n title_d <- 'Mean Spring Precipitation (mm / spring)'\n \n } else if (method == 'summer') {\n wm <- match(c(6, 7, 8), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop ('Summer has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, monthIndex = monthIndex, \n method = 'summer') \n title_d <- 'Mean Summer Precipitation (mm / summer)'\n \n } else if (method == 'autumn') {\n \n wm <- match(c(9, 10, 11), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop ('Autumn has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, monthIndex = monthIndex, \n method = 'autumn') \n title_d <- 'Mean Autumn Precipitation (mm / autumn)'\n \n } else if (method == 'mean') {\n \n #sum value of the dataset, this procedure is to get the mean value\n data_new <- apply(data, MARGIN = c(2, 1), FUN = mean, na.rm = TRUE)\n title_d <- 'Mean Daily Precipitation (mm / day)'\n \n } else if (method == 'max') {\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = suppressWarnings(max), na.rm = TRUE)\n title_d <- 'Max Daily Precipitation (mm / day)'\n \n } else if (method == 'min') {\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = suppressWarnings(min), na.rm = TRUE)\n title_d <- 'Min Daily Precipitation (mm / day)'\n \n } else if (is.numeric(method)) {\n \n data_new <- apply(data, MARGIN = c(2, 1), FUN = getMeanPreci, yearIndex = yearIndex, monthIndex = monthIndex, \n method = method) \n title_d <- paste(month.abb[method], 'Precipitation (mm / month)', sep = ' ')\n \n } else {\n wrongMethod <- method\n stop(paste('no method called', wrongMethod))\n }\n # This is to give attributes to the matrix and better be melted in ggplot.\n colnames(data_new) <- round(lon, 2)\n rownames(data_new) <- round(lat, 2)\n \n # If ... also has a title argument, this will cause conflicts. so title has to be renamed as title_d\n # This has to be paid a lot of attention when use ... to pass arguments.\n output <- getSpatialMap_mat(matrix = data_new, title_d = title_d, ...)\n return(output)\n}\n\n\n\n\n\n#' Replot raster matrix\n#' \n#' replot the matrix output from \\code{getSpatialMap}, when \\code{output = 'data'} or output is default\n#' value.\n#' \n#' @param matrix A matrix raster, should be the result of \\code{getSpatialMap()}, output should be default\n#' or 'data'\n#' @param title_d A string showing the title of the plot, defaut is NULL.\n#' @param catchment A catchment file geting from \\code{shp2cat()} in the package, if a catchment is available for background.\n#' @param point A dataframe, showing other information, e.g., location of the gauging stations. The \n#' the data.frame should be with columes \"name, lon, lat, z, value\".\n#' @param output A string showing the type of the output, if \\code{output = 'ggplot'}, the returned \n#' data can be used in ggplot and \\code{getSpatialMap_comb()}; if \\code{output = 'plot'}, the returned data is the plot containing all \n#' layers' information, and can be plot directly or used in grid.arrange; if not set, the raster matrix data\n#' will be returned.\n#' @param name If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\n#' different outputs in the later multiplot using \\code{getSpatialMap_comb}.\n#' @param info A boolean showing whether the information of the map, e.g., max, mean ..., default is FALSE.\n#' @param scale A string showing the plot scale, 'identity' or 'sqrt'.\n#' @param color Most of time you don't have to set this, but if you are not satisfied with the \n#' default color, you can set your own palette here. e.g., \\code{color = c('red', 'blue')}, then\n#' the value from lowest to highest, will have the color from red to blue. More info about color,\n#' please check ?palette().\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#'default is about precipitation.\n#' @return A matrix representing the raster map is returned, and the map is plotted.\n#' @examples\n#' data(tgridData)# the result of \\code{loadNcdf}\n#' #the output type of has to be default or 'data'.\n#' a1 <- getSpatialMap(tgridData, method = 'mean')\n#' a2 <- getSpatialMap(tgridData, method = 'max')\n#' a3 <- getSpatialMap(tgridData, method = 'winter')\n#' a4 <- getSpatialMap(tgridData, method = 'summer')\n#' #For example, if we want to investigate the difference between mean value and max.\n#' \n#' a5 <- a2 - a1\n#' getSpatialMap_mat(a4)\n#' \n#' #Or to investigate the difference between winter value and summer value.\n#' a6 <- a3 - a4\n#' getSpatialMap_mat(a6)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ggplot2 plyr maps maptools rgeos\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @references \n#' \n#' \\itemize{\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' \n#' \\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n#' 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/.\n#' \n#' \\item Hadley Wickham (2011). The Split-Apply-Combine Strategy for Data Analysis. Journal of Statistical\n#' Software, 40(1), 1-29. URL http://www.jstatsoft.org/v40/i01/.\n#' \n#' \\item Original S code by Richard A. Becker and Allan R. Wilks. R version by Ray Brownrigg. Enhancements\n#' by Thomas P Minka (2015). maps: Draw Geographical Maps. R package version\n#' 2.3-11. http://CRAN.R-project.org/package=maps\n#' \n#' \\item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial\n#' Objects. R package version 0.8-36. http://CRAN.R-project.org/package=maptools\n#' \n#' \\item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R\n#' package version 0.3-11. http://CRAN.R-project.org/package=rgeos\n#' \n#' }\n#' \n#' \n#' \n#' \n#' \ngetSpatialMap_mat <- function(matrix, title_d = NULL, catchment = NULL, point = NULL, output = 'data', \n name = NULL, info = FALSE, scale = 'identity', color = NULL, ...) {\n #check input\n checkWord <- c('lon', 'lat', 'z', 'value')\n if (is.null(attributes(matrix)$dimnames)) {\n stop('Input matrix is incorrect, check help to know how to get the matrix.')\n } else if (!is.null(catchment) & class(catchment) != \"SpatialPolygonsDataFrame\") {\n stop('Catchment format is incorrect, check help to get more details. ')\n } else if (!is.null(point) & any(is.na(match(checkWord, attributes(point)$names)))) {\n stop('point should be a dataframe with colnames \"lon, lat, z, value\".')\n }\n \n #ggplot\n #for the aes option in ggplot, it's independent from any other command through all ggplot, and aes() function\n #get data from the main dataset, in this case, data_ggplot. for other functions in ggplot, if it wants to use \n #data from the main dataset as parameters, it has to use aes() function. if not, it has to use data available \n #in the environment.\n #in other words, all the parameters in aes(), they have to come from the main dataset. Otherwise, just put them\n #outside aes() as normal parameters.\n \n if (info == TRUE) { \n plotMax <- round(max(matrix, na.rm = TRUE), 2)\n plotMin <- round(min(matrix, na.rm = TRUE), 2)\n plotMean <- round(mean(matrix, na.rm = TRUE), 2)\n plotMedian <- round(median(matrix, na.rm = TRUE), 2)\n word <- paste('\\n\\n', paste('Max', '=', plotMax), ',', paste('Min', '=', plotMin), ',',\n paste('Mean', '=', plotMean), ',', paste('Median', '=', plotMedian))\n } else {\n word <- NULL\n }\n \n x_word <- paste('Longitude', word)\n world_map <- map_data('world')\n \n # For some cases, matrix has to be reshaped, because it's too fat or too slim, to make\n # it shown on the map, the ratio is x : y is 4 : 3.\n matrix <- reshapeMatrix(matrix)\n \n \n # cannot remove NA, or the matrix shape will be changed.\n data_ggplot <- melt(matrix, na.rm = FALSE) \n \n colnames(data_ggplot) <- c('lat', 'lon', 'value')\n theme_set(theme_bw())\n \n if (is.null(color)) color <- c('yellow', 'orange', 'red')\n # if (is.null(color)) color <- rev(rainbow(n = 20, end = 0.7))\n \n mainLayer <- with(data_ggplot, {\n \n ggplot(data = data_ggplot) +\n geom_tile(aes(x = lon, y = lat, fill = value)) +\n #scale_fill_discrete()+\n scale_fill_gradientn(colours = color, na.value = 'transparent') +#usually scale = 'sqrt'\n #guide = guide_colorbar, colorbar and legend are not the same.\n guides(fill = guide_colourbar(title='Rainfall (mm)', barheight = rel(9), trans = scale)) +#usually scale = 'sqrt'\n geom_map(data = world_map, map = world_map, aes(map_id = region), fill = 'transparent', \n color='black') +\n # guides(fill = guide_colorbar(title='Rainfall (mm)', barheight = 15))+\n xlab(x_word) +\n ylab('Latitude') +\n ggtitle(title_d) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = rel(1.8), face = 'bold'),\n axis.title.x = element_text(size = rel(1.7)),\n axis.title.y = element_text(size = rel(1.7)),\n axis.text.x = element_text(size = rel(1.9)),\n axis.text.y = element_text(size = rel(1.9)),\n legend.text = element_text(size = rel(1.3)),\n legend.title = element_text(size = rel(1.3)))\n# coord_fixed(ratio = 1, xlim = xlim, ylim = ylim)\n \n# geom_rect(xmin=min(lon)+0.72*(max(lon)-min(lon)),\n# xmax=min(lon)+0.99*(max(lon)-min(lon)),\n# ymin=min(lat)+0.02*(max(lat)-min(lat)),\n# ymax=min(lat)+0.28*(max(lat)-min(lat)),\n# fill='white',colour='black')+\n# annotate('text', x = min(lon), y = min(lat), label=word, hjust = 0, vjust = -1)\n \n })\n \n printLayer <- mainLayer\n \n #catchment conversion\n if (is.null(catchment) == FALSE) {\n a <- catchment\n a@data$id <- rownames(a@data)\n b <- fortify(a, region = 'id')\n c <- join(b, a@data, by = 'id')\n catchmentLayer <- with(c, {\n geom_polygon(data = c, aes(long, lat, group = group), color = 'black', \n fill = 'transparent')\n })\n \n \n printLayer <- printLayer + catchmentLayer\n }\n #plot point\n if (is.null(point) == FALSE) {\n pointLayer <- with(point, {\n geom_point(data = point, aes(x = lon, y = lat, size = value, colour = z),\n guide = guide_legend(barheight = rel(3)))\n \n \n })\n \n printLayer <- printLayer + pointLayer\n }\n \n print(printLayer)\n \n if (output == 'ggplot') {\n if (is.null(name)) stop('\"name\" argument not found, \n If you choose \"ggplot\" as output, please assign a name.')\n data_ggplot$Name <- rep(name, dim(data_ggplot)[1])\n return (data_ggplot)\n } else if (output == 'plot') {\n return(printLayer)\n } else {\n return(matrix)\n }\n}\n\n\n#' Combine maps together\n#' @param ... different maps generated by \\code{getSpatialMap(, output = 'ggplot')}, see details.\n#' @param nrow A number showing the number of rows.\n#' @param list If input is a list containing different ggplot data, use \\code{list = inputlist}.\n#' @param x A string of x axis name.\n#' @param y A string of y axis name.\n#' @param title A string of the title.\n#' @param output A boolean, if chosen TRUE, the output will be given.\n#' @return A combined map.\n#' @examples\n#' data(tgridData)# the result of \\code{loadGridData{ecomsUDG.Raccess}}\n#' #The output should be 'ggplot'\n#' a1 <- getSpatialMap(tgridData, method = 'summer', output = 'ggplot', name = 'a1')\n#' a2 <- getSpatialMap(tgridData, method = 'winter', output = 'ggplot', name = 'a2')\n#'# a3 <- getSpatialMap(tgridData, method = 'mean', output = 'ggplot', name = 'a3')\n#'# a4 <- getSpatialMap(tgridData, method = 'max', output = 'ggplot', name = 'a4')\n#' getSpatialMap_comb(a1, a2)\n#' \n#' # or you can put them into a list.\n#' getSpatialMap_comb(list = list(a1, a2), nrow = 2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @details\n#' For \\code{getSpatialMap_comb}, the maps to be compared should be with same size and resolution, \n#' in other words, they should be fully overlapped by each other.\n#' \n#' If they have different resolutions, use \\code{interpGridData{ecomsUDG.Raccess}} to interpolate.\n#' \n#' @export\n#' @import ggplot2 maps\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' }\ngetSpatialMap_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title = '', \n output = FALSE) {\n \n \n if (!is.null(list)) {\n data_ggplot <- do.call('rbind', list)\n } else {\n maps <- list(...)\n checkBind(maps, 'rbind')\n data_ggplot <- do.call('rbind', maps)\n }\n \n if (!class(data_ggplot) == 'data.frame') {\n warning('Your input is probably a list, but you forget to add \"list = \" before it.\n Try again, or check help for more information.')\n } else if (is.null(data_ggplot$Name)) {\n stop('No \"Name\" column in the input data, check the arguments in getSpatialMap(), if \n output = \"ggplot\" is assigned, more info please check ?getSpatialMap().')\n }\n \n data_ggplot$Name <- factor(data_ggplot$Name, levels = data_ggplot$Name, ordered = TRUE)\n \n# lim <- getLim(data_ggplot$lon, data_ggplot$lat)\n# xlim <- lim[[1]] \n# ylim <- lim[[2]]\n \n world_map <- map_data('world')\n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) + \n geom_tile(aes(x = lon, y = lat, fill = value)) +\n #scale_fill_gradient(high = 'red', low = 'yellow')+\n scale_fill_gradientn(colours = c('yellow', 'orange', 'red'), na.value = 'transparent') +#usually scale = 'sqrt'\n geom_map(data = world_map, map = world_map, aes(map_id = region), fill = 'transparent', color = 'black') +\n# guides(fill = guide_colourbar(title='Rainfall (mm)', barheight = rel(9), trans = scale)) +#\n facet_wrap(~ Name, nrow = nrow) +\n theme(plot.title = element_text(size = rel(1.8), face = 'bold'),\n axis.title.x = element_text(size = rel(1.7)),\n axis.title.y = element_text(size = rel(1.7)),\n axis.text.x = element_text(size = rel(1.9)),\n axis.text.y = element_text(size = rel(1.9)),\n legend.text = element_text(size = rel(1.3)),\n legend.title = element_text(size = rel(1.3))) +\n # no solultion for some very fat or very slim, in facet ggplot2, so, it's not buitiful.\n #coord_equal() +\n labs(x = x, y = y, title = title)\n })\n \n \n suppressWarnings(print(mainLayer))\n \n if (output == TRUE) return(data_ggplot)\n}\n\n\n\nreshapeMatrix <- function(matrix) {\n # This is for the map plot to keep the ratio x : y == 4:3\n # mainly used in map plot in ggplot2.\n \n \n # So the input matrix should be reshaped, add in some NA values, \n # in order to be shown appropriately in ggplot.\n \n lon <- as.numeric(colnames(matrix))\n lat <- as.numeric(rownames(matrix))\n \n dx <- mean(diff(lon))\n dy <- mean(diff(lat))\n \n lx <- max(lon) - min(lon)\n ly <- max(lat) - min(lat)\n \n \n if (0.75 * lx < ly) {\n # In this case, x needs to be made longer\n \n xhalf <- 0.67 * ly\n xadd <- xhalf - lx / 2\n # calculate how many columns needs to be added.\n nxadd <- abs(round(xadd / dx))\n \n madd1 <- matrix(data = NA, nrow = length(lat), ncol = nxadd)\n madd2 <- madd1\n colnames(madd1) <- seq(to = min(lon) - dx, length = nxadd, by = dx)\n colnames(madd2) <- seq(from = max(lon) + dx, length = nxadd, by = dx)\n \n matrix_new <- cbind(madd1, matrix, madd2) \n \n \n } else if (0.75 * lx > ly) {\n \n yhalf <- 0.38 * lx\n yadd <- yhalf - ly / 2\n nyadd <- abs(round(yadd / dy))\n \n madd1 <- matrix(data = NA, nrow = nyadd, ncol = length(lon))\n madd2 <- madd1 \n \n rownames(madd1) <- seq(to = max(lat) + dy, length = nyadd, by = -dy)\n rownames(madd2) <- seq(from = min(lat) - dx, length = nyadd, by = -dy)\n \n matrix_new <- rbind(madd1, matrix, madd2)\n \n } else {\n matrix_new <- matrix\n }\n \n return(matrix_new)\n}\n", - "created" : 1446291675072.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "427365761", - "id" : "76FD9DF7", - "lastKnownWriteTime" : 1444589349, - "path" : "E:/1/R/hyfo/R/getSpatialMap.R", - "project_path" : "R/getSpatialMap.R", - "properties" : { - }, - "relative_order" : 12, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/7C472C81 b/.Rproj.user/D53FD3E6/sdb/per/t/7C472C81 deleted file mode 100644 index 3a15d68..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/7C472C81 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "\n\n\n\n#' Get bias factor for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param hindcast a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the hindcast data. This data will be used in the calibration of the forecast, so it's better to have the same date period as\n#' observation data. Check details for more information.\n#' @param obs a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data.\n#' @param method bias correct method, including 'delta', 'scaling'...,default method is 'scaling'.\n#' @param scaleType only when the method \"scaling\" is chosen, scaleType will be available. Two different types\n#' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method, default is 'multi'. More info check \n#' details.\n#' @param preci If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\n#' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \n#' Default is FALSE, refer to details.\n#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).\n#' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\n#' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.\n#' \n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction.\n#' \\code{\\link{applyBiasFactor}}, for the second part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs)\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\n#' \n#' \n# debug by trace(\"getBiasFactor\", browser, exit=browser, signature = c(\"list\", \"list\"))\nsetGeneric('getBiasFactor', function(hindcast, obs, method = 'scaling', scaleType = 'multi', \n preci = FALSE, prThreshold = 0, extrapolate = 'no') {\n standardGeneric('getBiasFactor')\n})\n\n#' @describeIn getBiasFactor\nsetMethod('getBiasFactor', signature('data.frame', 'data.frame'), \n function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n \n if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n \n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # if condition only accepts one condition, for list comparison, there are a lot of conditions, better\n # further process it, like using any.\n if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) {\n warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in \n the calibration.')\n }\n n <- ncol(hindcast)\n \n # For every column, it's biascorrected respectively.\n biasFactor <- lapply(2:n, function(x) getBiasFactor_core(hindcast[, x], obs[, 2], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate))\n if (n - 1 > 1) {\n biasFactor_all <- new('biasFactor.multiMember', biasFactor = biasFactor, memberDim = n - 1,\n method = method, preci = preci, prThreshold = prThreshold, scaleType = scaleType, \n extrapolate = extrapolate)\n \n } else {\n biasFactor_all <- new('biasFactor', biasFactor = biasFactor, method = method, \n preci = preci, prThreshold = prThreshold, scaleType = scaleType, \n extrapolate = extrapolate)\n }\n \n return(biasFactor_all)\n })\n\n\n# This is for the grid file from downscaleR\n#' @describeIn getBiasFactor\n#' @importFrom methods new\nsetMethod('getBiasFactor', signature('list', 'list'), \n function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) {\n \n ## Check if the data is a hyfo grid data.\n checkHyfo(hindcast, obs)\n \n hindcastData <- hindcast$Data\n obsData <- obs$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n hindcastDim <- attributes(hindcastData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n checkDimLength(hindcastData, obsData, dim = c('lon', 'lat'))\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(hindcastData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n biasFactor_all <- vector(mode = \"list\", length = dim(hindcastData)[4])\n for (member in 1:dim(hindcastData)[4]) {\n biasFactor_all[[member]] <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[member]][[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2])\n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[member]][[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,, member], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n }\n \n biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci,\n prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, \n lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')),\n memberDim = calcuDim(hindcastData, dim = 'member'))\n } else {\n \n hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time'))\n \n biasFactor_all <- vector(mode = 'list', length = dim(hindcastData)[1])\n for (lon in 1:dim(hindcastData)[1]) {\n biasFactor_all[[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) \n for (lat in 1:dim(hindcastData)[2]) {\n biasFactor_all[[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,], obsData[lon, lat,], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate)\n }\n }\n biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci,\n prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, \n lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')))\n \n }\n \n })\n\n\n\n\n#' Apply bias factor to different forecasts for multi-bias correction or operational (real time) bias correction.\n#' \n#' When you do multi bias correction or operational (real time) bias correction. It's too expensive\n#' to input hindcast and obs every time. Especially when you have a long period of hindcast\n#' and obs, but only a short period of frc, it's too unecessary to read and compute hindcast\n#' and obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\n#' get the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \n#' apply the biasFactor to different forecasts. \n#' \n#' \n#' @param frc a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \n#' representing the frc data. Check details for more information.\n#' @param biasFactor a file containing all the information of the calibration, will be\n#' applied to different forecasts.\n#' @param obs for some methods, observation input is necessary. obs is a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \n#' representing the observation data. Default value is NULL.\n#' @seealso \\code{\\link{biasCorrect}} for method used in bias correction. \n#' \\code{\\link{getBiasFactor}}, for the first part.\n#' \n#' @details \n#' \n#' Information about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n#' \n#' \\strong{why use biasFactor}\n#' \n#' As for forecasting, for daily data, there is usually no need to have\n#' different bias factor every different day. You can calculate one bisa factor using a long\n#' period of hindcast and obs, and apply that factor to different frc.\n#' \n#' For example,\n#' \n#' You have 10 years of hindcast and observation. you want to do bias correction for some \n#' forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\n#' about the future 6 months. So if you want to do the real time bias correction, you have to\n#' take the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\n#' time you get a new forecast. That's too expensive.\n#' \n#' For some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\n#' Maybe for February and March, you can use the same biasFactor, no need to do the computation \n#' again. \n#' \n#' @examples \n#' \n#' ######## hyfo grid file biascorrection\n#' ########\n#' \n#' # If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect\n#' # the file.\n#' \n#' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' data(tgridData)\n#' \n#' # Then we will use nc data as forecasting data, and use itself as hindcast data,\n#' # use tgridData as observation.\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData)\n#' newFrc <- applyBiasFactor(nc, biasFactor)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\n#' preci = TRUE)\n#' # This method needs obs input.\n#' newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n#' \n#' biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\n#' newFrc <- applyBiasFactor(nc, biasFactor) \n#' \n#' \n#' ######## Time series biascorrection\n#' ########\n#' \n#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl.\n#' data(testdl)\n#' \n#' # common period has to be extracted in order to better train the forecast.\n#' \n#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' frc <- datalist[[1]]\n#' hindcast <- datalist[[2]]\n#' obs <- datalist[[3]]\n#' \n#' \n#' # The data used here is just for example, so there could be negative data.\n#' \n#' # default method is delta\n#' biasFactor <- getBiasFactor(hindcast, obs)\n#' frc_new <- applyBiasFactor(frc, biasFactor)\n#' \n#' # for precipitation data, extra process needs to be executed, so you have to tell\n#' # the program to it is a precipitation data.\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\n#' frc_new1 <- applyBiasFactor(frc, biasFactor)\n#' \n#' # You can use other methods to biascorrect, e.g. delta method. \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n#' # delta method needs obs input.\n#' frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' # \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n#' # eqm needs obs input\n#' frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n#' \n#' biasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\n#' frc_new4 <- applyBiasFactor(frc, biasFactor)\n#' \n#' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum')\n#' \n#' # You can also give name to this input list.\n#' TSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\n#' names(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\n#' plotTS(list = TSlist, plot = 'cum')\n#' \n#' \n#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g.,\n#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be \n#' # for example Dec, Jan and Feb of every year from year 1999-2005.\n#' # In such case, you need to extract certain months and years from observed time series.\n#' # extractPeriod() can be then used.\n#' \n#' \n#'\n#'\n#'\n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\n#' \n#' @author Yuanchao Xu \\email{xuyuanchao37@@gmail.com }, S. Herrera \\email{sixto@@predictia.es }\n#' \n#' @export\nsetGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) {\n standardGeneric('applyBiasFactor')\n})\n\n#' @describeIn applyBiasFactor\n#' @importFrom methods setMethod\nsetMethod('applyBiasFactor', signature('data.frame', 'biasFactor'), \n function(frc, biasFactor, obs) {\n method <- biasFactor@method\n preci <- biasFactor@preci\n prThreshold <- biasFactor@prThreshold\n scaleType <- biasFactor@scaleType\n extrapolate <- biasFactor@extrapolate\n memberDim <- biasFactor@memberDim\n biasFactor <- biasFactor@biasFactor\n \n \n # First check if the first column is Date\n if (!grepl('-|/', frc[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.If your input is a hyfo dataset, put input = \"hyfo\" as an\n argument, check help for more info.')\n }\n # change to date type is easier, but in case in future the flood part is added, Date type doesn't have\n # hour, min and sec, so, it's better to convert it into POSIxlt.\n \n # In this case more than one value columns exist in the dataset, both frc and hindcast.\n \n n <- ncol(frc)\n if (n-1 != memberDim) stop('frc and biasFactor have different members.')\n \n \n # For every column, it's biascorrected respectively.\n frc_data <- lapply(2:n, function(x) applyBiasFactor_core(frc[, x], biasFactor = biasFactor[[x - 1]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obs[, 2]))\n frc_data <- do.call('cbind', frc_data)\n rownames(frc_data) <- NULL\n \n names <- colnames(frc)\n frc_new <- data.frame(frc[, 1], frc_data)\n colnames(frc_new) <- names\n \n return(frc_new)\n })\n \n#' @describeIn applyBiasFactor\n#' @importFrom methods setMethod\nsetMethod('applyBiasFactor', signature('list', 'biasFactor.hyfo'), \n function(frc, biasFactor, obs) {\n method <- biasFactor@method\n preci <- biasFactor@preci\n prThreshold <- biasFactor@prThreshold\n scaleType <- biasFactor@scaleType\n extrapolate <- biasFactor@extrapolate\n lonLatDim <- biasFactor@lonLatDim\n memberDim <- biasFactor@memberDim\n biasFactor <- biasFactor@biasFactor\n \n ## Check if the data is a hyfo grid data.\n checkHyfo(frc)\n \n \n obsData <- obs$Data\n frcData <- frc$Data\n \n ## save frc dimension order, at last, set the dimension back to original dimension\n frcDim <- attributes(frcData)$dimensions\n \n ## ajust the dimension into general dimension order.\n obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time'))\n \n ## CheckDimLength, check if all the input dataset has different dimension length\n # i.e. if they all have the same lon and lat number.\n if (!identical(calcuDim(frcData, dim = c('lon', 'lat')), lonLatDim)) {\n stop('frc data has different lon and lat from hindcast data.')\n }\n \n \n # Now real bias correction is executed.\n \n memberIndex <- match('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (!is.na(memberIndex)) {\n # check if frcData and hindcastData has the same dimension and length.\n if (calcuDim(frcData, dim = 'member') != memberDim) {\n stop('frc data has different member number from hindcast.')\n } \n \n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member'))\n \n # The following code may speed up because it doesn't use for loop.\n # It firstly combine different array into one array. combine the time \n # dimension of frc, hindcast and obs. Then use apply, each time extract \n # the total time dimension, and first part is frc, second is hindcast, third\n # is obs. Then use these three parts to bias correct. All above can be written\n # in one function and called within apply. But too complicated to understand,\n # So save it for future use maybe.\n \n # for (member in 1:dim(frcData)[4]) {\n # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData),\n # dim = c(dim(frcData)[1], dim(frcData)[2], \n # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3]))\n # }\n \n \n for (member in 1:dim(frcData)[4]) {\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,, member] <- applyBiasFactor_core(frcData[lon, lat,,member], biasFactor = biasFactor[[member]][[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n } else {\n frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time'))\n for (lon in 1:dim(frcData)[1]) {\n for (lat in 1:dim(frcData)[2]) {\n frcData[lon, lat,] <- applyBiasFactor_core(frcData[lon, lat,], biasFactor = biasFactor[[lon]][[lat]], method = method,\n scaleType = scaleType, preci = preci, prThreshold = prThreshold, \n extrapolate = extrapolate, obs = obsData[lon, lat,])\n }\n }\n }\n \n frcData <- adjustDim(frcData, ref = frcDim)\n frc$Data <- frcData\n frc$biasCorrected_by <- method\n frc_new <- frc\n \n return(frc_new)\n })\n\n\n#################\n################# core functions for multi bias correction.\n\n#' @importFrom MASS fitdistr\n#' @importFrom stats ecdf quantile pgamma qgamma rgamma\n#' \n#' @references \n#' Bias correction methods come from \\code{biasCorrection} from \\code{dowscaleR}\n#' \n#' \\itemize{\n#' \n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R\n#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki\n#' \n#' \\item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887\n#' \n#' \\item A. Amengual, V. Homar, R. Romero, S. Alonso, and C. Ramis (2012) A Statistical Adjustment of Regional Climate Model Outputs to Local Scales: Application to Platja de Palma, Spain. J. Clim., 25, 939-957\n#' \n#' \\item C. Piani, J. O. Haerter and E. Coppola (2009) Statistical bias correction for daily precipitation in regional climate models over Europe, Theoretical and Applied Climatology, 99, 187-192\n#' \n#' \\item O. Gutjahr and G. Heinemann (2013) Comparing precipitation bias correction methods for high-resolution regional climate simulations using COSMO-CLM, Theoretical and Applied Climatology, 114, 511-529\n#' }\ngetBiasFactor_core <- function(hindcast, obs, method , scaleType, preci, prThreshold, extrapolate){\n # If the variable is precipitation, some further process needs to be added.\n # The process is taken from downscaleR, to provide a more reasonable hindcast, used in the calibration.\n \n \n # check if frc, hindcast or obs are all na values\n if (!any(!is.na(obs)) | !any(!is.na(hindcast))) {\n warning('In this cell, hindcast or obs data is missing. No biasCorrection for this cell.')\n return(NA)\n } \n \n if (preci == TRUE) {\n preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold)\n hindcast <- preprocessHindcast_res[[1]]\n minHindcastPreci <- preprocessHindcast_res[[2]]\n }\n \n # default is the simplest method in biascorrection, just do simple addition and subtraction.\n if (method == 'delta') {\n biasFactor <- getBiasFactor_core_delta(hindcast)\n } else if (method == 'scaling') {\n biasFactor <- getBiasFactor_core_scaling(hindcast, obs, scaleType)\n } else if (method == 'eqm') {\n # In this method, the value is bounded by the observation\n # Preci or not both have the same biasFactor\n if (preci == FALSE) {\n biasFactor <- getBiasFactor_core_eqm_nonPreci(hindcast, obs, extrapolate)\n } else {\n biasFactor <- getBiasFactor_core_eqm_preci(hindcast, obs, minHindcastPreci, extrapolate, prThreshold)\n }\n \n \n } else if (method == 'gqm') {\n if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T')\n biasFactor <- getBiasFactor_core_gqm(hindcast, obs, prThreshold, minHindcastPreci)\n }\n \n if (preci == TRUE) biasFactor$minHindcastPreci <- minHindcastPreci\n \n return(biasFactor)\n}\n\n\napplyBiasFactor_core <- function(frc, biasFactor, method, preci, prThreshold, scaleType,\n extrapolate, obs = NULL) {\n \n if (!any(!is.na(biasFactor))) {\n warning('In this cell, biasFactor is missing.No biasCorrection for this cell.')\n # here return NA or return the unprocessed frc, both are OK. But return NA is more\n # obvious for user.\n return(NA)\n }\n \n if (method == 'delta') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.')\n frc <- applyBiasFactor_core_delta(frc = frc, biasFactor = biasFactor, obs = obs)\n } else if (method == 'scaling') {\n frc <- applyBiasFactor_core_scaling(frc = frc, biasFactor = biasFactor, scaleType = scaleType)\n } else if (method == 'eqm') {\n if (is.null(obs)) stop('This method needs obs input.')\n if (preci == FALSE) {\n frc <- applyBiasFactor_core_eqm_nonPreci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n obs = obs)\n } else {\n frc <- applyBiasFactor_core_eqm_preci(frc = frc, biasFactor = biasFactor, extrapolate = extrapolate, \n prThreshold = prThreshold, obs = obs)\n }\n } else if (method == 'gqm') {\n frc <- applyBiasFactor_core_gqm(frc = frc, biasFactor = biasFactor)\n }\n \n return(frc)\n}\n\n\ngetBiasFactor_core_delta <- function(hindcast) {\n biasFactor <- list()\n biasFactor$hindcastMean <- mean(hindcast, na.rm = TRUE)\n return(biasFactor)\n}\napplyBiasFactor_core_delta <- function(frc, biasFactor, obs) {\n hindcastMean <- biasFactor$hindcastMean\n frcMean <- mean(frc, na.rm = TRUE)\n return(obs - hindcastMean + frcMean)\n}\n\ngetBiasFactor_core_scaling <- function(hindcast, obs, scaleType) {\n biasFactor <- list()\n \n hindcastMean <- mean(hindcast, na.rm = TRUE)\n obsMean <- mean(obs, na.rm = TRUE)\n \n if (scaleType == 'multi') {\n biasFactor$scale <- obsMean / hindcastMean\n \n } else if (scaleType == 'add') {\n biasFactor$scale <- obsMean - hindcastMean\n }\n \n return(biasFactor)\n}\n\napplyBiasFactor_core_scaling <- function(frc, biasFactor, scaleType) {\n \n if (scaleType == 'multi') {\n frc <- frc * biasFactor$scale\n \n } else if (scaleType == 'add') {\n frc <- frc + biasFactor$scale\n }\n return(frc)\n}\n\ngetBiasFactor_core_eqm_nonPreci <- function(hindcast, obs, extrapolate) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast)\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, na.rm = TRUE)\n }\n \n return(biasFactor)\n}\n\ngetBiasFactor_core_eqm_preci <- function(hindcast, obs, minHindcastPreci, extrapolate,\n prThreshold) {\n \n biasFactor <- list()\n biasFactor$ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci])\n \n if (extrapolate == 'constant') {\n biasFactor$maxHindcast <- max(hindcast, na.rm = TRUE)\n biasFactor$minHindcast <- min(hindcast, na.rm = TRUE)\n biasFactor$higherIndex_dif <- biasFactor$maxHindcast - max(obs, na.rm = TRUE)\n biasFactor$lowerIndex_dif <- biasFactor$minHindcast - min(obs, nna.rm = TRUE)\n }\n biasFactor$availableHindcastLength <- length(which(hindcast > minHindcastPreci))\n \n # drizzle parameter 1\n biasFactor$drizzleP1 <- min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE)\n # biasFactor$prThreshold <- prThreshold\n return(biasFactor)\n}\n\napplyBiasFactor_core_eqm_nonPreci <- function(frc, biasFactor, extrapolate, obs) {\n ecdfHindcast <- biasFactor$ecdfHindcast\n \n if (extrapolate == 'constant') {\n higherIndex <- which(frc > biasFactor$maxHindcast)\n lowerIndex <- which(frc < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(frc), extrapolateIndex)\n \n # In case extrapolateIndex is of length zero, than extrapolate cannot be used afterwards\n # So use setdiff(1:length(sim), extrapolateIndex), if extrapolateIndex == 0, than it will\n # return 1:length(sim)\n \n if (length(higherIndex) > 0) {\n \n frc[higherIndex] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n \n frc[lowerIndex] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n frc[non_extrapolateIndex] <- quantile(obs, probs = ecdfHindcast(frc[non_extrapolateIndex]), \n na.rm = TRUE, type = 4)\n } else {\n frc <- quantile(obs, probs = ecdfHindcast(frc), na.rm = TRUE, type = 4)\n }\n return(frc)\n}\n\n#' @importFrom stats quantile\napplyBiasFactor_core_eqm_preci <- function(frc, biasFactor, extrapolate, prThreshold, obs) {\n \n # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be\n # always hindcast > minHindcastPreci exists.\n # Unless one condition that minHindcastPreci is the max in the hindcast, than on hindcast > minHindcastPreci\n if (biasFactor$availableHindcastLength > 0) {\n \n ecdfHindcast <- biasFactor$ecdfHindcast\n \n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n # drizzle is to see whether there are some precipitation between the min frc (over threshold) and \n # min hindcast (over threshold).\n drizzle <- which(frc > biasFactor$minHindcastPreci & frc <= biasFactor$drizzleP1 & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n \n if (extrapolate == 'constant') {\n \n # This higher and lower index mean the extrapolation part\n higherIndex <- which(frc[rain] > biasFactor$maxHindcast)\n lowerIndex <- which(frc[rain] < biasFactor$minHindcast)\n \n extrapolateIndex <- c(higherIndex, lowerIndex)\n non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex)\n \n if (length(higherIndex) > 0) {\n frc[rain[higherIndex]] <- frc[higherIndex] - biasFactor$higherIndex_dif\n }\n \n if (length(lowerIndex) > 0) {\n frc[rain[lowerIndex]] <- frc[lowerIndex] - biasFactor$lowerIndex_dif\n }\n \n \n # Here the original function doesn't accout for the situation that extraploateIndex is 0\n # if it is 0, rain[-extraploateIndex] would be nothing\n \n # Above has been solved by using setdiff.\n frc[rain[non_extrapolateIndex]] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain[non_extrapolateIndex]]), \n na.rm = TRUE, type = 4)\n \n } else {\n \n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], \n probs = ecdfHindcast(frc[rain]), na.rm = TRUE, type = 4)\n }\n }\n if (length(drizzle) > 0){\n \n # drizzle part is a seperate part. it use the ecdf of frc (larger than minHindcastPreci) to \n # biascorrect the original drizzle part \n frc[drizzle] <- quantile(frc[which(frc > biasFactor$drizzleP1 & !is.na(frc))], \n probs = ecdfFrc(frc[drizzle]), na.rm = TRUE, \n type = 4)\n }\n \n frc[noRain] <- 0\n \n } else {\n # in this condition minHindcastPreci is the max of hindcast, so all hindcast <= minHindcastPreci\n # And frc distribution is used then.\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n \n if (length(rain) > 0) {\n ecdfFrc <- ecdf(frc[rain])\n frc[rain] <- quantile(obs[which(obs > prThreshold & !is.na(obs))], probs = ecdfFrc(frc[rain]), \n na.rm = TRUE, type = 4)\n }\n frc[noRain]<-0\n }\n return(frc)\n}\n\n#' @importFrom MASS fitdistr\ngetBiasFactor_core_gqm <- function(hindcast, obs, prThreshold, minHindcastPreci) {\n if (any(obs > prThreshold)) {\n biasFactor <- list()\n ind <- which(obs > prThreshold & !is.na(obs))\n obsGamma <- fitdistr(obs[ind],\"gamma\")\n biasFactor$obsShape <- obsGamma$estimate[1]\n biasFactor$obsRate <- obsGamma$estimate[2]\n \n ind <- which(hindcast > 0 & !is.na(hindcast))\n hindcastGamma <- fitdistr(hindcast[ind],\"gamma\")\n biasFactor$hindcastShape <- hindcastGamma$estimate[1]\n biasFactor$hindcastRate <- hindcastGamma$estimate[2]\n biasFactor$minHindcastPreci <- minHindcastPreci\n \n } else {\n warning('All the observations of this cell(station) are lower than the threshold, \n no biasFactor returned.')\n biasFactor <- NA\n }\n return(biasFactor)\n}\n\n#' @importFrom stats pgamma qgamma\napplyBiasFactor_core_gqm <- function(frc, biasFactor) {\n \n rain <- which(frc > biasFactor$minHindcastPreci & !is.na(frc))\n noRain <- which(frc <= biasFactor$minHindcastPreci & !is.na(frc))\n \n probF <- pgamma(frc[rain], biasFactor$hindcastShape, rate = biasFactor$hindcastRate)\n frc[rain] <- qgamma(probF, biasFactor$obsShape, rate = biasFactor$obsRate)\n frc[noRain] <- 0\n \n return(frc)\n}", - "created" : 1446238542492.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "590667081", - "id" : "7C472C81", - "lastKnownWriteTime" : 1446291003, - "path" : "E:/1/R/hyfo/R/multi-biasCorrect(generic).R", - "project_path" : "R/multi-biasCorrect(generic).R", - "properties" : { - }, - "relative_order" : 8, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/7FAF7171 b/.Rproj.user/D53FD3E6/sdb/per/t/7FAF7171 deleted file mode 100644 index 41e08f8..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/7FAF7171 +++ /dev/null @@ -1,18 +0,0 @@ -{ - "contents" : "# \n# print <- function(object, ...) {\n# UseMethod('print')\n# }\n# \n# print.biasFactor <- function(object, ...) {\n# msg <- paste('biasFactor of method ', object@method)\n# if (length(object@memberDim)) msgM <- paste('There are', object@memberDim, 'members existing in the forecasting data.')\n# return(c(msg, msgM))\n# }\n\n#' #### Generics of biasFactor\n# @param object biasFactor object\n# @export\n# setGeneric('print', function(object) {\n# standardGeneric('print')\n# })\n# \n# \n# setMethod('print', signature('biasFactor'), function(object) {\n# msg <- paste('biasFactor of method ', object@method)\n# if (length(object@memberDim)) msgM <- paste('There are', object@memberDim, 'members existing in the forecasting data.')\n# return(c(msg, msgM))\n# })\n\n# #' @export\n# #' @param a biasFactor object\n# size <- function(x, ...) {\n# UseMethod('size', x)\n# }\n# \n# #' @describeIn size\n# size.biasFactor <-function(object) {\n# if (length(object@lonLatDim) == 0) {\n# return (1)\n# } else {\n# lonLat <- object@lonLatDim\n# msg <- paste('Grid file with', lonLat[1], 'grids in longitude, ', lonLat[2], 'grids in latitude.')\n# return(msg)\n# }\n# }\n\n##### hyfo\n\n# hyfo, TS and datalist should be three kinds of objects, so that many functions in hyfo can be split\n# into different generic methods, then no need to set up input = TS or input = hyfo.\n# But too much work to re-construct all the functions.\n\n# For new methods, it should set up different generic methods for hyfo, TS, and grid file from \n# downscaleR.\n", - "created" : 1446239993498.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "782457068", - "id" : "7FAF7171", - "lastKnownWriteTime" : 1446409776, - "path" : "E:/1/R/hyfo/R/generics.R", - "project_path" : "R/generics.R", - "properties" : { - "tempName" : "Untitled1" - }, - "relative_order" : 9, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/A952284D b/.Rproj.user/D53FD3E6/sdb/per/t/A952284D new file mode 100644 index 0000000..cebc6e2 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/A952284D @@ -0,0 +1,17 @@ +{ + "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' @param dataset A list containing different information, should be the result of reading netcdf file using\n#' \\code{loadNcdf}, or load functions from \\code{ecomsUDG.Raccess}\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\n#' @param TS A time series, with first column the Date, second the value. If TS is not empty, \n#' hyfo will take data from TS, not consider dataset, so you should only have one input, dataset\n#' or the time series. If your input is a time series, \\code{TS = yourTS} has to be put as an argument,\n#' or the program may take it as a dataet, and will give an error. TS can be an ENSEMBLE containning \n#' different members. Than the mean value will be given and the range will be given.\n#' @param cell A vector containing the locaton of the cell, e.g. c(2, 3), default is \"mean\", representing\n#' the spatially averaged value. Check details for more information.\n#' @param output A string showing the type of the output, if \\code{output = 'ggplot'}, the returned \n#' data can be used in ggplot and \\code{getPreciBar_comb()}; if \\code{output = 'plot'}, the returned data is the plot containing all \n#' layers' information, and can be plot directly or used in grid.arrange; if not set, the data\n#' will be returned.\n#' @param name If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\n#' different outputs in the later multiplot using \\code{getSpatialMap_comb}.\n#' @param plotRange A boolean showing whether the range will be plotted.\n#' @param member A number showing which member is selected to get, if the dataset has a \"member\" dimension. Default\n#' is NULL, if no member assigned, and there is a \"member\" in dimensions, the mean value of the members will be\n#' taken.\n#' @param omitNA A boolean showing whether the missing value is omitted.\n#' @param info A boolean showing whether the information of the map, e.g., max, mean ..., default is FALSE.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @details\n#' There are following methods to be selected, \n#' \"annual\": annual rainfall of each year is plotted. \n#' \"winter\", \"spring\", \"autumn\", \"summer\": seasonal rainfall of each year is plotted.\n#' Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfall of each year.\n#' \"meanMonthly\": the mean monthly rainfall of each month over the whole period.\n#' \n#' #Since \"winter\" is a crossing year, 12, 1, 2, 12 is in former year, and 1, 2 are in latter year.\n#' #so winter belongs to the latter year.\n#' \n#' \n#' \\code{cell} representing the location of the cell, NOTE: this location means the index of the cell,\n#' IT IS NOT THE LONGITUDE AND LATITUDE. e.g., \\code{cell = c(2, 3)}, the program will take the 2nd longitude\n#' and 3rd latitude, by the increasing order. Longitude comes first.\n#' \n#' @examples\n#' #gridData provided by package is the result of \\code{loadNcdf()}\n#' data(tgridData)\n#' b1 <- getPreciBar(tgridData, method = 'annual')\n#' b2 <- getPreciBar(tgridData, method = 'meanMonthly')\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\n#' @references \n#' \n#' \n#' \\itemize{\n#' \\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n#' 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/.\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#'\n#' \n#' @return The calculated mean value of the input time series and the plot of the result.\n#' @export\ngetPreciBar <- function(dataset, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, TS = NULL, info = FALSE,\n ...) {\n \n if (is.null(TS)) {\n #check input dataset\n checkHyfo(dataset)\n \n startTime <- as.POSIXlt(dataset$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n data <- dataset$Data\n \n # Dimension needs to be arranged. Make sure first and second dimension is lat and lon.\n data <- adjustDim(data, ref = c('lon', 'lat', 'time'))\n \n # Because in the following part, only 3 dimensions are allowed, so data has to be processed.\n if (is.null(member) & any(attributes(data)$dimensions == 'member')) {\n dimIndex3 <- which(attributes(data)$dimensions != 'member')\n data <- apply(data, MARGIN = dimIndex3, FUN = mean, na.rm = TRUE)\n } else if (!is.null(member) & any(attributes(data)$dimensions == 'member')) {\n dimIndex3 <- which(attributes(data)$dimensions == 'member')\n data <- chooseDim(data, dimIndex3, member, drop = TRUE)\n } else if (!is.null(member) & !any(attributes(data)$dimensions == 'member')){\n stop('There is no member part in the dataset, but you choose one, check the input\n dataset or change your arguments.')\n }\n \n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n\n } else {\n \n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n n <- ncol(TS) - 1\n \n if ( n == 1) {\n TS <- TS[, 2]\n } else {\n \n TS <- TS[, -1]\n # month index should be repeat, but years cannot.\n yearIndex <- sapply(1:n, function(x) yearIndex + x - 1)\n dim(yearIndex) <- c(n * nrow(yearIndex), 1)\n \n monthIndex <- rep(monthIndex, n)\n TS <- melt(TS)[, 2]\n \n }\n\n }\n \n if (method == 'meanMonthly') {\n \n monthlyPreci <- tapply(TS, INDEX = list(yearIndex, monthIndex), FUN = sum, na.rm = omitNA)\n meanMonthlyPreci <- apply(monthlyPreci, MARGIN = 2, FUN = mean, na.rm = TRUE)\n \n \n title <- 'Mean Monthly Precipitation'\n xlab <- 'Month'\n \n plotPreci <- data.frame(Index = month.abb[as.numeric(colnames(monthlyPreci))], \n Preci = meanMonthlyPreci)\n \n # Here factor has to be reassigned, to keep the original order, or it will be reordered.\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n if (plotRange) {\n maxValue <- apply(monthlyPreci, MARGIN = 2, FUN = max, na.rm = TRUE)\n minValue <- apply(monthlyPreci, MARGIN = 2, FUN = min, na.rm = TRUE)\n \n plotPreci$maxValue <- maxValue\n plotPreci$minValue <- minValue\n \n ylim <- c(0,max(maxValue, na.rm = TRUE) * 1.1)\n \n } else {\n ylim <- c(0,max(meanMonthlyPreci, na.rm = TRUE) * 1.1)\n }\n \n \n } else if (method == 'annual') { \n \n if (length(unique(monthIndex)) < 12) {\n warning ('There are less than 12 months in a year, the results may be inaccurate.')\n }\n \n annualPreci <- tapply(TS, INDEX = yearIndex, FUN = sum, na.rm = TRUE)\n title <- 'Annual Precipitation'\n xlab <- 'Year'\n plotName <- names(annualPreci)\n \n plotPreci <- data.frame(Index = names(annualPreci), Preci = annualPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n ylim <- c(0, max(annualPreci, na.rm = TRUE) * 1.1)\n \n } else if (is.numeric(method)) {\n month <- method\n monExisting <- length(which(unique(monthIndex) == month))\n if (monExisting == 0) stop(\"Your input month doesn't exist in the dataset.\")\n \n monthlyPreci <- getMeanPreci(TS, method = month, yearIndex = yearIndex,\n monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n # If monthlyPreci length is 1, names need to be added.\n if (length(monthlyPreci) == 1) names(monthlyPreci) <- unique(yearIndex)\n plotPreci <- data.frame(Index = names(monthlyPreci), Preci = monthlyPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n title <- paste(month.abb[month], 'Precipitation over Whole Period', sep = ' ')\n xlab <- 'Year'\n ylim <- c(0, max(monthlyPreci, na.rm = TRUE) * 1.1)\n \n } else if (method == 'spring') { \n \n wm <- match(c(3, 4, 5), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop('Spring has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n seasonalPreci <- getMeanPreci(TS, method = 'spring', yearIndex = yearIndex,\n monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n title <- paste('Spring', 'Precipitation over Whole Period', sep = ' ')\n xlab <- 'Year'\n ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n \n \n } else if (method == 'summer') {\n \n wm <- match(c(6, 7, 8), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop('Summer has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n seasonalPreci <- getMeanPreci(TS, method = 'summer', yearIndex = yearIndex,\n monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n title <- paste('Summer', 'Precipitation over Whole Period', sep = ' ')\n xlab <- 'Year'\n ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n \n \n } else if (method == 'autumn') {\n wm <- match(c(9, 10, 11), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop('Autumn has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n seasonalPreci <- getMeanPreci(TS, method = 'autumn', yearIndex = yearIndex,\n monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n title <- paste('Autumn', 'Precipitation over Whole Period', sep = ' ')\n xlab <- 'Year'\n ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n \n } else if (method == 'winter') {\n wm <- match(c(12, 1, 2), unique(monthIndex))\n if (length(which(!is.na(wm))) < 3) {\n stop('Winter has less than 3 months, check data and try to calculate every month\n seperately or choose another season.')\n }\n \n seasonalPreci <- getMeanPreci(TS, method = 'winter', yearIndex = yearIndex,\n monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n \n title <- paste('Winter', 'Precipitation over Whole Period', sep = ' ')\n xlab <- 'Year'\n ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n \n } else {\n stop(paste('No method called \"', method, '\", check help for information'))\n }\n \n \n xlim <- c(0, length(rownames(plotPreci))) \n \n if (info == TRUE) {\n meanValue <- round(mean(plotPreci$Preci, na.rm = TRUE), 2)\n medianValue <- round(median(plotPreci$Preci,na.rm = TRUE), 2)\n plotMean <- paste('Mean', ' = ', meanValue)\n plotMedian <- paste('Median', ' = ', medianValue)\n \n plotMax <- round(max(plotPreci$Preci, na.rm = TRUE), 2)\n plotMin <- round(min(plotPreci$Preci, na.rm = TRUE), 2)\n word <- paste('\\n\\n', paste(' Max', '=', plotMax), ',', paste('Min', '=', plotMin), ',',\n plotMean, ',', plotMedian)\n } else word <- NULL\n \n \n xlab <- paste(xlab, word)\n \n theme_set(theme_bw())\n \n mainLayer <- with(plotPreci, {\n ggplot(plotPreci) +\n geom_bar(aes(x = Index, y = Preci), stat = 'identity', colour = 'black', fill = 'cyan2', width = rel(.4)) +\n xlab(xlab) +\n ylab('Precipitation (mm)') +\n ggtitle(title) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = rel(1.6), face = 'bold'),\n axis.title.x = element_text(size = rel(1.6)),\n axis.title.y = element_text(size = rel(1.6)),\n axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.9)),\n axis.text.y = element_text(size = rel(1.9)))\n# geom_text(x = min(xlim) + 0.95 * (max(xlim) - min(xlim)), y = min(ylim) + 0.15 * (max(ylim) - min(ylim)),\n# label = word)+\n# geom_hline(yintercept = meanValue) +\n# geom_text(x = min(xlim) + 0.3 * (max(xlim) - min(xlim)), y = meanValue + 3, vjust = 0, label = 'mean') +\n# geom_hline(yintercept = medianValue, colour = 'red') +\n# geom_text(x = min(xlim) + 0.6 * (max(xlim) - min(xlim)), y = medianValue + 3, vjust = 0,\n# label = 'median', colour = 'red')\n })\n \n\n if (plotRange) {\n if (is.null(plotPreci$maxValue)) {\n message('There is no plotRange for this method')\n print(mainLayer)\n } else {\n rangeLayer <- with(plotPreci, {\n geom_errorbar(aes(x = Index, ymax = maxValue, ymin = minValue), width = rel(0.3))\n }) \n print(mainLayer + rangeLayer)\n }\n \n } else {\n print(mainLayer)\n } \n \n if (output == 'plot') {\n return(mainLayer)\n } else if (output == 'ggplot') {\n if (is.null(name)) stop('\"name\" argument not found, \n If you choose \"ggplot\" as output, please assign a name.')\n plotPreci$Name <- rep(name, dim(plotPreci)[1])\n return(plotPreci)\n } else {\n return(plotPreci)\n }\n}\n\n\n#' Combine bars together\n#' @param ... different barplots generated by \\code{getPreciBar(, output = 'ggplot')}, refer to details.\n#' @details\n#' ..., representing different ouput generated by \\code{getPreciBar(, output = 'ggplot')}, they \n#' have to be of the same type, e.g., \n#' 1. Jan precipitation of different years, Feb precipitation of different years, and... \n#' They are both monthly precipitation, and they share x axis.\n#' \n#' 2. Mean monthly precipitation of different dataset. e.g., long term mean monthly precipitation\n#' and short term mean monthly precipitation. They are both mean monthly precipitation.\n#' \n#' @param nrow A number showing the number of rows.\n#' @param list If input is a list containing different ggplot data, use l\\code{list = inputlist}.\n#' NOTE: yOU HAVE TO PUT A \\code{list = }, before your list.\n#' @param x A string of x axis name.\n#' @param y A string of y axis name.\n#' @param title A string of the title.\n#' @param output A boolean, if chosen TRUE, the output will be given.\n#' @return A combined barplot.\n#' @examples\n#' \n#' data(tgridData)# the result of \\code{loadGridData{ecomsUDG.Raccess}}\n#' #output type of getPreciBar() has to be 'ggplot'.\n#' b1 <- getPreciBar(tgridData, method = 2, output = 'ggplot', name = 'b1')\n#' b2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2')\n#' \n#' getPreciBar_comb(b1, b2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ggplot2\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' }\n#' \ngetPreciBar_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title = '', output = FALSE) {\n if (!is.null(list)) {\n data_ggplot <- do.call('rbind', list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n data_ggplot <- do.call('rbind', bars)\n }\n \n if (!class(data_ggplot) == 'data.frame') {\n warning('Your input is probably a list, but you forget to add \"list = \" before it.\n Try again, or check help for more information.')\n } else if (is.null(data_ggplot$Name)) {\n stop('No \"Name\" column in the input data, check the arguments in getPreciBar(), if \n output = \"ggplot\" is assigned, more info please check ?getPreciBar.')\n }\n \n data_ggplot$Name <- factor(data_ggplot$Name, levels = unique(data_ggplot$Name), ordered = TRUE)\n \n theme_set(theme_bw())\n \n mainLayer <- with(data_ggplot, {\n ggplot(data_ggplot) +\n geom_bar(aes(x = Index, y = Preci),fill = 'cyan2', stat = 'identity', \n colour = 'black', width = rel(.4)) +\n facet_wrap( ~ Name, nrow = nrow) +\n theme(plot.title = element_text(size = rel(1.6), face = 'bold'),\n axis.title.x = element_text(size = rel(1.6)),\n axis.title.y = element_text(size = rel(1.6)),\n axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.9)),\n axis.text.y = element_text(size = rel(1.9))) +\n labs(x = x, y = y, title = title)\n })\n \n if (!any(is.na(match(c('minValue', 'maxValue'), colnames(data_ggplot))))) {\n rangeLayer <- with(data_ggplot, {\n geom_errorbar(aes(x = Index, ymax = maxValue, ymin = minValue), width = rel(0.3))\n }) \n mainLayer <- mainLayer + rangeLayer\n }\n\n \n suppressWarnings(print(mainLayer))\n \n if (output == TRUE) return(data_ggplot)\n}\n\n", + "created" : 1446420613317.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1636827293", + "id" : "A952284D", + "lastKnownWriteTime" : 1446430429, + "path" : "E:/1/R/hyfo/R/getPreciBar.R", + "project_path" : "R/getPreciBar.R", + "properties" : { + }, + "relative_order" : 3, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/AC306809 b/.Rproj.user/D53FD3E6/sdb/per/t/AC306809 new file mode 100644 index 0000000..7af9a89 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/AC306809 @@ -0,0 +1,17 @@ +{ + "contents" : "#' Monthly data to daily data and the reverse conversion.\n#' \n#' @param TS A time series, with first column date, and second column value. The date column should\n#' follow the format in \\code{as.Date}, i.e. seperate with \"-\" or \"/\". Check details for more information.\n#' @param method A string showing whether you want to change a daily data to monthly data or monthly\n#' data to daily data.e.g. \"mon2day\" and \"day2mon\".\n#' @details \n#' Note, when you want to change daily data to monthly data, a new date column will be generated,\n#' usually the date column will be the middle date of each month, 15th, or 16th. However, if your \n#' time series doesn't start from the beginning of a month or ends to the end of a month, e.g. \n#' from 1999-3-14 to 2008-2-2, the first and last generated date could be wrong. Not only the date, but also the data, because you are \n#' not calculating based on a intact month. \n#' @return converted time series.\n#' @examples\n#' # Daily to monthly\n#' data(testdl)\n#' TS <- testdl[[2]] # Get daily data\n#' str(TS)\n#' TS_new <- resample(TS, method = 'day2mon')\n#' \n#' # Monthly to daily\n#' TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), \n#' runif(30, 3, 10))\n#' TS_new <- resample(TS, method = 'mon2day')\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom stats aggregate\n#' @references \n#' \n#' \\itemize{\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \n#' \nresample <- function(TS, method){\n if (length(TS) != 2) {\n stop('Time series not correct, should be two columns, Date and value.')\n } else if (!grepl('-|/', TS[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } \n \n \n if (method == 'mon2day') {\n \n data <- apply(TS, MARGIN = 1 , FUN = mon2day)\n \n output <- do.call('rbind', data)\n } else if (method == 'day2mon') {\n Date <- as.Date(TS[, 1])\n year <- format(Date, format = '%Y')\n mon <- format(Date, format = '%m')\n \n data <- aggregate(TS, by = list(year, mon), FUN = mean, na.rm = TRUE)\n data <- data[order(data$Date), ][, 3:4]\n rownames(data) <- 1:dim(data)[1]\n output <- data\n } else {\n stop('method is not correct, check method argument.')\n }\n\n return (output)\n}\n\n#' @importFrom utils tail\n#' @references \n#' \n#' \\itemize{\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \nmon2day <- function(monData) {\n Date <- as.Date(monData[1])\n data <- monData[2]\n \n DateY <- format(Date, format = '%Y')\n DateM <- format(Date, format = '%m')\n DateL <- seq(Date, length = 2, by = '1 months')[2] - Date\n \n DateD <- 1:DateL\n \n start <- as.Date(paste(DateY, DateM, DateD[1], sep = '-'))\n end <- as.Date(paste(DateY, DateM, tail(DateD, 1), sep = '-'))\n \n Date <- seq(start, end, by = '1 day')\n \n dailyData <- data.frame(Date = Date, value = rep(data, DateL))\n \n return(dailyData)\n}", + "created" : 1446420392398.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4200103718", + "id" : "AC306809", + "lastKnownWriteTime" : 1446424066, + "path" : "E:/1/R/hyfo/R/resample.R", + "project_path" : "R/resample.R", + "properties" : { + }, + "relative_order" : 2, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/B0B6357D b/.Rproj.user/D53FD3E6/sdb/per/t/B0B6357D deleted file mode 100644 index 25e8261..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/B0B6357D +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Get a catchment object from selected shape file.\n#' @param filePath A string representing the path of the shape file.\n#' @return A catchment object can be used in \\code{getSpatialMap()}.\n#' @export\n#' @details This function is based on the package \\code{rgdal} and \\code{sp}, and the output comes from the package \n#' \\code{sp}\n#' @examples\n#' #open internal file\n#' file <- system.file(\"extdata\", \"testCat.shp\", package = \"hyfo\")\n#' catchment <- shp2cat(file)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @import rgdal\n#' @importFrom utils tail\n#' @references \n#' \n#' \\itemize{\n#' \\item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data\n#' Abstraction Library. R package version 1.0-4. http://CRAN.R-project.org/package=rgdal\n#' \n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \n#' \nshp2cat <- function(filePath) {\n #if the path <- file.choose(), the seperator is '\\\\'\n if (grepl('\\\\\\\\', filePath)) {\n catName <- tail(strsplit(filePath,'\\\\\\\\')[[1]], 1)#needs to be four \\, caused by some window system problem\n catName1 <- strsplit(catName, '\\\\.')[[1]][1]\n catName2 <- paste('\\\\\\\\', catName, sep = '')\n folderName <- strsplit(filePath, catName2)[[1]]\n n <- list.files(folderName, pattern = catName1)\n if (length(n) == 1) stop('Please place the shp file in the folder containing \n full related files, not only the shape file')\n #the other seperator is '/' \n } else if (grepl('/', filePath)) {\n catName <- tail(strsplit(filePath,'/')[[1]], 1)#needs to be four \\, caused by some window system problem\n catName1 <- strsplit(catName, '\\\\.')[[1]][1]\n catName2 <- paste('/', catName, sep = '')\n folderName <- strsplit(filePath, catName2)[[1]]\n n <- list.files(folderName, pattern = catName1)\n if (length(n) == 1) stop('Please place the shp file in the folder containing \n full related files, not only the shape file')\n }\n \n if (length(folderName) == 0) stop('No shape file found, make sure the shp file is selected.')\n catchment <- readOGR(folderName, catName1)\n return(catchment)\n}\n", - "created" : 1446247741641.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3019466614", - "id" : "B0B6357D", - "lastKnownWriteTime" : 1443830746, - "path" : "E:/1/R/hyfo/R/shp2cat.R", - "project_path" : "R/shp2cat.R", - "properties" : { - }, - "relative_order" : 11, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/B74937DD b/.Rproj.user/D53FD3E6/sdb/per/t/B74937DD new file mode 100644 index 0000000..aafc6b3 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/B74937DD @@ -0,0 +1,17 @@ +{ + "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting R Package for Data Analysis and\n Visualization\nVersion: 1.3.0\nDate: 2015-11-2\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: This package can be used as a tool for hydrology and climate\n forecasting. There are several tools including data processing, data\n visualization and data analysis. For hydrological and hydraulic modellers, hyfo\n can be a good pre-processing and post-processing tool for you. hyfo has been\n tested stable on windows platform.\nLicense: GPL-2\nDepends:\n R (>= 3.1.0),\n stats (>= 3.1.3),\n utils(>= 3.1.3),\nImports:\n ggplot2 (>= 1.0.1),\n reshape2 (>= 1.4.1),\n zoo (>= 1.7-12),\n rgdal (>= 0.9-3),\n plyr (>= 1.8.3),\n moments (>= 0.14),\n lmom (>= 2.5),\n maps(>= 2.3-9),\n maptools (>= 0.8-36),\n rgeos (>= 0.3-8),\n ncdf (>= 1.6.8),\n MASS (>= 7.3-39),\n methods\nSuggests:\n gridExtra,\n knitr\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nrepository: github\n", + "created" : 1446423221493.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "970707720", + "id" : "B74937DD", + "lastKnownWriteTime" : 1446426059, + "path" : "E:/1/R/hyfo/DESCRIPTION", + "project_path" : "DESCRIPTION", + "properties" : { + }, + "relative_order" : 6, + "source_on_save" : false, + "type" : "dcf" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/D2A0802 b/.Rproj.user/D53FD3E6/sdb/per/t/D2A0802 new file mode 100644 index 0000000..770d727 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/D2A0802 @@ -0,0 +1,18 @@ +{ + "contents" : "#' Monthly data to daily data and the reverse conversion.\n#' \n#' @param data a hyfo grid data or a time series, with first column date, and second column value. The date column should\n#' follow the format in \\code{as.Date}, i.e. seperate with \"-\" or \"/\". Check details for more information.\n#' @param method A string showing whether you want to change a daily data to monthly data or monthly\n#' data to daily data.e.g. \"mon2day\" and \"day2mon\".\n#' @details \n#' Note, when you want to change daily data to monthly data, a new date column will be generated,\n#' usually the date column will be the middle date of each month, 15th, or 16th. However, if your \n#' time series doesn't start from the beginning of a month or ends to the end of a month, e.g. \n#' from 1999-3-14 to 2008-2-2, the first and last generated date could be wrong. Not only the date, but also the data, because you are \n#' not calculating based on a intact month. \n#' @return converted time series.\n#' @examples\n#' # Daily to monthly\n#' data(testdl)\n#' TS <- testdl[[2]] # Get daily data\n#' str(TS)\n#' TS_new <- resample(TS, method = 'day2mon')\n#' \n#' # Monthly to daily\n#' TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), \n#' runif(30, 3, 10))\n#' TS_new <- resample(TS, method = 'mon2day')\n#' \n#' #' # First load ncdf file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' varname <- getNcdfVar(filePath) \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' nc_new <- resample(nc, 'day2mon')\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom stats aggregate\n#' @references \n#' \n#' \\itemize{\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \nsetGeneric('resample', function(data, method) {\n standardGeneric('resample')\n})\n\n\n#' @describeIn resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @describeIn resample\nsetMethod('resample', signature('list'),\n function(data, method) {\n result <- resample.list(data, method)\n return(result)\n })\n\n\n\n#' @importFrom stats aggregate\nresample.TS <- function(TS, method) {\n if (length(TS) != 2) {\n stop('Time series not correct, should be two columns, Date and value.')\n } else if (!grepl('-|/', TS[1, 1])) {\n stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } \n \n \n if (method == 'mon2day') {\n \n data <- apply(TS, MARGIN = 1 , FUN = mon2day)\n \n output <- do.call('rbind', data)\n } else if (method == 'day2mon') {\n Date <- as.Date(TS[, 1])\n year <- format(Date, format = '%Y')\n mon <- format(Date, format = '%m')\n \n data <- aggregate(TS, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3:4]\n rownames(data) <- 1:dim(data)[1]\n output <- data\n } else {\n stop('method is not correct, check method argument.')\n }\n \n return (output)\n}\n\n#' @importFrom stats aggregate\nresample.list <- function(hyfo, method) {\n checkHyfo(hyfo)\n hyfoData <- hyfo$Data\n Date <- as.POSIXlt(hyfo$Dates$start)\n year <- Date$year + 1900\n mon <- Date$mon + 1\n # hyfoDim <- attributes(hyfoData)$dimensions\n # resample focuses on time dimension. No matter whether the member dimension exists.\n timeIndex <- match('time', attributes(hyfoData)$dimensions)\n dimArray <- 1:length(attributes(hyfoData)$dimensions)\n \n if (method == 'day2mon') {\n hyfoData <- apply(hyfoData, MARGIN = dimArray[-timeIndex], \n function(x) aggregate(x, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3])\n Date <- aggregate(Date, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3]\n } else if (method == 'mon2day') {\n message('Under development.')\n }\n \n hyfo$Dates$start <- Date\n hyfo$Data <- hyfoData\n return(hyfo)\n}\n\n\n\n\n#' @importFrom utils tail\n#' @references \n#' \n#' \\itemize{\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n#' }\n#' \nmon2day <- function(monData) {\n Date <- as.Date(monData[1])\n data <- monData[2]\n \n DateY <- format(Date, format = '%Y')\n DateM <- format(Date, format = '%m')\n DateL <- seq(Date, length = 2, by = '1 months')[2] - Date\n \n DateD <- 1:DateL\n \n start <- as.Date(paste(DateY, DateM, DateD[1], sep = '-'))\n end <- as.Date(paste(DateY, DateM, tail(DateD, 1), sep = '-'))\n \n Date <- seq(start, end, by = '1 day')\n \n dailyData <- data.frame(Date = Date, value = rep(data, DateL))\n \n return(dailyData)\n}", + "created" : 1446425586333.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2191928295", + "id" : "D2A0802", + "lastKnownWriteTime" : 1446479591, + "path" : "E:/1/R/hyfo/R/resample(generic).R", + "project_path" : "R/resample(generic).R", + "properties" : { + "tempName" : "Untitled1" + }, + "relative_order" : 10, + "source_on_save" : false, + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/D4CCEE99 b/.Rproj.user/D53FD3E6/sdb/per/t/D4CCEE99 deleted file mode 100644 index 741bbcc..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/D4CCEE99 +++ /dev/null @@ -1,18 +0,0 @@ -{ - "contents" : "# \n#' An S4 class, representing the biasFactor of single time series biasCorrection.\n#' @slot biasFactor list of biasFactor, containing all the information for computing.\n#' @slot method the biascorrection method\n#' @slot preci if the data is precipitation\n#' @slot scaleType 'Valid when 'scaling' method is selected, 'multi' or 'add'.\n#' @slot extrapolate Valid when 'eqm' method is selected, 'constant' or 'no'\n#' @slot memberDim members contained.\n#' @slot prThreshold precipitation threshold, under which the precipitation is considered as 0.\n#' @exportClass biasFactor\n#' @importFrom methods setClass\nsetClass(\"biasFactor\", representation(biasFactor = 'list', method = 'character', preci = 'logical', prThreshold = 'numeric',\n scaleType = 'character', extrapolate = 'character', memberDim = 'numeric'), \n validity = checkBiasFactor, \n prototype(memberDim = 1))\n# \n# \n#' An S4 class, representing the biasFactor of hyfo file.\n#' @slot lonLatDim lists of biasFactor\n#' @inheritParams biasFactor\nsetClass(\"biasFactor.hyfo\", representation(lonLatDim = 'integer'), contains = 'biasFactor', \n validity = checkBiasFactor.hyfo)\n\n\n\n\n\n\n# aa <- new('biasFactor', biasFactor = biasFactor[[1]], method = biasFactor$method, preci = biasFactor$preci, prThreshold = biasFactor$prThreshold,\n# scaleType = biasFactor$scaleType, extrapolate = biasFactor$extrapolate)\n\n# a <- new('biasFactor.multiMember', biasFactor = biasFactor[[1]], memberDim = biasFactor$memberDim,\n# method = biasFactor$method, preci = biasFactor$preci, prThreshold = biasFactor$prThreshold,\n# scaleType = biasFactor$scaleType, extrapolate = biasFactor$extrapolate, input = biasFactor$input)\n# \n# a <- new('biasFactor.hyfo.multiMember', biasFactor = biasFactor[[1]], memberDim = biasFactor$memberDim, lonLatDim = biasFactor$lonLatDim,\n# method = biasFactor$method, preci = biasFactor$preci, prThreshold = biasFactor$prThreshold,\n# scaleType = biasFactor$scaleType, extrapolate = biasFactor$extrapolate, input = biasFactor$input)\n# \n\n\n\n\n\n\n\n##### For hyfo class\n\n###### hyfo\n\n# Since hyfo has to inateract with other packages like downscaleR,\n# If particular class is defined, other packages may not be able to use the object.\n# So, for grid file, just keep it the list file. In future, if interpolate is added,\n# grid file may become a special class.\n\n# \n# \n# \n# checkHyfo <- function(object) {\n# errors <- character()\n# if (length(object@varName) == 0) {\n# msg <- 'hyfo must have a varName.'\n# errors <- c(errors, msg)\n# }\n# \n# if (length(object@xyCoords) != 2) {\n# msg <- 'hyfo must have x and y coordinats, stored in xyCooords.'\n# errors <- c(errors, msg)\n# }\n# \n# if (length(object@Data) == 0) {\n# msg <- 'hyfo must have a Data part, storing data.'\n# errors <- c(errors, msg)\n# } else {\n# validDim <- na.omit(match(c('lon', 'lat', 'time'),attributes(object@Data)$dimensions))\n# if (length(validDim) != 3) {\n# msg <- paste('Data should have at least dimensions \"lon\", \"lat\", \"time\".', '\\n',\n# 'Your input data has dimensions ', attributes(object@Data)$dimensions, sep = '')\n# errors <- c(errors, msg)\n# }\n# }\n# if (length(errors) == 0) TRUE else errors\n# }\n# \n# checkHyfo.multiMember <- function(object) {\n# errors <- character()\n# if (length(object@Members) == 0) {\n# msg <- 'Members names missing.'\n# errors <- c(errors, msg)\n# }\n# \n# memDim <- match('member', attributes(object@Data)$dimensions)\n# if (is.na(memDim)) {\n# msg <- 'Members dimension missing.'\n# errors <- c(errors, msg)\n# }\n# \n# if (length(errors) == 0) TRUE else errors\n# }\n\n\n\n\n\n# #' An S4 class representing the grid file loaded from netCDF file.\n# #' @slot varName the name of the varialbe of the hyfo object.\n# #' @slot xyCoords A list file containing longitude and latitude coordinates.\n# #' @slot Dates A list containing Date information.\n# #' @slot Data An array containing the data.\n# #' @slot Loaded An character showing the loading information. \n# #' @exportClass \n# setClass(\"hyfo\", representation(varName = \"character\", xyCoords = 'list', Dates = 'list',\n# Data = 'array', Loaded = 'character'),\n# prototype(Loaded = 'by hyfo package, http://yuanchao-xu.github.io/hyfo/'),\n# validity = checkHyfo)\n# \n# \n# #' An S4 class representing the multi-member grid file loaded from netCDF file.\n# #' @slot Members showing the name of the members.\n# #' @exportClass \n# setClass('hyfo.multiMember', representation(Members = 'array'), contains = 'hyfo',\n# validity = checkHyfo.multiMember)\n\n\n\n\n# \n# a <- new(\"hyfo\", varName = \"pr\", xyCoords = tgridData$xyCoords, Dates = tgridData$Dates, Data = tgridData$Data)\n# \n# a <- new(\"hyfo.multiMember\", varName = \"pr\", xyCoords = nc$xyCoords, Dates = nc$Dates, Data = nc$Data,\n# Members = nc$Members, Loaded = nc$Loaded)\n\n", - "created" : 1446229350238.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3466314913", - "id" : "D4CCEE99", - "lastKnownWriteTime" : 1446235115, - "path" : "E:/1/R/hyfo/R/classes.R", - "project_path" : "R/classes.R", - "properties" : { - "tempName" : "Untitled1" - }, - "relative_order" : 9, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/DEBB5BC6 b/.Rproj.user/D53FD3E6/sdb/per/t/DEBB5BC6 deleted file mode 100644 index 25bc3db..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/DEBB5BC6 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting R Package for Data Analysis and\n Visualization\nVersion: 1.2.9\nDate: 2015-10-30\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: This package can be used as a tool for hydrology and climate\n forecasting. There are several tools including data processing, data\n visualization and data analysis. For hydrological and hydraulic modellers, hyfo\n can be a good pre-processing and post-processing tool for you. hyfo has been\n tested stable on windows platform.\nLicense: GPL-2\nDepends:\n R (>= 3.1.0),\n stats (>= 3.1.3),\n utils(>= 3.1.3),\nImports:\n ggplot2 (>= 1.0.1),\n reshape2 (>= 1.4.1),\n zoo (>= 1.7-12),\n rgdal (>= 0.9-3),\n plyr (>= 1.8.3),\n moments (>= 0.14),\n lmom (>= 2.5),\n maps(>= 2.3-9),\n maptools (>= 0.8-36),\n rgeos (>= 0.3-8),\n ncdf (>= 1.6.8),\n MASS (>= 7.3-39),\n methods\nSuggests:\n gridExtra,\n knitr\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nrepository: github\n", - "created" : 1444011910438.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2232663633", - "id" : "DEBB5BC6", - "lastKnownWriteTime" : 1446239861, - "path" : "E:/1/R/hyfo/DESCRIPTION", - "project_path" : "DESCRIPTION", - "properties" : { - }, - "relative_order" : 6, - "source_on_save" : false, - "type" : "dcf" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/ECF59ED6 b/.Rproj.user/D53FD3E6/sdb/per/t/ECF59ED6 deleted file mode 100644 index 422b132..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/ECF59ED6 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "## For package updates information\n\n#' @importFrom utils packageDescription\nhyfoUpdates <- function(){\n page <- readLines('http://yuanchao-xu.github.io/hyfo/')\n updatesLine <- grep('id=\\\\\"updates\"', page)\n versionLine <- updatesLine + 2\n \n version <- unlist(strsplit(page[versionLine], split = ' '))[2]\n version_local <- packageDescription(\"hyfo\")$Version\n # generate message\n version_msg <- strsplit(strsplit(page[versionLine], split = '

')[[1]][2], split = '

')[[1]]\n infoLine <- versionLine + 2\n info_msg <- strsplit(strsplit(page[infoLine], split = '

')[[1]][2], split = '

')[[1]]\n install_msg <- 'You can update by type in: devtools::install_gihub(\"Yuanchao-Xu/hyfo\")'\n \n message_out <- NULL\n if (version != version_local) {\n message_out <- paste(version_msg, info_msg, install_msg, sep = '\\n')\n }\n return(message_out)\n}\n\n.onAttach <- function(libname, pkgname) {\n message_out <- suppressWarnings(try(hyfoUpdates(), silent = TRUE))\n if (!is.null(message_out)) {\n if (grepl('Version', message_out)) {\n packageStartupMessage(message_out)\n }\n }\n}\n", - "created" : 1445465732531.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1964752037", - "id" : "ECF59ED6", - "lastKnownWriteTime" : 1444046609, - "path" : "E:/1/R/hyfo/R/startup.R", - "project_path" : "R/startup.R", - "properties" : { - }, - "relative_order" : 7, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/F2C0C79C b/.Rproj.user/D53FD3E6/sdb/per/t/F2C0C79C deleted file mode 100644 index 7cb06d7..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/F2C0C79C +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Check data for bind function.\n#' \n#' check if the data is available for \\code{rbind()} or \\code{cbind()}\n#' \n#' @param data A list containing different sublists ready to be processed by \\code{do.call('rbind')} \n#' or \\code{do.call('cbind')}\n#' @param bind A string showing which bind you are going to use can be 'rbind' or 'cbind'\n#' @return data can be processed by bind function; data cannot be processed by bind function\n#' @examples\n#' data <- list(c(1,1,1),c(2,2,2))\n#' bind <- 'rbind'\n#' checkBind(data,bind)\n#' \n#' data(testdl)\n#' \\dontrun{\n#' checkBind(testdl, 'rbind')\n#' }\n#' # Since the colnames in testdl are not the same, so it cannot be bound.\n#' #\n#' @export\ncheckBind <- function(data, bind){\n # data has to be a list of values, and will be used in do.call('rbind')\n message ('Check if the data list is available for rbind or cbind... \\n')\n if (bind == 'rbind') {\n colNum <- sapply(data, function(x) dim(x)[2])\n colLev <- unique(colNum)\n if (length(colLev) != 1) {\n dif <- colLev[2]\n difNum <- which(colNum == dif)\n stop(sprintf('Different Colomn number in %s th of the input list \\n', difNum))\n \n }\n \n # For rbind, colnames has to be checked as well.\n colNameNum <- lapply(data, function(x) colnames(x))\n sameName <- sapply(1:length(colNameNum), function(x) colNameNum[[x]] == colNameNum[[1]])\n if (any(!is.null(unlist(colNameNum))) & (any(sameName == FALSE) | any(length(unlist(sameName)) == 0))) {\n stop('Data in list have Different colnames, which cannot process rbind. ')\n }\n \n \n }else if (bind =='cbind') {\n rowNum <- sapply(data, function(x) dim(x)[1])\n rowLev <- unique(rowNum)\n if (length(rowLev) != 1) {\n dif <- rowLev[2]\n difNum <- which(rowNum == dif)\n stop(sprintf('Different row number in %s th of the input list \\n', rowNum))\n \n }\n }\n message('Data list is OK')\n}\n\n# Check if a input file is a hyfo grid file.\ncheckHyfo <- function(...) {\n datalist <- list(...)\n lapply(datalist, FUN = checkHyfo_core)\n invisible()\n}\n\ncheckHyfo_core <- function(hyfo) {\n #This is to check if the input is a hyfo list.\n checkWord <- c('Data', 'xyCoords', 'Dates')\n if (any(is.na(match(checkWord, attributes(hyfo)$names)))) {\n stop('Input dataset is incorrect, it should contain \"Data\", \"xyCoords\", and \"Dates\",\ncheck help for details or use loadNCDF to read NetCDF file.\n\nIf time series input is needed, and your input is a time series, please put \"TS = yourinput\".')\n }\n}\n\n# This check dim is based on the name of the dimension\ncheckDimLength <- function(..., dim) {\n datalist <- list(...)\n \n for (x in dim) {\n dimLength <- sapply(datalist, function(y) calcuDim(y, x))\n if (any(is.na(dimLength))) stop('No input dimension name, check your dimension name.')\n if (length(unique(dimLength)) != 1) stop('Input data have different dimemsion length.')\n }\n \n invisible()\n}\n\n\n\n\n###########################################################################################\n##### For biasFactor class\n\n##### Validity functions\n\ncheckBiasFactor <- function(object) {\n errors <- character()\n if (length(object@biasFactor) == 0) {\n msg <- 'biasFactors should not be empty.'\n errors <- c(errors, msg)\n }\n \n if (length(object@method) == 0) {\n msg <- 'method should not be empty.'\n errors <- c(errors, msg)\n }\n \n if (length(object@preci) == 0) {\n msg <- 'preci should not be empty.' \n errors <- c(errors, msg)\n }\n \n prThreshold <- object@prThreshold\n if (length(prThreshold) != 0) {\n if (prThreshold < 0) {\n msg <- 'prThreshold should be greater than 0.'\n errors <- c(errors, msg)\n }\n }\n \n scaleType <- object@scaleType\n if (length(scaleType) != 0) {\n if (scaleType != 'multi' & scaleType != 'add') {\n msg <- paste('scaleType is ', scaleType, '. Should be \"multi\" or \"add\".', sep = '')\n errors <- c(errors, msg)\n }\n }\n \n extrapolate <- object@extrapolate\n if (length(extrapolate) != 0) {\n if (extrapolate != 'no' & extrapolate != 'constant') {\n msg <- paste('extrapolate is ', extrapolate, '. Should be \"no\" or \"constant\".', sep = '')\n errors <- c(errors, msg)\n }\n }\n \n if (length(errors) == 0) TRUE else errors\n}\n\n\ncheckBiasFactor.hyfo <- function(object) {\n errors <- character()\n length_lonLatDim <- length(object@lonLatDim)\n if (length_lonLatDim != 2) {\n msg <- paste('lonLatDim is length ', length_lonLatDim, '. Should be 2', sep = '')\n errors <- c(errors, msg)\n }\n \n if (length(errors) == 0) TRUE else errors\n}\n\n\n", - "created" : 1446227679840.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3565279330", - "id" : "F2C0C79C", - "lastKnownWriteTime" : 1446223879, - "path" : "E:/1/R/hyfo/R/check.R", - "project_path" : "R/check.R", - "properties" : { - }, - "relative_order" : 8, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/164A827F b/.Rproj.user/D53FD3E6/sdb/prop/164A827F new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/164A827F @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/24F549E6 b/.Rproj.user/D53FD3E6/sdb/prop/24F549E6 new file mode 100644 index 0000000..32390ac --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/24F549E6 @@ -0,0 +1,3 @@ +{ + "tempName" : "Untitled1" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/29F4A251 b/.Rproj.user/D53FD3E6/sdb/prop/29F4A251 new file mode 100644 index 0000000..32390ac --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/29F4A251 @@ -0,0 +1,3 @@ +{ + "tempName" : "Untitled1" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/5EBC0528 b/.Rproj.user/D53FD3E6/sdb/prop/5EBC0528 new file mode 100644 index 0000000..32390ac --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/5EBC0528 @@ -0,0 +1,3 @@ +{ + "tempName" : "Untitled1" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/65AE66E1 b/.Rproj.user/D53FD3E6/sdb/prop/65AE66E1 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/65AE66E1 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/6A40A26 b/.Rproj.user/D53FD3E6/sdb/prop/6A40A26 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/6A40A26 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/720670A7 b/.Rproj.user/D53FD3E6/sdb/prop/720670A7 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/720670A7 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/91966DDC b/.Rproj.user/D53FD3E6/sdb/prop/91966DDC new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/91966DDC @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/9302BC98 b/.Rproj.user/D53FD3E6/sdb/prop/9302BC98 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/9302BC98 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/BF1BF0F9 b/.Rproj.user/D53FD3E6/sdb/prop/BF1BF0F9 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/BF1BF0F9 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/prop/INDEX b/.Rproj.user/D53FD3E6/sdb/prop/INDEX index a7bdd27..9ce63b5 100644 --- a/.Rproj.user/D53FD3E6/sdb/prop/INDEX +++ b/.Rproj.user/D53FD3E6/sdb/prop/INDEX @@ -1,3 +1,5 @@ +E%3A%2F1%2FR%2FbiasCorrect.R="65AE66E1" +E%3A%2F1%2FR%2FextractPeriod.R="720670A7" E%3A%2F1%2FR%2Fhyfo%2F.Rhistory="760783DA" E%3A%2F1%2FR%2Fhyfo%2FDESCRIPTION="88293046" E%3A%2F1%2FR%2Fhyfo%2FNAMESPACE="12D182A8" @@ -8,6 +10,7 @@ E%3A%2F1%2FR%2Fhyfo%2FR%2FanalyzeTS.R="D4E15E86" E%3A%2F1%2FR%2Fhyfo%2FR%2Farray_dimension.R="D4F850C0" E%3A%2F1%2FR%2Fhyfo%2FR%2Fas(generic).R="81645264" E%3A%2F1%2FR%2Fhyfo%2FR%2Fas.R="671094BE" +E%3A%2F1%2FR%2Fhyfo%2FR%2FbiasCorrect(generic).R="29F4A251" E%3A%2F1%2FR%2Fhyfo%2FR%2FbiasCorrect.R="18776CC7" E%3A%2F1%2FR%2Fhyfo%2FR%2Fcheck.R="916C0516" E%3A%2F1%2FR%2Fhyfo%2FR%2FcheckBind.R="C9B15CF9" @@ -20,17 +23,23 @@ E%3A%2F1%2FR%2Fhyfo%2FR%2FcollectData_csv.R="369B58" E%3A%2F1%2FR%2Fhyfo%2FR%2FcollectData_excel.R="4E1FACE5" E%3A%2F1%2FR%2Fhyfo%2FR%2FcollectData_txt.R="32C7BBDF" E%3A%2F1%2FR%2Fhyfo%2FR%2Fdimension.R="E11E5063" +E%3A%2F1%2FR%2Fhyfo%2FR%2FextractPeriod(generic).R="5EBC0528" E%3A%2F1%2FR%2Fhyfo%2FR%2FextractPeriod.R="731AAA96" +E%3A%2F1%2FR%2Fhyfo%2FR%2FfillGap.R="164A827F" E%3A%2F1%2FR%2Fhyfo%2FR%2Fgenerics.R="580D466D" +E%3A%2F1%2FR%2Fhyfo%2FR%2FgetAnnual.R="9302BC98" E%3A%2F1%2FR%2Fhyfo%2FR%2FgetEnsemble.R="AE6FBA18" E%3A%2F1%2FR%2Fhyfo%2FR%2FgetMeanPreci.R="4314F813" E%3A%2F1%2FR%2Fhyfo%2FR%2FgetPreciBar.R="7388EAB7" E%3A%2F1%2FR%2Fhyfo%2FR%2FgetSpatialMap.R="D83C8CE2" E%3A%2F1%2FR%2Fhyfo%2FR%2Flist2dataframe.R="1E32383" +E%3A%2F1%2FR%2Fhyfo%2FR%2FmonDay.R="BF1BF0F9" E%3A%2F1%2FR%2Fhyfo%2FR%2Fmulti-biasCorrect(generic).R="EA14EE46" E%3A%2F1%2FR%2Fhyfo%2FR%2Fmulti-biasCorrect.R="60922670" E%3A%2F1%2FR%2Fhyfo%2FR%2Fmulti_biasCorrect(generic).R="FF40DCF8" E%3A%2F1%2FR%2Fhyfo%2FR%2Fncdf.R="990A4302" +E%3A%2F1%2FR%2Fhyfo%2FR%2Fresample(generic).R="24F549E6" +E%3A%2F1%2FR%2Fhyfo%2FR%2Fresample.R="6A40A26" E%3A%2F1%2FR%2Fhyfo%2FR%2Fshp2cat.R="8ACB3251" E%3A%2F1%2FR%2Fhyfo%2FR%2Fstartup.R="5CD9501A" E%3A%2F1%2FR%2Fhyfo%2FR%2Fupdates.R="236FB265" @@ -39,5 +48,6 @@ E%3A%2F1%2FR%2Fhyfo%2Fman%2FbiasCorrect.Rd="BBC1A28E" E%3A%2F1%2FR%2Fhyfo%2Fman%2FbiasFactor-class.Rd="F5E4D8AB" E%3A%2F1%2FR%2Fhyfo%2Fvignettes%2Fhyfo.Rmd="AEEF914F" E%3A%2F1%2FR%2Fmulti-biasCorrect.R="13F54F05" +E%3A%2F1%2FR%2Fresample.R="91966DDC" F%3A%2FDropbox%2FFiles%2FR%2FR%2FAnalysis.r="57133A7E" F%3A%2FDropbox%2FFiles%2FR%2FR%2Fanalysis.R="A8338788" diff --git a/DESCRIPTION b/DESCRIPTION index c5522c5..ed34ea7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,8 +2,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization -Version: 1.2.9 -Date: 2015-10-30 +Version: 1.3.0 +Date: 2015-11-2 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: This package can be used as a tool for hydrology and climate diff --git a/NAMESPACE b/NAMESPACE index 15b949e..76b90ea 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,9 +25,9 @@ export(getSpatialMap_comb) export(getSpatialMap_mat) export(list2Dataframe) export(loadNcdf) -export(monDay) export(plotTS) export(plotTS_comb) +export(resample) export(shp2cat) export(writeNcdf) exportClasses(biasFactor) diff --git a/NEWS b/NEWS index 42ec078..1ef7e48 100644 --- a/NEWS +++ b/NEWS @@ -1,11 +1,25 @@ +hyfo 1.3.0 +========== +Date: 2015.11.2 + +- new generic function biasCorrect, extractPeriod, resample added, + No need to designate inputtype any more, R will detect automatically. +- new user manual added. + + hyfo 1.2.9 ========== +Date: 2015.10.30 + - new biasFactor S4 class added, to avoid set the input type every time. - operational bias correction has been changed to generic function. - news file added. + hyfo 1.2.8 ========== +Date: 2015.10.10 + - operational bias correction added, in normal function. \ No newline at end of file diff --git a/R/array_dimension.R b/R/array_dimension.R index a674aaf..a596678 100644 --- a/R/array_dimension.R +++ b/R/array_dimension.R @@ -55,6 +55,7 @@ adjustDim <- function(data, ref = 'no') { } att <- attributes(data)$dimensions + if (is.null(att)) stop('No dimnames in the input data attributes, please use loadNcdf to load data.') if (identical(att, refOrder)) return(data) dimIndex <- seq(1, length(att)) diff --git a/R/biasCorrect.R b/R/biasCorrect(generic).R similarity index 80% rename from R/biasCorrect.R rename to R/biasCorrect(generic).R index cc2a4f6..513932b 100644 --- a/R/biasCorrect.R +++ b/R/biasCorrect(generic).R @@ -1,5 +1,6 @@ + #' Biascorrect the input timeseries or hyfo dataset #' #' Biascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast. @@ -19,8 +20,6 @@ #' @param scaleType only when the method "scaling" is chosen, scaleType will be available. Two different types #' of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check #' details. Default scaleType is 'multi'. -#' @param input If input is a time series, \code{input = 'TS'} needs to be assigned, or hyfo will take it as -#' an hyfo output grid file. Default is hyfo output grid file, where in most of the cases we prefer. #' @param preci If the precipitation is biascorrected, then you have to assign \code{preci = TRUE}. Since for #' precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. #' Default is FALSE, refer to details. @@ -145,19 +144,19 @@ #' # The data used here is just for example, so there could be negative data. #' #' # default method is scaling, with 'multi' scaleType -#' frc_new <- biasCorrect(frc, hindcast, obs, input = 'TS') +#' frc_new <- biasCorrect(frc, hindcast, obs) #' #' # for precipitation data, extra process needs to be executed, so you have to tell #' # the program that it is a precipitation data. #' -#' frc_new1 <- biasCorrect(frc, hindcast, obs, input = 'TS', preci = TRUE) +#' frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE) #' #' # You can use other scaling methods to biascorrect. -#' frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add', input = 'TS') +#' frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add') #' #' # -#' frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE) -#' frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE) +#' frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE) +#' frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) #' #' plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum') #' @@ -198,113 +197,130 @@ #' } #' #' @author Yuanchao Xu \email{xuyuanchao37@@gmail.com }, S. Herrera \email{sixto@@predictia.es } -#' +#' @importFrom methods setMethod #' @export +#' +setGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', + preci = FALSE, prThreshold = 0, extrapolate = 'no') { + standardGeneric('biasCorrect') +}) + +#' @describeIn biasCorrect +setMethod('biasCorrect', signature('data.frame', 'data.frame', 'data.frame'), + function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + result <- biasCorrect.TS(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) + return(result) + }) -biasCorrect <- function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', input = 'hyfo', - preci = FALSE, prThreshold = 0, extrapolate = 'no'){ +#' @describeIn biasCorrect +setMethod('biasCorrect', signature('list', 'list', 'list'), + function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + result <- biasCorrect.list(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) + return(result) + }) + + +biasCorrect.TS <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + # First check if the first column is Date + if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1]) | !grepl('-|/', frc[1, 1])) { + stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} + and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an + argument, check help for more info.') + } + # change to date type is easier, but in case in future the flood part is added, Date type doesn't have + # hour, min and sec, so, it's better to convert it into POSIxlt. - if (input == 'TS') { - # First check if the first column is Date - if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1]) | !grepl('-|/', frc[1, 1])) { - stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} - and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an - argument, check help for more info.') - } - # change to date type is easier, but in case in future the flood part is added, Date type doesn't have - # hour, min and sec, so, it's better to convert it into POSIxlt. - - # if condition only accepts one condition, for list comparison, there are a lot of conditions, better - # further process it, like using any. - if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) { - warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in - the calibration.') - } - n <- ncol(frc) - - # For every column, it's biascorrected respectively. - frc_data <- lapply(2:n, function(x) biasCorrect_core(frc[, x], hindcast[, x], obs[, 2], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate)) - frc_data <- do.call('cbind', frc_data) - rownames(frc_data) <- NULL - - names <- colnames(frc) - frc_new <- data.frame(frc[, 1], frc_data) - colnames(frc_new) <- names - - } else if (input == 'hyfo') { - ## Check if the data is a hyfo grid data. - checkHyfo(frc, hindcast, obs) - - hindcastData <- hindcast$Data - obsData <- obs$Data - frcData <- frc$Data - - ## save frc dimension order, at last, set the dimension back to original dimension - frcDim <- attributes(frcData)$dimensions - - ## ajust the dimension into general dimension order. - hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time')) - obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) + # if condition only accepts one condition, for list comparison, there are a lot of conditions, better + # further process it, like using any. + if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) { + warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in + the calibration.') + } + n <- ncol(frc) + + # For every column, it's biascorrected respectively. + frc_data <- lapply(2:n, function(x) biasCorrect_core(frc[, x], hindcast[, x], obs[, 2], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate)) + frc_data <- do.call('cbind', frc_data) + rownames(frc_data) <- NULL + + names <- colnames(frc) + frc_new <- data.frame(frc[, 1], frc_data) + colnames(frc_new) <- names + return(frc_new) +} + +biasCorrect.list <- function(frc, hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + ## Check if the data is a hyfo grid data. + checkHyfo(frc, hindcast, obs) + + hindcastData <- hindcast$Data + obsData <- obs$Data + frcData <- frc$Data + + ## save frc dimension order, at last, set the dimension back to original dimension + frcDim <- attributes(frcData)$dimensions + + ## ajust the dimension into general dimension order. + hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time')) + obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) + + ## CheckDimLength, check if all the input dataset has different dimension length + # i.e. if they all have the same lon and lat number. + checkDimLength(frcData, hindcastData, obsData, dim = c('lon', 'lat')) + + + # Now real bias correction is executed. + + memberIndex <- match('member', attributes(frcData)$dimensions) + + # For dataset that has a member part + if (!is.na(memberIndex)) { + # check if frcData and hindcastData has the same dimension and length. + checkDimLength(frcData, hindcastData, dim = 'member') - ## CheckDimLength, check if all the input dataset has different dimension length - # i.e. if they all have the same lon and lat number. - checkDimLength(frcData, hindcastData, obsData, dim = c('lon', 'lat')) + frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member')) + # The following code may speed up because it doesn't use for loop. + # It firstly combine different array into one array. combine the time + # dimension of frc, hindcast and obs. Then use apply, each time extract + # the total time dimension, and first part is frc, second is hindcast, third + # is obs. Then use these three parts to bias correct. All above can be written + # in one function and called within apply. But too complicated to understand, + # So save it for future use maybe. - # Now real bias correction is executed. + # for (member in 1:dim(frcData)[4]) { + # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), + # dim = c(dim(frcData)[1], dim(frcData)[2], + # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) + # } - memberIndex <- match('member', attributes(frcData)$dimensions) - # For dataset that has a member part - if (!is.na(memberIndex)) { - # check if frcData and hindcastData has the same dimension and length. - checkDimLength(frcData, hindcastData, dim = 'member') - - frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member')) - - # The following code may speed up because it doesn't use for loop. - # It firstly combine different array into one array. combine the time - # dimension of frc, hindcast and obs. Then use apply, each time extract - # the total time dimension, and first part is frc, second is hindcast, third - # is obs. Then use these three parts to bias correct. All above can be written - # in one function and called within apply. But too complicated to understand, - # So save it for future use maybe. - -# for (member in 1:dim(frcData)[4]) { -# totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), -# dim = c(dim(frcData)[1], dim(frcData)[2], -# dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) -# } - - - for (member in 1:dim(frcData)[4]) { - for (lon in 1:dim(frcData)[1]) { - for (lat in 1:dim(frcData)[2]) { - frcData[lon, lat,, member] <- biasCorrect_core(frcData[lon, lat,,member], hindcastData[lon, lat,, member], obsData[lon, lat,], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate) - } - } - } - } else { - frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time')) + for (member in 1:dim(frcData)[4]) { for (lon in 1:dim(frcData)[1]) { for (lat in 1:dim(frcData)[2]) { - frcData[lon, lat,] <- biasCorrect_core(frcData[lon, lat,], hindcastData[lon, lat,], obsData[lon, lat,], method = method, + frcData[lon, lat,, member] <- biasCorrect_core(frcData[lon, lat,,member], hindcastData[lon, lat,, member], obsData[lon, lat,], method = method, scaleType = scaleType, preci = preci, prThreshold = prThreshold, extrapolate = extrapolate) } } } - - frcData <- adjustDim(frcData, ref = frcDim) - frc$Data <- frcData - frc$biasCorrected_by <- method - frc_new <- frc + } else { + frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time')) + for (lon in 1:dim(frcData)[1]) { + for (lat in 1:dim(frcData)[2]) { + frcData[lon, lat,] <- biasCorrect_core(frcData[lon, lat,], hindcastData[lon, lat,], obsData[lon, lat,], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate) + } + } } + frcData <- adjustDim(frcData, ref = frcDim) + frc$Data <- frcData + frc$biasCorrected_by <- method + frc_new <- frc return(frc_new) } @@ -312,6 +328,7 @@ biasCorrect <- function(frc, hindcast, obs, method = 'scaling', scaleType = 'mul + #' @importFrom MASS fitdistr #' @importFrom stats ecdf quantile pgamma qgamma rgamma #' @@ -345,14 +362,14 @@ biasCorrect_core <- function(frc, hindcast, obs, method, scaleType, preci, prThr warning('In this cell, frc, hindcast or obs data is missing. No biasCorrection for this cell.') return(NA) } - - + + if (preci == TRUE) { preprocessHindcast_res <- preprocessHindcast(hindcast = hindcast, obs = obs, prThreshold = prThreshold) hindcast <- preprocessHindcast_res[[1]] minHindcastPreci <- preprocessHindcast_res[[2]] } - + # default is the simplest method in biascorrection, just do simple addition and subtraction. if (method == 'delta') { if (length(frc) != length(obs)) stop('This method needs frc data have the same length as obs data.') @@ -378,7 +395,7 @@ biasCorrect_core <- function(frc, hindcast, obs, method, scaleType, preci, prThr frc <- biasCorrect_core_eqm_nonPreci(frc, hindcast, obs, extrapolate, prThreshold) } else { frc <- biasCorrect_core_eqm_preci(frc, hindcast, obs, minHindcastPreci, extrapolate, - prThreshold) + prThreshold) } } else if (method == 'gqm') { @@ -508,7 +525,7 @@ biasCorrect_core_eqm_nonPreci <- function(frc, hindcast, obs, extrapolate, prThr } biasCorrect_core_eqm_preci <- function(frc, hindcast, obs, minHindcastPreci, extrapolate, - prThreshold) { + prThreshold) { # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be # always hindcast > minHindcastPreci exists. @@ -607,4 +624,4 @@ biasCorrect_core_gqm <- function(frc, hindcast, obs, prThreshold, minHindcastPre no bias correction applied.') } return(frc) -} + } diff --git a/R/extractPeriod.R b/R/extractPeriod(generic).R similarity index 73% rename from R/extractPeriod.R rename to R/extractPeriod(generic).R index e4aa357..8e3139c 100644 --- a/R/extractPeriod.R +++ b/R/extractPeriod(generic).R @@ -3,14 +3,11 @@ #' Extract common period or certain period from a list of different dataframes of time series, or from a #' dataframe. #' NOTE: all the dates in the datalist should follow the format in ?as.Date{base}. -#' @param datalist A list of different dataframes of time series . +#' @param data A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value. #' @param startDate A Date showing the start of the extract period, default as NULL, check details. #' @param endDate A Date showing the end of the extract period, default as NULL, check details. #' @param commonPeriod A boolean showing whether the common period is extracted. If chosen, startDate and endDate #' should be NULL. -#' @param dataframe A dataframe with first column Date, the rest columns value. If your input is a -#' dataframe, not time series list, you can put \code{dataframe = yourdataframe}. And certain period will be -#' extracted. Note: if your input is a time series, that means all the columns share the same period of date. #' @param year extract certain year in the entire time series. if you want to extract year 2000, set \code{year = 2000} #' @param month extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, #' set \code{month = c(1, 2)}. @@ -74,8 +71,8 @@ #' #' dataframe <- list2Dataframe(datalist_com1) #' # now we have a dataframe to extract certain months and years. -#' dataframe_new <- extractPeriod(dataframe = dataframe, month = c(1,2,3)) -#' dataframe_new <- extractPeriod(dataframe = dataframe, month = c(12,1,2), year = 1995) +#' dataframe_new <- extractPeriod(dataframe, month = c(1,2,3)) +#' dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995) #' #' #' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ @@ -89,35 +86,49 @@ #' } #' #' @export -extractPeriod <- function(datalist, startDate = NULL, endDate = NULL, commonPeriod = FALSE, - dataframe = NULL, year = NULL, month = NULL) { - if (!is.null(dataframe)) { - dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year, - month = month) - - - } else { - if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) { - dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, - month = month) - } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) { - - Dates <- lapply(datalist, extractPeriod_getDate) - Dates <- do.call('rbind', Dates) - - startDate <- as.Date(max(Dates[, 1])) - endDate <- as.Date(min(Dates[, 2])) - - dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, - month = month) - - } else { - stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE') - } - } - - return(dataset) -} +setGeneric('extractPeriod', function(data, startDate = NULL, endDate = NULL, commonPeriod = FALSE, + year = NULL, month = NULL) { + standardGeneric('extractPeriod') +}) + + +#' @describeIn extractPeriod +#' @importFrom methods setMethod +setMethod('extractPeriod', signature('data.frame'), + function(data, startDate, endDate, commonPeriod, year, month) { + dataframe <- data + dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year, + month = month) + return(dataset) + +}) + + +#' @describeIn extractPeriod +#' @importFrom methods setMethod +setMethod('extractPeriod', signature('list'), + function(data, startDate, endDate, commonPeriod, year, month) { + datalist <- data + if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) { + dataset <- lapply(data, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, + month = month) + } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) { + + Dates <- lapply(datalist, extractPeriod_getDate) + Dates <- do.call('rbind', Dates) + + startDate <- as.Date(max(Dates[, 1])) + endDate <- as.Date(min(Dates[, 2])) + + dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year, + month = month) + + } else { + stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE') + } + return(dataset) + }) + @@ -138,13 +149,13 @@ extractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, stop('startDate and endDate exceeds the date limits in dataframe. Check datalsit please.') } output <- dataframe[startIndex:endIndex, ] - + if (!is.null(year)) { Date <- as.POSIXlt(output[, 1]) yea <- Date$year + 1900 mon <- Date$mon + 1 - + if (is.null(month) || !any(sort(month) != month)) { DateIndex <- which(yea %in% year) if (length(DateIndex) == 0) stop('No input years in the input ts, check your input.') @@ -164,7 +175,7 @@ extractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, stop('Cannot find input months and input years in the input time series.') } output <- output[startIndex:endIndex, ] - + if (any(diff(year) != 1)) { # if year is not continuous, like 1999, 2003, 2005, than we have to sift again. Date <- as.POSIXlt(output[, 1]) @@ -183,27 +194,27 @@ extractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, # cannot directly return output here, because sometimes, month can be incontinuous, # we still need the next process to sift month. - } } - } + + } + + if (!is.null(month)) { + Date <- as.POSIXlt(output[, 1]) + mon <- Date$mon + 1 - if (!is.null(month)) { - Date <- as.POSIXlt(output[, 1]) - mon <- Date$mon + 1 + # %in% can deal with multiple equalities + DateIndex <- which(mon %in% month) - # %in% can deal with multiple equalities - DateIndex <- which(mon %in% month) - - if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.') - - output <- output[DateIndex, ] + if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.') + + output <- output[DateIndex, ] } - + return(output) -} + } #' @importFrom utils tail @@ -219,14 +230,14 @@ extractPeriod_getDate <- function(dataset) { if (!grepl('-|/', dataset[1, 1])) { stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base}, - and use as.Date to convert.') + and use as.Date to convert.') } start <- as.Date(dataset[1, 1]) end <- as.Date(tail(dataset[, 1], 1)) return(c(start, end)) -} + } diff --git a/R/generics.R b/R/generics.R index f565575..851767a 100644 --- a/R/generics.R +++ b/R/generics.R @@ -1,50 +1,22 @@ -# -# print <- function(object, ...) { -# UseMethod('print') -# } -# -# print.biasFactor <- function(object, ...) { -# msg <- paste('biasFactor of method ', object@method) -# if (length(object@memberDim)) msgM <- paste('There are', object@memberDim, 'members existing in the forecasting data.') -# return(c(msg, msgM)) -# } +##### Prepared for future use, when hyfo becomes a class. -#' #### Generics of biasFactor -# @param object biasFactor object -# @export -# setGeneric('print', function(object) { -# standardGeneric('print') + +# # change to hyfo +# setGeneric('as.hyfo', function(x) { +# standardGeneric('as.hyfo') # }) # +# setMethod('as.hyfo', signature('list'), +# function(x) { +# +# if (!is.null(x$Members)) { +# hyfo <- new("hyfo.multiMember", varName = x$Variable$varName, xyCoords = x$xyCoords, Dates = x$Dates, Data = x$Data, +# Members = x$Members) +# } else { +# hyfo <- new("hyfo", varName = x$Variable$varName, xyCoords = x$xyCoords, Dates = x$Dates, Data = x$Data) # -# setMethod('print', signature('biasFactor'), function(object) { -# msg <- paste('biasFactor of method ', object@method) -# if (length(object@memberDim)) msgM <- paste('There are', object@memberDim, 'members existing in the forecasting data.') -# return(c(msg, msgM)) -# }) - -# #' @export -# #' @param a biasFactor object -# size <- function(x, ...) { -# UseMethod('size', x) -# } +# } +# return(hyfo) +# +# }) # -# #' @describeIn size -# size.biasFactor <-function(object) { -# if (length(object@lonLatDim) == 0) { -# return (1) -# } else { -# lonLat <- object@lonLatDim -# msg <- paste('Grid file with', lonLat[1], 'grids in longitude, ', lonLat[2], 'grids in latitude.') -# return(msg) -# } -# } - -##### hyfo - -# hyfo, TS and datalist should be three kinds of objects, so that many functions in hyfo can be split -# into different generic methods, then no need to set up input = TS or input = hyfo. -# But too much work to re-construct all the functions. - -# For new methods, it should set up different generic methods for hyfo, TS, and grid file from -# downscaleR. diff --git a/R/getPreciBar.R b/R/getPreciBar.R index d807714..88504bb 100644 --- a/R/getPreciBar.R +++ b/R/getPreciBar.R @@ -78,14 +78,7 @@ getPreciBar <- function(dataset, method, cell = 'mean', output = 'data', name = data <- dataset$Data # Dimension needs to be arranged. Make sure first and second dimension is lat and lon. - att <- attributes(data)$dimensions - dimIndex <- seq(1, length(att)) - dimIndex1 <- match(c('lon', 'lat', 'time'), att)# match can apply to simple cases - dimIndex2 <- dimIndex[-dimIndex1]# choose nomatch - - - data <- aperm(data, c(dimIndex1, dimIndex2)) - attributes(data)$dimensions <- att[c(dimIndex1, dimIndex2)] + data <- adjustDim(data, ref = c('lon', 'lat', 'time')) # Because in the following part, only 3 dimensions are allowed, so data has to be processed. if (is.null(member) & any(attributes(data)$dimensions == 'member')) { diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 5c73471..ab9128c 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -1,7 +1,7 @@ #' Get spatial map of the input dataset. #' #' @param dataset A list containing different information, should be the result of reading netcdf file using -#' \code{library(ecomsUDG.Raccess)}. +#' \code{loadNcdf}. #' @param method A string showing different calculating method for the map. More information please refer to #' details. #' @param member A number showing which member is selected to get, if the dataset has a "member" dimension. Default @@ -18,7 +18,7 @@ #' "mean", "max", "min": mean daily, maximum daily, minimum daily precipitation. #' @examples #' -#' #gridData provided in the package is the result of \code {loadGridData{ecomsUDG.Raccess}} +#' #gridData provided in the package is the result of \code {loadNcdf} #' data(tgridData) #' getSpatialMap(tgridData, method = 'meanAnnual') #' getSpatialMap(tgridData, method = 'winter') @@ -47,18 +47,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { data <- dataset$Data # Dimension needs to be arranged. Make sure first and second dimension is lat and lon. - # Further may be arranged into a seperate function - att <- attributes(data)$dimensions - if (is.null(att)) stop('No dimnames for the input data, please use loadNcdf to load data.') - dimIndex <- seq(1, length(att)) - dimIndex1 <- match(c('lon', 'lat', 'time'), att)# match can apply to simple cases - - # for array this works, or setdiff can be used here to find the nomatch element. - dimIndex2 <- dimIndex[-dimIndex1]# choose nomatch - - - data <- aperm(data, c(dimIndex1, dimIndex2)) - attributes(data)$dimensions <- att[c(dimIndex1, dimIndex2)] + data <- adjustDim(data, ref = c('lon', 'lat', 'time')) # Because in the following part, only 3 dimensions are allowed, so data has to be processed. if (member == 'mean' & any(attributes(data)$dimensions == 'member')) { diff --git a/R/multi-biasCorrect(generic).R b/R/multi-biasCorrect(generic).R index d3a4c7a..91d8c75 100644 --- a/R/multi-biasCorrect(generic).R +++ b/R/multi-biasCorrect(generic).R @@ -163,6 +163,7 @@ #' #' @author Yuanchao Xu \email{xuyuanchao37@@gmail.com }, S. Herrera \email{sixto@@predictia.es } #' +#' @importFrom methods setMethod #' @export #' #' @@ -175,40 +176,8 @@ setGeneric('getBiasFactor', function(hindcast, obs, method = 'scaling', scaleTyp #' @describeIn getBiasFactor setMethod('getBiasFactor', signature('data.frame', 'data.frame'), function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { - - if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1])) { - stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} - and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an - argument, check help for more info.') - } - - # change to date type is easier, but in case in future the flood part is added, Date type doesn't have - # hour, min and sec, so, it's better to convert it into POSIxlt. - - # if condition only accepts one condition, for list comparison, there are a lot of conditions, better - # further process it, like using any. - if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) { - warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in - the calibration.') - } - n <- ncol(hindcast) - - # For every column, it's biascorrected respectively. - biasFactor <- lapply(2:n, function(x) getBiasFactor_core(hindcast[, x], obs[, 2], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate)) - if (n - 1 > 1) { - biasFactor_all <- new('biasFactor.multiMember', biasFactor = biasFactor, memberDim = n - 1, - method = method, preci = preci, prThreshold = prThreshold, scaleType = scaleType, - extrapolate = extrapolate) - - } else { - biasFactor_all <- new('biasFactor', biasFactor = biasFactor, method = method, - preci = preci, prThreshold = prThreshold, scaleType = scaleType, - extrapolate = extrapolate) - } - - return(biasFactor_all) + result <- getBiasFactor.TS(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) + return(result) }) @@ -217,83 +186,8 @@ setMethod('getBiasFactor', signature('data.frame', 'data.frame'), #' @importFrom methods new setMethod('getBiasFactor', signature('list', 'list'), function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { - - ## Check if the data is a hyfo grid data. - checkHyfo(hindcast, obs) - - hindcastData <- hindcast$Data - obsData <- obs$Data - - ## save frc dimension order, at last, set the dimension back to original dimension - hindcastDim <- attributes(hindcastData)$dimensions - - ## ajust the dimension into general dimension order. - obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) - - ## CheckDimLength, check if all the input dataset has different dimension length - # i.e. if they all have the same lon and lat number. - checkDimLength(hindcastData, obsData, dim = c('lon', 'lat')) - - - # Now real bias correction is executed. - - memberIndex <- match('member', attributes(hindcastData)$dimensions) - - # For dataset that has a member part - if (!is.na(memberIndex)) { - - hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member')) - - # The following code may speed up because it doesn't use for loop. - # It firstly combine different array into one array. combine the time - # dimension of frc, hindcast and obs. Then use apply, each time extract - # the total time dimension, and first part is frc, second is hindcast, third - # is obs. Then use these three parts to bias correct. All above can be written - # in one function and called within apply. But too complicated to understand, - # So save it for future use maybe. - - # for (member in 1:dim(frcData)[4]) { - # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), - # dim = c(dim(frcData)[1], dim(frcData)[2], - # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) - # } - - biasFactor_all <- vector(mode = "list", length = dim(hindcastData)[4]) - for (member in 1:dim(hindcastData)[4]) { - biasFactor_all[[member]] <- vector(mode = 'list', length = dim(hindcastData)[1]) - for (lon in 1:dim(hindcastData)[1]) { - biasFactor_all[[member]][[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) - for (lat in 1:dim(hindcastData)[2]) { - biasFactor_all[[member]][[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,, member], obsData[lon, lat,], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate) - } - } - } - - biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci, - prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, - lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')), - memberDim = calcuDim(hindcastData, dim = 'member')) - } else { - - hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time')) - - biasFactor_all <- vector(mode = 'list', length = dim(hindcastData)[1]) - for (lon in 1:dim(hindcastData)[1]) { - biasFactor_all[[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) - for (lat in 1:dim(hindcastData)[2]) { - biasFactor_all[[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,], obsData[lon, lat,], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate) - } - } - biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci, - prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, - lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat'))) - - } - + result <- getBiasFactor.list(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) + return(result) }) @@ -459,132 +353,263 @@ setGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) { #' @importFrom methods setMethod setMethod('applyBiasFactor', signature('data.frame', 'biasFactor'), function(frc, biasFactor, obs) { - method <- biasFactor@method - preci <- biasFactor@preci - prThreshold <- biasFactor@prThreshold - scaleType <- biasFactor@scaleType - extrapolate <- biasFactor@extrapolate - memberDim <- biasFactor@memberDim - biasFactor <- biasFactor@biasFactor - - - # First check if the first column is Date - if (!grepl('-|/', frc[1, 1])) { - stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} - and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an - argument, check help for more info.') - } - # change to date type is easier, but in case in future the flood part is added, Date type doesn't have - # hour, min and sec, so, it's better to convert it into POSIxlt. - - # In this case more than one value columns exist in the dataset, both frc and hindcast. - - n <- ncol(frc) - if (n-1 != memberDim) stop('frc and biasFactor have different members.') - - - # For every column, it's biascorrected respectively. - frc_data <- lapply(2:n, function(x) applyBiasFactor_core(frc[, x], biasFactor = biasFactor[[x - 1]], method = method, - scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate, obs = obs[, 2])) - frc_data <- do.call('cbind', frc_data) - rownames(frc_data) <- NULL - - names <- colnames(frc) - frc_new <- data.frame(frc[, 1], frc_data) - colnames(frc_new) <- names - - return(frc_new) + result <- applyBiasFactor.TS(frc, biasFactor, obs) + return(result) }) #' @describeIn applyBiasFactor #' @importFrom methods setMethod setMethod('applyBiasFactor', signature('list', 'biasFactor.hyfo'), function(frc, biasFactor, obs) { - method <- biasFactor@method - preci <- biasFactor@preci - prThreshold <- biasFactor@prThreshold - scaleType <- biasFactor@scaleType - extrapolate <- biasFactor@extrapolate - lonLatDim <- biasFactor@lonLatDim - memberDim <- biasFactor@memberDim - biasFactor <- biasFactor@biasFactor - - ## Check if the data is a hyfo grid data. - checkHyfo(frc) - - - obsData <- obs$Data - frcData <- frc$Data - - ## save frc dimension order, at last, set the dimension back to original dimension - frcDim <- attributes(frcData)$dimensions - - ## ajust the dimension into general dimension order. - obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) - - ## CheckDimLength, check if all the input dataset has different dimension length - # i.e. if they all have the same lon and lat number. - if (!identical(calcuDim(frcData, dim = c('lon', 'lat')), lonLatDim)) { - stop('frc data has different lon and lat from hindcast data.') - } - - - # Now real bias correction is executed. - - memberIndex <- match('member', attributes(frcData)$dimensions) - - # For dataset that has a member part - if (!is.na(memberIndex)) { - # check if frcData and hindcastData has the same dimension and length. - if (calcuDim(frcData, dim = 'member') != memberDim) { - stop('frc data has different member number from hindcast.') - } - - frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member')) - - # The following code may speed up because it doesn't use for loop. - # It firstly combine different array into one array. combine the time - # dimension of frc, hindcast and obs. Then use apply, each time extract - # the total time dimension, and first part is frc, second is hindcast, third - # is obs. Then use these three parts to bias correct. All above can be written - # in one function and called within apply. But too complicated to understand, - # So save it for future use maybe. - - # for (member in 1:dim(frcData)[4]) { - # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), - # dim = c(dim(frcData)[1], dim(frcData)[2], - # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) - # } - - - for (member in 1:dim(frcData)[4]) { - for (lon in 1:dim(frcData)[1]) { - for (lat in 1:dim(frcData)[2]) { - frcData[lon, lat,, member] <- applyBiasFactor_core(frcData[lon, lat,,member], biasFactor = biasFactor[[member]][[lon]][[lat]], method = method, + result <- applyBiasFactor.list(frc, biasFactor, obs) + return(result) + }) + + +### generic functions +getBiasFactor.TS <- function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + + if (!grepl('-|/', obs[1, 1]) | !grepl('-|/', hindcast[1, 1])) { + stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} + and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an + argument, check help for more info.') + } + + # change to date type is easier, but in case in future the flood part is added, Date type doesn't have + # hour, min and sec, so, it's better to convert it into POSIxlt. + + # if condition only accepts one condition, for list comparison, there are a lot of conditions, better + # further process it, like using any. + if (any(as.POSIXlt(hindcast[, 1]) != as.POSIXlt(obs[, 1]))) { + warning('time of obs and time of hindcast are not the same, which may cause inaccuracy in + the calibration.') + } + n <- ncol(hindcast) + + # For every column, it's biascorrected respectively. + biasFactor <- lapply(2:n, function(x) getBiasFactor_core(hindcast[, x], obs[, 2], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate)) + if (n - 1 > 1) { + biasFactor_all <- new('biasFactor.multiMember', biasFactor = biasFactor, memberDim = n - 1, + method = method, preci = preci, prThreshold = prThreshold, scaleType = scaleType, + extrapolate = extrapolate) + + } else { + biasFactor_all <- new('biasFactor', biasFactor = biasFactor, method = method, + preci = preci, prThreshold = prThreshold, scaleType = scaleType, + extrapolate = extrapolate) + } + + return(biasFactor_all) +} + +getBiasFactor.list <- function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { + + ## Check if the data is a hyfo grid data. + checkHyfo(hindcast, obs) + + hindcastData <- hindcast$Data + obsData <- obs$Data + + ## save frc dimension order, at last, set the dimension back to original dimension + hindcastDim <- attributes(hindcastData)$dimensions + + ## ajust the dimension into general dimension order. + obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) + + ## CheckDimLength, check if all the input dataset has different dimension length + # i.e. if they all have the same lon and lat number. + checkDimLength(hindcastData, obsData, dim = c('lon', 'lat')) + + + # Now real bias correction is executed. + + memberIndex <- match('member', attributes(hindcastData)$dimensions) + + # For dataset that has a member part + if (!is.na(memberIndex)) { + + hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member')) + + # The following code may speed up because it doesn't use for loop. + # It firstly combine different array into one array. combine the time + # dimension of frc, hindcast and obs. Then use apply, each time extract + # the total time dimension, and first part is frc, second is hindcast, third + # is obs. Then use these three parts to bias correct. All above can be written + # in one function and called within apply. But too complicated to understand, + # So save it for future use maybe. + + # for (member in 1:dim(frcData)[4]) { + # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), + # dim = c(dim(frcData)[1], dim(frcData)[2], + # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) + # } + + biasFactor_all <- vector(mode = "list", length = dim(hindcastData)[4]) + for (member in 1:dim(hindcastData)[4]) { + biasFactor_all[[member]] <- vector(mode = 'list', length = dim(hindcastData)[1]) + for (lon in 1:dim(hindcastData)[1]) { + biasFactor_all[[member]][[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) + for (lat in 1:dim(hindcastData)[2]) { + biasFactor_all[[member]][[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,, member], obsData[lon, lat,], method = method, scaleType = scaleType, preci = preci, prThreshold = prThreshold, - extrapolate = extrapolate, obs = obsData[lon, lat,]) - } - } - } - } else { - frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time')) - for (lon in 1:dim(frcData)[1]) { - for (lat in 1:dim(frcData)[2]) { - frcData[lon, lat,] <- applyBiasFactor_core(frcData[lon, lat,], biasFactor = biasFactor[[lon]][[lat]], method = method, + extrapolate = extrapolate) + } + } + } + + biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci, + prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, + lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat')), + memberDim = calcuDim(hindcastData, dim = 'member')) + } else { + + hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time')) + + biasFactor_all <- vector(mode = 'list', length = dim(hindcastData)[1]) + for (lon in 1:dim(hindcastData)[1]) { + biasFactor_all[[lon]] <- vector(mode = 'list', length = dim(hindcastData)[2]) + for (lat in 1:dim(hindcastData)[2]) { + biasFactor_all[[lon]][[lat]] <- getBiasFactor_core(hindcastData[lon, lat,], obsData[lon, lat,], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate) + } + } + biasFactor <- new('biasFactor.hyfo', biasFactor = biasFactor_all, method = method, preci = preci, + prThreshold = prThreshold, scaleType = scaleType, extrapolate = extrapolate, + lonLatDim = calcuDim(hindcastData, dim = c('lon', 'lat'))) + + } + + return(biasFactor) +} + +applyBiasFactor.TS <- function(frc, biasFactor, obs) { + method <- biasFactor@method + preci <- biasFactor@preci + prThreshold <- biasFactor@prThreshold + scaleType <- biasFactor@scaleType + extrapolate <- biasFactor@extrapolate + memberDim <- biasFactor@memberDim + biasFactor <- biasFactor@biasFactor + + + # First check if the first column is Date + if (!grepl('-|/', frc[1, 1])) { + stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} + and use as.Date to convert.If your input is a hyfo dataset, put input = "hyfo" as an + argument, check help for more info.') + } + # change to date type is easier, but in case in future the flood part is added, Date type doesn't have + # hour, min and sec, so, it's better to convert it into POSIxlt. + + # In this case more than one value columns exist in the dataset, both frc and hindcast. + + n <- ncol(frc) + if (n-1 != memberDim) stop('frc and biasFactor have different members.') + + + # For every column, it's biascorrected respectively. + frc_data <- lapply(2:n, function(x) applyBiasFactor_core(frc[, x], biasFactor = biasFactor[[x - 1]], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate, obs = obs[, 2])) + frc_data <- do.call('cbind', frc_data) + rownames(frc_data) <- NULL + + names <- colnames(frc) + frc_new <- data.frame(frc[, 1], frc_data) + colnames(frc_new) <- names + + return(frc_new) + +} + +applyBiasFactor.list <- function(frc, biasFactor, obs) { + method <- biasFactor@method + preci <- biasFactor@preci + prThreshold <- biasFactor@prThreshold + scaleType <- biasFactor@scaleType + extrapolate <- biasFactor@extrapolate + lonLatDim <- biasFactor@lonLatDim + memberDim <- biasFactor@memberDim + biasFactor <- biasFactor@biasFactor + + ## Check if the data is a hyfo grid data. + checkHyfo(frc) + + + obsData <- obs$Data + frcData <- frc$Data + + ## save frc dimension order, at last, set the dimension back to original dimension + frcDim <- attributes(frcData)$dimensions + + ## ajust the dimension into general dimension order. + obsData <- adjustDim(obsData, ref = c('lon', 'lat', 'time')) + + ## CheckDimLength, check if all the input dataset has different dimension length + # i.e. if they all have the same lon and lat number. + if (!identical(calcuDim(frcData, dim = c('lon', 'lat')), lonLatDim)) { + stop('frc data has different lon and lat from hindcast data.') + } + + + # Now real bias correction is executed. + + memberIndex <- match('member', attributes(frcData)$dimensions) + + # For dataset that has a member part + if (!is.na(memberIndex)) { + # check if frcData and hindcastData has the same dimension and length. + if (calcuDim(frcData, dim = 'member') != memberDim) { + stop('frc data has different member number from hindcast.') + } + + frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time', 'member')) + + # The following code may speed up because it doesn't use for loop. + # It firstly combine different array into one array. combine the time + # dimension of frc, hindcast and obs. Then use apply, each time extract + # the total time dimension, and first part is frc, second is hindcast, third + # is obs. Then use these three parts to bias correct. All above can be written + # in one function and called within apply. But too complicated to understand, + # So save it for future use maybe. + + # for (member in 1:dim(frcData)[4]) { + # totalArr <- array(c(frcData[,,, member], hindcastData[,,, member], obsData), + # dim = c(dim(frcData)[1], dim(frcData)[2], + # dim(frcData)[3] + dim(hindcastData)[3] + dim(obsData)[3])) + # } + + + for (member in 1:dim(frcData)[4]) { + for (lon in 1:dim(frcData)[1]) { + for (lat in 1:dim(frcData)[2]) { + frcData[lon, lat,, member] <- applyBiasFactor_core(frcData[lon, lat,,member], biasFactor = biasFactor[[member]][[lon]][[lat]], method = method, scaleType = scaleType, preci = preci, prThreshold = prThreshold, extrapolate = extrapolate, obs = obsData[lon, lat,]) - } - } - } - - frcData <- adjustDim(frcData, ref = frcDim) - frc$Data <- frcData - frc$biasCorrected_by <- method - frc_new <- frc - - return(frc_new) - }) + } + } + } + } else { + frcData <- adjustDim(frcData, ref = c('lon', 'lat', 'time')) + for (lon in 1:dim(frcData)[1]) { + for (lat in 1:dim(frcData)[2]) { + frcData[lon, lat,] <- applyBiasFactor_core(frcData[lon, lat,], biasFactor = biasFactor[[lon]][[lat]], method = method, + scaleType = scaleType, preci = preci, prThreshold = prThreshold, + extrapolate = extrapolate, obs = obsData[lon, lat,]) + } + } + } + + frcData <- adjustDim(frcData, ref = frcDim) + frc$Data <- frcData + frc$biasCorrected_by <- method + frc_new <- frc + + return(frc_new) +} ################# diff --git a/R/monDay.R b/R/resample(generic).R similarity index 59% rename from R/monDay.R rename to R/resample(generic).R index 265a9c6..2e3f254 100644 --- a/R/monDay.R +++ b/R/resample(generic).R @@ -1,6 +1,6 @@ #' Monthly data to daily data and the reverse conversion. #' -#' @param TS A time series, with first column date, and second column value. The date column should +#' @param data a hyfo grid data or a time series, with first column date, and second column value. The date column should #' follow the format in \code{as.Date}, i.e. seperate with "-" or "/". Check details for more information. #' @param method A string showing whether you want to change a daily data to monthly data or monthly #' data to daily data.e.g. "mon2day" and "day2mon". @@ -16,12 +16,20 @@ #' data(testdl) #' TS <- testdl[[2]] # Get daily data #' str(TS) -#' TS_new <- monDay(TS, method = 'day2mon') +#' TS_new <- resample(TS, method = 'day2mon') #' #' # Monthly to daily #' TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), #' runif(30, 3, 10)) -#' TS_new <- monDay(TS, method = 'mon2day') +#' TS_new <- resample(TS, method = 'mon2day') +#' +#' #' # First load ncdf file. +#' filePath <- system.file("extdata", "tnc.nc", package = "hyfo") +#' varname <- getNcdfVar(filePath) +#' nc <- loadNcdf(filePath, varname) +#' +#' nc_new <- resample(nc, 'day2mon') +#' #' #' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ #' @@ -34,18 +42,39 @@ #' Statistical Computing, Vienna, Austria. URL http://www.R-project.org/. #' } #' -#' -monDay <- function(TS, method){ +setGeneric('resample', function(data, method) { + standardGeneric('resample') +}) + + +#' @describeIn resample +setMethod('resample', signature('data.frame'), + function(data, method) { + result <- resample.TS(data, method) + return(result) + }) + +#' @describeIn resample +setMethod('resample', signature('list'), + function(data, method) { + result <- resample.list(data, method) + return(result) + }) + + + +#' @importFrom stats aggregate +resample.TS <- function(TS, method) { if (length(TS) != 2) { stop('Time series not correct, should be two columns, Date and value.') } else if (!grepl('-|/', TS[1, 1])) { stop('First column is not date or Wrong Date formate, check the format in ?as.Date{base} - and use as.Date to convert.') + and use as.Date to convert.') } if (method == 'mon2day') { - + data <- apply(TS, MARGIN = 1 , FUN = mon2day) output <- do.call('rbind', data) @@ -54,17 +83,44 @@ monDay <- function(TS, method){ year <- format(Date, format = '%Y') mon <- format(Date, format = '%m') - data <- aggregate(TS, by = list(year, mon), FUN = mean, na.rm = TRUE) - data <- data[order(data$Date), ][, 3:4] + data <- aggregate(TS, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3:4] rownames(data) <- 1:dim(data)[1] output <- data } else { stop('method is not correct, check method argument.') } - + return (output) } +#' @importFrom stats aggregate +resample.list <- function(hyfo, method) { + checkHyfo(hyfo) + hyfoData <- hyfo$Data + Date <- as.POSIXlt(hyfo$Dates$start) + year <- Date$year + 1900 + mon <- Date$mon + 1 + # hyfoDim <- attributes(hyfoData)$dimensions + # resample focuses on time dimension. No matter whether the member dimension exists. + timeIndex <- match('time', attributes(hyfoData)$dimensions) + dimArray <- 1:length(attributes(hyfoData)$dimensions) + + if (method == 'day2mon') { + hyfoData <- apply(hyfoData, MARGIN = dimArray[-timeIndex], + function(x) aggregate(x, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3]) + Date <- aggregate(Date, by = list(mon, year), FUN = mean, na.rm = TRUE)[, 3] + } else if (method == 'mon2day') { + message('Under development.') + } + + hyfo$Dates$start <- Date + hyfo$Data <- hyfoData + return(hyfo) +} + + + + #' @importFrom utils tail #' @references #' diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 403f925..8a3d5fc 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -1,11 +1,22 @@ % Generated by roxygen2 (4.1.1): do not edit by hand -% Please edit documentation in R/biasCorrect.R +% Please edit documentation in R/biasCorrect(generic).R +\docType{methods} \name{biasCorrect} \alias{biasCorrect} +\alias{biasCorrect,data.frame,data.frame,data.frame-method} +\alias{biasCorrect,list,list,list-method} \title{Biascorrect the input timeseries or hyfo dataset} \usage{ biasCorrect(frc, hindcast, obs, method = "scaling", scaleType = "multi", - input = "hyfo", preci = FALSE, prThreshold = 0, extrapolate = "no") + preci = FALSE, prThreshold = 0, extrapolate = "no") + +\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs, + method = "scaling", scaleType = "multi", preci = FALSE, + prThreshold = 0, extrapolate = "no") + +\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = "scaling", + scaleType = "multi", preci = FALSE, prThreshold = 0, + extrapolate = "no") } \arguments{ \item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, @@ -24,9 +35,6 @@ representing the observation data.} of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check details. Default scaleType is 'multi'.} -\item{input}{If input is a time series, \code{input = 'TS'} needs to be assigned, or hyfo will take it as -an hyfo output grid file. Default is hyfo output grid file, where in most of the cases we prefer.} - \item{preci}{If the precipitation is biascorrected, then you have to assign \code{preci = TRUE}. Since for precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. Default is FALSE, refer to details.} @@ -116,6 +124,12 @@ that uses the theorical instead of the empirical distribution. It can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable. Better have a long period of training, and the if the forecast system is relatively stable. } +\section{Methods (by class)}{ +\itemize{ +\item \code{frc = data.frame,hindcast = data.frame,obs = data.frame}: + +\item \code{frc = list,hindcast = list,obs = list}: +}} \examples{ ######## hyfo grid file biascorrection ######## @@ -157,19 +171,19 @@ obs <- datalist[[3]] # The data used here is just for example, so there could be negative data. # default method is scaling, with 'multi' scaleType -frc_new <- biasCorrect(frc, hindcast, obs, input = 'TS') +frc_new <- biasCorrect(frc, hindcast, obs) # for precipitation data, extra process needs to be executed, so you have to tell # the program that it is a precipitation data. -frc_new1 <- biasCorrect(frc, hindcast, obs, input = 'TS', preci = TRUE) +frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE) # You can use other scaling methods to biascorrect. -frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add', input = 'TS') +frc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add') # -frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', input = 'TS', preci = TRUE) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', input = 'TS', preci = TRUE) +frc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) plotTS(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4, plot = 'cum') diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index 251d9da..19c9f6e 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -1,14 +1,23 @@ % Generated by roxygen2 (4.1.1): do not edit by hand -% Please edit documentation in R/extractPeriod.R +% Please edit documentation in R/extractPeriod(generic).R +\docType{methods} \name{extractPeriod} \alias{extractPeriod} +\alias{extractPeriod,data.frame-method} +\alias{extractPeriod,list-method} \title{Extract period from list or dataframe.} \usage{ -extractPeriod(datalist, startDate = NULL, endDate = NULL, - commonPeriod = FALSE, dataframe = NULL, year = NULL, month = NULL) +extractPeriod(data, startDate = NULL, endDate = NULL, + commonPeriod = FALSE, year = NULL, month = NULL) + +\S4method{extractPeriod}{data.frame}(data, startDate = NULL, endDate = NULL, + commonPeriod = FALSE, year = NULL, month = NULL) + +\S4method{extractPeriod}{list}(data, startDate = NULL, endDate = NULL, + commonPeriod = FALSE, year = NULL, month = NULL) } \arguments{ -\item{datalist}{A list of different dataframes of time series .} +\item{data}{A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.} \item{startDate}{A Date showing the start of the extract period, default as NULL, check details.} @@ -17,10 +26,6 @@ extractPeriod(datalist, startDate = NULL, endDate = NULL, \item{commonPeriod}{A boolean showing whether the common period is extracted. If chosen, startDate and endDate should be NULL.} -\item{dataframe}{A dataframe with first column Date, the rest columns value. If your input is a -dataframe, not time series list, you can put \code{dataframe = yourdataframe}. And certain period will be -extracted. Note: if your input is a time series, that means all the columns share the same period of date.} - \item{year}{extract certain year in the entire time series. if you want to extract year 2000, set \code{year = 2000}} \item{month}{extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, @@ -57,6 +62,12 @@ have to set \code{year = 1998 : 1999}. Well, if you set \code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998, then, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year. } +\section{Methods (by class)}{ +\itemize{ +\item \code{data.frame}: + +\item \code{list}: +}} \examples{ # Generate timeseries datalist. Each data frame consists of a Date and a value. @@ -91,8 +102,8 @@ datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-1 dataframe <- list2Dataframe(datalist_com1) # now we have a dataframe to extract certain months and years. -dataframe_new <- extractPeriod(dataframe = dataframe, month = c(1,2,3)) -dataframe_new <- extractPeriod(dataframe = dataframe, month = c(12,1,2), year = 1995) +dataframe_new <- extractPeriod(dataframe, month = c(1,2,3)) +dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ diff --git a/man/getSpatialMap.Rd b/man/getSpatialMap.Rd index 985ef6d..fee65d3 100644 --- a/man/getSpatialMap.Rd +++ b/man/getSpatialMap.Rd @@ -8,7 +8,7 @@ getSpatialMap(dataset, method = NULL, member = "mean", ...) } \arguments{ \item{dataset}{A list containing different information, should be the result of reading netcdf file using -\code{library(ecomsUDG.Raccess)}.} +\code{loadNcdf}.} \item{method}{A string showing different calculating method for the map. More information please refer to details.} @@ -34,7 +34,7 @@ Month(number 1 to 12): MEAN month rainfall of each year is plotted, e.g. MEAN ma "mean", "max", "min": mean daily, maximum daily, minimum daily precipitation. } \examples{ -#gridData provided in the package is the result of \\code {loadGridData{ecomsUDG.Raccess}} +#gridData provided in the package is the result of \\code {loadNcdf} data(tgridData) getSpatialMap(tgridData, method = 'meanAnnual') getSpatialMap(tgridData, method = 'winter') diff --git a/man/monDay.Rd b/man/resample.Rd similarity index 65% rename from man/monDay.Rd rename to man/resample.Rd index b8a8f7d..a527082 100644 --- a/man/monDay.Rd +++ b/man/resample.Rd @@ -1,13 +1,20 @@ % Generated by roxygen2 (4.1.1): do not edit by hand -% Please edit documentation in R/monDay.R -\name{monDay} -\alias{monDay} +% Please edit documentation in R/resample(generic).R +\docType{methods} +\name{resample} +\alias{resample} +\alias{resample,data.frame-method} +\alias{resample,list-method} \title{Monthly data to daily data and the reverse conversion.} \usage{ -monDay(TS, method) +resample(data, method) + +\S4method{resample}{data.frame}(data, method) + +\S4method{resample}{list}(data, method) } \arguments{ -\item{TS}{A time series, with first column date, and second column value. The date column should +\item{data}{a hyfo grid data or a time series, with first column date, and second column value. The date column should follow the format in \code{as.Date}, i.e. seperate with "-" or "/". Check details for more information.} \item{method}{A string showing whether you want to change a daily data to monthly data or monthly @@ -26,17 +33,31 @@ time series doesn't start from the beginning of a month or ends to the end of a from 1999-3-14 to 2008-2-2, the first and last generated date could be wrong. Not only the date, but also the data, because you are not calculating based on a intact month. } +\section{Methods (by class)}{ +\itemize{ +\item \code{data.frame}: + +\item \code{list}: +}} \examples{ # Daily to monthly data(testdl) TS <- testdl[[2]] # Get daily data str(TS) -TS_new <- monDay(TS, method = 'day2mon') +TS_new <- resample(TS, method = 'day2mon') # Monthly to daily TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), runif(30, 3, 10)) -TS_new <- monDay(TS, method = 'mon2day') +TS_new <- resample(TS, method = 'mon2day') + +#' # First load ncdf file. +filePath <- system.file("extdata", "tnc.nc", package = "hyfo") +varname <- getNcdfVar(filePath) +nc <- loadNcdf(filePath, varname) + +nc_new <- resample(nc, 'day2mon') + # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ }