From 509fb6dcff9b26ebedf27ce30acb7bd94cb8ece3 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 22 Mar 2016 00:02:18 +0800 Subject: [PATCH 01/43] add showNA to plotTS --- .Rhistory | 420 +++++++++--------- .Rproj.user/D53FD3E6/pcs/find-in-files.pper | 2 +- .Rproj.user/D53FD3E6/pcs/source-pane.pper | 2 +- .Rproj.user/D53FD3E6/sdb/per/t/166D8D14 | 18 - .Rproj.user/D53FD3E6/sdb/per/t/188497E | 17 + .Rproj.user/D53FD3E6/sdb/per/t/222F1822 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/39BBA10B | 17 - .Rproj.user/D53FD3E6/sdb/per/t/46C049C3 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/5D765D44 | 18 - .Rproj.user/D53FD3E6/sdb/per/t/67AB4AD7 | 18 - .Rproj.user/D53FD3E6/sdb/per/t/6A0664B3 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/805EE7EC | 17 - .Rproj.user/D53FD3E6/sdb/per/t/9CDBC212 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/B5E420D2 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/B74937DD | 17 - .Rproj.user/D53FD3E6/sdb/per/t/B8F92D53 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/BDA65B7E | 17 - .Rproj.user/D53FD3E6/sdb/per/t/E1BDCB97 | 17 - .Rproj.user/D53FD3E6/sdb/per/t/FCC66B37 | 18 - .Rproj.user/D53FD3E6/sdb/prop/947FDB3E | 2 + .Rproj.user/D53FD3E6/sdb/prop/INDEX | 1 + .Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file | 0 NEWS | 10 +- R/analyzeTS.R | 17 +- man/plotTS.Rd | 4 +- 25 files changed, 255 insertions(+), 479 deletions(-) delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/166D8D14 create mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/188497E delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/222F1822 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/39BBA10B delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/46C049C3 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/5D765D44 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/67AB4AD7 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/6A0664B3 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/805EE7EC delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/9CDBC212 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/B5E420D2 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/B74937DD delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/B8F92D53 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/BDA65B7E delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/E1BDCB97 delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/FCC66B37 create mode 100644 .Rproj.user/D53FD3E6/sdb/prop/947FDB3E create mode 100644 .Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file diff --git a/.Rhistory b/.Rhistory index eabe56c..a1080a4 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,213 +1,3 @@ -if (!is.null(message_out)) { -if (grepl('Version', message_out)) { -packageStartupMessage(message_out) -} -} -} -devtools::document() -devtools::check() -devtools::document() -devtools::install_github('Yuanchao-Xu/hyfo') -library(hyfo) -devtools::document() -devtools::document -devtools::document() -devtools::check() -install.packages('devtools') -devtools::install_github('Yuanchao-Xu/hyfo') -library(devtools) -install_github('Yuanchao-Xu/hyfo') -library(hyfo) -?getPreciBar -b1 <- getPreciBar(tgridData, method = 'annual') -b2 <- getPreciBar(tgridData, method = 'meanMonthly') -b1 <- getPreciBar(tgridData, method = 'annual') -?getBiasFactor -devtools::document() -devtools::check() -?getPreciBar -debug(getBiasFactor) -?getBiasFactor -filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) -nc <- loadNcdf(filePath, varname) -biasFactor <- getBiasFactor(nc, tgridData) -S -str(biasFactor) -biasFactor <- getBiasFactor(nc, tgridData) -debug(standardGeneric) -devtools::document() -devtools::check() -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -library(devtools) -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -install_github('Yuanchao-Xu/hyfo') -install_github('Yuanchao-Xu/hyfo') -install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -devtools::install_github('Yuanchao-Xu/hyfo') -library(hyfo) -?getBiasFactor -?getPreciBar -devtools::build() -devtools::document() -devtools::check() -devtools::build() -??readData_folder -?hyfo::readData_folder -devtools::use_travis() -devtools::check() -devtools::check(cran = T) -?check -devtools::check(cran = T) -devtools::build() -Sys.getenv("R_PROFILE_USER") -?install -??install -devtools::use_vignette("my-vignette") -devtools::check(cran = T) -devtools::check(cran = T) -?tools -devtools::check(cran = T) -devtools::build() -devtools::check(cran = T) -devtools::build() -devtools::check(cran = T) -devtools::build() -devtools::check(cran = T) -devtools::build() -devtools::check(cran = T) -devtools::build() -devtools::check(cran = T) -devtools::build() -a <- readLines('https://cran.r-project.org/web/packages/hyfo/NEWS') -a -devtools::check(cran = T) -devtools::build() -devtools::build() -devtools::build() -devtools::document() -devtools::check() -devtools::document() -devtools::check(cran = T) -install.packages('ncdf4') -library(ncdf4) -?open.ncdf -library(ncdf) -?open.ncdf -?nc_open -filePath <- file.choose() -nc <- nc_open(filePath) -names <- names(nc$var) -str(nc) -names <- names(nc$var) -names -citation(ncdf4) -citation('ncdf4') -name -names -varname <- names -nc <- nc_open(filePath) -str(nc) -varname -call_1 <- as.call(c( -list(as.name('$'), var, varname) -)) -var <- eval(call_1) -var <- nc$var -var <- eval(call_1) -call_1 <- as.call(c( -list(as.name('$'), var, varname) -)) -var <- eval(call_1) -if(is.null(var)) stop('No such variable name, check source file.') -var -str(var) -nc_data <- ncvar_get(nc, var) -str(nc_data) -a <- nc_data -nc_data <- get.var.ncdf(nc,var) -dimNames <- unlist(lapply(1:length(var$dim), function(x) var$dim[[x]]$name)) -dimIndex <- match(c('lon', 'lat', 'time', 'member'), dimNames) -gridData <- list() -gridData$Variable$varName <- varname -gridData$xyCoords$x <- var$dim[[dimIndex[1]]]$vals -gridData$xyCoords$y <- var$dim[[dimIndex[2]]]$vals -timeUnit <- strsplit(var$dim[[dimIndex[3]]]$units, split = ' since')[[1]][1] -timeDiff <- var$dim[[dimIndex[3]]]$vals -# To get real time, time since when has to be grabbed from the dataset. -timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz) -timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz) -tz = 'GMT' -timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz) -unitDic <- data.frame(weeks = 'weeks', days = 'days', hours = 'hours', -minutes = 'mins', seconds = 'secs') -timeDiff <- as.difftime(timeDiff, units = as.character(unitDic[1, timeUnit])) -Date <- timeSince + timeDiff -if (length(Date) == 1) { -warning("Only one time step is taken, time dimension is dropped in the original data. -But after loading, the time dimension (with length : 1) will be added.") -} -gridData$Dates$start <- as.character(Date) -if (length(dim(nc_data)) < 3) { -dim(nc_data) <- c(dim(nc_data), 1) -message('Time dimension is added, make sure in your original data, only time dimension was dropped.') -} -gridData$Data <- nc_data -attributes(gridData$Data)$dimensions <- dimNames -if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals -gridData$Loaded <- 'by hyfo package, http://yuanchao-xu.github.io/hyfo/' -nc_close(nc) -downscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) { -if (!is.null(year)) { -Dates <- as.POSIXlt(gridData$Dates$start) -yearIndex <- Dates$year + 1900 -monIndex <- Dates$mon + 1 -timeDim <- match('time', attributes(gridData$Data)$dimensions) -if (is.null(month) || !any(sort(month) != month)) { -targetYearIndex <- which(yearIndex %in% year) -if (length(targetYearIndex) == 0) stop('No input years in the input ts, check your input.') -# if year crossing than sort(month) != month -} else { -startIndex <- intersect(which(yearIndex == year[1] - 1), which(monIndex == month[1]))[1] -endIndex <- tail(intersect(which(yearIndex == tail(year, 1)), which(monIndex == 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.') -} else { -targetYearIndex <- startIndex:endIndex -if (any(diff(year) != 1)) { -# if year is not continuous, like 1999, 2003, 2005, than we have to sift again. -# Only for special cases. -Dates <- Dates[targetYearIndex] -yea <- Dates$year + 1900 -mon <- Dates$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) -})) -targetYearIndex <- targetYearIndex[DateIndex] -# cannot directly return output here, because sometimes, month can be incontinuous, -# we still need the next process to sift month. -} -} -} -gridData$Dates$start <- gridData$Dates$start[targetYearIndex] -gridData$Dates$end <- gridData$Dates$end[targetYearIndex] -gridData$Data <- chooseDim(gridData$Data, timeDim, targetYearIndex) -} -if (!is.null(month)) { -Dates <- as.POSIXlt(gridData$Dates$start) -monIndex <- Dates$mon + 1 -targetMonIndex <- which(monIndex %in% month) -if (length(targetMonIndex) == 0) stop('Check your input year, it may exceed the years -in the input dataset.') gridData$Dates$start <- gridData$Dates$start[targetMonIndex] gridData$Dates$end <- gridData$Dates$end[targetMonIndex] timeDim <- match('time', attributes(gridData$Data)$dimensions) @@ -510,3 +300,213 @@ debug(biasCorrect.list) newFrc <- biasCorrect(tgridData, tgridData, tgridData) memberIndex devtools::check() +devtools::build() +newFrc <- biasCorrect(tgridData, tgridData, tgridData) +devtools::check() +newFrc <- biasCorrect(tgridData, tgridData, tgridData) +devtools::build() +?fortify +??fortify +library(hyfo) +plotTS(testdl[[1]]) +plotTS(testdl[[1]], x = 'xxx', y = 'yyy', title = 'aaa') +plotTS(list = testdl) +plotTS(testdl[[1]], testdl[[2]], plot = 'cum') +plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, x = NULL, +y = NULL, title = NULL, list = NULL) { +## arrange input TS or TS list. +if (is.null(list)) { +list <- list(...) +if (!class(list[[1]]) == 'data.frame') { +warning('Your input is probably a list, but you forget to add "list = " before it. +Try again, or check help for more information.') +} +# Following part is for plot different time series with different date, but too complicated +# using ggplot. and normal use doesn't need such process. So save it as backup. +# listNames <- names(list) +# # in order to be used later to differentiate lists, there should be a name for each element. +# # Then assign the name column to each list element. +# if (is.null(listNames)) listNames <- 1:length(list) +# +# giveName <- function(x, y) { +# colnames(x) <- NULL +# x$TSname <- rep(listNames[y], nrow(x)) +# return(x) +# } +# list1 <- mapply(FUN = giveName, x = list, y = 1:length(list), SIMPLIFY = FALSE) +# +# checkBind(list1, 'rbind') +# +# TS <- do.call('rbind', list1) +} +list_common <- extractPeriod(list, commonPeriod = TRUE) +TS <- list2Dataframe(list_common) +if (!is.null(names(list)) & (ncol(TS) - 1) == length(list)) colnames(TS)[2:(length(list) + 1)] <- names(list) +# Check input, only check the first column and first row. +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.') +} +TS[, 1] <- as.Date(TS[, 1]) +colnames(TS)[1] <- 'Date' +# first column's name may not be Date, so change its name to Date +data_plot <- melt(TS, id.var = 'Date') +NAIndex <- which(is.na(data_plot$value)) +# assign 0 to NA values +if (plot == 'norm') { +data_plot$value[NAIndex] <- 0 +lineSize <- 0.7 +} else if (plot == 'cum') { +TS[is.na(TS)] <- 0 +cum <- cbind(data.frame(Date = TS[, 1]), cumsum(TS[2:ncol(TS)])) +data_plot <- melt(cum, id.var = 'Date') +lineSize <- 1 +} +# Assigning x, y and title +if (is.null(x)) x <- colnames(TS)[1] +# y aixs cannot decide if it's a multi column dataframe +#if (is.null(y)) y <- names[2] +theme_set(theme_bw()) +mainLayer <- with(data_plot, { +ggplot(data = data_plot) + +# It's always better to use colname to refer to +aes(x = Date, y = value, color = variable) + +theme(plot.title = element_text(size = rel(1.8), face = 'bold'), +axis.text.x = element_text(size = rel(1.8)), +axis.text.y = element_text(size = rel(1.8)), +axis.title.x = element_text(size = rel(1.8)), +axis.title.y = element_text(size = rel(1.8))) + +labs(x = x, y = y, title = title) +}) +# color <- 'dodgerblue4' +if (type == 'bar') { +secondLayer <- with(data_plot, { +geom_bar(stat = 'identity') +}) +} else if (type == 'line') { +secondLayer <- with(data_plot, { +geom_line(size = lineSize) +}) +} else { +stop("No such plot type.") +} +missingVLayer <- with(TS, { +geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') +}) +plotLayer <- mainLayer + secondLayer + missingVLayer +print(plotLayer) +if (output == 'ggplot') { +if (is.null(name)) stop('"name" argument not found, +If you choose "ggplot" as output, please assign a name.') +data_plot$name <- rep(name, nrow(data_plot)) +data_plot$nav <- rep(0, nrow(data_plot)) +data_plot$nav[NAIndex] <- 1 +return(data_plot) +} +} +plotTS(list = testdl) +library(reshape2) +plotTS(list = testdl) +library(ggplot2) +plotTS(list = testdl) +#' @export +plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, showNA = TRUE, +x = NULL, y = NULL, title = NULL, list = NULL) { +## arrange input TS or TS list. +if (is.null(list)) { +list <- list(...) +if (!class(list[[1]]) == 'data.frame') { +warning('Your input is probably a list, but you forget to add "list = " before it. +Try again, or check help for more information.') +} +# Following part is for plot different time series with different date, but too complicated +# using ggplot. and normal use doesn't need such process. So save it as backup. +# listNames <- names(list) +# # in order to be used later to differentiate lists, there should be a name for each element. +# # Then assign the name column to each list element. +# if (is.null(listNames)) listNames <- 1:length(list) +# +# giveName <- function(x, y) { +# colnames(x) <- NULL +# x$TSname <- rep(listNames[y], nrow(x)) +# return(x) +# } +# list1 <- mapply(FUN = giveName, x = list, y = 1:length(list), SIMPLIFY = FALSE) +# +# checkBind(list1, 'rbind') +# +# TS <- do.call('rbind', list1) +} +list_common <- extractPeriod(list, commonPeriod = TRUE) +TS <- list2Dataframe(list_common) +if (!is.null(names(list)) & (ncol(TS) - 1) == length(list)) colnames(TS)[2:(length(list) + 1)] <- names(list) +# Check input, only check the first column and first row. +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.') +} +TS[, 1] <- as.Date(TS[, 1]) +colnames(TS)[1] <- 'Date' +# first column's name may not be Date, so change its name to Date +data_plot <- melt(TS, id.var = 'Date') +NAIndex <- which(is.na(data_plot$value)) +# assign 0 to NA values +if (plot == 'norm') { +data_plot$value[NAIndex] <- 0 +lineSize <- 0.7 +} else if (plot == 'cum') { +TS[is.na(TS)] <- 0 +cum <- cbind(data.frame(Date = TS[, 1]), cumsum(TS[2:ncol(TS)])) +data_plot <- melt(cum, id.var = 'Date') +lineSize <- 1 +} +# Assigning x, y and title +if (is.null(x)) x <- colnames(TS)[1] +# y aixs cannot decide if it's a multi column dataframe +#if (is.null(y)) y <- names[2] +theme_set(theme_bw()) +mainLayer <- with(data_plot, { +ggplot(data = data_plot) + +# It's always better to use colname to refer to +aes(x = Date, y = value, color = variable) + +theme(plot.title = element_text(size = rel(1.8), face = 'bold'), +axis.text.x = element_text(size = rel(1.8)), +axis.text.y = element_text(size = rel(1.8)), +axis.title.x = element_text(size = rel(1.8)), +axis.title.y = element_text(size = rel(1.8))) + +labs(x = x, y = y, title = title) +}) +# color <- 'dodgerblue4' +if (type == 'bar') { +secondLayer <- with(data_plot, { +geom_bar(stat = 'identity') +}) +} else if (type == 'line') { +secondLayer <- with(data_plot, { +geom_line(size = lineSize) +}) +} else { +stop("No such plot type.") +} +if (showNA == TRUE) { +missingVLayer <- with(TS, { +geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') +}) +mainLayer <- mainLayer + missingVLayer +} +plotLayer <- mainLayer + secondLayer +print(plotLayer) +if (output == 'ggplot') { +if (is.null(name)) stop('"name" argument not found, +If you choose "ggplot" as output, please assign a name.') +data_plot$name <- rep(name, nrow(data_plot)) +data_plot$nav <- rep(0, nrow(data_plot)) +data_plot$nav[NAIndex] <- 1 +return(data_plot) +} +} +plotTS(list = testdl) +plotTS(list = testdl, showNA = F) +devtools::document() +devtools::check() +devtools::document() diff --git a/.Rproj.user/D53FD3E6/pcs/find-in-files.pper b/.Rproj.user/D53FD3E6/pcs/find-in-files.pper index 941ba9c..3bb4cdd 100644 --- a/.Rproj.user/D53FD3E6/pcs/find-in-files.pper +++ b/.Rproj.user/D53FD3E6/pcs/find-in-files.pper @@ -4,7 +4,7 @@ "filePatterns" : [ ], "path" : "E:/1/R/hyfo/R", - "query" : "grepAndmatch", + "query" : "pre", "regex" : false } } \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/pcs/source-pane.pper b/.Rproj.user/D53FD3E6/pcs/source-pane.pper index 70829f6..1743e40 100644 --- a/.Rproj.user/D53FD3E6/pcs/source-pane.pper +++ b/.Rproj.user/D53FD3E6/pcs/source-pane.pper @@ -1,3 +1,3 @@ { - "activeTab" : 1 + "activeTab" : 0 } \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/166D8D14 b/.Rproj.user/D53FD3E6/sdb/per/t/166D8D14 deleted file mode 100644 index cf5b1e7..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/166D8D14 +++ /dev/null @@ -1,18 +0,0 @@ -{ - "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 }\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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1449959816305.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "4278190572", - "id" : "166D8D14", - "lastKnownWriteTime" : 1452416339, - "path" : "E:/1/R/hyfo/R/biasCorrect(generic).R", - "project_path" : "R/biasCorrect(generic).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/188497E b/.Rproj.user/D53FD3E6/sdb/per/t/188497E new file mode 100644 index 0000000..43357fb --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/188497E @@ -0,0 +1,17 @@ +{ + "contents" : "hyfo 1.3.7\n==========\nDate: 2016.3.1\n\n- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted.\n\n\n\nhyfo 1.3.6\n==========\nDate: 2015.12.15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n====\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015.12.6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015.11.27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015.11.7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015.11.3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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" : 1458575550609.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "636433438", + "id" : "188497E", + "lastKnownWriteTime" : 1458575701, + "path" : "E:/1/R/hyfo/NEWS", + "project_path" : "NEWS", + "properties" : { + }, + "relative_order" : 1, + "source_on_save" : false, + "type" : "text" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 b/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 deleted file mode 100644 index fd02f78..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/222F1822 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "hyfo 1.3.6\n==========\nDate: 2015.12.15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n----\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015.12.6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015.11.27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015.11.7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015.11.3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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" : "4159313557", - "id" : "222F1822", - "lastKnownWriteTime" : 1452416339, - "path" : "E:/1/R/hyfo/NEWS", - "project_path" : "NEWS", - "properties" : { - }, - "relative_order" : 2, - "source_on_save" : false, - "type" : "text" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/39BBA10B b/.Rproj.user/D53FD3E6/sdb/per/t/39BBA10B deleted file mode 100644 index 268b842..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/39BBA10B +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Get variable name of the NetCDF file.\n#' \n#' Get variable name in the NetCDF file. After knowning the name, you can use \\code{loadNcdf} to load\n#' the target variable.\n#' \n#' @param filePath A path pointing to the netCDF file.\n#' @return The names of the varialbes in the file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' }\n#' \n#' \n#' \n#' @export\ngetNcdfVar <- function(filePath) {\n nc <- nc_open(filePath)\n names <- names(nc$var)\n return(names)\n}\n\n\n#' Load NetCDF file\n#' \n#' @param filePath A path pointing to the NetCDF file, version3.\n#' @param varname A character representing the variable name, you can use \\code{getNcdfVar} to\n#' get the basic information about the variables and select the target.\n#' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n# @param drop When the time dimension only have one value, the output data will drop\n# this dimension automatically (\\code{drop = TRUE}), default value is \\code{drop = FALSE}, then time dimension will be added.\n# This argument mainly applies to the later calculations based on hyfo file. If the dimension\n# is dropped, than some calculations may not be processed afterwards. \n#' @param ... Several arguments including Year, month, lon, lat \n#' type in \\code{?downscaleNcdf} for details.You can load while downscale, \n#' and also first load than use \\code{downscaleNcdf} to downscale.\n#' @return A list object from \\code{hyfo} containing the information to be used in the analysis, \n#' or biascorrection.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # you can directly add your downscale information to the argument.\n#' nc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), \n#' lat = c(43.2, 43.7))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \nloadNcdf <- function(filePath, varname, tz = 'GMT', ...) {\n nc <- nc_open(filePath)\n \n var <- nc$var\n # Use name to locate the variable\n call_1 <- as.call(c(\n list(as.name('$'), var, varname)\n ))\n var <- eval(call_1)\n if(is.null(var)) stop('No such variable name, check source file.')\n \n dimNames <- unlist(lapply(1:length(var$dim), function(x) var$dim[[x]]$name))\n \n # Only deals with the most common dimensions, futher dimensions will be added in future.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\n if (length(dimIndex) < 3) stop('Your file has less than 3 dimensions.')\n \n # First needs to identify the variable name, load the right data\n message('Loading data...')\n nc_data <- ncvar_get(nc, var)\n message('Processing...')\n \n gridData <- list()\n gridData$Variable$varName <- varname\n gridData$xyCoords$x <- var$dim[[dimIndex[1]]]$vals\n attributes(gridData$xyCoords$x)$name <- dimNames[dimIndex[1]]\n \n gridData$xyCoords$y <- var$dim[[dimIndex[2]]]$vals\n attributes(gridData$xyCoords$y)$name <- dimNames[dimIndex[2]]\n \n # Time part needs to be taken seperately\n \n timeUnit <- strsplit(var$dim[[dimIndex[3]]]$units, split = ' since')[[1]][1]\n timeDiff <- var$dim[[dimIndex[3]]]$vals\n # To get real time, time since when has to be grabbed from the dataset.\n timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz)\n \n \n# Date <- rep(timeSince, length(timeDiff))\n \n \n unitDic <- data.frame(weeks = 'weeks', days = 'days', hours = 'hours',\n minutes = 'mins', seconds = 'secs')\n \n timeDiff <- as.difftime(timeDiff, units = as.character(unitDic[1, timeUnit]))\n \n# if (grepl('day', timeUnit)) {\n# Date$mday <- Date$mday + timeDiff\n# } else if (grepl('second', timeUnit)) {\n# Date$sec <- Date$sec + timeDiff\n# }\n Date <- timeSince + timeDiff\n \n # data directly loaded from ncdf4 will drop the dimension with only one value.\n # the varsize shows the real dimension, without any dropping.\n dim(nc_data) <- var$varsize \n \n # Right now there is no need to add end Date, in furture, may be added as needed.\n gridData$Dates$start <- as.character(Date)\n \n # Assing data to grid data\n # At leaset should be 3 dimensions, lon, lat, time. So if less than 3, \n \n gridData$Data <- nc_data\n \n attributes(gridData$Data)$dimensions <- dimNames\n \n if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals\n \n gridData$Loaded <- 'by hyfo package, http://yuanchao-xu.github.io/hyfo/'\n nc_close(nc)\n \n output <- downscaleNcdf(gridData, ...)\n \n return(output)\n \n}\n\n\n\n\n#' Downscale NetCDF file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param year A vector of the target year. e.g. \\code{year = 2000}, \\code{year = 1980:2000}\n#' @param month A vector of the target month. e.g. \\code{month = 2}, \\code{month = 3:12}\n#' @param lon A vector of the range of the downscaled longitude, should contain a max value\n#' and a min value. e.g. \\code{lon = c(-1.5, 2,5)}\n#' @param lat A vector of the range of the downscaled latitude, should contain a max value\n#' and a min value. e.g. \\code{lat = c(32,2, 36)}\n#' @return A downscaled hyfo list file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7))\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#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \ndownscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) {\n \n \n if (!is.null(year)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n yearIndex <- Dates$year + 1900\n monIndex <- Dates$mon + 1\n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n \n if (is.null(month) || !any(sort(month) != month)) {\n targetYearIndex <- which(yearIndex %in% year)\n if (length(targetYearIndex) == 0) stop('No input years in the input ts, check your input.')\n \n \n # if year crossing than sort(month) != month\n } else {\n \n startIndex <- intersect(which(yearIndex == year[1] - 1), which(monIndex == month[1]))[1]\n endIndex <- tail(intersect(which(yearIndex == tail(year, 1)), which(monIndex == tail(month, 1))), 1)\n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n } else {\n \n targetYearIndex <- startIndex:endIndex\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again.\n # Only for special cases.\n Dates <- Dates[targetYearIndex]\n yea <- Dates$year + 1900\n mon <- Dates$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n targetYearIndex <- targetYearIndex[DateIndex]\n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n }\n \n gridData$Dates$start <- gridData$Dates$start[targetYearIndex]\n gridData$Dates$end <- gridData$Dates$end[targetYearIndex]\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetYearIndex)\n } \n \n if (!is.null(month)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n monIndex <- Dates$mon + 1\n \n targetMonIndex <- which(monIndex %in% month)\n if (length(targetMonIndex) == 0) stop('Check your input year, it may exceed the years \n in the input dataset.')\n gridData$Dates$start <- gridData$Dates$start[targetMonIndex]\n gridData$Dates$end <- gridData$Dates$end[targetMonIndex]\n \n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex)\n \n }\n \n if (!is.null(lon)) {\n \n lonIndex <- gridData$xyCoords$x\n \n lonI1 <- which(abs(lonIndex - min(lon)) == min(abs(lonIndex - min(lon)), na.rm = TRUE)) \n lonI2 <- which(abs(lonIndex - max(lon)) == min(abs(lonIndex - max(lon)), na.rm = TRUE)) \n \n # take the as large as possible range\n targetLonIndex <- lonI1[length(lonI1)]:lonI2[length(lonI2)]\n if (length(targetLonIndex) == 0) stop('Your input lon is too small, try to expand the \n longitude range.') \n gridData$xyCoords$x <- gridData$xyCoords$x[targetLonIndex]\n lonDim <- grepAndMatch('lon', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, lonDim, targetLonIndex)\n }\n \n \n if (!is.null(lat)) {\n latIndex <- gridData$xyCoords$y\n \n latI1 <- which(abs(latIndex - min(lat)) == min(abs(latIndex - min(lat)), na.rm = TRUE)) \n latI2 <- which(abs(latIndex - max(lat)) == min(abs(latIndex - max(lat)), na.rm = TRUE)) \n \n targetLatIndex <- latI1[length(latI1)]:latI2[length(latI2)]\n \n if (length(targetLonIndex) == 0) stop('Your input lat is too small, try to expand the \n latitude range.') \n gridData$xyCoords$y <- gridData$xyCoords$y[targetLatIndex]\n latDim <- grepAndMatch('lat', attributes(gridData$Data)$dimensions)\n gridData$Data <- chooseDim(gridData$Data, latDim, targetLatIndex)\n }\n \n return(gridData)\n \n}\n\n\n\n\n\n\n\n\n\n\n#' Write to NetCDF file using hyfo list file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param filePath A path of the new NetCDF file, should end with \".nc\"\n#' @param missingValue A number representing the missing value in the NetCDF file, default\n#' is 1e20\n#' #' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n#' @param units A string showing in which unit you are putting in the NetCDF file, it can be \n#' seconds or days and so on. If not specified, the function will pick up the possible largest \n#' time units from \\code{c('weeks', 'days', 'hours', 'mins', 'secs')}\n#' @param version ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.\n#' @return An NetCDF version 3 file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' writeNcdf(nc, 'test.nc')\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' \n#' }\n#' \n#' \nwriteNcdf <- function(gridData, filePath, missingValue = 1e20, tz = 'GMT', units = NULL, version = 3) {\n \n name <- gridData$Variable$varName\n # First defines dimensions.\n lonName <- attributes(gridData$xyCoords$x)$name\n latName <- attributes(gridData$xyCoords$y)$name\n dimLon <- ncdim_def(lonName, 'degree', gridData$xyCoords$x)\n dimLat <- ncdim_def(latName, 'degree', gridData$xyCoords$y)\n dimMem <- NULL\n if (!is.null(gridData$Members)) {\n dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members))\n }\n \n \n # Time needs to be treated seperately\n dates <- as.POSIXlt(gridData$Dates$start, tz = tz)\n if (is.null(units)) {\n units <- getTimeUnit(dates)\n time <- difftime(dates, dates[1], units = units)\n } else {\n time <- difftime(dates, dates[1], units = units)\n }\n timeUnits <- paste(units, 'since', dates[1])\n # Here time needs to be numeric, as required by ncdf4 package, which is not the same\n # with ncdf\n dimTime <- ncdim_def('time', timeUnits, as.numeric(time))\n \n \n # Depending on whether there is a member part of the dataset.\n # default list\n dimList <- list(dimLon, dimLat, dimTime, dimMem)\n \n # In order to keep the dim list exactly the same with the original one, it needs to be changed.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), attributes(gridData$Data)$dimensions)\n dimIndex <- na.omit(dimIndex)\n \n # Here order is needed, cuz in the procesure above, c('lon', 'lat', 'time', 'member')\n # is the pattern, while actually, attributes(gridData$Data)$dimensions should be the pattern.\n # So here needs an order() to get the wanted result.\n dimList <- dimList[order(dimIndex)]\n \n # delete the NULL list, in order that there is no member part in the data.\n dimList <- Filter(Negate(is.null), dimList)\n # Then difines data\n var <- ncvar_def( name, \"units\", dimList, missingValue)\n \n \n # Here for ncdf4, there is an option to create version 4 ncdf, in future, it\n # may added here.\n if (version == 3) {\n nc <- nc_create(filePath, var) \n } else if (version == 4) {\n nc <- nc_create(filePath, var, force_v4 = TRUE)\n } else {\n stop(\"Which ncdf version you want? Only 3 and 4 can be selected!\")\n }\n \n # This part comes from the library downscaleR, can be deleted if you don't \n # use {ecomsUDG.Raccess}, by adding this, the file can be read by the package {ecomsUDG.Raccess}\n ncatt_put(nc, \"time\", \"standard_name\",\"time\")\n ncatt_put(nc, \"time\", \"axis\",\"T\")\n ncatt_put(nc, \"time\", \"_CoordinateAxisType\",\"Time\")\n #ncatt_put(nc, \"time\", \"_ChunkSize\",1)\n ncatt_put(nc, lonName, \"standard_name\",\"longitude\")\n ncatt_put(nc, lonName, \"_CoordinateAxisType\",\"Lon\")\n ncatt_put(nc, latName, \"standard_name\",\"latitude\")\n ncatt_put(nc, latName, \"_CoordinateAxisType\",\"Lat\")\n if (!is.null(dimMem)){\n ncatt_put(nc, \"member\", \"standard_name\",\"realization\")\n ncatt_put(nc, \"member\", \"_CoordinateAxisType\",\"Ensemble\")\n #att.put.ncdf(nc, \"member\", \"ref\",\"http://www.uncertml.org/samples/realisation\")\n }\n \n \n # This part has to be put\n ncatt_put(nc, 0, \"Conventions\",\"CF-1.4\")\n ncatt_put(nc, 0, 'WrittenBy', 'hyfo(http://yuanchao-xu.github.io/hyfo/)')\n \n #data <- aperm(gridData$Data, dimIndex) no need to do this, in the process above\n # when you define the dimlist, the order of the dimension was fixed.\n data <- gridData$Data\n ncvar_put(nc, name, data)\n nc_close(nc)\n \n}\n\n# For internaluse by writeNcdf\ngetTimeUnit <- function(dates) {\n units <- c('weeks', 'days', 'hours', 'mins', 'secs')\n output <- NULL\n for (unit in units) {\n time <- difftime(dates, dates[1], units = unit)\n rem <- sapply(time, function(x) x%%1)\n if (!any(rem != 0)) {\n output <- unit\n break\n }\n } \n return(output)\n}\n\n\n# Save for future use. \n#' @import ncdf4\n#' @references \n#' David Pierce (2014). ncdf: Interface to Unidata netCDF data files. R package version 1.6.8.\n#' http://CRAN.R-project.org/package=ncdf\ngetExtralDim <- function(...) {\n dimList <- list(...)\n \n \n}\n\n# in order to first grep than match.\n# match only provides for exactly match, \n# dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\ngrepAndMatch <- function(x, table) {\n index <- unlist(lapply(x, function(x) {\n a <- grep(x, table)\n }))\n return(index)\n}", - "created" : 1449680737769.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3683291925", - "id" : "39BBA10B", - "lastKnownWriteTime" : 1450178194, - "path" : "E:/1/R/hyfo/R/ncdf.R", - "project_path" : "R/ncdf.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/46C049C3 b/.Rproj.user/D53FD3E6/sdb/per/t/46C049C3 deleted file mode 100644 index 8901087..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/46C049C3 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "---\ntitle: '[hyfo Easy Start](http://yuanchao-xu.github.io/hyfo/)'\nauthor: '[Yuanchao Xu](https://dk.linkedin.com/in/xuyuanchao37)'\ndate: '`r Sys.Date()`'\noutput: \n pdf_document:\n toc: yes\n toc_depth: 3\n html_document:\n toc: yes\nvignette: > \n %\\VignetteIndexEntry{hyfo easy start} \n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{ASCII}\n---\n\n# Introduction\n\n**Official Website is [http://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo), where manuals and more details can be found.**\n\nhyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate.\n\nThis package mainly focuses on data process and visulization in hydrology and climate forecasting. Main function includes NetCDF file processing, data extraction, data downscaling, data resampling, gap filler of precipitation, bias correction of forecasting data, flexible time series plot, and spatial map generation. It is a good pre-processing and post-processing tool for hydrological and hydraulic modellers.\n\n**If you feel hyfo is of a little help, please cite it as following:**\n\nXu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/\n\n[Author in this corner](https://dk.linkedin.com/in/xuyuanchao37)\n\n#### TIPS\n* For the hydrology tools part, the minimum time unit is a day, i.e., it mainly focuses on water resource and some long term analysis. For flood analysis part, it will be added in future.\n\n\n* One important characteristic by which hyfo can be distinguished from others is its convenience in multiple plots and series plots. Most data visualization tool in hyfo provides the output that can be directly re-plot by `ggplot2`, if `output = 'ggplot'` is assigned in the argument of the function, which will be easier for the users to generated series/multiple plots afterwards. When `output = 'ggplot'` is selected, you also have to assigne a `name = 'yourname'` in the argument, for the convenience of generating multiplots in future. All the functions ending with `_comb` can generated series/multiple plots, details can be found in the user mannual. \n\n\n* For the forecasting tools part, `hyfo` mainly focuses on the post processing of the gridData derived from forecasts or other sources. The input is a list file, usually an NetCDF file. There are `getNcdfVar()`, `loadNcdf()` and `writeNcdf()` prepared in hyfo, for you to deal with NetCDF file. \n\n* If you don't like the tile, x axis, y axis of the plot, just set them as '', e.g. `title = ''`\n\n* For R beginners, R provides different functions to write to file. `write.table` is a popular choice, and after write the results to a file, you can directly copy paste to your model or to other uses.\n\n* The functions end with `_anarbe` are the functions designed specially for some case in Spain, those functions mostly are about data collection of the anarbe catchment, which will be introduced in the end of this mannual.\n", - "created" : 1443834320384.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2573223757", - "id" : "46C049C3", - "lastKnownWriteTime" : 1449243907, - "path" : "E:/1/R/hyfo/vignettes/hyfo.Rmd", - "project_path" : "vignettes/hyfo.Rmd", - "properties" : { - }, - "relative_order" : 1, - "source_on_save" : false, - "type" : "r_markdown" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/5D765D44 b/.Rproj.user/D53FD3E6/sdb/per/t/5D765D44 deleted file mode 100644 index 1dd1b6a..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/5D765D44 +++ /dev/null @@ -1,18 +0,0 @@ -{ - "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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" : 1449960005295.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3185161121", - "id" : "5D765D44", - "lastKnownWriteTime" : 1446994437, - "path" : "E:/1/R/hyfo/R/resample(generic).R", - "project_path" : "R/resample(generic).R", - "properties" : { - "tempName" : "Untitled1" - }, - "relative_order" : 15, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/67AB4AD7 b/.Rproj.user/D53FD3E6/sdb/per/t/67AB4AD7 deleted file mode 100644 index d2fe7b0..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/67AB4AD7 +++ /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" : 1449959862664.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3466314913", - "id" : "67AB4AD7", - "lastKnownWriteTime" : 1446235115, - "path" : "E:/1/R/hyfo/R/classes.R", - "project_path" : "R/classes.R", - "properties" : { - "tempName" : "Untitled1" - }, - "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/6A0664B3 b/.Rproj.user/D53FD3E6/sdb/per/t/6A0664B3 deleted file mode 100644 index 5db9bf5..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/6A0664B3 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "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" : 1449959878337.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1620316423", - "id" : "6A0664B3", - "lastKnownWriteTime" : 1446467132, - "path" : "E:/1/R/hyfo/R/getMeanPreci.R", - "project_path" : "R/getMeanPreci.R", - "properties" : { - }, - "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/805EE7EC b/.Rproj.user/D53FD3E6/sdb/per/t/805EE7EC deleted file mode 100644 index b1e709c..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/805EE7EC +++ /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" : 1449959837684.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3565279330", - "id" : "805EE7EC", - "lastKnownWriteTime" : 1446223879, - "path" : "E:/1/R/hyfo/R/check.R", - "project_path" : "R/check.R", - "properties" : { - }, - "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/9CDBC212 b/.Rproj.user/D53FD3E6/sdb/per/t/9CDBC212 deleted file mode 100644 index 77bbbfd..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/9CDBC212 +++ /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(plotTS)\nexport(plotTS_comb)\nexport(resample)\nexport(shp2cat)\nexport(writeNcdf)\nexportClasses(biasFactor)\nimport(ggplot2)\nimport(maps)\nimport(maptools)\nimport(ncdf4)\nimport(plyr)\nimport(rgdal)\nimport(rgeos)\nimportFrom(MASS,fitdistr)\nimportFrom(grDevices,rainbow)\nimportFrom(lmom,samlmu)\nimportFrom(methods,new)\nimportFrom(methods,setClass)\nimportFrom(methods,setGeneric)\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,combn)\nimportFrom(utils,packageDescription)\nimportFrom(utils,read.csv)\nimportFrom(utils,read.fwf)\nimportFrom(utils,tail)\nimportFrom(zoo,as.Date)\n", - "created" : 1449183386056.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "547348008", - "id" : "9CDBC212", - "lastKnownWriteTime" : 1452416343, - "path" : "E:/1/R/hyfo/NAMESPACE", - "project_path" : "NAMESPACE", - "properties" : { - }, - "relative_order" : 5, - "source_on_save" : false, - "type" : "r_namespace" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/B5E420D2 b/.Rproj.user/D53FD3E6/sdb/per/t/B5E420D2 deleted file mode 100644 index e0ae531..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/B5E420D2 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "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 <- grepAndMatch(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 <- grepAndMatch(dim, attributes(data)$dimensions)\n dimLength <- dim(data)[dimIndex]\n return(dimLength)\n}\n", - "created" : 1449949349073.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2303557273", - "id" : "B5E420D2", - "lastKnownWriteTime" : 1449960012, - "path" : "E:/1/R/hyfo/R/array_dimension.R", - "project_path" : "R/array_dimension.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/B74937DD b/.Rproj.user/D53FD3E6/sdb/per/t/B74937DD deleted file mode 100644 index 88f013a..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/B74937DD +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.6\nDate: 2015-12-10\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling, data \n resampling, gap filler of precipitation, bias correction of forecasting data, flexible\n time series plot, and spatial map generation. It is a good pre-processing and \n post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods\nSuggests: \n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\n", - "created" : 1446423221493.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "699911376", - "id" : "B74937DD", - "lastKnownWriteTime" : 1449709567, - "path" : "E:/1/R/hyfo/DESCRIPTION", - "project_path" : "DESCRIPTION", - "properties" : { - }, - "relative_order" : 3, - "source_on_save" : false, - "type" : "dcf" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/B8F92D53 b/.Rproj.user/D53FD3E6/sdb/per/t/B8F92D53 deleted file mode 100644 index 2065764..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/B8F92D53 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Get ensemble forecast from historical data.\n#' \n#' getHisEnsem use historical data as the forecasting input time series.\n#' \n#' @param TS A time series dataframe, with first column Date, and second column value.\n#' @param example A vector containing two strings showing the start and end date, which represent the \n#' forecasting period. Check details for more information.\n#'\n#' the program will extract every possible period in TS you provided to generate the ensemble. Check details for \n#' more information.\n#' @param interval A number representing the interval of each ensemble member. NOTE: \"interval\" takes\n#' 365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval \n#' to be 2 years, set \\code{interval = 730}, which equals 2 * 365 ; if two months, set \\code{interval = 60}; \n#' 2 days, \\code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the \n#' number as days.By defualt interval is set to be 365, a year.\n#' @param buffer A number showing how many days are used as buffer period for models. Check details for more\n#' information.\n#' \n#' @param plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\n#' \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{getEnsem_comb}.\n#' \n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \n#' \n#' \\code{example} E.g., if you have a time series from 2000 to 2010. Assuming you are in 2003,\n#' you want to forecast the period from 2003-2-1 to 2003-4-1. Then for each year in your input\n#' time series, every year from 1st Feb to 1st Apr will be extracted to generate the ensemble\n#' forecasts. In this case your input example should be \\code{example = c('2003-2-1', '2003-4-1')}\n#' \n#' \\code{interval} doesn't care about leap year and the months with 31 days, it will take 365 as a year, and 30 as a month.\n#' e.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28\n#' days.\n#' \n#' \\code{example} and \\code{interval} controls how the ensemble will be generated. e.g. if the time series is from \n#' 1990-1-1 to 2001-1-1.\n#' \n#' if \\code{example = c('1992-3-1', '1994-1-1')} and \\code{interval = 1095}, note, 1095 = 365 * 3, so the program treat\n#' this as 3 years.\n#' \n#' Then you are supposed to get the ensemble consisting of following part:\n#' \n#' 1. 1992-3-1 to 1994-1-1 first one is the example, and it's NOT start from 1990-3-1.\n#' 2. 1995-3-1 to 1997-1-1 second one starts from 1993, because \"interval\" is 3 years.\n#' 3. 1998-3-1 to 2000-1-1\n#' \n#' because the last one \"2000-3-1 to 2002-1-1\", 2002 exceeds the original TS range, so it will not be included.\n#' \n#' Sometimes, there are leap years and months with 31 days included in some ensemble part, in which case the length of the data will\n#' be different, e.g., 1999-1-1 to 1999-3-1 is 1 day less than 2000-1-1 to 2000-3-1. In this situation,\n#' the data will use example as a standard. If the example is 1999-1-1 to 1999-3-1, then the latter one\n#' will be changed to 2001-1-1 to 2000-2-29, which keeps the start Date and change the end Date.\n#' \n#' If the end date is so important that cannot be changed, try to solve this problem by resetting\n#' the example period, to make the event included in the example.\n#' \n#' Good set of example and interval can generate good ensemble.\n#' \n#' \\code{buffer}\n#' Sometimes the model needs to run for a few days to warm up, before the forecast. E.g., if a forecast starts at\n#' '1990-1-20', for some model like MIKE NAM model, the run needs to be started about 14 days. So the input timeseries\n#' should start from '1990-1-6'.\n#' \n#' Buffer is mainly used for the model hotstart. Sometimes the hot start file cannot contain all the parameters needed,\n#' only some important parameters. In this case, the model needs to run for some time, to make other parameters ready\n#' for the simulation.\n#' \n#' \n#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, name has to be assigned if \\code{output = 'ggplot'} is selected,\n#' @return A ensemble time series using historical data as forecast.\n#' \n#' @examples\n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'))\n#' \n#' # Default interval is one year, can be set to other values, check help for information.\n#' \n#' # Take 7 months as interval\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') \n#' # Take 30 days as buffer\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @importFrom reshape2 melt \n#' @importFrom grDevices rainbow\n#' @import ggplot2\n#' @references \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#' }\n#' \n#' \n#' @export\n\ngetHisEnsem <- function (TS, example, interval = 365, buffer = 0, plot = 'norm', output = 'data', \n name = NULL, mv = 0, ...) {\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 } else if (!grepl('-|/', example[1]) | !grepl('-|/', example[1])) {\n stop('Wrong date format in the example, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } else {\n \n \n \n TS[, 1] <- as.Date(TS[, 1])\n example <- as.Date(example ,tz = '')\n exL <- example[2] - example[1]\n # Test if example is in the range of the TS\n a <- which(TS[, 1] == example[1] | TS[, 1] == example[2])\n if (length(a) < 2) stop('Example is out of the time series, reset example.')\n \n \n \n if (interval %% 365 == 0) {\n d <- interval / 365\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'years')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'years'))\n\n n <- length(startDate) + length(endDate) - 1 # example is counted twice, should be subtracted. \n \n # Generate full start date series.\n startDate <- seq(min(startDate), length = n, by = paste(d, 'years'))\n endDate <- startDate + exL\n \n } else if (interval %% 30) {\n d <- interval / 30\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'months')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'months'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'months'))\n endDate <- startDate + exL\n \n } else {\n d <- interval\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'days')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'days'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'days'))\n endDate <- startDate + exL\n }\n \n data <- mapply(FUN = function(x, y) extractPeriod_dataframe(dataframe = TS, startDate = x, endDate = y),\n x = startDate, y = endDate)\n \n data <- lapply(1:n, function(x) data.frame(data[, x]))\n \n if (buffer > 0) {\n bufferStart <- example[1] - buffer\n bufferEnd <- example[1] - 1\n bufferTS <- extractPeriod_dataframe(TS, bufferStart, bufferEnd)\n \n data <- lapply(data, function(x) rbind(bufferTS, x))\n \n } else if (buffer < 0) {\n stop ('Buffer should be positive, or reset example.')\n }\n \n \n data_output <- list2Dataframe(data)\n colnames(data_output) <- c('Date', as.character(startDate))\n \n # Rearrange dataframe to make example the first column.\n ind <- match(c('Date', as.character(example[1])), colnames(data_output))\n # when use cbind, to ensure the output is also a dataframe, one inside cbind should be dataframe\n # Even output is alread a dataframe, but when ind is a single number, then output[ind] will\n # not be a dataframe, but an array.\n data_output <- cbind(data.frame(data_output[ind]), data_output[-ind])\n ex_date <- seq(from = example[1] - buffer, to = example[2], by = 1)\n data_output$Date <- ex_date\n colnames(data_output)[2] <- 'Observation'\n \n meanV <- apply(data_output[, 2:ncol(data_output)], MARGIN = 1, FUN = mean, na.rm = TRUE)\n \n data_output <- cbind(data.frame(Date = data_output[, 1]), Mean = meanV, \n data_output[, 2:ncol(data_output)])\n \n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n \n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n } else {\n stop('plot can only be \"norm\" or \"cum\", do not assign other words')\n }\n \n #generate different colors \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable, group = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_point(data = data_ggplot[NAIndex, ], size = 3, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(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 })\n print(mainLayer)\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, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n\n return(data_ggplot)\n } else {\n return(data_output)\n }\n }\n}\n\n\n\n\n\n\n#' Extract time series from forecasting data.\n#' \n#' getFrcEnsem extract timeseries from forecasting data, if forecasting data has a member session\n#' an ensemble time sereis will be returned, if forecasting data doesn't have a member session, a singe time\n#' series will be returned.\n#' \n#' @param dataset A list containing different information, should be the result of \\code{\\link{loadNcdf}}\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 plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\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{getEnsem_comb}.\n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param coord A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned,\n#' cell argument will no longer be used.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \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#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, If name is not assigned and \\code{output = 'ggplot'} is selected, then\n#' the system time will be selected as name column.\n#' \n#' @examples \n#' \n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' nc <- loadNcdf(filePath, varname)\n#' a <- getFrcEnsem(nc)\n#' \n#' # If there is no member session in the dataset, a single time sereis will be extracted.\n#' a1 <- getFrcEnsem(tgridData)\n#' \n#' \n#' # The default output is spatially averaged, if there are more than one cells in the dataset, \n#' # the mean value of the cells will be calculated. While if you are interested in special cell, \n#' # you can assign the cell value. You can also directly use longitude and latitude to extract \n#' # time series.\n#' \n#' getSpatialMap(nc, 'mean')\n#' a <- getFrcEnsem(nc, cell = c(6,2))\n#' \n#' # From the map, cell = c(6, 2) means lon = -1.4, lat = 43.2, so you can use corrd to locate\n#' # your research area and extract time series.\n#' b <- getFrcEnsem(nc, coord = c(-1.4, 43.2))\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @return A ensemble time series extracted from forecating data.\n#' \n#' @import ggplot2\n#' @importFrom reshape2 melt\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' @export\ngetFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', name = NULL,\n mv = 0, coord = NULL, ...) {\n # cell should be a vector showing the location, or mean representing the loacation averaged.\n \n checkHyfo(dataset)\n \n Date <- as.Date(dataset$Dates$start)\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 if (!is.null(coord)) {\n cell <- coord2cell(coord, dataset$xyCoords$x, dataset$xyCoords$y)\n } \n \n \n if (!any(attributes(data)$dimensions == 'member')){\n message('There is no member part in the dataset, there will be only one column of value\n returned.')\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], ]\n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n \n } else {\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], , ]\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem) \n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = c(3, 4), FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n }\n\n \n data_output <- data.frame(Date, data_ensem)\n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n \n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n \n }\n \n colors = c('brown1', rainbow(n = length(unique(data_ggplot$variable)) - 1,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6, color = 'red') +\n geom_point(data = data_ggplot[NAIndex, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n print(mainLayer)\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_ggplot$name <- rep(name, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n return(data_ggplot)\n } else {\n return(data_output)\n }\n}\n\n\n\n#' Combine ensembles together\n#' @param ... different ensembles generated by \\code{getHisEnsem(, output = 'ggplot')} \n#' or \\code{getFrcEnsem(, 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 legend A boolean representing whether you want the legend. Sometimes when you combine\n#' plots, there will be a lot of legends, if you don't like it, you can turn it off by setting\n#' \\code{legend = FALSE}, default is TRUE.\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 ensemble plot.\n#' @examples \n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' \n#' \n#' b1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot',\n#' name = 1)\n#' \n#' b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot',\n#' name = 2)\n#' \n#' getEnsem_comb(b1, b2)\n#' getEnsem_comb(list = list(b1, b2), nrow = 2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' \n\ngetEnsem_comb <- function(..., list = NULL, nrow = 1, legend = TRUE, x = '', y = '', title = '', \n output = FALSE) {\n \n if (!is.null(list)) {\n checkBind(list, 'rbind')\n data_ggplot <- do.call('rbind', list)\n } else {\n plots <- list(...)\n checkBind(plots, 'rbind')\n data_ggplot <- do.call('rbind', plots)\n } \n #data_ggplot$name <- factor(data_ggplot$name, levels = data_ggplot$name, ordered = TRUE)\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 getFreEnsem() or getHisEnsem(), if \n output = \"ggplot\" is assigned, more info please check ?getFreEnsem() or ?getHisEnsem().')\n }\n \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_point(data = data_ggplot[data_ggplot$nav == 1, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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 facet_wrap( ~ name, nrow = nrow) +\n labs(x = x, y = y, title = title)\n \n })\n if (legend == FALSE) {\n mainLayer <- mainLayer + \n theme(legend.position = 'none')\n# following ones are to add label, may be added in future.\n# geom_text(data = data_ggplot[data_ggplot$Date == '2003-12-10', ], aes(label = variable), hjust = 0.7, vjust = 1)\n# geom_text(data = data_ggplot[data_ggplot$variable == 'Mean', ], aes(label = variable), hjust = 0.7, vjust = 1)\n }\n \n \n print(mainLayer)\n \n if (output == TRUE) return(data_ggplot)\n \n}", - "created" : 1449959868792.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3391383568", - "id" : "B8F92D53", - "lastKnownWriteTime" : 1449680802, - "path" : "E:/1/R/hyfo/R/getEnsemble.R", - "project_path" : "R/getEnsemble.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/BDA65B7E b/.Rproj.user/D53FD3E6/sdb/per/t/BDA65B7E deleted file mode 100644 index e8c2ac5..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/BDA65B7E +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "\n\n\n\n#' Get bias factor for multi/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method. \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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\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/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' #' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\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 <- grepAndMatch('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 <- grepAndMatch('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" : 1449959888674.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2627193633", - "id" : "BDA65B7E", - "lastKnownWriteTime" : 1449960337, - "path" : "E:/1/R/hyfo/R/multi-biasCorrect(generic).R", - "project_path" : "R/multi-biasCorrect(generic).R", - "properties" : { - }, - "relative_order" : 14, - "source_on_save" : false, - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/E1BDCB97 b/.Rproj.user/D53FD3E6/sdb/per/t/E1BDCB97 deleted file mode 100644 index f2fcb1a..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/E1BDCB97 +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "#' Collect data from csv for Anarbe case.\n#' \n#' Collect data from the gauging stations in spain, catchement Anarbe\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param output A boolean showing whether the output is given, default is T.\n#' @return The collected data from different csv files.\n#' @examples\n#' \n#' #use internal data as an example.\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_csv_anarbe(folder)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\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#' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n#' @export\n#' @importFrom utils tail\ncollectData_csv_anarbe <- function(folderName, output = TRUE){\n \n fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE)\n data <- lapply(fileNames, readColumn_csv_anarbe)\n data <- do.call('rbind', data)\n data <- data[, 1:2]\n data[, 1] <- as.Date(data[, 1], format = '%d/%m/%Y')\n \n #newFileName <- file.choose(new = T)\n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n if (output) return(data)\n}\n\n\nreadColumn_csv_anarbe <- function(fileName){\n data <- read.csv(fileName, skip = 4)\n endIndex <- which(data == '', arr.ind = TRUE)[1]-1\n \n data <- data[1:endIndex, ]\n \n if (!is.null(levels(data[, 2]))) {\n data[, 2] <- as.numeric(levels((data[, 2])))[data[, 2]]\n }\n \n colnames(data) <- c('Date', 'target')\n message(fileName)\n \n return(data)\n}\n\n\n\n#' Collect data from different excel files\n#' \n#' @param folderName A string showing the folder path.\n#' @param keyword A string showing the extracted column, e.g., waterLevel, waterBalance.\n#' @param output A boolean showing whether the output is given.\n#' @return The collected data from different excel files.\n#' @export\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# @importFrom utils write.table\ncollectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){\n \n message('In order to make \"hyfo\" easier to be installed, this part is commented,\n check original R file in your computer or go to \n https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData_excel.R\n for ideas.')\n \n \n # newFileName <- file.choose(new = TRUE)\n # message ('new file should be located a different location than the excel folder, \n # in order to avoid error.\n # At least 2 excels should be in the folder\\n')\n # \n # message ('this function only applies to strange spain dem operation record file, and this strange file changes\n # its format in the middle of the record. For other applications, some tiny changes needs to be made.')\n # if (is.null(keyword)) stop('key word is needed, e.g.\"waterLevel\".')\n # \n # fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n # data <- lapply(fileNames, FUN = readColumn_excel_anarbe, keyword = keyword)\n # checkBind(data, 'rbind')\n # data <- do.call('rbind', data)\n # \n # data_new <- data.frame(data)\n # \n # data_new <- data_new[order(data_new[, 1]), ]\n # \n # \n # startDate <- data_new[1, 1]\n # endDate <- data_new[length(data_new[, 1]), 1]\n # \n # Date <- as.factor(seq(startDate, endDate, by = 1))\n # \n # if (length(Date) != length(data_new[, 1])) stop('check if the excel files are continuous')\n # \n # colnames(data_new) <- c('Date', keyword)\n # \n # write.table(data_new, file = newFileName,\n # row.names = FALSE, col.names = TRUE, sep = ',')\n # if(output == TRUE) return(data_new)\n}\n\n# \n# @importFrom xlsx read.xlsx\n# readTable_excel_anarbe <- function(fileName){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]], 3)\n# raw_year <- index[1]\n# raw_mon <- index[2]\n# \n# raw <- read.xlsx(fileName, sheetName='A')\n# startRow <- which(raw == 'COTA', arr.ind = TRUE)[1]+4\n# startCol <- which(raw == 'COTA',arr.ind = TRUE)[2]-1\n# stopRow <- which(raw =='TOTAL',arr.ind = TRUE)[1]-1\n# stopCol1 <- startCol + 17\n# stopCol2 <- which(raw == 'SUPERFICIE', arr.ind = TRUE)[2]\n# data <- cbind(raw[startRow:stopRow,startCol:stopCol1], raw[startRow:stopRow,stopCol2])\n# \n# \n# yearIndex <- rep(raw_year, stopRow-startRow+1)\n# monIndex <- rep(raw_mon, stopRow-startRow+1)\n# \n# data <- cbind(yearIndex, monIndex, data)\n# return(data)\n# }\n# # \n# @importFrom utils tail\n# readColumn_excel_anarbe <- function(fileName, keyword = NULL){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]],3)\n# year <- as.numeric(index[1])\n# mon <- as.numeric(index[2])\n# \n# if (year == 99) {\n# year = year + 1900\n# } else year = year + 2000\n# \n# word = c('COTA', 'Cota\\n(m)', 'TOTAL', ' TOTAL')\n# \n# if (keyword == 'waterLevel') {\n# searchWord <- c('COTA', 'Cota\\n(m)')\n# } else if (keyword == 'discharge_ERE') {\n# searchWord <- c('AF.ERE-', 'Caudal\\n(m??/s)')\n# } else if (keyword == 'waterBalance') {\n# searchWord <- c('INCREMENTO', 'al Canal Bajo', 'AFORO',\n# 'Variaci??n\\nvolumen embalsado')\n# } else if (keyword == 'surfaceArea') {\n# searchWord <- c('SUPERFICIE', 'SUPERFICIE')\n# } else if (keyword == 'volume') {\n# searchWord <- c('EMBALSADO', 'Volumen\\n(m????)')\n# }\n# \n# \n# if (year == 1999 | year < 2009 | (year == 2009 & mon < 5)) {\n# raw <- xlsx::read.xlsx(fileName, sheetName = 'A')\n# startIndex <- which(raw == word[1], arr.ind = TRUE)\n# endIndex <- which(raw == word[3], arr.ind = TRUE)\n# startRow <- startIndex[1]+4\n# endRow <- endIndex[1]-1\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# \n# targetCol <- which(raw == searchWord[1], arr.ind = TRUE)[2]\n# \n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[3], arr.ind = TRUE)[2]\n# a <- raw[startRow:endRow, targetStart:targetEnd]\n# a <- sapply(a, function(x) as.numeric(levels(x)[x]))\n# \n# if (year == 1999 & mon == 4) {\n# \n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, rep(NA, dim(a)[1]), a[, 6] * 86.4,\n# a[, 4] * 86.4, a[, 11] * 86.4, a[, 3], a[, 7], rep(NA, dim(a)[1]), a[, 1])\n# } else {\n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, a[, 6] * 86.4, a[, 7] * 86.4, \n# a[, 4] * 86.4, a[, 12] * 86.4, a[, 3], a[, 8], rep(NA, dim(a)[1]), a[, 1])\n# } \n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# if (keyword == 'discharge_ERE') target <- as.numeric(levels(target))[target]/1000\n# }\n# \n# } else {\n# raw <- read.xlsx(fileName,sheetName = 'parte del embalse')\n# startIndex <- which(raw == word[2], arr.ind = TRUE)\n# endIndex <- which(raw == word[4], arr.ind = TRUE)\n# startRow <- startIndex[1]+1\n# endRow <- endIndex[1]-2\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# targetCol <- which(raw == searchWord[2], arr.ind=TRUE)[2]\n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[4], arr.ind=TRUE)[2]\n# target <- raw[startRow:endRow, targetStart:targetEnd]\n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# }\n# \n# }\n# \n# \n# startDate <- as.Date(paste(year, mon, day[1], sep = '-'))\n# endDate <- as.Date(paste(year, mon, tail(day,1), sep = '-'))\n# \n# Date <- seq(startDate, endDate, 1)\n# output <- data.frame(Date, as.vector(target))\n# colnames(output) <- c('Date', seq(1, dim(output)[2] - 1))\n# message(fileName) \n# return(output)\n# \n# }\n# \n\n\n\n\n\n#' collect data from different txt.\n#' \n#' @param folderName A string showing the folder path.\n#' @param output A boolean showing whether the result is given.\n#' @param rangeWord A list containing the keyword and the shift. \n#' defaut is set to be used in spain gauging station.\n#' @examples\n#' \n#' #use internal data as an example.\n#' \n#' \\dontrun{\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_txt_anarbe(folder)\n#' }\n#'\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://www4.gipuzkoa.net/oohh/web/esp/02.asp\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#' @source http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n#' @return The collected data from different txt files.\n#' @export\n#' @importFrom utils tail\ncollectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene ', -1, \n 'Total ', -6)){\n #All the code should be ASCII encode, so there should be no strange symbol.\n if (is.null(rangeWord)) {\n stop('rangeWord consists of 4 elements:\n 1. start word which program can recognise.\n 2. shift1, the shift needs to be made. E.g. start word is in line 7, and program\n should read file from line 9, then shift is 9-7 = 2.\n 3. end word, as start word\n 4. shift2, same as shift1, sometimes can be negative\n \n E.g. rangeWord=c(\\\"aaa\\\",2,\\\"bbb\\\",-2)\n if no rangeWord, just input c(NULL,NULL,NULL,NULL)')\n \n }\n \n \n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n \n data <- lapply(fileNames, FUN = readColumn_txt_anarbe, rangeWord = rangeWord)\n \n data <- do.call('rbind', data)\n \n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n #newFileName <- file.choose(new = T)\n message('new file should be located a different location than the excel folder,\n in order to avoid error.\n At least 2 excels should be in the folder')\n \n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n \n \n if (output == TRUE) return(data)\n \n} \n\n\n\nanarbe_txt <- function(dataset, x1, x2){\n \n data <- as.matrix(dataset[x1:x2, 2:13])\n startYear <- data[1, 6]\n \n data <- data[5:35, ]\n \n date <- which(data != ' ', arr.ind = TRUE)\n startDate <- date[1, ]\n \n endDate <- date[length(date[, 1]), ]\n \n startDate <- as.Date(paste(startYear, startDate[2], startDate[1], sep = '-'))\n endDate <- as.Date(paste(startYear, endDate[2], endDate[1], sep = '-'))\n \n Date <- as.factor(seq(startDate, endDate, 1))\n \n dim(data) <- c(length(data), 1)\n \n data <- as.numeric(data[which(data != ' '), ])\n \n if (length(data) != length(Date)) {\n stop('check original txt file. for missing value, the symbol is \"--\", check\n if this symbol is missing somewhere')\n }\n \n output <- data.frame(Date = Date, target = data)\n \n return(output)\n }\n\n\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#' @importFrom utils read.fwf\nreadColumn_txt_anarbe <- function(fileName, keyword = NULL, rangeWord = NULL){\n \n a <- read.fwf(fileName, widths = rep(10,13))#read file with fixed width\n \n startRow <- which(a == rangeWord[1], arr.ind = TRUE)[, 1]\n startRow <- startRow + as.numeric(rangeWord[2])\n \n endRow <- which(a == rangeWord[3], arr.ind = TRUE)[, 1]\n endRow <- endRow + as.numeric(rangeWord[4])\n \n data <- mapply(FUN = function(x1, x2) anarbe_txt(dataset = a, x1, x2), startRow, endRow)\n \n data_new <- data.frame(Data = unlist(data[1, ]), target = unlist(data[2, ]))\n message(fileName)\n return(data_new)\n}\n", - "created" : 1449334884164.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "897129278", - "id" : "E1BDCB97", - "lastKnownWriteTime" : 1446510987, - "path" : "E:/1/R/hyfo/R/case_anarbe.R", - "project_path" : "R/case_anarbe.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/FCC66B37 b/.Rproj.user/D53FD3E6/sdb/per/t/FCC66B37 deleted file mode 100644 index ce7dc02..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/FCC66B37 +++ /dev/null @@ -1,18 +0,0 @@ -{ - "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @describeIn getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @describeIn getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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" : 1449680759518.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3579155930", - "id" : "FCC66B37", - "lastKnownWriteTime" : 1449680802, - "path" : "E:/1/R/hyfo/R/getPreciBar(generic).R", - "project_path" : "R/getPreciBar(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/prop/947FDB3E b/.Rproj.user/D53FD3E6/sdb/prop/947FDB3E new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/prop/947FDB3E @@ -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 12b747d..cf885ce 100644 --- a/.Rproj.user/D53FD3E6/sdb/prop/INDEX +++ b/.Rproj.user/D53FD3E6/sdb/prop/INDEX @@ -1,3 +1,4 @@ +C%3A%2FUsers%2FYuanchao%2FDesktop%2Fmapping.R="947FDB3E" E%3A%2F1%2FR%2Faaa.R="C5F1CC77" E%3A%2F1%2FR%2FbiasCorrect.R="65AE66E1" E%3A%2F1%2FR%2FextractPeriod.R="720670A7" diff --git a/.Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file b/.Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file new file mode 100644 index 0000000..e69de29 diff --git a/NEWS b/NEWS index 8702cef..8bed25f 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.3.7 +========== +Date: 2016.3.1 + +- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted. + + + hyfo 1.3.6 ========== Date: 2015.12.15 @@ -10,7 +18,7 @@ Date: 2015.12.15 - bug fixed for nc files without members. NOTE: ----- +==== - for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5. diff --git a/R/analyzeTS.R b/R/analyzeTS.R index c0546f8..528040d 100644 --- a/R/analyzeTS.R +++ b/R/analyzeTS.R @@ -9,6 +9,7 @@ #' different outputs in the later multiplot using \code{plotTS_comb}. #' @param plot representing the plot type, there are two types, "norm" and "cum", "norm" gives an normal #' plot, and "cum" gives a cumulative plot. Default is "norm". +#' @param showNA A boolean representing whether the NA values should be marked, default is TRUE. #' @param x label for x axis. #' @param y label for y axis. #' @param title plot title. @@ -50,8 +51,8 @@ #' @import ggplot2 #' @importFrom reshape2 melt #' @export -plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, x = NULL, - y = NULL, title = NULL, list = NULL) { +plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, showNA = TRUE, + x = NULL, y = NULL, title = NULL, list = NULL) { ## arrange input TS or TS list. if (is.null(list)) { list <- list(...) @@ -142,12 +143,16 @@ plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NU stop("No such plot type.") } + if (showNA == TRUE) { + missingVLayer <- with(TS, { + geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') + }) + + mainLayer <- mainLayer + missingVLayer + } - missingVLayer <- with(TS, { - geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') - }) - plotLayer <- mainLayer + secondLayer + missingVLayer + plotLayer <- mainLayer + secondLayer print(plotLayer) diff --git a/man/plotTS.Rd b/man/plotTS.Rd index 636988b..d4a379b 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -5,7 +5,7 @@ \title{plot time series, with marks on missing value.} \usage{ plotTS(..., type = "line", output = "data", plot = "norm", name = NULL, - x = NULL, y = NULL, title = NULL, list = NULL) + showNA = TRUE, x = NULL, y = NULL, title = NULL, list = NULL) } \arguments{ \item{...}{input time series.} @@ -22,6 +22,8 @@ plot, and "cum" gives a cumulative plot. Default is "norm".} \item{name}{If \code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate different outputs in the later multiplot using \code{plotTS_comb}.} +\item{showNA}{A boolean representing whether the NA values should be marked, default is TRUE.} + \item{x}{label for x axis.} \item{y}{label for y axis.} From 2945744e80ee1e13f64452d16eee5b92fc7144dc Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 22 Mar 2016 00:15:01 +0800 Subject: [PATCH 02/43] add showNA to plotTS --- .Rhistory | 2 +- .Rproj.user/D53FD3E6/sdb/per/t/188497E | 17 ----------------- .Rproj.user/D53FD3E6/sdb/per/t/62C82440 | 17 +++++++++++++++++ .Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file | 0 DESCRIPTION | 4 ++-- 5 files changed, 20 insertions(+), 20 deletions(-) delete mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/188497E create mode 100644 .Rproj.user/D53FD3E6/sdb/per/t/62C82440 delete mode 100644 .Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file diff --git a/.Rhistory b/.Rhistory index a1080a4..cd59609 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,4 +1,3 @@ -gridData$Dates$start <- gridData$Dates$start[targetMonIndex] gridData$Dates$end <- gridData$Dates$end[targetMonIndex] timeDim <- match('time', attributes(gridData$Data)$dimensions) gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex) @@ -510,3 +509,4 @@ plotTS(list = testdl, showNA = F) devtools::document() devtools::check() devtools::document() +devtools::document() diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/188497E b/.Rproj.user/D53FD3E6/sdb/per/t/188497E deleted file mode 100644 index 43357fb..0000000 --- a/.Rproj.user/D53FD3E6/sdb/per/t/188497E +++ /dev/null @@ -1,17 +0,0 @@ -{ - "contents" : "hyfo 1.3.7\n==========\nDate: 2016.3.1\n\n- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted.\n\n\n\nhyfo 1.3.6\n==========\nDate: 2015.12.15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n====\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015.12.6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015.11.27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015.11.7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015.11.3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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" : 1458575550609.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "636433438", - "id" : "188497E", - "lastKnownWriteTime" : 1458575701, - "path" : "E:/1/R/hyfo/NEWS", - "project_path" : "NEWS", - "properties" : { - }, - "relative_order" : 1, - "source_on_save" : false, - "type" : "text" -} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/per/t/62C82440 b/.Rproj.user/D53FD3E6/sdb/per/t/62C82440 new file mode 100644 index 0000000..b192179 --- /dev/null +++ b/.Rproj.user/D53FD3E6/sdb/per/t/62C82440 @@ -0,0 +1,17 @@ +{ + "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.7\nDate: 2016-3-21\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling, data \n resampling, gap filler of precipitation, bias correction of forecasting data, flexible\n time series plot, and spatial map generation. It is a good pre-processing and \n post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods\nSuggests: \n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\n", + "created" : 1458576791467.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "355092708", + "id" : "62C82440", + "lastKnownWriteTime" : 1458576809, + "path" : "E:/1/R/hyfo/DESCRIPTION", + "project_path" : "DESCRIPTION", + "properties" : { + }, + "relative_order" : 1, + "source_on_save" : false, + "type" : "dcf" +} \ No newline at end of file diff --git a/.Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file b/.Rproj.user/D53FD3E6/sdb/s-B88BB6B9/lock_file deleted file mode 100644 index e69de29..0000000 diff --git a/DESCRIPTION b/DESCRIPTION index 51a25d6..8bf62ec 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.3.6 -Date: 2015-12-10 +Version: 1.3.7 +Date: 2016-3-21 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and From cbea860fe5ae392a0ff9c16800262896286f5036 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 20 Dec 2016 00:18:09 +0800 Subject: [PATCH 03/43] Update README.md --- README.md | 1 - 1 file changed, 1 deletion(-) diff --git a/README.md b/README.md index dac2176..d3e018c 100644 --- a/README.md +++ b/README.md @@ -28,7 +28,6 @@ This package mainly focuses on data process and visulization in hydrology and cl Xu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/ -[Author in this corner](https://dk.linkedin.com/in/xuyuanchao37) From fad2f9774af9fad16c12d26f85e98e135ddc6fc6 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 20 Dec 2016 09:36:50 +0800 Subject: [PATCH 04/43] Update .travis.yml --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 71a9e19..71f1854 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,4 +28,5 @@ apt_packages: # - libgdal-dev # - libgdal1-dev r_binary_packages: - - rgdal \ No newline at end of file + - rgdal + - rgeos From 207674c4919f7422bd86716cf4c1023891a55c25 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 27 Dec 2016 00:40:15 +0800 Subject: [PATCH 05/43] minor changes --- vignettes/hyfo.Rmd | 1 - 1 file changed, 1 deletion(-) diff --git a/vignettes/hyfo.Rmd b/vignettes/hyfo.Rmd index 44ee087..d11546e 100644 --- a/vignettes/hyfo.Rmd +++ b/vignettes/hyfo.Rmd @@ -26,7 +26,6 @@ This package mainly focuses on data process and visulization in hydrology and cl Xu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/ -[Author in this corner](https://dk.linkedin.com/in/xuyuanchao37) #### TIPS * For the hydrology tools part, the minimum time unit is a day, i.e., it mainly focuses on water resource and some long term analysis. For flood analysis part, it will be added in future. From 4e2ecd56a50d300fc41301a1e7e6d00d7ed39b49 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 10 Jan 2017 23:49:34 +0800 Subject: [PATCH 06/43] 3.1.8 --- .Rhistory | 1006 ++++++++--------- .Rproj.user/D1D10CF6/cpp-definition-cache | 2 + .../D1D10CF6/pcs/debug-breakpoints.pper | 6 + .Rproj.user/D1D10CF6/pcs/files-pane.pper | 9 + .Rproj.user/D1D10CF6/pcs/find-in-files.pper | 10 + .Rproj.user/D1D10CF6/pcs/source-pane.pper | 3 + .../D1D10CF6/pcs/windowlayoutstate.pper | 14 + .Rproj.user/D1D10CF6/pcs/workbench-pane.pper | 6 + .Rproj.user/D1D10CF6/rmd-outputs | 5 + .Rproj.user/D1D10CF6/saved_source_markers | 1 + .Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA | 20 + .Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B | 20 + .Rproj.user/D1D10CF6/sdb/per/t/882400E4 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/9A428717 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A | 20 + .Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB | 20 + .Rproj.user/D1D10CF6/sdb/per/t/EF2B4E | 20 + .Rproj.user/D1D10CF6/sdb/per/t/FFE783F | 20 + .Rproj.user/D1D10CF6/sdb/prop/1BB4BBB4 | 2 + .Rproj.user/D1D10CF6/sdb/prop/23571832 | 2 + .Rproj.user/D1D10CF6/sdb/prop/2988B998 | 2 + .Rproj.user/D1D10CF6/sdb/prop/5B6E4CB4 | 2 + .Rproj.user/D1D10CF6/sdb/prop/7EEE6E30 | 2 + .Rproj.user/D1D10CF6/sdb/prop/85BAB51C | 2 + .Rproj.user/D1D10CF6/sdb/prop/A5EB009E | 2 + .Rproj.user/D1D10CF6/sdb/prop/BF639043 | 2 + .Rproj.user/D1D10CF6/sdb/prop/D338C194 | 2 + .Rproj.user/D1D10CF6/sdb/prop/DD613721 | 2 + .Rproj.user/D1D10CF6/sdb/prop/INDEX | 10 + .Rproj.user/D1D10CF6/session-persistent-state | 1 + .Rproj.user/shared/notebooks/paths | 1 + DESCRIPTION | 19 +- NAMESPACE | 2 +- NEWS | 23 +- R/biasCorrect(generic).R | 10 +- R/extractPeriod(generic).R | 4 +- R/getAnnual(generic).R | 4 +- R/getPreciBar(generic).R | 4 +- R/multi-biasCorrect(generic).R | 8 +- R/ncdf.R | 1 + R/resample(generic).R | 4 +- man/applyBiasFactor.Rd | 43 +- man/biasCorrect.Rd | 93 +- man/biasFactor-class.Rd | 2 +- man/biasFactor.hyfo-class.Rd | 2 +- man/checkBind.Rd | 4 +- man/collectData.Rd | 6 +- man/collectData_csv_anarbe.Rd | 4 +- man/collectData_excel_anarbe.Rd | 2 +- man/collectData_txt_anarbe.Rd | 6 +- man/coord2cell.Rd | 2 +- man/downscaleNcdf.Rd | 3 +- man/extractPeriod.Rd | 33 +- man/fillGap.Rd | 15 +- man/getAnnual.Rd | 17 +- man/getAnnual_dataframe.Rd | 2 +- man/getBiasFactor.Rd | 47 +- man/getEnsem_comb.Rd | 9 +- man/getFrcEnsem.Rd | 16 +- man/getHisEnsem.Rd | 25 +- man/getLMom.Rd | 3 +- man/getMeanPreci.Rd | 10 +- man/getMoment.Rd | 3 +- man/getNcdfVar.Rd | 3 +- man/getPreciBar.Rd | 19 +- man/getPreciBar_comb.Rd | 10 +- man/getSpatialMap.Rd | 11 +- man/getSpatialMap_comb.Rd | 7 +- man/getSpatialMap_mat.Rd | 12 +- man/list2Dataframe.Rd | 5 +- man/loadNcdf.Rd | 13 +- man/monthlyPreci.Rd | 2 +- man/plotTS.Rd | 7 +- man/plotTS_comb.Rd | 5 +- man/resample.Rd | 23 +- man/shp2cat.Rd | 5 +- man/testCat.Rd | 2 +- man/testdl.Rd | 2 +- man/tgridData.Rd | 8 +- man/writeNcdf.Rd | 13 +- 81 files changed, 1068 insertions(+), 779 deletions(-) create mode 100644 .Rproj.user/D1D10CF6/cpp-definition-cache create mode 100644 .Rproj.user/D1D10CF6/pcs/debug-breakpoints.pper create mode 100644 .Rproj.user/D1D10CF6/pcs/files-pane.pper create mode 100644 .Rproj.user/D1D10CF6/pcs/find-in-files.pper create mode 100644 .Rproj.user/D1D10CF6/pcs/source-pane.pper create mode 100644 .Rproj.user/D1D10CF6/pcs/windowlayoutstate.pper create mode 100644 .Rproj.user/D1D10CF6/pcs/workbench-pane.pper create mode 100644 .Rproj.user/D1D10CF6/rmd-outputs create mode 100644 .Rproj.user/D1D10CF6/saved_source_markers create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/882400E4 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/9A428717 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/EF2B4E create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/FFE783F create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/1BB4BBB4 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/23571832 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/2988B998 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/5B6E4CB4 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/7EEE6E30 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/85BAB51C create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/A5EB009E create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/BF639043 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D338C194 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/DD613721 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/INDEX create mode 100644 .Rproj.user/D1D10CF6/session-persistent-state create mode 100644 .Rproj.user/shared/notebooks/paths diff --git a/.Rhistory b/.Rhistory index cd59609..2babc6b 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,512 +1,512 @@ -gridData$Dates$end <- gridData$Dates$end[targetMonIndex] -timeDim <- match('time', attributes(gridData$Data)$dimensions) -gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex) -} -if (!is.null(lon)) { -lonIndex <- gridData$xyCoords$x -lonI1 <- which(abs(lonIndex - min(lon)) == min(abs(lonIndex - min(lon)), na.rm = TRUE)) -lonI2 <- which(abs(lonIndex - max(lon)) == min(abs(lonIndex - max(lon)), na.rm = TRUE)) -# take the as large as possible range -targetLonIndex <- lonI1[length(lonI1)]:lonI2[length(lonI2)] -if (length(targetLonIndex) == 0) stop('Your input lon is too small, try to expand the -longitude range.') -gridData$xyCoords$x <- gridData$xyCoords$x[targetLonIndex] -lonDim <- match('lon', attributes(gridData$Data)$dimensions) -gridData$Data <- chooseDim(gridData$Data, lonDim, targetLonIndex) -} -if (!is.null(lat)) { -latIndex <- gridData$xyCoords$y -latI1 <- which(abs(latIndex - min(lat)) == min(abs(latIndex - min(lat)), na.rm = TRUE)) -latI2 <- which(abs(latIndex - max(lat)) == min(abs(latIndex - max(lat)), na.rm = TRUE)) -targetLatIndex <- latI1[length(latI1)]:latI2[length(latI2)] -if (length(targetLonIndex) == 0) stop('Your input lat is too small, try to expand the -latitude range.') -gridData$xyCoords$y <- gridData$xyCoords$y[targetLatIndex] -latDim <- match('lat', attributes(gridData$Data)$dimensions) -gridData$Data <- chooseDim(gridData$Data, latDim, targetLatIndex) -} -return(gridData) -} -output <- downscaleNcdf(gridData, ...) -output <- downscaleNcdf(gridData) -str(gridData) -name <- gridData$Variable$varName -filePath <- file.choose(new = T) -missingValue = 1e20 -units = NULL -name <- gridData$Variable$varName -dimLon <- ncdim_def('lon', 'degree', gridData$xyCoords$x) -dimLat <- ncdim_def('lat', 'degree', gridData$xyCoords$y) -dimMem <- NULL -dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members)) -dimMem -is.null(gridData$Members) -dimMem <- NULL -if (!is.null(gridData$Members)) { -dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members)) -} -# Time needs to be treated seperately -dates <- as.POSIXlt(gridData$Dates$start, tz = tz) -?getTimeUnit -??getTimeUnit -units <- getTimeUnit(dates) -??getTimeUnit -getTimeUnit <- function(dates) { -units <- c('weeks', 'days', 'hours', 'mins', 'secs') -output <- NULL -for (unit in units) { -time <- difftime(dates, dates[1], units = unit) -rem <- sapply(time, function(x) x%%1) -if (!any(rem != 0)) { -output <- unit -break -} -} -return(output) -} -dates <- as.POSIXlt(gridData$Dates$start, tz = tz) -if (is.null(units)) { -units <- getTimeUnit(dates) -time <- difftime(dates, dates[1], units = units) -} else { -time <- difftime(dates, dates[1], units = units) -} -timeUnits <- paste(units, 'since', dates[1]) -dimTime <- ncdim_def('time', timeUnits, time) -timeUnits -time -as.numeric(time) -dimTime <- ncdim_def('time', timeUnits, as.numeric(time)) -str(dimTime) -dimList <- list(dimLon, dimLat, dimTime, dimMem) -dimList <- Filter(Negate(is.null), dimList) -var <- ncvar_def( name, "units", dimList, missingValue) -nc <- nc_create(filePath, var) -ncatt_put(nc, "time", "standard_name","time") -ncatt_put(nc, "time", "axis","T") -ncatt_put(nc, "time", "_CoordinateAxisType","Time") -#ncatt_put(nc, "time", "_ChunkSize",1) -ncatt_put(nc, "lon", "standard_name","longitude") -ncatt_put(nc, "lon", "_CoordinateAxisType","Lon") -ncatt_put(nc, "lat", "standard_name","latitude") -ncatt_put(nc, "lat", "_CoordinateAxisType","Lat") -if (!is.null(dimMem)){ -ncatt_put(nc, "member", "standard_name","realization") -ncatt_put(nc, "member", "_CoordinateAxisType","Ensemble") -#att.put.ncdf(nc, "member", "ref","http://www.uncertml.org/samples/realisation") -} -ncatt_put(nc, 0, "Conventions","CF-1.4") -ncatt_put(nc, 0, 'WrittenBy', 'hyfo(http://yuanchao-xu.github.io/hyfo/)') -dimIndex <- match(c('lon', 'lat', 'time', 'member'), attributes(gridData$Data)$dimensions) -dimIndex <- na.omit(dimIndex) -dimIndex -data <- aperm(gridData$Data, dimIndex) -ncvar_put(nc, name, data) -nc_close(nc) -devtools::document() -devtools::check(cran=T) -devtools::document() -devtools::check(cran=T) -devtools::build() -a <- c(null,null) -a <- c(NULL, NULL) -a -?match -match() -match -x <- c('lon', 'lat', 'time', 'member') -table <- c('longitude', 'latitude') -index <- lapply(x, function(x) { -a <- grep(x, table) +#' ######## +#' +#' # If your input is obtained by \code{loadNcdf}, you can also directly biascorrect +#' # the file. +#' +#' # First load ncdf file. +#' filePath <- system.file("extdata", "tnc.nc", package = "hyfo") +#' varname <- getNcdfVar(filePath) +#' nc <- loadNcdf(filePath, varname) +#' +#' data(tgridData) +#' # Since the example data, has some NA values, the process will include some warning #message, +#' # which can be ignored in this case. +#' +#' +#' +#' +#' # Then we will use nc data as forecasting data, and use itself as hindcast data, +#' # use tgridData as observation. +#' newFrc <- biasCorrect(nc, nc, tgridData) +#' newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') +#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', +#' preci = TRUE) +#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +#' +#' +#' ######## Time series biascorrection +#' ######## +#' +#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl. +#' data(testdl) +#' +#' # common period has to be extracted in order to better train the forecast. +#' +#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') +#' +#' frc <- datalist[[1]] +#' hindcast <- datalist[[2]] +#' 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) +#' +#' # 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, preci = TRUE) +#' +#' # You can use other scaling methods to biascorrect. +#' 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') +#' +#' # You can also give name to this input list. +#' 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') +#' +#' +#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g., +#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be +#' # for example Dec, Jan and Feb of every year from year 1999-2005. +#' # In such case, you need to extract certain months and years from observed time series. +#' # extractPeriod() can be then used. +#' +#' +#' +#' +#' +#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' +#' +#' @references +#' Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} +#' +#' \itemize{ +#' +#' \item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R +#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki +#' +#' \item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887 +#' +#' \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 +#' } +#' +#' @author Yuanchao Xu \email{xuyuanchao37@@gmail.com } +#' @importFrom methods setMethod +#' @export +#' +setGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', +preci = FALSE, prThreshold = 0, extrapolate = 'no') { +standardGeneric('biasCorrect') }) -a -index -index <- sapply(x, function(x) { -a <- grep(x, table) +# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2 +# so use rdname instead +#' @rdname 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) }) -index -index <- unlist(lapply(x, function(x) { -a <- grep(x, table) -})) -index -table <- c('latitude', 'longitude') -index <- unlist(lapply(x, function(x) { -a <- grep(x, table) -})) -index -table <- c('itude', 'itude') -index <- unlist(lapply(x, function(x) { -a <- grep(x, table) -})) -index -devtools::document() -devtools::check() -devtools::check() -devtools::build() -devtools::document() -devtools::check() -devtools::check() -?match -devtools::build() -devtools::document() -devtools::check() -devtools::document() -devtools::check() -devtools::build() -devtools::document() -devtools::check() -devtools::build() -devtools::document() -devtools::check() -devtools::build() -devtools::document() -devtools::check() -devtools::build() -library(ncdf4) -?nc_write -??nc_create -devtools::document() -devtools::document() -devtools::check() -devtools::build() -writePath <- file.choose() -writePath <- file.choose(new = T) -library(hyfo) -filePath <- file.choose() -name <- getNcdfVar(filePath) -a <- loadNcdf(filePath, name[6]) -str(a) -a$xyCoords$y -attributes(a$xyCoords$y) -attributes(a$xyCoords$y)$name <- 'dafa' -attributes(a$xyCoords$y) -devtools::build() -devtools::check() -devtools::check() -attributes(a$xyCoords$x)$name -?writeNcdf -filePath1 <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath1) -nc <- loadNcdf(filePath1, varname1) -nc <- loadNcdf(filePath1, varname) -str(nc) -nc$xyCoords$x -nc$xyCoords$y -devtools::check() -devtools::build() -devtools::check() -devtools::build() -devtools::check() -filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) -nc <- loadNcdf(filePath, varname) -writePath <- file.choose(new=T) -writeNcdf(nc, writePath) -a <- loadNcdf(writePath, varname) -str(a) -filePath <- file.choose() -name <- getNcdfVar(filePath) -a <- loadNcdf(filePath, name[6]) -writeNcdf(nc, writePath) -b <- loadNcdf(writePath, name[6]) -writeNcdf(a, writePath) -b <- loadNcdf(writePath, name[6]) -str(b) -str(a) -debug(writeNcdf) -writeNcdf(a, writePath) -str(data) -debug(loadNcdf) -b <- loadNcdf(writePath, name[6]) -str(var) -devtools::check() -writeNcdf(a, writePath) -b <- loadNcdf(writePath, name[6]) -str(b) -debug(writeNcdf) -writeNcdf(a, writePath) -dimIndex -dimIndex -str(diList) -str(dimList) -str(dimList) -str(dimList) -name -str(var) -str(dimList) -dimIndex -attributes(gridData$Data)$dimensions -str(dimList) -c('lon', 'lat', 'time', 'member')[dimIndex] -dimIndex -c('lon', 'lat', 'time', 'member')[c(1,3,2)] -c('lon', 'lat', 'time', 'member')[c(1,2,3)] -attributes(gridData$Data)$dimensions -grep('longitude', 'lon') -grep('lon','longitude') -?grep -dimIndex -order(dimIndex) -dimIndex -str(dimIndex) -devtools::check() -devtools::check() -writeNcdf(a, writePath) -debug(writeNcdf) -writeNcdf(a, writePath) +#' @rdname 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 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 <- grepAndMatch('member', attributes(frcData)$dimensions) +# For dataset that has a member part +if (length(memberIndex) != 0) { +# 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 (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) +} +#' @importFrom MASS fitdistr +#' @importFrom stats ecdf quantile pgamma qgamma rgamma +#' +#' @references +#' Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} +#' +#' \itemize{ +#' +#' \item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R +#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki +#' +#' \item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887 +#' +#' \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 +#' } +#' +#' +#' +# this is only used to calculate the value column, +biasCorrect_core <- function(frc, 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(frc)) | !any(!is.na(hindcast))) { +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.') +# comes from downscaleR biascorrection method +frcMean <- mean(frc, na.rm = TRUE) +hindcastMean <- mean(hindcast, na.rm = TRUE) +frc <- obs - hindcastMean + frcMean +} else if (method == 'scaling') { +obsMean <- mean(obs, na.rm = TRUE) +hindcastMean <- mean(hindcast, na.rm = TRUE) +if (scaleType == 'multi') { +frc <- frc / hindcastMean * obsMean +} else if (scaleType == 'add') { +frc <- frc - hindcastMean + obsMean +} +} else if (method == 'eqm') { +if (preci == FALSE) { +frc <- biasCorrect_core_eqm_nonPreci(frc, hindcast, obs, extrapolate, prThreshold) +} else { +frc <- biasCorrect_core_eqm_preci(frc, hindcast, obs, minHindcastPreci, extrapolate, +prThreshold) +} +} else if (method == 'gqm') { +if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T') +frc <- biasCorrect_core_gqm(frc, hindcast, obs, prThreshold, minHindcastPreci) +} +return(frc) +} +#' @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", lower = c(0, 0)) +# 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)) +} +biasCorrect_core_eqm_nonPreci <- function(frc, hindcast, obs, extrapolate, prThreshold) { +ecdfHindcast <- ecdf(hindcast) +if (extrapolate == 'constant') { +higherIndex <- which(frc > max(hindcast, na.rm = TRUE)) +lowerIndex <- which(frc < min(hindcast, na.rm = TRUE)) +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) { +maxHindcast <- max(hindcast, na.rm = TRUE) +dif <- maxHindcast - max(obs, na.rm = TRUE) +frc[higherIndex] <- frc[higherIndex] - dif +} +if (length(lowerIndex) > 0) { +minHindcast <- min(hindcast, na.rm = TRUE) +dif <- minHindcast - min(obs, nna.rm = TRUE) +frc[lowerIndex] <- frc[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) +} +biasCorrect_core_eqm_preci <- function(frc, hindcast, obs, minHindcastPreci, extrapolate, +prThreshold) { +# 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 (length(which(hindcast > minHindcastPreci)) > 0) { +ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci]) +noRain <- which(frc <= minHindcastPreci & !is.na(frc)) +rain <- which(frc > 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 > minHindcastPreci & frc <= min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) +& !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] > max(hindcast, na.rm = TRUE)) +lowerIndex <- which(frc[rain] < min(hindcast, na.rm = TRUE)) +extrapolateIndex <- c(higherIndex, lowerIndex) +non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex) +if (length(higherIndex) > 0) { +maxHindcast <- max(hindcast, na.rm = TRUE) +dif <- maxHindcast - max(obs, na.rm = TRUE) +frc[rain[higherIndex]] <- frc[higherIndex] - dif +} +if (length(lowerIndex) > 0) { +minHindcast <- min(hindcast, na.rm = TRUE) +dif <- minHindcast - min(obs, nna.rm = TRUE) +frc[rain[lowerIndex]] <- frc[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 > min(hindcast[which(hindcast > minHindcastPreci)], na.rm = TRUE) & +!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 <= minHindcastPreci & !is.na(frc)) +rain <- which(frc > 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) +} +biasCorrect_core_gqm <- function(frc, hindcast, obs, prThreshold, minHindcastPreci) { +if (any(obs > prThreshold)) { +ind <- which(obs > prThreshold & !is.na(obs)) +obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0)) +ind <- which(hindcast > 0 & !is.na(hindcast)) +hindcastGamma <- fitdistr(hindcast[ind],"gamma", lower = c(0, 0)) +rain <- which(frc > minHindcastPreci & !is.na(frc)) +noRain <- which(frc <= minHindcastPreci & !is.na(frc)) +probF <- pgamma(frc[rain], hindcastGamma$estimate[1], rate = hindcastGamma$estimate[2]) +frc[rain] <- qgamma(probF,obsGamma$estimate[1], rate = obsGamma$estimate[2]) +frc[noRain] <- 0 +} else { +warning('All the observations of this cell(station) are lower than the threshold, +no bias correction applied.') +} +return(frc) +} +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +library(MASS) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +trace(biasCorrect) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) devtools::check() -debug(writeNcdf) -writeNcdf(a, writePath) -dimIndex -str(dimList) -str(dimList) -str(dimList) -str(var) -name -str(nc) -b <- loadNcdf(writePath, name[6]) -str(b) -identical(a, b) -str(a) -identical(a$Variable, b$Variable) -identical(a$xyCoords, b$xyCoords) -identical(a$Dates, b$Dates) -identical(a$Data, b$Data) -str(a$Data) -str(b$Data) -a$Data == b$Data -a$Data - b$Data -a$Data - b$Data > 0.0001 -any((a$Data - b$Data > 0.0001) == T) -any((a$Data - b$Data > 0.0000001) == T) -devtools::build() +trace("biasCorrect", browser, exit=browser, signature = c("data.frame", "data.frame", "data.frame")) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +debug(hindcast) +debug(preprocessHindcast) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) +debug(biasCorrect_core_gqm) +frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) devtools::check() -devtools::build() -library(hyfo) -?biasCorrect filePath <- system.file("extdata", "tnc.nc", package = "hyfo") varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) data(tgridData) -newFrc <- biasCorrect(nc, tgridData, tgridData) -newFrc <- biasCorrect(tgridData, tgridData, tgridData) -debug(biasCorrect) -newFrc <- biasCorrect(tgridData, tgridData, tgridData) -undebug(biasCorrect) -debug(biasCorrect.list) -devtools::check() -debug(biasCorrect.list) -newFrc <- biasCorrect(tgridData, tgridData, tgridData) -memberIndex -devtools::check() -devtools::build() -newFrc <- biasCorrect(tgridData, tgridData, tgridData) -devtools::check() -newFrc <- biasCorrect(tgridData, tgridData, tgridData) -devtools::build() -?fortify -??fortify -library(hyfo) -plotTS(testdl[[1]]) -plotTS(testdl[[1]], x = 'xxx', y = 'yyy', title = 'aaa') -plotTS(list = testdl) -plotTS(testdl[[1]], testdl[[2]], plot = 'cum') -plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, x = NULL, -y = NULL, title = NULL, list = NULL) { -## arrange input TS or TS list. -if (is.null(list)) { -list <- list(...) -if (!class(list[[1]]) == 'data.frame') { -warning('Your input is probably a list, but you forget to add "list = " before it. -Try again, or check help for more information.') -} -# Following part is for plot different time series with different date, but too complicated -# using ggplot. and normal use doesn't need such process. So save it as backup. -# listNames <- names(list) -# # in order to be used later to differentiate lists, there should be a name for each element. -# # Then assign the name column to each list element. -# if (is.null(listNames)) listNames <- 1:length(list) -# -# giveName <- function(x, y) { -# colnames(x) <- NULL -# x$TSname <- rep(listNames[y], nrow(x)) -# return(x) -# } -# list1 <- mapply(FUN = giveName, x = list, y = 1:length(list), SIMPLIFY = FALSE) -# -# checkBind(list1, 'rbind') -# -# TS <- do.call('rbind', list1) -} -list_common <- extractPeriod(list, commonPeriod = TRUE) -TS <- list2Dataframe(list_common) -if (!is.null(names(list)) & (ncol(TS) - 1) == length(list)) colnames(TS)[2:(length(list) + 1)] <- names(list) -# Check input, only check the first column and first row. -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.') -} -TS[, 1] <- as.Date(TS[, 1]) -colnames(TS)[1] <- 'Date' -# first column's name may not be Date, so change its name to Date -data_plot <- melt(TS, id.var = 'Date') -NAIndex <- which(is.na(data_plot$value)) -# assign 0 to NA values -if (plot == 'norm') { -data_plot$value[NAIndex] <- 0 -lineSize <- 0.7 -} else if (plot == 'cum') { -TS[is.na(TS)] <- 0 -cum <- cbind(data.frame(Date = TS[, 1]), cumsum(TS[2:ncol(TS)])) -data_plot <- melt(cum, id.var = 'Date') -lineSize <- 1 -} -# Assigning x, y and title -if (is.null(x)) x <- colnames(TS)[1] -# y aixs cannot decide if it's a multi column dataframe -#if (is.null(y)) y <- names[2] -theme_set(theme_bw()) -mainLayer <- with(data_plot, { -ggplot(data = data_plot) + -# It's always better to use colname to refer to -aes(x = Date, y = value, color = variable) + -theme(plot.title = element_text(size = rel(1.8), face = 'bold'), -axis.text.x = element_text(size = rel(1.8)), -axis.text.y = element_text(size = rel(1.8)), -axis.title.x = element_text(size = rel(1.8)), -axis.title.y = element_text(size = rel(1.8))) + -labs(x = x, y = y, title = title) -}) -# color <- 'dodgerblue4' -if (type == 'bar') { -secondLayer <- with(data_plot, { -geom_bar(stat = 'identity') -}) -} else if (type == 'line') { -secondLayer <- with(data_plot, { -geom_line(size = lineSize) -}) -} else { -stop("No such plot type.") -} -missingVLayer <- with(TS, { -geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') -}) -plotLayer <- mainLayer + secondLayer + missingVLayer -print(plotLayer) -if (output == 'ggplot') { -if (is.null(name)) stop('"name" argument not found, -If you choose "ggplot" as output, please assign a name.') -data_plot$name <- rep(name, nrow(data_plot)) -data_plot$nav <- rep(0, nrow(data_plot)) -data_plot$nav[NAIndex] <- 1 -return(data_plot) -} -} -plotTS(list = testdl) -library(reshape2) -plotTS(list = testdl) -library(ggplot2) -plotTS(list = testdl) -#' @export -plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, showNA = TRUE, -x = NULL, y = NULL, title = NULL, list = NULL) { -## arrange input TS or TS list. -if (is.null(list)) { -list <- list(...) -if (!class(list[[1]]) == 'data.frame') { -warning('Your input is probably a list, but you forget to add "list = " before it. -Try again, or check help for more information.') -} -# Following part is for plot different time series with different date, but too complicated -# using ggplot. and normal use doesn't need such process. So save it as backup. -# listNames <- names(list) -# # in order to be used later to differentiate lists, there should be a name for each element. -# # Then assign the name column to each list element. -# if (is.null(listNames)) listNames <- 1:length(list) -# -# giveName <- function(x, y) { -# colnames(x) <- NULL -# x$TSname <- rep(listNames[y], nrow(x)) -# return(x) -# } -# list1 <- mapply(FUN = giveName, x = list, y = 1:length(list), SIMPLIFY = FALSE) -# -# checkBind(list1, 'rbind') -# -# TS <- do.call('rbind', list1) -} -list_common <- extractPeriod(list, commonPeriod = TRUE) -TS <- list2Dataframe(list_common) -if (!is.null(names(list)) & (ncol(TS) - 1) == length(list)) colnames(TS)[2:(length(list) + 1)] <- names(list) -# Check input, only check the first column and first row. -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.') -} -TS[, 1] <- as.Date(TS[, 1]) -colnames(TS)[1] <- 'Date' -# first column's name may not be Date, so change its name to Date -data_plot <- melt(TS, id.var = 'Date') -NAIndex <- which(is.na(data_plot$value)) -# assign 0 to NA values -if (plot == 'norm') { -data_plot$value[NAIndex] <- 0 -lineSize <- 0.7 -} else if (plot == 'cum') { -TS[is.na(TS)] <- 0 -cum <- cbind(data.frame(Date = TS[, 1]), cumsum(TS[2:ncol(TS)])) -data_plot <- melt(cum, id.var = 'Date') -lineSize <- 1 -} -# Assigning x, y and title -if (is.null(x)) x <- colnames(TS)[1] -# y aixs cannot decide if it's a multi column dataframe -#if (is.null(y)) y <- names[2] -theme_set(theme_bw()) -mainLayer <- with(data_plot, { -ggplot(data = data_plot) + -# It's always better to use colname to refer to -aes(x = Date, y = value, color = variable) + -theme(plot.title = element_text(size = rel(1.8), face = 'bold'), -axis.text.x = element_text(size = rel(1.8)), -axis.text.y = element_text(size = rel(1.8)), -axis.title.x = element_text(size = rel(1.8)), -axis.title.y = element_text(size = rel(1.8))) + -labs(x = x, y = y, title = title) -}) -# color <- 'dodgerblue4' -if (type == 'bar') { -secondLayer <- with(data_plot, { -geom_bar(stat = 'identity') -}) -} else if (type == 'line') { -secondLayer <- with(data_plot, { -geom_line(size = lineSize) -}) -} else { -stop("No such plot type.") -} -if (showNA == TRUE) { -missingVLayer <- with(TS, { -geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black') -}) -mainLayer <- mainLayer + missingVLayer -} -plotLayer <- mainLayer + secondLayer -print(plotLayer) -if (output == 'ggplot') { -if (is.null(name)) stop('"name" argument not found, -If you choose "ggplot" as output, please assign a name.') -data_plot$name <- rep(name, nrow(data_plot)) -data_plot$nav <- rep(0, nrow(data_plot)) -data_plot$nav[NAIndex] <- 1 -return(data_plot) -} -} -plotTS(list = testdl) -plotTS(list = testdl, showNA = F) -devtools::document() +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0)) +obsGamma <- fitdistr(obs[ind],"gamma") +obsGamma <- fitdistr(obs[ind],"gamma", lower = c(-4, -5)) +?optim +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +debug(optim) +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +method +trace("optim") +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +trace("optim") +traceback("optim") +traceback("optim") +debug(fitdistr) +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +start +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +obsGamma <- fitdistr(obs[ind],"gamma") +start +method +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +length(NULL) +start +method +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +obsGamma <- fitdistr(obs[ind],"gamma") +start +method +method +lower +length(lower) +length(lower) > 1L +npar +par +con +lower +upper +rep_len(upper) +npar +rep_len(upper, npar) +parm +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +fn +fn() +?fn +??fn +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0), upper = c(1000, 0)) devtools::check() -devtools::document() -devtools::document() diff --git a/.Rproj.user/D1D10CF6/cpp-definition-cache b/.Rproj.user/D1D10CF6/cpp-definition-cache new file mode 100644 index 0000000..32960f8 --- /dev/null +++ b/.Rproj.user/D1D10CF6/cpp-definition-cache @@ -0,0 +1,2 @@ +[ +] \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/debug-breakpoints.pper b/.Rproj.user/D1D10CF6/pcs/debug-breakpoints.pper new file mode 100644 index 0000000..5528aea --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/debug-breakpoints.pper @@ -0,0 +1,6 @@ +{ + "debugBreakpointsState" : { + "breakpoints" : [ + ] + } +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/files-pane.pper b/.Rproj.user/D1D10CF6/pcs/files-pane.pper new file mode 100644 index 0000000..7931319 --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/files-pane.pper @@ -0,0 +1,9 @@ +{ + "path" : "~/GitHub/hyfo", + "sortOrder" : [ + { + "ascending" : true, + "columnIndex" : 2 + } + ] +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/find-in-files.pper b/.Rproj.user/D1D10CF6/pcs/find-in-files.pper new file mode 100644 index 0000000..1780c45 --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/find-in-files.pper @@ -0,0 +1,10 @@ +{ + "dialog-state" : { + "caseSensitive" : true, + "filePatterns" : [ + ], + "path" : "~/GitHub/hyfo", + "query" : "newFrc", + "regex" : false + } +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/source-pane.pper b/.Rproj.user/D1D10CF6/pcs/source-pane.pper new file mode 100644 index 0000000..3249574 --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/source-pane.pper @@ -0,0 +1,3 @@ +{ + "activeTab" : 2 +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/windowlayoutstate.pper b/.Rproj.user/D1D10CF6/pcs/windowlayoutstate.pper new file mode 100644 index 0000000..47ab870 --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/windowlayoutstate.pper @@ -0,0 +1,14 @@ +{ + "left" : { + "panelheight" : 1069, + "splitterpos" : 443, + "topwindowstate" : "NORMAL", + "windowheight" : 1108 + }, + "right" : { + "panelheight" : 1069, + "splitterpos" : 664, + "topwindowstate" : "NORMAL", + "windowheight" : 1108 + } +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper b/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper new file mode 100644 index 0000000..0e24b84 --- /dev/null +++ b/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper @@ -0,0 +1,6 @@ +{ + "TabSet1" : 0, + "TabSet2" : 0, + "TabZoom" : { + } +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/rmd-outputs b/.Rproj.user/D1D10CF6/rmd-outputs new file mode 100644 index 0000000..3f2ff2d --- /dev/null +++ b/.Rproj.user/D1D10CF6/rmd-outputs @@ -0,0 +1,5 @@ + + + + + diff --git a/.Rproj.user/D1D10CF6/saved_source_markers b/.Rproj.user/D1D10CF6/saved_source_markers new file mode 100644 index 0000000..2b1bef1 --- /dev/null +++ b/.Rproj.user/D1D10CF6/saved_source_markers @@ -0,0 +1 @@ +{"active_set":"","sets":[]} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA b/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA new file mode 100644 index 0000000..f6a123c --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' f\n#' \n#' \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 }\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\n# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1483875773075.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1352449680", + "id" : "2A6E2BEA", + "lastKnownWriteTime" : 1483973407, + "last_content_update" : 1483973407763, + "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", + "project_path" : "R/biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 2, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 b/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 new file mode 100644 index 0000000..3b93faf --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "hyfo 1.3.8\n==========\nDate: 2017-1-8\n\n- add changes to the new version of roxygen2\n- change biasCorrection's description, change default prThreshold to 0, since not every one is an expert and know how to set it, better keep the original unchanged.\n\n\n\nhyfo 1.3.7\n==========\nDate: 2016-3-1\n\n- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted.\n\n\n\nhyfo 1.3.6\n==========\nDate: 2015-12-15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n====\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015-12-6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015-11-27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015-11-7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015-11-3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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" : 1483876849677.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "395220279", + "id" : "390DEBE1", + "lastKnownWriteTime" : 1483973453, + "last_content_update" : 1483973453652, + "path" : "~/GitHub/hyfo/NEWS", + "project_path" : "NEWS", + "properties" : { + }, + "relative_order" : 9, + "source_on_save" : false, + "source_window" : "", + "type" : "text" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B b/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B new file mode 100644 index 0000000..0a5af98 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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" : 1483876772702.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4265558900", + "id" : "6DDA2A7B", + "lastKnownWriteTime" : 1483876799, + "last_content_update" : 1483876799732, + "path" : "~/GitHub/hyfo/R/getPreciBar(generic).R", + "project_path" : "R/getPreciBar(generic).R", + "properties" : { + }, + "relative_order" : 7, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 b/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 new file mode 100644 index 0000000..e8dead6 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "\n\n\n\n#' Get bias factor for multi/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method. \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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\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#' @rdname 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#' @rdname 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/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' #' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\n#' \n#' @export\nsetGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) {\n standardGeneric('applyBiasFactor')\n})\n\n#' @rdname 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#' @rdname 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 <- grepAndMatch('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 <- grepAndMatch('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" : 1483876652911.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3103634387", + "id" : "882400E4", + "lastKnownWriteTime" : 1483876696, + "last_content_update" : 1483876696357, + "path" : "~/GitHub/hyfo/R/multi-biasCorrect(generic).R", + "project_path" : "R/multi-biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 5, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 b/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 new file mode 100644 index 0000000..f8a5986 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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#' @rdname resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @rdname 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" : 1483876700794.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1807730850", + "id" : "9A428717", + "lastKnownWriteTime" : 1483876727, + "last_content_update" : 1483876727135, + "path" : "~/GitHub/hyfo/R/resample(generic).R", + "project_path" : "R/resample(generic).R", + "properties" : { + }, + "relative_order" : 6, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A b/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A new file mode 100644 index 0000000..a9dc2c6 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get annual rainfall of different rainfall time series\n#' \n#' Get annual rainfall of different raninfall time series.\n#' \n#' \n#' @param data A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\n#' gauging stations. Usually an output of \\code{list2Dataframe}.\n#' @param output A string showing the output output.\n#' @param minRecords A number showing the minimum accept record number, e.g. for a normal \n#' year(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\n#' of a year, it will be ignored in the mean annual value calculation. Only valid \n#' when \\code{output = \"mean\"}, default is 355.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @return The annual rainfall and the number of missing data of each year and each rainfall gauge, which \n#' will also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n#' @details \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #datalist is provided by the package as a test.\n#' data(testdl)\n#' a <- getAnnual(testdl)\n#' #set minRecords to control the calculation of annual rainfall.\n#' b <- getAnnual(testdl, output = 'mean', minRecords = 350)\n#' c <- getAnnual(testdl, output = 'mean', minRecords = 365)\n#' \n#' a1 <- extractPeriod(testdl, comm = TRUE)\n#' a2 <- list2Dataframe(a1)\n#' getAnnual(a2)\n#' \n#' a3 <- fillGap(a2)\n#' getAnnual(a3)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom methods setGeneric\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 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#' \nsetGeneric('getAnnual', function(data, output = 'series', minRecords = 355, \n ...) {\n standardGeneric('getAnnual')\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('data.frame'), \n function(data, output, minRecords, ...) {\n result <- getAnnual.TS(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('list'),\n function(data, output, minRecords, ...) {\n result <- getAnnual.list(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n })\n\ngetAnnual.TS <- function(dataframe) {\n Date <- as.POSIXlt(dataframe[, 1])\n # Calculate how many gauging stations.\n stations <- colnames(dataframe)[2:ncol(dataframe)]\n \n data <- lapply(stations, function(x) {\n dataframe_new <- data.frame(Date, dataframe[, x])\n colnames(dataframe_new)[2] <- x\n getAnnual_dataframe(dataframe_new)\n })\n \n data <- do.call('rbind', data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n \n return(data)\n}\n\n\ngetAnnual.list <- function(datalist) {\n data <- lapply(datalist, FUN = getAnnual_dataframe)\n data <- do.call('rbind', data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n return(data)\n}\n\n#' @import ggplot2 \n#' @importFrom reshape2 melt\n#' @importFrom stats aggregate\ngetAnnual.plot <- function(data, output, minRecords, ...) {\n theme_set(theme_bw())\n \n if (output == 'mean') {\n validData <- data[data$recordNum >= minRecords,]\n \n data <- aggregate(validData$AnnualPreci, list(validData$Name), mean)\n colnames(data) <- c('Name', 'AnnualPreci')\n \n mainLayer <- with(data, {\n ggplot(data)+\n geom_bar(aes(x = Name, y = AnnualPreci, fill = Name), stat = 'identity')+\n labs(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n \n print(mainLayer)\n \n } else {\n \n plotData <- with(data, {\n subset(data, select = c(Year, Name, NANum, AnnualPreci))\n })\n \n plotData <- melt(plotData, var.id = c('Year', 'Name'))\n \n \n mainLayer <- with(plotData, {\n ggplot(plotData) +\n geom_bar(aes(x = Year, y = value , fill = Name), \n stat = 'identity') +\n facet_grid(variable ~ Name, scale = 'free') +\n xlab('Year') +\n ylab(NULL) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = 20, face = 'bold', vjust = 1)) +\n theme(axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.5)),\n axis.text.y = element_text(size = rel(1.5)))\n # grid.arrange(mainLayer, ncol = 4)\n \n })\n \n \n print(mainLayer)\n } \n}\n\n\n\n\n\n\n\n\n#' Get annual rainfall of the input time series.\n#' \n#' @param dataset A dataframe containing one time series, e.g., rainfall from one gauging station.\n#' the time should follow the format : \"1990-1-1\"\n#' @return The annual rainfall of each year of the input station.\n# @examples\n# data(testdl)\n# getAnnual_dataframe(testdl[[1]])\n#' \ngetAnnual_dataframe <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n year <- format(Date, '%Y')\n yearUnique <- unique(year)\n # yearUnique <- factor(yearUnique, levels = yearUnique, ordered = TRUE)\n calcuNum <- c(1:length(yearUnique))\n \n \n annualPreci <- tapply(dataset[, 2], INDEX = year, FUN = sum, na.rm = TRUE)\n recordNum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(!is.na(x))))\n NANum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(is.na(x))))\n \n \n name <- rep(colnames(dataset)[2], length(calcuNum))\n output <- data.frame(Year = as.numeric(yearUnique), Name = name, AnnualPreci = annualPreci,\n recordNum, NANum)\n \n #output$Year <- factor(output$Year, levels = output$Year, ordered = TRUE)\n return(output)\n}\n\n", + "created" : 1483876618596.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "375535863", + "id" : "BFF6AE7A", + "lastKnownWriteTime" : 1483876696, + "last_content_update" : 1483876696288, + "path" : "~/GitHub/hyfo/R/getAnnual(generic).R", + "project_path" : "R/getAnnual(generic).R", + "properties" : { + }, + "relative_order" : 4, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB b/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB new file mode 100644 index 0000000..6f56db8 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.8\nDate: 2017-1-8\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling,\n data resampling, gap filler of precipitation, bias correction of forecasting\n data, flexible time series plot, and spatial map generation. It is a good pre-\n processing and post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods\nSuggests:\n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\nRoxygenNote: 5.0.1\n", + "created" : 1483876827452.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "958407147", + "id" : "EEC7BFEB", + "lastKnownWriteTime" : 1483876922, + "last_content_update" : 1483876922508, + "path" : "~/GitHub/hyfo/DESCRIPTION", + "project_path" : "DESCRIPTION", + "properties" : { + }, + "relative_order" : 8, + "source_on_save" : false, + "source_window" : "", + "type" : "dcf" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E b/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E new file mode 100644 index 0000000..d69d971 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get variable name of the NetCDF file.\n#' \n#' Get variable name in the NetCDF file. After knowning the name, you can use \\code{loadNcdf} to load\n#' the target variable.\n#' \n#' @param filePath A path pointing to the netCDF file.\n#' @return The names of the varialbes in the file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' }\n#' \n#' \n#' \n#' @export\ngetNcdfVar <- function(filePath) {\n nc <- nc_open(filePath)\n names <- names(nc$var)\n return(names)\n}\n\n\n#' Load NetCDF file\n#' \n#' @param filePath A path pointing to the NetCDF file, version3.\n#' @param varname A character representing the variable name, you can use \\code{getNcdfVar} to\n#' get the basic information about the variables and select the target.\n#' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n# @param drop When the time dimension only have one value, the output data will drop\n# this dimension automatically (\\code{drop = TRUE}), default value is \\code{drop = FALSE}, then time dimension will be added.\n# This argument mainly applies to the later calculations based on hyfo file. If the dimension\n# is dropped, than some calculations may not be processed afterwards. \n#' @param ... Several arguments including Year, month, lon, lat \n#' type in \\code{?downscaleNcdf} for details.You can load while downscale, \n#' and also first load than use \\code{downscaleNcdf} to downscale.\n#' @return A list object from \\code{hyfo} containing the information to be used in the analysis, \n#' or biascorrection.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # you can directly add your downscale information to the argument.\n#' nc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), \n#' lat = c(43.2, 43.7))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \nloadNcdf <- function(filePath, varname, tz = 'GMT', ...) {\n nc <- nc_open(filePath)\n \n var <- nc$var\n # Use name to locate the variable\n call_1 <- as.call(c(\n list(as.name('$'), var, varname)\n ))\n var <- eval(call_1)\n if(is.null(var)) stop('No such variable name, check source file.')\n \n dimNames <- unlist(lapply(1:length(var$dim), function(x) var$dim[[x]]$name))\n \n # Only deals with the most common dimensions, futher dimensions will be added in future.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\n if (length(dimIndex) < 3) stop('Your file has less than 3 dimensions.')\n \n # First needs to identify the variable name, load the right data\n message('Loading data...')\n nc_data <- ncvar_get(nc, var)\n message('Processing...')\n \n gridData <- list()\n gridData$Variable$varName <- varname\n gridData$xyCoords$x <- var$dim[[dimIndex[1]]]$vals\n attributes(gridData$xyCoords$x)$name <- dimNames[dimIndex[1]]\n \n gridData$xyCoords$y <- var$dim[[dimIndex[2]]]$vals\n attributes(gridData$xyCoords$y)$name <- dimNames[dimIndex[2]]\n \n # Time part needs to be taken seperately\n \n timeUnit <- strsplit(var$dim[[dimIndex[3]]]$units, split = ' since')[[1]][1]\n timeDiff <- var$dim[[dimIndex[3]]]$vals\n # To get real time, time since when has to be grabbed from the dataset.\n timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz)\n \n \n# Date <- rep(timeSince, length(timeDiff))\n \n \n unitDic <- data.frame(weeks = 'weeks', days = 'days', hours = 'hours',\n minutes = 'mins', seconds = 'secs')\n \n timeDiff <- as.difftime(timeDiff, units = as.character(unitDic[1, timeUnit]))\n \n# if (grepl('day', timeUnit)) {\n# Date$mday <- Date$mday + timeDiff\n# } else if (grepl('second', timeUnit)) {\n# Date$sec <- Date$sec + timeDiff\n# }\n Date <- timeSince + timeDiff\n \n # data directly loaded from ncdf4 will drop the dimension with only one value.\n # the varsize shows the real dimension, without any dropping.\n dim(nc_data) <- var$varsize \n \n # Right now there is no need to add end Date, in furture, may be added as needed.\n gridData$Dates$start <- as.character(Date)\n \n # Assing data to grid data\n # At leaset should be 3 dimensions, lon, lat, time. So if less than 3, \n \n gridData$Data <- nc_data\n \n attributes(gridData$Data)$dimensions <- dimNames\n \n if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals\n \n gridData$Loaded <- 'by hyfo package, http://yuanchao-xu.github.io/hyfo/'\n nc_close(nc)\n \n output <- downscaleNcdf(gridData, ...)\n \n return(output)\n \n}\n\n\n\n\n#' Downscale NetCDF file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param year A vector of the target year. e.g. \\code{year = 2000}, \\code{year = 1980:2000}\n#' @param month A vector of the target month. e.g. \\code{month = 2}, \\code{month = 3:12}\n#' @param lon A vector of the range of the downscaled longitude, should contain a max value\n#' and a min value. e.g. \\code{lon = c(-1.5, 2,5)}\n#' @param lat A vector of the range of the downscaled latitude, should contain a max value\n#' and a min value. e.g. \\code{lat = c(32,2, 36)}\n#' @return A downscaled hyfo list file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7))\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#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \ndownscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) {\n \n \n if (!is.null(year)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n yearIndex <- Dates$year + 1900\n monIndex <- Dates$mon + 1\n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n \n if (is.null(month) || !any(sort(month) != month)) {\n targetYearIndex <- which(yearIndex %in% year)\n if (length(targetYearIndex) == 0) stop('No input years in the input ts, check your input.')\n \n \n # if year crossing than sort(month) != month\n } else {\n \n startIndex <- intersect(which(yearIndex == year[1] - 1), which(monIndex == month[1]))[1]\n endIndex <- tail(intersect(which(yearIndex == tail(year, 1)), which(monIndex == tail(month, 1))), 1)\n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n } else {\n \n targetYearIndex <- startIndex:endIndex\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again.\n # Only for special cases.\n Dates <- Dates[targetYearIndex]\n yea <- Dates$year + 1900\n mon <- Dates$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n targetYearIndex <- targetYearIndex[DateIndex]\n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n }\n \n gridData$Dates$start <- gridData$Dates$start[targetYearIndex]\n gridData$Dates$end <- gridData$Dates$end[targetYearIndex]\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetYearIndex)\n } \n \n if (!is.null(month)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n monIndex <- Dates$mon + 1\n \n targetMonIndex <- which(monIndex %in% month)\n if (length(targetMonIndex) == 0) stop('Check your input year, it may exceed the years \n in the input dataset.')\n gridData$Dates$start <- gridData$Dates$start[targetMonIndex]\n gridData$Dates$end <- gridData$Dates$end[targetMonIndex]\n \n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex)\n \n }\n \n if (!is.null(lon)) {\n \n lonIndex <- gridData$xyCoords$x\n \n lonI1 <- which(abs(lonIndex - min(lon)) == min(abs(lonIndex - min(lon)), na.rm = TRUE)) \n lonI2 <- which(abs(lonIndex - max(lon)) == min(abs(lonIndex - max(lon)), na.rm = TRUE)) \n \n # take the as large as possible range\n targetLonIndex <- lonI1[length(lonI1)]:lonI2[length(lonI2)]\n if (length(targetLonIndex) == 0) stop('Your input lon is too small, try to expand the \n longitude range.') \n gridData$xyCoords$x <- gridData$xyCoords$x[targetLonIndex]\n lonDim <- grepAndMatch('lon', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, lonDim, targetLonIndex)\n }\n \n \n if (!is.null(lat)) {\n latIndex <- gridData$xyCoords$y\n \n latI1 <- which(abs(latIndex - min(lat)) == min(abs(latIndex - min(lat)), na.rm = TRUE)) \n latI2 <- which(abs(latIndex - max(lat)) == min(abs(latIndex - max(lat)), na.rm = TRUE)) \n \n targetLatIndex <- latI1[length(latI1)]:latI2[length(latI2)]\n \n if (length(targetLonIndex) == 0) stop('Your input lat is too small, try to expand the \n latitude range.') \n gridData$xyCoords$y <- gridData$xyCoords$y[targetLatIndex]\n latDim <- grepAndMatch('lat', attributes(gridData$Data)$dimensions)\n gridData$Data <- chooseDim(gridData$Data, latDim, targetLatIndex)\n }\n \n return(gridData)\n \n}\n\n\n\n\n\n\n\n\n\n\n#' Write to NetCDF file using hyfo list file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param filePath A path of the new NetCDF file, should end with \".nc\"\n#' @param missingValue A number representing the missing value in the NetCDF file, default\n#' is 1e20\n#' #' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n#' @param units A string showing in which unit you are putting in the NetCDF file, it can be \n#' seconds or days and so on. If not specified, the function will pick up the possible largest \n#' time units from \\code{c('weeks', 'days', 'hours', 'mins', 'secs')}\n#' @param version ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.\n#' @param tz time zone, default is \"GMT\"\n#' @return An NetCDF version 3 file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' writeNcdf(nc, 'test.nc')\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' \n#' }\n#' \n#' \nwriteNcdf <- function(gridData, filePath, missingValue = 1e20, tz = 'GMT', units = NULL, version = 3) {\n \n name <- gridData$Variable$varName\n # First defines dimensions.\n lonName <- attributes(gridData$xyCoords$x)$name\n latName <- attributes(gridData$xyCoords$y)$name\n dimLon <- ncdim_def(lonName, 'degree', gridData$xyCoords$x)\n dimLat <- ncdim_def(latName, 'degree', gridData$xyCoords$y)\n dimMem <- NULL\n if (!is.null(gridData$Members)) {\n dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members))\n }\n \n \n # Time needs to be treated seperately\n dates <- as.POSIXlt(gridData$Dates$start, tz = tz)\n if (is.null(units)) {\n units <- getTimeUnit(dates)\n time <- difftime(dates, dates[1], units = units)\n } else {\n time <- difftime(dates, dates[1], units = units)\n }\n timeUnits <- paste(units, 'since', dates[1])\n # Here time needs to be numeric, as required by ncdf4 package, which is not the same\n # with ncdf\n dimTime <- ncdim_def('time', timeUnits, as.numeric(time))\n \n \n # Depending on whether there is a member part of the dataset.\n # default list\n dimList <- list(dimLon, dimLat, dimTime, dimMem)\n \n # In order to keep the dim list exactly the same with the original one, it needs to be changed.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), attributes(gridData$Data)$dimensions)\n dimIndex <- na.omit(dimIndex)\n \n # Here order is needed, cuz in the procesure above, c('lon', 'lat', 'time', 'member')\n # is the pattern, while actually, attributes(gridData$Data)$dimensions should be the pattern.\n # So here needs an order() to get the wanted result.\n dimList <- dimList[order(dimIndex)]\n \n # delete the NULL list, in order that there is no member part in the data.\n dimList <- Filter(Negate(is.null), dimList)\n # Then difines data\n var <- ncvar_def( name, \"units\", dimList, missingValue)\n \n \n # Here for ncdf4, there is an option to create version 4 ncdf, in future, it\n # may added here.\n if (version == 3) {\n nc <- nc_create(filePath, var) \n } else if (version == 4) {\n nc <- nc_create(filePath, var, force_v4 = TRUE)\n } else {\n stop(\"Which ncdf version you want? Only 3 and 4 can be selected!\")\n }\n \n # This part comes from the library downscaleR, can be deleted if you don't \n # use {ecomsUDG.Raccess}, by adding this, the file can be read by the package {ecomsUDG.Raccess}\n ncatt_put(nc, \"time\", \"standard_name\",\"time\")\n ncatt_put(nc, \"time\", \"axis\",\"T\")\n ncatt_put(nc, \"time\", \"_CoordinateAxisType\",\"Time\")\n #ncatt_put(nc, \"time\", \"_ChunkSize\",1)\n ncatt_put(nc, lonName, \"standard_name\",\"longitude\")\n ncatt_put(nc, lonName, \"_CoordinateAxisType\",\"Lon\")\n ncatt_put(nc, latName, \"standard_name\",\"latitude\")\n ncatt_put(nc, latName, \"_CoordinateAxisType\",\"Lat\")\n if (!is.null(dimMem)){\n ncatt_put(nc, \"member\", \"standard_name\",\"realization\")\n ncatt_put(nc, \"member\", \"_CoordinateAxisType\",\"Ensemble\")\n #att.put.ncdf(nc, \"member\", \"ref\",\"http://www.uncertml.org/samples/realisation\")\n }\n \n \n # This part has to be put\n ncatt_put(nc, 0, \"Conventions\",\"CF-1.4\")\n ncatt_put(nc, 0, 'WrittenBy', 'hyfo(http://yuanchao-xu.github.io/hyfo/)')\n \n #data <- aperm(gridData$Data, dimIndex) no need to do this, in the process above\n # when you define the dimlist, the order of the dimension was fixed.\n data <- gridData$Data\n ncvar_put(nc, name, data)\n nc_close(nc)\n \n}\n\n# For internaluse by writeNcdf\ngetTimeUnit <- function(dates) {\n units <- c('weeks', 'days', 'hours', 'mins', 'secs')\n output <- NULL\n for (unit in units) {\n time <- difftime(dates, dates[1], units = unit)\n rem <- sapply(time, function(x) x%%1)\n if (!any(rem != 0)) {\n output <- unit\n break\n }\n } \n return(output)\n}\n\n\n# Save for future use. \n#' @import ncdf4\n#' @references \n#' David Pierce (2014). ncdf: Interface to Unidata netCDF data files. R package version 1.6.8.\n#' http://CRAN.R-project.org/package=ncdf\ngetExtralDim <- function(...) {\n dimList <- list(...)\n \n \n}\n\n# in order to first grep than match.\n# match only provides for exactly match, \n# dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\ngrepAndMatch <- function(x, table) {\n index <- unlist(lapply(x, function(x) {\n a <- grep(x, table)\n }))\n return(index)\n}", + "created" : 1483880947871.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2949555972", + "id" : "EF2B4E", + "lastKnownWriteTime" : 1483880994, + "last_content_update" : 1483880994072, + "path" : "~/GitHub/hyfo/R/ncdf.R", + "project_path" : "R/ncdf.R", + "properties" : { + }, + "relative_order" : 10, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F new file mode 100644 index 0000000..868471c --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/biasCorrect(generic).R\n\\docType{methods}\n\\name{biasCorrect}\n\\alias{biasCorrect}\n\\alias{biasCorrect,data.frame,data.frame,data.frame-method}\n\\alias{biasCorrect,list,list,list-method}\n\\title{Biascorrect the input timeseries or hyfo dataset}\n\\usage{\nbiasCorrect(frc, hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the forecast to be calibrated.}\n\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \ndetails. Default scaleType is 'multi'.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nBiascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\nobservation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\nwill be returned. If the input is a time series, first column should be date column and rest columns should be \nthe value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\nfile with the same format.\n}\n\\details{\nSince climate forecast is based on global condition, when downscaling to different regions, it may include\nsome bias, biascorrection is used then to fix the bias.\n\n\\strong{Hindcast}\n\nIn order to bias correct, we need to pick up some data from the forecast to train with\nthe observation, which is called hindcast in this function. Using hindcast and observation, \nthe program can analyze the bias and correct the bias in the forecast. \n\nHindcast should have \\strong{EVERY} attributes that forecast has.\n\nHindcast 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\nis the hindcast period, and 2005-2010, this period is the forecast period.\n\nHindcast 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\nForecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \nforecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \ndata (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n\nE.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \nperiod (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\nThe program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \nmodification to the forecast data.\n\nThe more categorized input, the more accurate result you will get. E.g., if you want to \nbias correct a forecast for winter season. So you'd better to extract all the winter period\nin the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n\n\\strong{method}\n\nDifferent methods used in the bias correction. Among which, delta, scaling can be applied\nto different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\nit needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\ndesigned for rainfall data, so \\code{preci = TRUE} needs to be set.\n\n\\strong{delta}\n\nThis method consists on adding to the observations the mean change signal (delta method). \nThis 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 \nThis method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \nbetween the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\ncorrection is defined by parameter \\code{scaling.type} (default is \\code{additive}).\nThe additive version is preferably applicable to unbounded variables (e.g. temperature) \nand the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n \n \\strong{eqm}\n \nEmpirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \nby adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \nThis method is applicable to any kind of variable.\n\nIt can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\nthat the extreme value is an error.\n \n \\strong{gqm}\n \nGamma 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\nand simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \nthat uses the theorical instead of the empirical distribution. \n \nIt can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\nBetter have a long period of training, and the if the forecast system is relatively stable.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\nf\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\nnewFrc <- biasCorrect(nc, nc, tgridData) \nnewFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \nnewFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \npreci = TRUE) \nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nfrc_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\nfrc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n\n# You can use other scaling methods to biascorrect.\nfrc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n\n# \nfrc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\nfrc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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", + "created" : 1483875745269.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1889128030", + "id" : "FFE783F", + "lastKnownWriteTime" : 1483973423, + "last_content_update" : 1483973423, + "path" : "~/GitHub/hyfo/man/biasCorrect.Rd", + "project_path" : "man/biasCorrect.Rd", + "properties" : { + }, + "relative_order" : 1, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/1BB4BBB4 b/.Rproj.user/D1D10CF6/sdb/prop/1BB4BBB4 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/1BB4BBB4 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/23571832 b/.Rproj.user/D1D10CF6/sdb/prop/23571832 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/23571832 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/2988B998 b/.Rproj.user/D1D10CF6/sdb/prop/2988B998 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/2988B998 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/5B6E4CB4 b/.Rproj.user/D1D10CF6/sdb/prop/5B6E4CB4 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/5B6E4CB4 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/7EEE6E30 b/.Rproj.user/D1D10CF6/sdb/prop/7EEE6E30 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/7EEE6E30 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/85BAB51C b/.Rproj.user/D1D10CF6/sdb/prop/85BAB51C new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/85BAB51C @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/A5EB009E b/.Rproj.user/D1D10CF6/sdb/prop/A5EB009E new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/A5EB009E @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/BF639043 b/.Rproj.user/D1D10CF6/sdb/prop/BF639043 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/BF639043 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D338C194 b/.Rproj.user/D1D10CF6/sdb/prop/D338C194 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D338C194 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/DD613721 b/.Rproj.user/D1D10CF6/sdb/prop/DD613721 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/DD613721 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/INDEX b/.Rproj.user/D1D10CF6/sdb/prop/INDEX new file mode 100644 index 0000000..4d398cf --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/INDEX @@ -0,0 +1,10 @@ +~%2FGitHub%2Fhyfo%2FDESCRIPTION="1BB4BBB4" +~%2FGitHub%2Fhyfo%2FNEWS="5B6E4CB4" +~%2FGitHub%2Fhyfo%2FR%2FbiasCorrect(generic).R="7EEE6E30" +~%2FGitHub%2Fhyfo%2FR%2FextractPeriod(generic).R="2988B998" +~%2FGitHub%2Fhyfo%2FR%2FgetAnnual(generic).R="D338C194" +~%2FGitHub%2Fhyfo%2FR%2FgetPreciBar(generic).R="BF639043" +~%2FGitHub%2Fhyfo%2FR%2Fmulti-biasCorrect(generic).R="23571832" +~%2FGitHub%2Fhyfo%2FR%2Fncdf.R="DD613721" +~%2FGitHub%2Fhyfo%2FR%2Fresample(generic).R="85BAB51C" +~%2FGitHub%2Fhyfo%2Fman%2FbiasCorrect.Rd="A5EB009E" diff --git a/.Rproj.user/D1D10CF6/session-persistent-state b/.Rproj.user/D1D10CF6/session-persistent-state new file mode 100644 index 0000000..18e80d5 --- /dev/null +++ b/.Rproj.user/D1D10CF6/session-persistent-state @@ -0,0 +1 @@ +virtual-session-id="E90651FF" diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths new file mode 100644 index 0000000..3b1c0c8 --- /dev/null +++ b/.Rproj.user/shared/notebooks/paths @@ -0,0 +1 @@ +C:/Users/user/Documents/GitHub/hyfo/R/extractPeriod(generic).R="35D21910" diff --git a/DESCRIPTION b/DESCRIPTION index 8bf62ec..bad2ba7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,21 +1,21 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.3.7 -Date: 2016-3-21 +Version: 1.3.8 +Date: 2017-1-8 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and - climate forecasting. Main function includes data extraction, data downscaling, data - resampling, gap filler of precipitation, bias correction of forecasting data, flexible - time series plot, and spatial map generation. It is a good pre-processing and - post-processing tool for hydrological and hydraulic modellers. + climate forecasting. Main function includes data extraction, data downscaling, + data resampling, gap filler of precipitation, bias correction of forecasting + data, flexible time series plot, and spatial map generation. It is a good pre- + processing and post-processing tool for hydrological and hydraulic modellers. License: GPL-2 -Depends: +Depends: R (>= 3.1.0), stats (>= 3.1.3), utils(>= 3.1.3), -Imports: +Imports: ggplot2 (>= 1.0.1), reshape2 (>= 1.4.1), zoo (>= 1.7-12), @@ -29,7 +29,7 @@ Imports: ncdf4 (>= 1.14.1), MASS (>= 7.3-39), methods -Suggests: +Suggests: gridExtra, knitr, rmarkdown @@ -38,3 +38,4 @@ LazyData: true URL: http://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN +RoxygenNote: 5.0.1 diff --git a/NAMESPACE b/NAMESPACE index 41cfe53..5fb35c9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,4 +1,4 @@ -# Generated by roxygen2 (4.1.1): do not edit by hand +# Generated by roxygen2: do not edit by hand export(applyBiasFactor) export(biasCorrect) diff --git a/NEWS b/NEWS index 8bed25f..899b933 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,15 @@ +hyfo 1.3.8 +========== +Date: 2017-1-8 + +- add changes to the new version of roxygen2 +- change biasCorrection's description, change default prThreshold to 0, since not every one is an expert and know how to set it, better keep the original unchanged. + + + hyfo 1.3.7 ========== -Date: 2016.3.1 +Date: 2016-3-1 - add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted. @@ -8,7 +17,7 @@ Date: 2016.3.1 hyfo 1.3.6 ========== -Date: 2015.12.15 +Date: 2015-12-15 - transfer from ncdf to ncdf4 - grepAndMatch created, for capturing dimension names. @@ -25,7 +34,7 @@ NOTE: hyfo 1.3.5 ========== -Date: 2015.12.6 +Date: 2015-12-6 - travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu. - changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped. @@ -36,7 +45,7 @@ Date: 2015.12.6 hyfo 1.3.3 ========== -Date: 2015.11.27 +Date: 2015-11-27 - Delete readData_folder, since it's only windows based, add information to get special version for windows users. - travis test added. @@ -44,7 +53,7 @@ Date: 2015.11.27 hyfo 1.3.2 ========== -Date: 2015.11.7 +Date: 2015-11-7 - bug fixed about getPreciBar, signature('data.frame') - vignettes updated about bug and hided the warning information. @@ -54,7 +63,7 @@ Date: 2015.11.7 hyfo 1.3.1 ========== -Date: 2015.11.3 +Date: 2015-11-3 - new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically. - coordinates conversion function extracted. @@ -64,7 +73,7 @@ Date: 2015.11.3 hyfo 1.2.9 ========== -Date: 2015.10.30 +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. diff --git a/R/biasCorrect(generic).R b/R/biasCorrect(generic).R index b087d5c..ae7eb2f 100644 --- a/R/biasCorrect(generic).R +++ b/R/biasCorrect(generic).R @@ -120,7 +120,7 @@ #' data(tgridData) #' # Since the example data, has some NA values, the process will include some warning #message, #' # which can be ignored in this case. -#' +#' f #' #' #' @@ -212,14 +212,18 @@ setGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scale standardGeneric('biasCorrect') }) -#' @describeIn biasCorrect + +# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2 +# so use rdname instead +#' @rdname 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) }) -#' @describeIn biasCorrect +#' @rdname 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) diff --git a/R/extractPeriod(generic).R b/R/extractPeriod(generic).R index 7976c73..97519c5 100644 --- a/R/extractPeriod(generic).R +++ b/R/extractPeriod(generic).R @@ -93,7 +93,7 @@ setGeneric('extractPeriod', function(data, startDate = NULL, endDate = NULL, com }) -#' @describeIn extractPeriod +#' @rdname extractPeriod #' @importFrom methods setMethod setMethod('extractPeriod', signature('data.frame'), function(data, startDate, endDate, commonPeriod, year, month) { @@ -105,7 +105,7 @@ setMethod('extractPeriod', signature('data.frame'), }) -#' @describeIn extractPeriod +#' @rdname extractPeriod #' @importFrom methods setMethod setMethod('extractPeriod', signature('list'), function(data, startDate, endDate, commonPeriod, year, month) { diff --git a/R/getAnnual(generic).R b/R/getAnnual(generic).R index b00cbd1..a6109a4 100644 --- a/R/getAnnual(generic).R +++ b/R/getAnnual(generic).R @@ -53,7 +53,7 @@ setGeneric('getAnnual', function(data, output = 'series', minRecords = 355, standardGeneric('getAnnual') }) -#' @describeIn getAnnual +#' @rdname getAnnual #' @importFrom methods setMethod setMethod('getAnnual', signature('data.frame'), function(data, output, minRecords, ...) { @@ -62,7 +62,7 @@ setMethod('getAnnual', signature('data.frame'), return(result) }) -#' @describeIn getAnnual +#' @rdname getAnnual #' @importFrom methods setMethod setMethod('getAnnual', signature('list'), function(data, output, minRecords, ...) { diff --git a/R/getPreciBar(generic).R b/R/getPreciBar(generic).R index 3b2d994..cd5ea67 100644 --- a/R/getPreciBar(generic).R +++ b/R/getPreciBar(generic).R @@ -77,7 +77,7 @@ setGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', standardGeneric('getPreciBar') }) -#' @describeIn getPreciBar +#' @rdname getPreciBar setMethod('getPreciBar', signature('list'), function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) { TS <- getPreciBar.list(data, cell, member) @@ -91,7 +91,7 @@ setMethod('getPreciBar', signature('list'), return(result) }) -#' @describeIn getPreciBar +#' @rdname getPreciBar setMethod('getPreciBar', signature('data.frame'), function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) { Date <- as.POSIXlt(TS[, 1]) diff --git a/R/multi-biasCorrect(generic).R b/R/multi-biasCorrect(generic).R index c846307..b128380 100644 --- a/R/multi-biasCorrect(generic).R +++ b/R/multi-biasCorrect(generic).R @@ -179,7 +179,7 @@ setGeneric('getBiasFactor', function(hindcast, obs, method = 'scaling', scaleTyp standardGeneric('getBiasFactor') }) -#' @describeIn getBiasFactor +#' @rdname getBiasFactor setMethod('getBiasFactor', signature('data.frame', 'data.frame'), function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { result <- getBiasFactor.TS(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) @@ -188,7 +188,7 @@ setMethod('getBiasFactor', signature('data.frame', 'data.frame'), # This is for the grid file from downscaleR -#' @describeIn getBiasFactor +#' @rdname getBiasFactor #' @importFrom methods new setMethod('getBiasFactor', signature('list', 'list'), function(hindcast, obs, method, scaleType, preci, prThreshold, extrapolate) { @@ -362,7 +362,7 @@ setGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) { standardGeneric('applyBiasFactor') }) -#' @describeIn applyBiasFactor +#' @rdname applyBiasFactor #' @importFrom methods setMethod setMethod('applyBiasFactor', signature('data.frame', 'biasFactor'), function(frc, biasFactor, obs) { @@ -370,7 +370,7 @@ setMethod('applyBiasFactor', signature('data.frame', 'biasFactor'), return(result) }) -#' @describeIn applyBiasFactor +#' @rdname applyBiasFactor #' @importFrom methods setMethod setMethod('applyBiasFactor', signature('list', 'biasFactor.hyfo'), function(frc, biasFactor, obs) { diff --git a/R/ncdf.R b/R/ncdf.R index aad5254..e201c28 100644 --- a/R/ncdf.R +++ b/R/ncdf.R @@ -324,6 +324,7 @@ downscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = #' seconds or days and so on. If not specified, the function will pick up the possible largest #' time units from \code{c('weeks', 'days', 'hours', 'mins', 'secs')} #' @param version ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4. +#' @param tz time zone, default is "GMT" #' @return An NetCDF version 3 file. #' @examples #' # First open the test NETcDF file. diff --git a/R/resample(generic).R b/R/resample(generic).R index d54ba69..117cf95 100644 --- a/R/resample(generic).R +++ b/R/resample(generic).R @@ -54,14 +54,14 @@ setGeneric('resample', function(data, method) { }) -#' @describeIn resample +#' @rdname resample setMethod('resample', signature('data.frame'), function(data, method) { result <- resample.TS(data, method) return(result) }) -#' @describeIn resample +#' @rdname resample setMethod('resample', signature('list'), function(data, method) { result <- resample.list(data, method) diff --git a/man/applyBiasFactor.Rd b/man/applyBiasFactor.Rd index f236ddc..8287dce 100644 --- a/man/applyBiasFactor.Rd +++ b/man/applyBiasFactor.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/multi-biasCorrect(generic).R \docType{methods} \name{applyBiasFactor} @@ -14,13 +14,13 @@ applyBiasFactor(frc, biasFactor, obs = NULL) \S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, obs = NULL) } \arguments{ -\item{frc}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, +\item{frc}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, representing the frc data. Check details for more information.} \item{biasFactor}{a file containing all the information of the calibration, will be applied to different forecasts.} -\item{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, +\item{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, representing the observation data. Default value is NULL.} } \description{ @@ -28,7 +28,7 @@ When you do multi/operational/real time bias correction. It's too expensive to input hindcast and obs every time. Especially when you have a long period of hindcast and obs, but only a short period of frc, it's too unecessary to read and compute hindcast and obs everytime. Therefore, biasFactor is designed. Using \code{getBiasFactor}, you can -get the biasFactor with hindcast and observation, then you can use \code{applyBiasFactor} to +get the biasFactor with hindcast and observation, then you can use \code{applyBiasFactor} to apply the biasFactor to different forecasts. } \details{ @@ -42,27 +42,22 @@ period of hindcast and obs, and apply that factor to different frc. For example, -You have 10 years of hindcast and observation. you want to do bias correction for some +You have 10 years of hindcast and observation. you want to do bias correction for some forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast about the future 6 months. So if you want to do the real time bias correction, you have to take the 10 years of hindcast and observation data with you, and run \code{biasCorrect} every time you get a new forecast. That's too expensive. For some practical use in forecasting, there isn't a so high demand for accuracy. E.g., -Maybe for February and March, you can use the same biasFactor, no need to do the computation -again. +Maybe for February and March, you can use the same biasFactor, no need to do the computation +again. -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\section{Methods (by class)}{ -\itemize{ -\item \code{frc = data.frame,biasFactor = biasFactor}: - -\item \code{frc = list,biasFactor = biasFactor.hyfo}: -}} \examples{ + ######## hyfo grid file biascorrection ######## @@ -71,11 +66,11 @@ for how to debug S4 method. # First load ncdf file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) +varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) data(tgridData) -#' # Since the example data, has some NA values, the process will include some warning #message, +#' # Since the example data, has some NA values, the process will include some warning #message, # which can be ignored in this case. @@ -85,14 +80,14 @@ data(tgridData) biasFactor <- getBiasFactor(nc, tgridData) newFrc <- applyBiasFactor(nc, biasFactor) - + biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant', preci = TRUE) # This method needs obs input. newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData) biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE) -newFrc <- applyBiasFactor(nc, biasFactor) +newFrc <- applyBiasFactor(nc, biasFactor) ######## Time series biascorrection @@ -122,12 +117,12 @@ frc_new <- applyBiasFactor(frc, biasFactor) biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE) frc_new1 <- applyBiasFactor(frc, biasFactor) -# You can use other methods to biascorrect, e.g. delta method. +# You can use other methods to biascorrect, e.g. delta method. biasFactor <- getBiasFactor(hindcast, obs, method = 'delta') # delta method needs obs input. frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs) -# +# biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE) # eqm needs obs input frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs) @@ -144,16 +139,18 @@ plotTS(list = TSlist, plot = 'cum') # If the forecasts you extracted only has incontinuous data for certain months and years, e.g., -# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be +# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be # for example Dec, Jan and Feb of every year from year 1999-2005. # In such case, you need to extract certain months and years from observed time series. # extractPeriod() can be then used. + + +# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ } \author{ Yuanchao Xu \email{xuyuanchao37@gmail.com } @@ -176,7 +173,7 @@ package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki } } \seealso{ -\code{\link{biasCorrect}} for method used in bias correction. +\code{\link{biasCorrect}} for method used in bias correction. \code{\link{getBiasFactor}}, for the first part. } diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 8df832d..3360b94 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/biasCorrect(generic).R \docType{methods} \name{biasCorrect} @@ -19,24 +19,24 @@ biasCorrect(frc, hindcast, obs, method = "scaling", scaleType = "multi", 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, +\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, representing the forecast to be calibrated.} -\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, +\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, 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 observation data. Check details for more information.} -\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, +\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, representing the observation data.} \item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'} \item{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 +of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check details. Default scaleType is 'multi'.} \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. +precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. Default is FALSE, refer to details.} \item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).} @@ -47,7 +47,7 @@ If 'constant' is set, modified frc is not bounded by the range of obs. Default i \description{ Biascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast. observation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast -will be returned. If the input is a time series, first column should be date column and rest columns should be +will be returned. If the input is a time series, first column should be date column and rest columns should be the value column. If the input is a hyfo dataset, the dataset should be the result of \code{loadNcdf}, or a list file with the same format. } @@ -58,8 +58,8 @@ some bias, biascorrection is used then to fix the bias. \strong{Hindcast} In order to bias correct, we need to pick up some data from the forecast to train with -the observation, which is called hindcast in this function. Using hindcast and observation, -the program can analyze the bias and correct the bias in the forecast. +the observation, which is called hindcast in this function. Using hindcast and observation, +the program can analyze the bias and correct the bias in the forecast. Hindcast should have \strong{EVERY} attributes that forecast has. @@ -71,16 +71,16 @@ Hindcast can be the same as forecast, i.e., you can use forecast itself as hindc \strong{How it works} -Forecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the -forecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast +Forecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the +forecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast data (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004) -E.g. you have observation from 2001-2002, this is your input obs. Then you can take the same +E.g. you have observation from 2001-2002, this is your input obs. Then you can take the same period (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period. -The program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the +The program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the modification to the forecast data. -The more categorized input, the more accurate result you will get. E.g., if you want to +The more categorized input, the more accurate result you will get. E.g., if you want to bias correct a forecast for winter season. So you'd better to extract all the winter period in the hindcast and observation to train. \code{extractPeriod} can be used for this purpose. @@ -93,47 +93,42 @@ designed for rainfall data, so \code{preci = TRUE} needs to be set. \strong{delta} -This method consists on adding to the observations the mean change signal (delta method). +This method consists on adding to the observations the mean change signal (delta method). This method is applicable to any kind of variable but it is preferable to avoid it for bounded variables - (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained + (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained (e.g. negative wind speeds...) - + \strong{scaling} - -This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) + +This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) between the observed and simulated means in the train period. The \code{additive} or \code{multiplicative} correction is defined by parameter \code{scaling.type} (default is \code{additive}). -The additive version is preferably applicable to unbounded variables (e.g. temperature) -and the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). - +The additive version is preferably applicable to unbounded variables (e.g. temperature) +and the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). + \strong{eqm} - -Empirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) -by adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. + +Empirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) +by adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. This method is applicable to any kind of variable. It can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk that the extreme value is an error. - + \strong{gqm} - + 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 -and simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map -that uses the theorical instead of the empirical distribution. - +and simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map +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. -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\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 ######## @@ -142,23 +137,23 @@ for how to debug S4 method. # First load ncdf file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) +varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) data(tgridData) -# Since the example data, has some NA values, the process will include some warning #message, +# Since the example data, has some NA values, the process will include some warning #message, # which can be ignored in this case. - +f # Then we will use nc data as forecasting data, and use itself as hindcast data, # use tgridData as observation. -newFrc <- biasCorrect(nc, nc, tgridData) -newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') -newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', -preci = TRUE) -newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) +newFrc <- biasCorrect(nc, nc, tgridData) +newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') +newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', +preci = TRUE) +newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) ######## Time series biascorrection @@ -189,7 +184,7 @@ frc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE) # You can use other scaling methods to biascorrect. 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) @@ -202,16 +197,18 @@ plotTS(list = TSlist, plot = 'cum') # If the forecasts you extracted only has incontinuous data for certain months and years, e.g., -# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be +# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be # for example Dec, Jan and Feb of every year from year 1999-2005. # In such case, you need to extract certain months and years from observed time series. # extractPeriod() can be then used. + + +# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ } \author{ Yuanchao Xu \email{xuyuanchao37@gmail.com } diff --git a/man/biasFactor-class.Rd b/man/biasFactor-class.Rd index dfb5b4b..6464aad 100644 --- a/man/biasFactor-class.Rd +++ b/man/biasFactor-class.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/classes.R \docType{class} \name{biasFactor-class} diff --git a/man/biasFactor.hyfo-class.Rd b/man/biasFactor.hyfo-class.Rd index a27d64a..eae58c7 100644 --- a/man/biasFactor.hyfo-class.Rd +++ b/man/biasFactor.hyfo-class.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/classes.R \docType{class} \name{biasFactor.hyfo-class} diff --git a/man/checkBind.Rd b/man/checkBind.Rd index fd3242f..50108ab 100644 --- a/man/checkBind.Rd +++ b/man/checkBind.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/check.R \name{checkBind} \alias{checkBind} @@ -7,7 +7,7 @@ checkBind(data, bind) } \arguments{ -\item{data}{A list containing different sublists ready to be processed by \code{do.call('rbind')} +\item{data}{A list containing different sublists ready to be processed by \code{do.call('rbind')} or \code{do.call('cbind')}} \item{bind}{A string showing which bind you are going to use can be 'rbind' or 'cbind'} diff --git a/man/collectData.Rd b/man/collectData.Rd index ca599db..eedbb4d 100644 --- a/man/collectData.Rd +++ b/man/collectData.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/collectData.R \name{collectData} \alias{collectData} @@ -11,7 +11,7 @@ collectData(folderName, fileType = NULL, range = NULL, sheetIndex = 1) \item{fileType}{A string showing the file type, e.g. "txt", "csv", "excel".} -\item{range}{A vector containing startRow, endRow, startColumn, endColumn, e.g., +\item{range}{A vector containing startRow, endRow, startColumn, endColumn, e.g., c(2,15,2,3)} \item{sheetIndex}{A number showing the sheetIndex in the excel file, if fileType is excel, @@ -24,6 +24,7 @@ The collected data from different files in the folder. Collect data from different csv files. } \examples{ + #use internal data as an example. folder <- file.path(path.package("hyfo"), 'extdata') # file may vary with different environment, it if doesn't work, use local way to get @@ -32,5 +33,6 @@ folder <- file.path(path.package("hyfo"), 'extdata') a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2)) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } diff --git a/man/collectData_csv_anarbe.Rd b/man/collectData_csv_anarbe.Rd index 07c6313..f8c3ad9 100644 --- a/man/collectData_csv_anarbe.Rd +++ b/man/collectData_csv_anarbe.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/case_anarbe.R \name{collectData_csv_anarbe} \alias{collectData_csv_anarbe} @@ -21,12 +21,14 @@ The collected data from different csv files. Collect data from the gauging stations in spain, catchement Anarbe } \examples{ + #use internal data as an example. file <- system.file("extdata", "1999.csv", package = "hyfo") folder <- strsplit(file, '1999')[[1]][1] a <- collectData_csv_anarbe(folder) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/collectData_excel_anarbe.Rd b/man/collectData_excel_anarbe.Rd index 4e05c1b..3e2d3d4 100644 --- a/man/collectData_excel_anarbe.Rd +++ b/man/collectData_excel_anarbe.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/case_anarbe.R \name{collectData_excel_anarbe} \alias{collectData_excel_anarbe} diff --git a/man/collectData_txt_anarbe.Rd b/man/collectData_txt_anarbe.Rd index 9fed426..795ecde 100644 --- a/man/collectData_txt_anarbe.Rd +++ b/man/collectData_txt_anarbe.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/case_anarbe.R \name{collectData_txt_anarbe} \alias{collectData_txt_anarbe} @@ -15,7 +15,7 @@ collectData_txt_anarbe(folderName, output = TRUE, \item{output}{A boolean showing whether the result is given.} -\item{rangeWord}{A list containing the keyword and the shift. +\item{rangeWord}{A list containing the keyword and the shift. defaut is set to be used in spain gauging station.} } \value{ @@ -25,6 +25,7 @@ The collected data from different txt files. collect data from different txt. } \examples{ + #use internal data as an example. \dontrun{ @@ -35,6 +36,7 @@ a <- collectData_txt_anarbe(folder) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/coord2cell.Rd b/man/coord2cell.Rd index d2e9e1f..46d5f27 100644 --- a/man/coord2cell.Rd +++ b/man/coord2cell.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coordinate.R \name{coord2cell} \alias{coord2cell} diff --git a/man/downscaleNcdf.Rd b/man/downscaleNcdf.Rd index 1630c1a..b4e66ac 100644 --- a/man/downscaleNcdf.Rd +++ b/man/downscaleNcdf.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ncdf.R \name{downscaleNcdf} \alias{downscaleNcdf} @@ -42,6 +42,7 @@ nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7)) nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7)) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index 604905a..825c673 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extractPeriod(generic).R \docType{methods} \name{extractPeriod} @@ -28,21 +28,21 @@ should be NULL.} \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, +\item{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)}.} } \value{ A list or a dataframe with all the time series inside containing the same period. } \description{ -Extract common period or certain period from a list of different dataframes of time series, or from a -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}. } \details{ \strong{startDate and endDate} -If startDate and endDate are assigned, then certain period between startDate and endDate will be returned, +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, @@ -51,26 +51,20 @@ If startDate and endDate are NOT assigned, then, 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. + 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 +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. -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\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. @@ -81,12 +75,12 @@ Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1), 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), +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)) +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. @@ -96,7 +90,7 @@ list_com <- extractPeriod(list, commonPeriod = TRUE) 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 +# make sure startDate is later than any startDate in each dataframe and endDate is # earlier than any endDate in each dataframe. data(testdl) @@ -110,6 +104,7 @@ 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/ + } \references{ \itemize{ diff --git a/man/fillGap.Rd b/man/fillGap.Rd index 5c081fb..1ceb056 100644 --- a/man/fillGap.Rd +++ b/man/fillGap.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fillGap.R \name{fillGap} \alias{fillGap} @@ -9,7 +9,7 @@ fillGap(dataset, corPeriod = "daily") \arguments{ \item{dataset}{A dataframe with first column the time, the rest columns are rainfall data of different gauges} -\item{corPeriod}{A string showing the period used in the correlation computing, +\item{corPeriod}{A string showing the period used in the correlation computing, e.g. daily, monthly, yearly.} } \value{ @@ -23,21 +23,21 @@ the gap filler follows the rules below: 1. The correlation coefficient of every two columns (except time column) is calculated. the correlation coefficient calculation can be based on 'daily', 'monthly', 'annual', -in each case, the daily data, the monthly mean daily data and annual mean daily data of +in each case, the daily data, the monthly mean daily data and annual mean daily data of each column will be taken in the correlation calculation. -Then the correlation matrix is got, then based on the matrix, for each column, +Then the correlation matrix is got, then based on the matrix, for each column, the 1st, 2nd, 3rd,... correlated column will be got. So if there is missing value in the column, it will get data from orderly 1st, 2nd, 3rd column. 2. The simple linear regress is calculated between every two columns. When generating the - linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to + linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to y = a*x. - + 3. Gap filling. E.g., on a certain date, there is a missing value in column A, then the correlation order is column B, column C, column D, which means A should take values from B firstly, if B is also missing data, then C, then D. - + Assuming finally value from column C is taken. Then according to step 2, A = a*C, then the final value filled in column A is missing_in_A = a*value_in_C, a is the linear coeffcient. } @@ -62,6 +62,7 @@ a3 <- fillGap(a1, corPeriod = 'monthly') # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ Gap fiiling method based on correlation and linear regression. diff --git a/man/getAnnual.Rd b/man/getAnnual.Rd index 7b5623e..506bf9e 100644 --- a/man/getAnnual.Rd +++ b/man/getAnnual.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getAnnual(generic).R \docType{methods} \name{getAnnual} @@ -20,30 +20,24 @@ gauging stations. Usually an output of \code{list2Dataframe}.} \item{output}{A string showing the output output.} -\item{minRecords}{A number showing the minimum accept record number, e.g. for a normal +\item{minRecords}{A number showing the minimum accept record number, e.g. for a normal year(365 days), if \code{minRecords = 360}, it means if a year has less than 360 records -of a year, it will be ignored in the mean annual value calculation. Only valid +of a year, it will be ignored in the mean annual value calculation. Only valid when \code{output = "mean"}, default is 355.} \item{...}{\code{title, x, y} showing the title and x and y axis of the plot. e.g. \code{title = 'aaa'}} } \value{ -The annual rainfall and the number of missing data of each year and each rainfall gauge, which +The annual rainfall and the number of missing data of each year and each rainfall gauge, which will also be plotted. If output "mean" is seleted, the mean annual rainfall will be returned. } \description{ Get annual rainfall of different raninfall time series. } \details{ -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\section{Methods (by class)}{ -\itemize{ -\item \code{data.frame}: - -\item \code{list}: -}} \examples{ #datalist is provided by the package as a test. data(testdl) @@ -61,6 +55,7 @@ getAnnual(a3) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getAnnual_dataframe.Rd b/man/getAnnual_dataframe.Rd index d0aefd1..4d663cb 100644 --- a/man/getAnnual_dataframe.Rd +++ b/man/getAnnual_dataframe.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getAnnual(generic).R \name{getAnnual_dataframe} \alias{getAnnual_dataframe} diff --git a/man/getBiasFactor.Rd b/man/getBiasFactor.Rd index 822e984..74697e3 100644 --- a/man/getBiasFactor.Rd +++ b/man/getBiasFactor.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/multi-biasCorrect(generic).R \docType{methods} \name{getBiasFactor} @@ -19,21 +19,21 @@ getBiasFactor(hindcast, obs, method = "scaling", scaleType = "multi", extrapolate = "no") } \arguments{ -\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, +\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, 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 observation data. Check details for more information.} -\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, +\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, representing the observation data.} \item{method}{bias correct method, including 'delta', 'scaling'...,default method is 'scaling'.} \item{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, default is 'multi'. More info check +of scaling method, 'add' and 'multi', which means additive and multiplicative scaling method, default is 'multi'. More info check details.} \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. +precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. Default is FALSE, refer to details.} \item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).} @@ -46,7 +46,7 @@ When you do multi/operational/real time bias correction. It's too expensive to input hindcast and obs every time. Especially when you have a long period of hindcast and obs, but only a short period of frc, it's too unecessary to read and compute hindcast and obs everytime. Therefore, biasFactor is designed. Using \code{getBiasFactor}, you can -get the biasFactor with hindcast and observation, then you can use \code{applyBiasFactor} to +get the biasFactor with hindcast and observation, then you can use \code{applyBiasFactor} to apply the biasFactor to different forecasts. } \details{ @@ -60,26 +60,21 @@ period of hindcast and obs, and apply that factor to different frc. For example, -You have 10 years of hindcast and observation. you want to do bias correction for some +You have 10 years of hindcast and observation. you want to do bias correction for some forecasting product, e.g. system 4. For system 4, each month, you will get a new forecast about the future 6 months. So if you want to do the real time bias correction, you have to take the 10 years of hindcast and observation data with you, and run \code{biasCorrect} every time you get a new forecast. That's too expensive. For some practical use in forecasting, there isn't a so high demand for accuracy. E.g., -Maybe for February and March, you can use the same biasFactor, no need to do the computation -again. - -It is a generic function, if in your case you need to debug, please see \code{?debug()} +Maybe for February and March, you can use the same biasFactor, no need to do the computation +again. + +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\section{Methods (by class)}{ -\itemize{ -\item \code{hindcast = data.frame,obs = data.frame}: - -\item \code{hindcast = list,obs = list}: -}} \examples{ + ######## hyfo grid file biascorrection ######## @@ -88,11 +83,11 @@ for how to debug S4 method. # First load ncdf file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) +varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) data(tgridData) -# Since the example data, has some NA values, the process will include some warning #message, +# Since the example data, has some NA values, the process will include some warning #message, # which can be ignored in this case. @@ -102,14 +97,14 @@ data(tgridData) biasFactor <- getBiasFactor(nc, tgridData) newFrc <- applyBiasFactor(nc, biasFactor) - + biasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant', preci = TRUE) # This method needs obs input. newFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData) biasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE) -newFrc <- applyBiasFactor(nc, biasFactor) +newFrc <- applyBiasFactor(nc, biasFactor) ######## Time series biascorrection @@ -139,12 +134,12 @@ frc_new <- applyBiasFactor(frc, biasFactor) biasFactor <- getBiasFactor(hindcast, obs, preci = TRUE) frc_new1 <- applyBiasFactor(frc, biasFactor) -# You can use other methods to biascorrect, e.g. delta method. +# You can use other methods to biascorrect, e.g. delta method. biasFactor <- getBiasFactor(hindcast, obs, method = 'delta') # delta method needs obs input. frc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs) -# +# biasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE) # eqm needs obs input frc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs) @@ -161,16 +156,18 @@ plotTS(list = TSlist, plot = 'cum') # If the forecasts you extracted only has incontinuous data for certain months and years, e.g., -# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be +# for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be # for example Dec, Jan and Feb of every year from year 1999-2005. # In such case, you need to extract certain months and years from observed time series. # extractPeriod() can be then used. + + +# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ } \author{ Yuanchao Xu \email{xuyuanchao37@gmail.com } diff --git a/man/getEnsem_comb.Rd b/man/getEnsem_comb.Rd index 3e62f58..4459a74 100644 --- a/man/getEnsem_comb.Rd +++ b/man/getEnsem_comb.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getEnsemble.R \name{getEnsem_comb} \alias{getEnsem_comb} @@ -8,7 +8,7 @@ getEnsem_comb(..., list = NULL, nrow = 1, legend = TRUE, x = "", y = "", title = "", output = FALSE) } \arguments{ -\item{...}{different ensembles generated by \code{getHisEnsem(, output = 'ggplot')} +\item{...}{different ensembles generated by \code{getHisEnsem(, output = 'ggplot')} or \code{getFrcEnsem(, output = 'ggplot')}, see details.} \item{list}{If input is a list containing different ggplot data, use \code{list = inputlist}.} @@ -34,6 +34,7 @@ A combined ensemble plot. Combine ensembles together } \examples{ + data(testdl) a <- testdl[[1]] @@ -43,7 +44,7 @@ a <- testdl[[1]] b1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot', name = 1) - + b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot', name = 2) @@ -51,6 +52,8 @@ getEnsem_comb(b1, b2) getEnsem_comb(list = list(b1, b2), nrow = 2) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + + } \references{ \itemize{ diff --git a/man/getFrcEnsem.Rd b/man/getFrcEnsem.Rd index f8a063b..1585b5f 100644 --- a/man/getFrcEnsem.Rd +++ b/man/getFrcEnsem.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getEnsemble.R \name{getFrcEnsem} \alias{getFrcEnsem} @@ -13,10 +13,10 @@ getFrcEnsem(dataset, cell = "mean", plot = "norm", output = "data", \item{cell}{A vector containing the locaton of the cell, e.g. c(2, 3), default is "mean", representing the spatially averaged value. Check details for more information.} -\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), +\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.} -\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the +\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the data that can be directly plotted by ggplot2 will be returned, which is easier for you to make series plots afterwards. NOTE: If \code{output = 'ggplot'}, the missing value in the data will be replaced by \code{mv}, if assigned, default mv is 0.} @@ -24,7 +24,7 @@ be replaced by \code{mv}, if assigned, default mv is 0.} \item{name}{If \code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate different outputs in the later multiplot using \code{getEnsem_comb}.} -\item{mv}{A number showing representing the missing value. When calculating the cumulative value, +\item{mv}{A number showing representing the missing value. When calculating the cumulative value, missing value will be replaced by mv, default is 0.} \item{coord}{A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned, @@ -52,6 +52,7 @@ by the argument directly, If name is not assigned and \code{output = 'ggplot'} i the system time will be selected as name column. } \examples{ + filePath <- system.file("extdata", "tnc.nc", package = "hyfo") # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) @@ -62,9 +63,9 @@ a <- getFrcEnsem(nc) a1 <- getFrcEnsem(tgridData) -# The default output is spatially averaged, if there are more than one cells in the dataset, -# the mean value of the cells will be calculated. While if you are interested in special cell, -# you can assign the cell value. You can also directly use longitude and latitude to extract +# The default output is spatially averaged, if there are more than one cells in the dataset, +# the mean value of the cells will be calculated. While if you are interested in special cell, +# you can assign the cell value. You can also directly use longitude and latitude to extract # time series. getSpatialMap(nc, 'mean') @@ -76,6 +77,7 @@ b <- getFrcEnsem(nc, coord = c(-1.4, 43.2)) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getHisEnsem.Rd b/man/getHisEnsem.Rd index b0fec84..18c836b 100644 --- a/man/getHisEnsem.Rd +++ b/man/getHisEnsem.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getEnsemble.R \name{getHisEnsem} \alias{getHisEnsem} @@ -10,25 +10,25 @@ getHisEnsem(TS, example, interval = 365, buffer = 0, plot = "norm", \arguments{ \item{TS}{A time series dataframe, with first column Date, and second column value.} -\item{example}{A vector containing two strings showing the start and end date, which represent the +\item{example}{A vector containing two strings showing the start and end date, which represent the forecasting period. Check details for more information. -the program will extract every possible period in TS you provided to generate the ensemble. Check details for +the program will extract every possible period in TS you provided to generate the ensemble. Check details for more information.} \item{interval}{A number representing the interval of each ensemble member. NOTE: "interval" takes -365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval -to be 2 years, set \code{interval = 730}, which equals 2 * 365 ; if two months, set \code{interval = 60}; -2 days, \code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the +365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval +to be 2 years, set \code{interval = 730}, which equals 2 * 365 ; if two months, set \code{interval = 60}; +2 days, \code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the number as days.By defualt interval is set to be 365, a year.} \item{buffer}{A number showing how many days are used as buffer period for models. Check details for more information.} -\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), +\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.} -\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the +\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the data that can be directly plotted by ggplot2 will be returned, which is easier for you to make series plots afterwards. NOTE: If \code{output = 'ggplot'}, the missing value in the data will be replaced by \code{mv}, if assigned, default mv is 0.} @@ -36,7 +36,7 @@ be replaced by \code{mv}, if assigned, default mv is 0.} \item{name}{If \code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate different outputs in the later multiplot using \code{getEnsem_comb}.} -\item{mv}{A number showing representing the missing value. When calculating the cumulative value, +\item{mv}{A number showing representing the missing value. When calculating the cumulative value, missing value will be replaced by mv, default is 0.} \item{...}{\code{title, x, y} showing the title and x and y axis of the plot. e.g. \code{title = 'aaa'}} @@ -57,7 +57,7 @@ forecasts. In this case your input example should be \code{example = c('2003-2-1 e.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28 days. -\code{example} and \code{interval} controls how the ensemble will be generated. e.g. if the time series is from +\code{example} and \code{interval} controls how the ensemble will be generated. e.g. if the time series is from 1990-1-1 to 2001-1-1. if \code{example = c('1992-3-1', '1994-1-1')} and \code{interval = 1095}, note, 1095 = 365 * 3, so the program treat @@ -97,6 +97,7 @@ need a name column to differentiate one ggplot output from the other. You can as by the argument directly, name has to be assigned if \code{output = 'ggplot'} is selected, } \examples{ + data(testdl) a <- testdl[[1]] @@ -107,12 +108,14 @@ b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4')) # Default interval is one year, can be set to other values, check help for information. # Take 7 months as interval -b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') +b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') # Take 30 days as buffer b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + + } \references{ \itemize{ diff --git a/man/getLMom.Rd b/man/getLMom.Rd index e91ef2f..9ea245a 100644 --- a/man/getLMom.Rd +++ b/man/getLMom.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyzeTS.R \name{getLMom} \alias{getLMom} @@ -20,6 +20,7 @@ dis <- seq(1, 100) getLMom(dis) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getMeanPreci.Rd b/man/getMeanPreci.Rd index 1e98e68..43284cf 100644 --- a/man/getMeanPreci.Rd +++ b/man/getMeanPreci.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getMeanPreci.R \name{getMeanPreci} \alias{getMeanPreci} @@ -17,14 +17,14 @@ more information please refer to details.} \item{monthIndex}{A NUMERIC ARRAY showing the month index of the time series.} -\item{fullResults}{A boolean showing whether the full results are shown, default is FALSE. If +\item{fullResults}{A boolean showing whether the full results are shown, default is FALSE. If FALSE, only mean value will be returned, if TRUE, the sequence of values will be returned.} \item{omitNA}{A boolean showing in the calculation, whether NA is omitted, default is FALSE.} \item{plot}{A boolean showing whether the results will be plotted.} -\item{...,}{\code{title, x, y} showing the title and x and y axis of the plot, shoud be a string.} +\item{..., }{\code{title, x, y} showing the title and x and y axis of the plot, shoud be a string.} } \value{ The mean value of the input time series or the full results before calculating mean. @@ -33,8 +33,8 @@ The mean value of the input time series or the full results before calculating m Get mean rainfall data, e.g. mean annual rainfall, mean monthly rainfall and mean winter rainfall. } \details{ -There are following methods to be selected, -"annual": annual rainfall of each year is plotted. +There are following methods to be selected, +"annual": annual rainfall of each year is plotted. "winter", "spring", "autumn", "summer": seasonal rainfall of each year is plotted. Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfall of each year. "meanMonthly": the mean monthly rainfall of each month over the whole period. diff --git a/man/getMoment.Rd b/man/getMoment.Rd index 28ded94..a0fae96 100644 --- a/man/getMoment.Rd +++ b/man/getMoment.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyzeTS.R \name{getMoment} \alias{getMoment} @@ -20,6 +20,7 @@ dis <- seq(1, 100) getMoment(dis) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getNcdfVar.Rd b/man/getNcdfVar.Rd index 725ba25..1701587 100644 --- a/man/getNcdfVar.Rd +++ b/man/getNcdfVar.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ncdf.R \name{getNcdfVar} \alias{getNcdfVar} @@ -24,6 +24,7 @@ filePath <- system.file("extdata", "tnc.nc", package = "hyfo") varname <- getNcdfVar(filePath) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getPreciBar.Rd b/man/getPreciBar.Rd index cce6f9b..2aad764 100644 --- a/man/getPreciBar.Rd +++ b/man/getPreciBar.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getPreciBar(generic).R \docType{methods} \name{getPreciBar} @@ -29,8 +29,8 @@ please refer to the details.} \item{cell}{A vector containing the locaton of the cell, e.g. c(2, 3), default is "mean", representing the spatially averaged value. Check details for more information.} -\item{output}{A string showing the type of the output, if \code{output = 'ggplot'}, the returned -data can be used in ggplot and \code{getPreciBar_comb()}; if \code{output = 'plot'}, the returned data is the plot containing all +\item{output}{A string showing the type of the output, if \code{output = 'ggplot'}, the returned +data can be used in ggplot and \code{getPreciBar_comb()}; if \code{output = 'plot'}, the returned data is the plot containing all layers' information, and can be plot directly or used in grid.arrange; if not set, the data will be returned.} @@ -56,8 +56,8 @@ The calculated mean value of the input time series and the plot of the result. get mean rainfall bar plot of the input dataset or time series. } \details{ -There are following methods to be selected, -"annual": annual rainfall of each year is plotted. +There are following methods to be selected, +"annual": annual rainfall of each year is plotted. "winter", "spring", "autumn", "summer": seasonal rainfall of each year is plotted. Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfall of each year. "meanMonthly": the mean monthly rainfall of each month over the whole period. @@ -71,15 +71,9 @@ IT IS NOT THE LONGITUDE AND LATITUDE. e.g., \code{cell = c(2, 3)}, the program w and 3rd latitude, by the increasing order. Longitude comes first. -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\section{Methods (by class)}{ -\itemize{ -\item \code{list}: - -\item \code{data.frame}: -}} \examples{ #gridData provided by package is the result of \\code{loadNcdf()} data(tgridData) @@ -94,6 +88,7 @@ a <- getPreciBar(TS, method = 'spring', info = TRUE) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getPreciBar_comb.Rd b/man/getPreciBar_comb.Rd index 6c65499..dadd8a2 100644 --- a/man/getPreciBar_comb.Rd +++ b/man/getPreciBar_comb.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getPreciBar(generic).R \name{getPreciBar_comb} \alias{getPreciBar_comb} @@ -30,15 +30,16 @@ A combined barplot. Combine bars together } \details{ -..., representing different ouput generated by \code{getPreciBar(, output = 'ggplot')}, they -have to be of the same type, e.g., -1. Jan precipitation of different years, Feb precipitation of different years, and... +..., representing different ouput generated by \code{getPreciBar(, output = 'ggplot')}, they +have to be of the same type, e.g., +1. Jan precipitation of different years, Feb precipitation of different years, and... They are both monthly precipitation, and they share x axis. 2. Mean monthly precipitation of different dataset. e.g., long term mean monthly precipitation and short term mean monthly precipitation. They are both mean monthly precipitation. } \examples{ + data(tgridData)# the result of \\code{\\link{loadNcdf}} #output type of getPreciBar() has to be 'ggplot'. b1 <- getPreciBar(tgridData, method = 2, output = 'ggplot', name = 'b1') @@ -47,6 +48,7 @@ b2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2') getPreciBar_comb(b1, b2) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getSpatialMap.Rd b/man/getSpatialMap.Rd index 4a3d047..6fe3722 100644 --- a/man/getSpatialMap.Rd +++ b/man/getSpatialMap.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getSpatialMap.R \name{getSpatialMap} \alias{getSpatialMap} @@ -17,7 +17,7 @@ details.} is NULL, if no member assigned, and there is a "member" in dimensions, the mean value of the members will be taken.} -\item{...}{several arguments including x, y, title, catchment, point, output, name, info, scale, color, +\item{...}{several arguments including x, y, title, catchment, point, output, name, info, scale, color, type in \code{?getSpatialMap_mat} for details.} } \value{ @@ -27,13 +27,15 @@ A matrix representing the raster map is returned, and the map is plotted. Get spatial map of the input dataset. } \details{ -There are following methods to be selected, -"meanAnnual": annual rainfall of each year is plotted. +There are following methods to be selected, +"meanAnnual": annual rainfall of each year is plotted. "winter", "spring", "autumn", "summer": MEAN seasonal rainfall of each year is plotted. Month(number 1 to 12): MEAN month rainfall of each year is plotted, e.g. MEAN march rainfall of each year. "mean", "max", "min": mean daily, maximum daily, minimum daily precipitation. } \examples{ + + \dontrun{ #gridData provided in the package is the result of \\code {loadNcdf} data(tgridData) @@ -50,5 +52,6 @@ getSpatialMap(tgridData, method = 'winter', catchment = testCat, point = point) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } diff --git a/man/getSpatialMap_comb.Rd b/man/getSpatialMap_comb.Rd index 7d8b009..c2b50d9 100644 --- a/man/getSpatialMap_comb.Rd +++ b/man/getSpatialMap_comb.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getSpatialMap.R \name{getSpatialMap_comb} \alias{getSpatialMap_comb} @@ -29,12 +29,14 @@ A combined map. Combine maps together } \details{ -For \code{getSpatialMap_comb}, the maps to be compared should be with same size and resolution, +For \code{getSpatialMap_comb}, the maps to be compared should be with same size and resolution, in other words, they should be fully overlapped by each other. If they have different resolutions, use \code{interpGridData{ecomsUDG.Raccess}} to interpolate. } \examples{ + + \dontrun{ data(tgridData)# the result of \\code{\\link{loadNcdf}} #The output should be 'ggplot' @@ -51,6 +53,7 @@ getSpatialMap_comb(list = list(a1, a2), nrow = 2) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index 08d34d3..4b6fbcb 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getSpatialMap.R \name{getSpatialMap_mat} \alias{getSpatialMap_mat} @@ -16,11 +16,11 @@ or 'data'} \item{catchment}{A catchment file geting from \code{shp2cat()} in the package, if a catchment is available for background.} -\item{point}{A dataframe, showing other information, e.g., location of the gauging stations. The +\item{point}{A dataframe, showing other information, e.g., location of the gauging stations. The the data.frame should be with columes "name, lon, lat, z, value".} -\item{output}{A string showing the type of the output, if \code{output = 'ggplot'}, the returned -data can be used in ggplot and \code{getSpatialMap_comb()}; if \code{output = 'plot'}, the returned data is the plot containing all +\item{output}{A string showing the type of the output, if \code{output = 'ggplot'}, the returned +data can be used in ggplot and \code{getSpatialMap_comb()}; if \code{output = 'plot'}, the returned data is the plot containing all layers' information, and can be plot directly or used in grid.arrange; if not set, the raster matrix data will be returned.} @@ -31,7 +31,7 @@ different outputs in the later multiplot using \code{getSpatialMap_comb}.} \item{scale}{A string showing the plot scale, 'identity' or 'sqrt'.} -\item{color}{Most of time you don't have to set this, but if you are not satisfied with the +\item{color}{Most of time you don't have to set this, but if you are not satisfied with the default color, you can set your own palette here. e.g., \code{color = c('red', 'blue')}, then the value from lowest to highest, will have the color from red to blue. More info about color, please check ?palette().} @@ -47,6 +47,7 @@ replot the matrix output from \code{getSpatialMap}, when \code{output = 'data'} value. } \examples{ + \dontrun{ data(tgridData)# the result of \\code{loadNcdf} #the output type of has to be default or 'data'. @@ -67,6 +68,7 @@ getSpatialMap_mat(a6) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/list2Dataframe.Rd b/man/list2Dataframe.Rd index b43b7bf..255ef42 100644 --- a/man/list2Dataframe.Rd +++ b/man/list2Dataframe.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/list2dataframe.R \name{list2Dataframe} \alias{list2Dataframe} @@ -15,7 +15,7 @@ The converted dataframe \description{ Convert a list of different time series to a dataframe. Usually the list is the output of \code{extractPeriod} -NOTE: Since it's dataframe, so the dataframes in the input datalist should have the same +NOTE: Since it's dataframe, so the dataframes in the input datalist should have the same date, if not, please use \code{extractPeriod} to process. } \examples{ @@ -27,5 +27,6 @@ datalist_new <- extractPeriod(datalist, commonPeriod = TRUE) dataframe <- list2Dataframe(datalist_new) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } diff --git a/man/loadNcdf.Rd b/man/loadNcdf.Rd index fe82428..085a427 100644 --- a/man/loadNcdf.Rd +++ b/man/loadNcdf.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ncdf.R \name{loadNcdf} \alias{loadNcdf} @@ -12,15 +12,15 @@ loadNcdf(filePath, varname, tz = "GMT", ...) \item{varname}{A character representing the variable name, you can use \code{getNcdfVar} to get the basic information about the variables and select the target.} -\item{tz}{A string representing the time zone, default is GMT, if you know what time zone is +\item{tz}{A string representing the time zone, default is GMT, if you know what time zone is you can assign it in the argument. If \code{tz = ''}, current time zone will be taken.} -\item{...}{Several arguments including Year, month, lon, lat -type in \code{?downscaleNcdf} for details.You can load while downscale, +\item{...}{Several arguments including Year, month, lon, lat +type in \code{?downscaleNcdf} for details.You can load while downscale, and also first load than use \code{downscaleNcdf} to downscale.} } \value{ -A list object from \code{hyfo} containing the information to be used in the analysis, +A list object from \code{hyfo} containing the information to be used in the analysis, or biascorrection. } \description{ @@ -37,10 +37,11 @@ nc <- loadNcdf(filePath, varname) # you can directly add your downscale information to the argument. nc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7)) -nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), +nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7)) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/monthlyPreci.Rd b/man/monthlyPreci.Rd index 38cbcfa..b5dd206 100644 --- a/man/monthlyPreci.Rd +++ b/man/monthlyPreci.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fillGap.R \name{monthlyPreci} \alias{monthlyPreci} diff --git a/man/plotTS.Rd b/man/plotTS.Rd index d4a379b..75da04c 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyzeTS.R \name{plotTS} \alias{plotTS} @@ -12,7 +12,7 @@ plotTS(..., type = "line", output = "data", plot = "norm", name = NULL, \item{type}{A string representing the type of the time series, e.g. 'line' or 'bar'.} -\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the +\item{output}{A string showing which type of output you want. Default is "data", if "ggplot", the data that can be directly plotted by ggplot2 will be returned, which is easier for you to make series plots afterwards.} @@ -39,7 +39,7 @@ A plot of the input time series. plot time series, with marks on missing value. } \details{ -If your input has more than one time series, the program will only plot the common period of +If your input has more than one time series, the program will only plot the common period of different time series. } \examples{ @@ -66,6 +66,7 @@ plotTS(dataframe, dataframe1, plot = 'cum') # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/plotTS_comb.Rd b/man/plotTS_comb.Rd index 857dc0d..582bd9a 100644 --- a/man/plotTS_comb.Rd +++ b/man/plotTS_comb.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyzeTS.R \name{plotTS_comb} \alias{plotTS_comb} @@ -32,7 +32,7 @@ A combined time series plot. Combine time seires plot together } \details{ -..., representing different ouput file generated by \code{plotTS(, output = 'ggplot'), name = yourname}, +..., representing different ouput file generated by \code{plotTS(, output = 'ggplot'), name = yourname}, different names must be assigned when generating different output. e.g. @@ -47,6 +47,7 @@ plotTS_comb(a1, a2) plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/resample.Rd b/man/resample.Rd index df9e891..d45f3f6 100644 --- a/man/resample.Rd +++ b/man/resample.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/resample(generic).R \docType{methods} \name{resample} @@ -28,20 +28,14 @@ Resameple your time series or ncdf files, more info pleae see details. } \details{ Note, when you want to change daily data to monthly data, a new date column will be generated, -usually the date column will be the middle date of each month, 15th, or 16th. However, if your -time series doesn't start from the beginning of a month or ends to the end of a month, e.g. -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. +usually the date column will be the middle date of each month, 15th, or 16th. However, if your +time series doesn't start from the beginning of a month or ends to the end of a month, e.g. +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. -It is a generic function, if in your case you need to debug, please see \code{?debug()} +It is a generic function, if in your case you need to debug, please see \code{?debug()} for how to debug S4 method. } -\section{Methods (by class)}{ -\itemize{ -\item \code{data.frame}: - -\item \code{list}: -}} \examples{ # Daily to monthly data(testdl) @@ -50,19 +44,20 @@ str(TS) TS_new <- resample(TS, method = 'day2mon') # Monthly to daily -TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), +TS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), runif(30, 3, 10)) TS_new <- resample(TS, method = 'mon2day') #' # First load ncdf file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -varname <- getNcdfVar(filePath) +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/ + } \references{ \itemize{ diff --git a/man/shp2cat.Rd b/man/shp2cat.Rd index 8fc9890..6c60613 100644 --- a/man/shp2cat.Rd +++ b/man/shp2cat.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shp2cat.R \name{shp2cat} \alias{shp2cat} @@ -16,7 +16,7 @@ A catchment object can be used in \code{getSpatialMap()}. Get a catchment object from selected shape file. } \details{ -This function is based on the package \code{rgdal} and \code{sp}, and the output comes from the package +This function is based on the package \code{rgdal} and \code{sp}, and the output comes from the package \code{sp} } \examples{ @@ -25,6 +25,7 @@ file <- system.file("extdata", "testCat.shp", package = "hyfo") catchment <- shp2cat(file) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ diff --git a/man/testCat.Rd b/man/testCat.Rd index 4c7cfbe..e203f3c 100644 --- a/man/testCat.Rd +++ b/man/testCat.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDocument.R \docType{data} \name{testCat} diff --git a/man/testdl.Rd b/man/testdl.Rd index b0f1a94..93cfa83 100644 --- a/man/testdl.Rd +++ b/man/testdl.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDocument.R \docType{data} \name{testdl} diff --git a/man/tgridData.Rd b/man/tgridData.Rd index 6fcf41c..22bcf0b 100644 --- a/man/tgridData.Rd +++ b/man/tgridData.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDocument.R \docType{data} \name{tgridData} @@ -23,9 +23,9 @@ A list containing different information getting from grid data file, e.g., netcd } \references{ \itemize{ -\item Herrera, S., Ancell, R., Gutierrez, J. M., Pons, M. R., Frias, M. D., & Fernandez, J. -(2012). Development and analysis of a 50-year high-resolution daily gridded precipitation dataset -over Spain (Spain02). International Journal of Climatology +\item Herrera, S., Ancell, R., Gutierrez, J. M., Pons, M. R., Frias, M. D., & Fernandez, J. +(2012). Development and analysis of a 50-year high-resolution daily gridded precipitation dataset +over Spain (Spain02). International Journal of Climatology (http://www.meteo.unican.es/datasets/spain02), 10.1002/joc.2256. } } diff --git a/man/writeNcdf.Rd b/man/writeNcdf.Rd index f669f25..5becb22 100644 --- a/man/writeNcdf.Rd +++ b/man/writeNcdf.Rd @@ -1,4 +1,4 @@ -% Generated by roxygen2 (4.1.1): do not edit by hand +% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ncdf.R \name{writeNcdf} \alias{writeNcdf} @@ -14,13 +14,13 @@ writeNcdf(gridData, filePath, missingValue = 1e+20, tz = "GMT", \item{missingValue}{A number representing the missing value in the NetCDF file, default is 1e20 -#'} - -\item{tz}{A string representing the time zone, default is GMT, if you know what time zone is +#' @param tz A string representing the time zone, default is GMT, if you know what time zone is you can assign it in the argument. If \code{tz = ''}, current time zone will be taken.} -\item{units}{A string showing in which unit you are putting in the NetCDF file, it can be -seconds or days and so on. If not specified, the function will pick up the possible largest +\item{tz}{time zone, default is "GMT"} + +\item{units}{A string showing in which unit you are putting in the NetCDF file, it can be +seconds or days and so on. If not specified, the function will pick up the possible largest time units from \code{c('weeks', 'days', 'hours', 'mins', 'secs')}} \item{version}{ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.} @@ -46,6 +46,7 @@ nc <- loadNcdf(filePath, varname) writeNcdf(nc, 'test.nc') # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ + } \references{ \itemize{ From 5422e8d3705bf80a8d7082c770add23a4c8f756c Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 11 Jan 2017 15:14:32 +0800 Subject: [PATCH 07/43] minor changes --- .Rhistory | 4 ++-- .Rproj.user/D1D10CF6/pcs/files-pane.pper | 2 +- .Rproj.user/D1D10CF6/pcs/source-pane.pper | 2 +- .Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA | 8 ++++---- .Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A | 20 ++++++++++++++++++++ .Rproj.user/D1D10CF6/sdb/per/t/FFE783F | 8 ++++---- .Rproj.user/D1D10CF6/sdb/prop/E538DE4 | 2 ++ .Rproj.user/D1D10CF6/sdb/prop/INDEX | 1 + R/biasCorrect(generic).R | 4 ++-- man/biasCorrect.Rd | 4 ++-- 10 files changed, 39 insertions(+), 16 deletions(-) create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/E538DE4 diff --git a/.Rhistory b/.Rhistory index 2babc6b..4f6855f 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,5 +1,3 @@ -#' ######## -#' #' # If your input is obtained by \code{loadNcdf}, you can also directly biascorrect #' # the file. #' @@ -510,3 +508,5 @@ fn() newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0), upper = c(1000, 0)) devtools::check() +devtools::check() +devtools::check() diff --git a/.Rproj.user/D1D10CF6/pcs/files-pane.pper b/.Rproj.user/D1D10CF6/pcs/files-pane.pper index 7931319..10314bb 100644 --- a/.Rproj.user/D1D10CF6/pcs/files-pane.pper +++ b/.Rproj.user/D1D10CF6/pcs/files-pane.pper @@ -1,5 +1,5 @@ { - "path" : "~/GitHub/hyfo", + "path" : "~/GitHub/hyfo/R", "sortOrder" : [ { "ascending" : true, diff --git a/.Rproj.user/D1D10CF6/pcs/source-pane.pper b/.Rproj.user/D1D10CF6/pcs/source-pane.pper index 3249574..70829f6 100644 --- a/.Rproj.user/D1D10CF6/pcs/source-pane.pper +++ b/.Rproj.user/D1D10CF6/pcs/source-pane.pper @@ -1,3 +1,3 @@ { - "activeTab" : 2 + "activeTab" : 1 } \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA b/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA index f6a123c..012be54 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA +++ b/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA @@ -1,14 +1,14 @@ { "collab_server" : "", - "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' f\n#' \n#' \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 }\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\n# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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", + "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 }\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\n# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1483875773075.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1352449680", + "hash" : "1965966598", "id" : "2A6E2BEA", - "lastKnownWriteTime" : 1483973407, - "last_content_update" : 1483973407763, + "lastKnownWriteTime" : 1484118501, + "last_content_update" : 1484118501532, "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", "project_path" : "R/biasCorrect(generic).R", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A b/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A new file mode 100644 index 0000000..277cad5 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/dataDocument.R\n\\docType{data}\n\\name{tgridData}\n\\alias{tgridData}\n\\title{tgridData}\n\\format{A list containing different information.\n\\describe{\n \\item{Variables}{variable information. }\n \\item{Data}{Data.}\n \\item{xyCoords}{longitude and latitude of the data.}\n \\item{Dates}{Date information.}\n ...\n}}\n\\source{\nhttp://www.meteo.unican.es/datasets/spain02\n}\n\\usage{\ntgridData\n}\n\\description{\nA list containing different information getting from grid data file, e.g., netcdf file.\n}\n\\references{\n\\itemize{\n\\item Herrera, S., Ancell, R., Gutierrez, J. M., Pons, M. R., Frias, M. D., & Fernandez, J. \n(2012). Development and analysis of a 50-year high-resolution daily gridded precipitation dataset \nover Spain (Spain02). International Journal of Climatology \n(http://www.meteo.unican.es/datasets/spain02), 10.1002/joc.2256.\n}\n}\n\\keyword{datasets}\n\n", + "created" : 1484118438453.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3096661772", + "id" : "CA11BD0A", + "lastKnownWriteTime" : 1484118700, + "last_content_update" : 1484118700, + "path" : "~/GitHub/hyfo/man/tgridData.Rd", + "project_path" : "man/tgridData.Rd", + "properties" : { + }, + "relative_order" : 10, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F index 868471c..ba0fe4f 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F +++ b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/biasCorrect(generic).R\n\\docType{methods}\n\\name{biasCorrect}\n\\alias{biasCorrect}\n\\alias{biasCorrect,data.frame,data.frame,data.frame-method}\n\\alias{biasCorrect,list,list,list-method}\n\\title{Biascorrect the input timeseries or hyfo dataset}\n\\usage{\nbiasCorrect(frc, hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the forecast to be calibrated.}\n\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \ndetails. Default scaleType is 'multi'.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nBiascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\nobservation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\nwill be returned. If the input is a time series, first column should be date column and rest columns should be \nthe value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\nfile with the same format.\n}\n\\details{\nSince climate forecast is based on global condition, when downscaling to different regions, it may include\nsome bias, biascorrection is used then to fix the bias.\n\n\\strong{Hindcast}\n\nIn order to bias correct, we need to pick up some data from the forecast to train with\nthe observation, which is called hindcast in this function. Using hindcast and observation, \nthe program can analyze the bias and correct the bias in the forecast. \n\nHindcast should have \\strong{EVERY} attributes that forecast has.\n\nHindcast 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\nis the hindcast period, and 2005-2010, this period is the forecast period.\n\nHindcast 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\nForecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \nforecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \ndata (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n\nE.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \nperiod (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\nThe program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \nmodification to the forecast data.\n\nThe more categorized input, the more accurate result you will get. E.g., if you want to \nbias correct a forecast for winter season. So you'd better to extract all the winter period\nin the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n\n\\strong{method}\n\nDifferent methods used in the bias correction. Among which, delta, scaling can be applied\nto different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\nit needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\ndesigned for rainfall data, so \\code{preci = TRUE} needs to be set.\n\n\\strong{delta}\n\nThis method consists on adding to the observations the mean change signal (delta method). \nThis 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 \nThis method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \nbetween the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\ncorrection is defined by parameter \\code{scaling.type} (default is \\code{additive}).\nThe additive version is preferably applicable to unbounded variables (e.g. temperature) \nand the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n \n \\strong{eqm}\n \nEmpirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \nby adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \nThis method is applicable to any kind of variable.\n\nIt can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\nthat the extreme value is an error.\n \n \\strong{gqm}\n \nGamma 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\nand simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \nthat uses the theorical instead of the empirical distribution. \n \nIt can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\nBetter have a long period of training, and the if the forecast system is relatively stable.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\nf\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\nnewFrc <- biasCorrect(nc, nc, tgridData) \nnewFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \nnewFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \npreci = TRUE) \nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nfrc_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\nfrc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n\n# You can use other scaling methods to biascorrect.\nfrc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n\n# \nfrc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\nfrc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/biasCorrect(generic).R\n\\docType{methods}\n\\name{biasCorrect}\n\\alias{biasCorrect}\n\\alias{biasCorrect,data.frame,data.frame,data.frame-method}\n\\alias{biasCorrect,list,list,list-method}\n\\title{Biascorrect the input timeseries or hyfo dataset}\n\\usage{\nbiasCorrect(frc, hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the forecast to be calibrated.}\n\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \ndetails. Default scaleType is 'multi'.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nBiascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\nobservation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\nwill be returned. If the input is a time series, first column should be date column and rest columns should be \nthe value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\nfile with the same format.\n}\n\\details{\nSince climate forecast is based on global condition, when downscaling to different regions, it may include\nsome bias, biascorrection is used then to fix the bias.\n\n\\strong{Hindcast}\n\nIn order to bias correct, we need to pick up some data from the forecast to train with\nthe observation, which is called hindcast in this function. Using hindcast and observation, \nthe program can analyze the bias and correct the bias in the forecast. \n\nHindcast should have \\strong{EVERY} attributes that forecast has.\n\nHindcast 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\nis the hindcast period, and 2005-2010, this period is the forecast period.\n\nHindcast 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\nForecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \nforecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \ndata (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n\nE.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \nperiod (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\nThe program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \nmodification to the forecast data.\n\nThe more categorized input, the more accurate result you will get. E.g., if you want to \nbias correct a forecast for winter season. So you'd better to extract all the winter period\nin the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n\n\\strong{method}\n\nDifferent methods used in the bias correction. Among which, delta, scaling can be applied\nto different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\nit needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\ndesigned for rainfall data, so \\code{preci = TRUE} needs to be set.\n\n\\strong{delta}\n\nThis method consists on adding to the observations the mean change signal (delta method). \nThis 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 \nThis method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \nbetween the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\ncorrection is defined by parameter \\code{scaling.type} (default is \\code{additive}).\nThe additive version is preferably applicable to unbounded variables (e.g. temperature) \nand the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n \n \\strong{eqm}\n \nEmpirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \nby adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \nThis method is applicable to any kind of variable.\n\nIt can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\nthat the extreme value is an error.\n \n \\strong{gqm}\n \nGamma 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\nand simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \nthat uses the theorical instead of the empirical distribution. \n \nIt can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\nBetter have a long period of training, and the if the forecast system is relatively stable.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\n\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\nnewFrc <- biasCorrect(nc, nc, tgridData) \nnewFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \nnewFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \npreci = TRUE) \nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nfrc_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\nfrc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n\n# You can use other scaling methods to biascorrect.\nfrc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n\n# \nfrc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\nfrc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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", "created" : 1483875745269.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1889128030", + "hash" : "1881246410", "id" : "FFE783F", - "lastKnownWriteTime" : 1483973423, - "last_content_update" : 1483973423, + "lastKnownWriteTime" : 1484118700, + "last_content_update" : 1484118700, "path" : "~/GitHub/hyfo/man/biasCorrect.Rd", "project_path" : "man/biasCorrect.Rd", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/prop/E538DE4 b/.Rproj.user/D1D10CF6/sdb/prop/E538DE4 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/E538DE4 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/INDEX b/.Rproj.user/D1D10CF6/sdb/prop/INDEX index 4d398cf..a316fe7 100644 --- a/.Rproj.user/D1D10CF6/sdb/prop/INDEX +++ b/.Rproj.user/D1D10CF6/sdb/prop/INDEX @@ -8,3 +8,4 @@ ~%2FGitHub%2Fhyfo%2FR%2Fncdf.R="DD613721" ~%2FGitHub%2Fhyfo%2FR%2Fresample(generic).R="85BAB51C" ~%2FGitHub%2Fhyfo%2Fman%2FbiasCorrect.Rd="A5EB009E" +~%2FGitHub%2Fhyfo%2Fman%2FtgridData.Rd="E538DE4" diff --git a/R/biasCorrect(generic).R b/R/biasCorrect(generic).R index ae7eb2f..dc3c3e5 100644 --- a/R/biasCorrect(generic).R +++ b/R/biasCorrect(generic).R @@ -75,7 +75,7 @@ #' (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained #' (e.g. negative wind speeds...) #' -#' \strong{scaling} +#' \strong{scaling} #' #' This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) #' between the observed and simulated means in the train period. The \code{additive} or \code{multiplicative} @@ -120,7 +120,7 @@ #' data(tgridData) #' # Since the example data, has some NA values, the process will include some warning #message, #' # which can be ignored in this case. -#' f +#' #' #' #' diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 3360b94..11c0072 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -98,7 +98,7 @@ This method is applicable to any kind of variable but it is preferable to avoid (e.g. precipitation, wind speed, etc.) because values out of the variable range could be obtained (e.g. negative wind speeds...) - \strong{scaling} +\strong{scaling} This method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) between the observed and simulated means in the train period. The \code{additive} or \code{multiplicative} @@ -143,7 +143,7 @@ nc <- loadNcdf(filePath, varname) data(tgridData) # Since the example data, has some NA values, the process will include some warning #message, # which can be ignored in this case. -f + From 4a6be13d13a5a7b86f663ee89903084f44ae76d8 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 20 Feb 2017 20:56:20 +0800 Subject: [PATCH 08/43] apply data.table --- .Rhistory | 502 +++++++++---------- .Rproj.user/D1D10CF6/pcs/find-in-files.pper | 4 +- .Rproj.user/D1D10CF6/pcs/source-pane.pper | 2 +- .Rproj.user/D1D10CF6/pcs/workbench-pane.pper | 2 +- .Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 | 8 +- .Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/6511719A | 20 + .Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B | 8 +- .Rproj.user/D1D10CF6/sdb/per/t/9A428717 | 8 +- .Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/A879E0CC | 20 + .Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C | 20 + .Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A | 8 +- .Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A | 4 +- .Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB | 8 +- .Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 | 20 + .Rproj.user/D1D10CF6/sdb/per/t/FFE783F | 4 +- .Rproj.user/D1D10CF6/sdb/prop/16BD8E13 | 2 + .Rproj.user/D1D10CF6/sdb/prop/1C27F867 | 2 + .Rproj.user/D1D10CF6/sdb/prop/224CF03 | 2 + .Rproj.user/D1D10CF6/sdb/prop/31175AC6 | 2 + .Rproj.user/D1D10CF6/sdb/prop/3A3983B1 | 2 + .Rproj.user/D1D10CF6/sdb/prop/715D0DA2 | 2 + .Rproj.user/D1D10CF6/sdb/prop/7E5B8828 | 2 + .Rproj.user/D1D10CF6/sdb/prop/ADA38099 | 2 + .Rproj.user/D1D10CF6/sdb/prop/INDEX | 8 + DESCRIPTION | 7 +- NAMESPACE | 1 + NEWS | 8 + R/analyzeTS.R | 9 +- R/case_anarbe.R | 9 +- R/collectData.R | 3 +- R/extractPeriod(generic).R | 3 +- R/getAnnual(generic).R | 6 +- R/getEnsemble.R | 7 +- R/getPreciBar(generic).R | 7 +- R/getSpatialMap.R | 5 +- R/resample(generic).R | 3 +- 41 files changed, 529 insertions(+), 301 deletions(-) create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/6511719A create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/A879E0CC create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 create mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/16BD8E13 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/1C27F867 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/224CF03 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/31175AC6 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/3A3983B1 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/715D0DA2 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/7E5B8828 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/ADA38099 diff --git a/.Rhistory b/.Rhistory index 4f6855f..5bc7561 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,254 +1,3 @@ -#' # If your input is obtained by \code{loadNcdf}, you can also directly biascorrect -#' # the file. -#' -#' # First load ncdf file. -#' filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -#' varname <- getNcdfVar(filePath) -#' nc <- loadNcdf(filePath, varname) -#' -#' data(tgridData) -#' # Since the example data, has some NA values, the process will include some warning #message, -#' # which can be ignored in this case. -#' -#' -#' -#' -#' # Then we will use nc data as forecasting data, and use itself as hindcast data, -#' # use tgridData as observation. -#' newFrc <- biasCorrect(nc, nc, tgridData) -#' newFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') -#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', -#' preci = TRUE) -#' newFrc <- biasCorrect(nc, nc, tgridData, method = 'gqm', preci = TRUE) -#' -#' -#' ######## Time series biascorrection -#' ######## -#' -#' # Use the time series from testdl as an example, we take frc, hindcast and obs from testdl. -#' data(testdl) -#' -#' # common period has to be extracted in order to better train the forecast. -#' -#' datalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1') -#' -#' frc <- datalist[[1]] -#' hindcast <- datalist[[2]] -#' 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) -#' -#' # 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, preci = TRUE) -#' -#' # You can use other scaling methods to biascorrect. -#' 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') -#' -#' # You can also give name to this input list. -#' 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') -#' -#' -#' # If the forecasts you extracted only has incontinuous data for certain months and years, e.g., -#' # for seasonal forecasting, forecasts only provide 3-6 months data, so the case can be -#' # for example Dec, Jan and Feb of every year from year 1999-2005. -#' # In such case, you need to extract certain months and years from observed time series. -#' # extractPeriod() can be then used. -#' -#' -#' -#' -#' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ -#' -#' -#' @references -#' Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} -#' -#' \itemize{ -#' -#' \item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R -#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki -#' -#' \item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887 -#' -#' \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 -#' } -#' -#' @author Yuanchao Xu \email{xuyuanchao37@@gmail.com } -#' @importFrom methods setMethod -#' @export -#' -setGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scaleType = 'multi', -preci = FALSE, prThreshold = 0, extrapolate = 'no') { -standardGeneric('biasCorrect') -}) -# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2 -# so use rdname instead -#' @rdname 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) -}) -#' @rdname 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 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 <- grepAndMatch('member', attributes(frcData)$dimensions) -# For dataset that has a member part -if (length(memberIndex) != 0) { -# 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 (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) -} -#' @importFrom MASS fitdistr -#' @importFrom stats ecdf quantile pgamma qgamma rgamma -#' -#' @references -#' Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} -#' -#' \itemize{ -#' -#' \item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and statistical downscaling. R -#' package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki -#' -#' \item R.A.I. Wilcke, T. Mendlik and A. Gobiet (2013) Multi-variable error correction of regional climate models. Climatic Change, 120, 871-887 -#' -#' \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 -#' } -#' -#' -#' -# this is only used to calculate the value column, -biasCorrect_core <- function(frc, 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(frc)) | !any(!is.na(hindcast))) { -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.') -# comes from downscaleR biascorrection method -frcMean <- mean(frc, na.rm = TRUE) -hindcastMean <- mean(hindcast, na.rm = TRUE) -frc <- obs - hindcastMean + frcMean -} else if (method == 'scaling') { -obsMean <- mean(obs, na.rm = TRUE) -hindcastMean <- mean(hindcast, na.rm = TRUE) -if (scaleType == 'multi') { -frc <- frc / hindcastMean * obsMean -} else if (scaleType == 'add') { frc <- frc - hindcastMean + obsMean } } else if (method == 'eqm') { @@ -510,3 +259,254 @@ obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0), upper = c(1000, 0)) devtools::check() devtools::check() devtools::check() +DT1 = data.table(A=1:3,B=letters[1:3]) +DT2 = data.table(B=letters[4:5],A=4:5) +l = list(DT1,DT2) +rbindlist(l, use.names=TRUE) +install.packages('data.table') +library(data.table) +DT1 = data.table(A=1:3,B=letters[1:3]) +DT2 = data.table(B=letters[4:5],A=4:5) +l = list(DT1,DT2) +rbindlist(l, use.names=TRUE) +DT1 +DT2 +devtools::document() +devtools::check() +devtools::document() +devtools::check() +devtools::check() +devtools::check() +plotTS(testdl[[1]]) +plotTS(testdl[[1]], x = 'xxx', y = 'yyy', title = 'aaa') +plotTS(list = testdl) +a1 <- plotTS(testdl[[1]], output = 'ggplot', name = 1) +a2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2) +plotTS_comb(a1, a2) +plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) +debug(plotTS_comb) +plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) +class(data_ggplot) +devtools::check() +a1 <- plotTS(testdl[[1]], output = 'ggplot', name = 1) +a2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2) +plotTS_comb(a1, a2) +debug(plotTS_comb) +plotTS_comb(a1, a2) +class(data_ggplot) +class(data_ggplot) +class(data_ggplot) == c('data.table', 'data.frame') +data_ggplot$name +devtools::check() +a1 <- plotTS(testdl[[1]], output = 'ggplot', name = 1) +a2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2) +plotTS_comb(a1, a2) +plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) +devtools::check() +trace("extractPeriod", browser, exit=browser, signature = c("list")) +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) +Dates +Dates <- rbindlist(Dates) +do.call('rbind', Dates) +Dates[1] +Dates[[1]] +rbindlist(Dates) +is.list(Dates[1]) +debug(rbindlist) +rbindlist(Dates) +Dates[[1]] +Dates +datalist +str(datalist) +str(Dates) +rbindlist(datalist) +devtools::document() +devtools::check() +debug(collectData_csv_anarbe) +file <- system.file("extdata", "1999.csv", package = "hyfo") +folder <- strsplit(file, '1999')[[1]][1] +a <- collectData_csv_anarbe(folder) +data +data <- rbindlist(data) +undebug(rbindlist) +data <- rbindlist(data) +do.call('rbind', data) +fileNames +str(data) +data <- lapply(fileNames, readColumn_csv_anarbe) +str(data) +rbindlist(data) +fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) +data <- lapply(fileNames, readColumn_csv_anarbe) +rbindlist(data) +a <- collectData_csv_anarbe(folder) +do.call('rbind', data) +data <- do.call('rbind', data) +data <- data[, 1:2] +data +data[,1] +data <- rbindlist(data) +fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) +data <- lapply(fileNames, readColumn_csv_anarbe) +data <- rbindlist(data) +data +data <- data[, 1:2] +data +data[, 1] +as.Date(data[, 1], format = '%d/%m/%Y') +str(data[,1]) +fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) +data <- lapply(fileNames, readColumn_csv_anarbe) +data <- do.call('rbind', data) +data <- data[, 1:2] +data +data[, 1] +str(data[, 1]) +a <- data[, 1] +a +fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) +data <- lapply(fileNames, readColumn_csv_anarbe) +data <- rbindlist(data) +data <- data[, 1:2] +b <- data[, 1] +b +str(b) +str(a) +as.Date(data[, 1], format = '%d/%m/%Y') +as.Date(data[1, 1], format = '%d/%m/%Y') +data[1, 1] +str(data[1, 1]) +as.Date(data[1, 1]) +data[1,] +data[1,1] +data[1,1] = '02/01/1999' +data[1,1] == '02/01/1999' +data[2,1] +data[2,1] == '03/01/1999' +data[,1] == '03/01/1999' +data[,1] +as.Date('03/01/1999') +data[, 1] +data[2, 1] +str(data[2, 1]) +data[[2]] +data[,2] +devtools::check() +debug(collectData_csv_anarbe) +a <- collectData_csv_anarbe(folder) +file <- system.file("extdata", "1999.csv", package = "hyfo") +folder <- strsplit(file, '1999')[[1]][1] +a <- collectData_csv_anarbe(folder) +devtools::check() +debug(collectData_csv_anarbe) +file <- system.file("extdata", "1999.csv", package = "hyfo") +folder <- strsplit(file, '1999')[[1]][1] +a <- collectData_csv_anarbe(folder) +data +data[, 1] <- as.Date(data[[1]], format = '%d/%m/%Y') +data +fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) +data <- lapply(fileNames, readColumn_csv_anarbe) +data <- rbindlist(data) +data <- data[, 1:2] +data[[1]] <- as.Date(data[[1]], format = '%d/%m/%Y') +data +debug(fillGap_lmCoef) +b <- read.table(text = ' Date AAA BBB CCC DDD EEE +49 1999-12-15 24.8 21.4 25.6 35.0 17.4 +50 1999-12-16 NA 0.6 1.5 6.3 2.5 +51 1999-12-17 NA 16.3 20.3 NA 19.2 +52 1999-12-18 13 1.6 NA 6.3 0.0 +53 1999-12-19 10 36.4 12.5 26.8 24.9 +54 1999-12-20 NA 0.0 0.0 0.2 0.0 +55 1999-12-21 0.2 0.0 0.0 0.0 0.0 +56 1999-12-22 0.0 0.0 0.0 0.0 0.0') +b1 <- fillGap(b) +lmCoef +rbindlist(lmCoef) +l <- list(c("16:59:20", "100", "143.88"), c("16:59:05", "106", "143.90"), +c("16:58:49", "900", "143.92"), c("16:58:49", "100", "143.92"), +c("16:58:46", "100", "143.93"), c("16:58:46", "200", "143.93")) +transpose(l) +rbindlist(transpose(lmCoef)) +transpose(lmCoef) +lmCoef +rbindlist(l) +rbindlist(transpose(l)) +setDT(l) +l +t(setDT(l)) +setDT(t(lmCoef)) +lmCoef +l <- dim(data)[2] +m <- diag(l)# m is the coeficients matrix +m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0))) +tm <- t(m) +tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0))) +m <- t(tm) +lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]]) +lmCoef +a <- setDT(t(lmCoef)) +a +a <- setDT(lmCoef) +a +lmCoef +l <- dim(data)[2] +m <- diag(l)# m is the coeficients matrix +m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0))) +tm <- t(m) +tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0))) +m <- t(tm) +lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]]) +a <- setDT(lmCoef) +a +lmCoef +l <- dim(data)[2] +m <- diag(l)# m is the coeficients matrix +m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0))) +tm <- t(m) +tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0))) +m <- t(tm) +lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]]) +lmCoef +t(setDT(lmCoef)) +l <- dim(data)[2] +m <- diag(l)# m is the coeficients matrix +m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0))) +tm <- t(m) +tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0))) +m <- t(tm) +lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]]) +lmCoef +lmCoef[[1]] +lmCoef[[1]] <- rbind(lmCoef[[1]], lmCoef[[2]]) +lmCoef +rbindlist(lmCoef) +do.call('rbind', lmCoef) +lmCoef[[2]] <- rbind(lmCoef[[3]], lmCoef[[4]]) +lmCoef +a <- lmCoef[1:2] +a +rbindlist(a) +rbindlist(list = list(a[[1]], b[[2]])) +rbindlist(list(a[[1]], b[[2]])) +?rbindlist +a <- list(a[[1]], b[[2]]) +a +b <- list(a[[1]], a[[2]]) +b +a[[2]] +a +devtools::check() diff --git a/.Rproj.user/D1D10CF6/pcs/find-in-files.pper b/.Rproj.user/D1D10CF6/pcs/find-in-files.pper index 1780c45..5771dfb 100644 --- a/.Rproj.user/D1D10CF6/pcs/find-in-files.pper +++ b/.Rproj.user/D1D10CF6/pcs/find-in-files.pper @@ -1,10 +1,10 @@ { "dialog-state" : { - "caseSensitive" : true, + "caseSensitive" : false, "filePatterns" : [ ], "path" : "~/GitHub/hyfo", - "query" : "newFrc", + "query" : "lmcoef", "regex" : false } } \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/source-pane.pper b/.Rproj.user/D1D10CF6/pcs/source-pane.pper index 70829f6..d3d70fa 100644 --- a/.Rproj.user/D1D10CF6/pcs/source-pane.pper +++ b/.Rproj.user/D1D10CF6/pcs/source-pane.pper @@ -1,3 +1,3 @@ { - "activeTab" : 1 + "activeTab" : 6 } \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper b/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper index 0e24b84..92c5223 100644 --- a/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper +++ b/.Rproj.user/D1D10CF6/pcs/workbench-pane.pper @@ -1,6 +1,6 @@ { "TabSet1" : 0, - "TabSet2" : 0, + "TabSet2" : 3, "TabZoom" : { } } \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 b/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 index 3b93faf..8a1514f 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 +++ b/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "hyfo 1.3.8\n==========\nDate: 2017-1-8\n\n- add changes to the new version of roxygen2\n- change biasCorrection's description, change default prThreshold to 0, since not every one is an expert and know how to set it, better keep the original unchanged.\n\n\n\nhyfo 1.3.7\n==========\nDate: 2016-3-1\n\n- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted.\n\n\n\nhyfo 1.3.6\n==========\nDate: 2015-12-15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n====\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015-12-6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015-11-27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015-11-7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015-11-3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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.", + "contents" : "hyfo 1.3.9\n==========\nDate: 2017-2-20\n\n- apply data.table package to facilitate data processing\n\n\n\nhyfo 1.3.8\n==========\nDate: 2017-1-8\n\n- add changes to the new version of roxygen2\n- change biasCorrection's description, change default prThreshold to 0, since not every one is an expert and know how to set it, better keep the original unchanged.\n\n\n\nhyfo 1.3.7\n==========\nDate: 2016-3-1\n\n- add one more argument to plotTS, to cancel the marking of NA values. For some users, NA values are too many to be plotted.\n\n\n\nhyfo 1.3.6\n==========\nDate: 2015-12-15\n\n- transfer from ncdf to ncdf4\n- grepAndMatch created, for capturing dimension names.\n- minor bug fixed about the loadNcdf, when no dimension found, it will give an error indicating.\n- change most of the match function into grepAndMatch, in order to deal with different dimension names.\n- add name attributes to gridfile$xyCoords$x,y, when writeNcdf, the dim names will be taken from that attribute, which can be exactly the same with the original. \n- bug fixed for nc files without members.\n\nNOTE:\n====\n- for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5.\n\n\n\nhyfo 1.3.5\n==========\nDate: 2015-12-6\n\n- travis check passed, change the rgdal version from 0.9-3 back to 0.8-16 due to the lack of packages on travis ubuntu.\n- changed .yml file to fix the problem with No repository set, so cyclic dependency check skipped.\n- on CRAN\n- fully supported for windows, Linux and OS.\n\n\n\nhyfo 1.3.3\n==========\nDate: 2015-11-27\n\n- Delete readData_folder, since it's only windows based, add information to get special version for windows users.\n- travis test added.\n\n\nhyfo 1.3.2\n==========\nDate: 2015-11-7\n\n- bug fixed about getPreciBar, signature('data.frame')\n- vignettes updated about bug and hided the warning information.\n- Add how to debug in the documentation for the generic functions.\n\n\n\nhyfo 1.3.1\n==========\nDate: 2015-11-3\n\n- new generic function biasCorrect, extractPeriod, resample, getAnnual, getPreciBar added. No need to designate input type any more, R will detect automatically.\n- coordinates conversion function extracted.\n- new user manual about real time bias correction and resample 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" : 1483876849677.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "395220279", + "hash" : "676496319", "id" : "390DEBE1", - "lastKnownWriteTime" : 1483973453, - "last_content_update" : 1483973453652, + "lastKnownWriteTime" : 1487522938, + "last_content_update" : 1487522938948, "path" : "~/GitHub/hyfo/NEWS", "project_path" : "NEWS", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 b/.Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 new file mode 100644 index 0000000..47bcc25 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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 <- grepAndMatch(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 <- grepAndMatch(dim, attributes(data)$dimensions)\n dimLength <- dim(data)[dimIndex]\n return(dimLength)\n}\n", + "created" : 1487525892454.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2303557273", + "id" : "47CB7F65", + "lastKnownWriteTime" : 1483875653, + "last_content_update" : 1483875653, + "path" : "~/GitHub/hyfo/R/array_dimension.R", + "project_path" : "R/array_dimension.R", + "properties" : { + }, + "relative_order" : 19, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/6511719A b/.Rproj.user/D1D10CF6/sdb/per/t/6511719A new file mode 100644 index 0000000..7d11b91 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/6511719A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Fill gaps in the rainfall time series.\n#'\n#' @param dataset A dataframe with first column the time, the rest columns are rainfall data of different gauges\n#' @param corPeriod A string showing the period used in the correlation computing, \n#' e.g. daily, monthly, yearly.\n#' @return The filled dataframe\n#' @details\n#' the gap filler follows the rules below:\n#' \n#' 1. The correlation coefficient of every two columns (except time column) is calculated.\n#' the correlation coefficient calculation can be based on 'daily', 'monthly', 'annual',\n#' in each case, the daily data, the monthly mean daily data and annual mean daily data of \n#' each column will be taken in the correlation calculation.\n#' \n#' Then the correlation matrix is got, then based on the matrix, for each column, \n#' the 1st, 2nd, 3rd,... correlated column will be got. So if there is missing value in the\n#' column, it will get data from orderly 1st, 2nd, 3rd column.\n#' \n#' 2. The simple linear regress is calculated between every two columns. When generating the\n#' linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to \n#' y = a*x.\n#' \n#' 3. Gap filling. E.g., on a certain date, there is a missing value in column A, then the\n#' correlation order is column B, column C, column D, which means A should take values from\n#' B firstly, if B is also missing data, then C, then D.\n#' \n#' Assuming finally value from column C is taken. Then according to step 2, A = a*C, then the\n#' final value filled in column A is missing_in_A = a*value_in_C, a is the linear coeffcient.\n#' \n#' @examples\n#' b <- read.table(text = ' Date AAA BBB CCC DDD EEE\n#' 49 1999-12-15 24.8 21.4 25.6 35.0 17.4\n#' 50 1999-12-16 NA 0.6 1.5 6.3 2.5\n#' 51 1999-12-17 NA 16.3 20.3 NA 19.2\n#' 52 1999-12-18 13 1.6 NA 6.3 0.0\n#' 53 1999-12-19 10 36.4 12.5 26.8 24.9\n#' 54 1999-12-20 NA 0.0 0.0 0.2 0.0\n#' 55 1999-12-21 0.2 0.0 0.0 0.0 0.0\n#' 56 1999-12-22 0.0 0.0 0.0 0.0 0.0')\n#' \n#' b1 <- fillGap(b) # if corPeriod is missing, 'daily' is taken as default.\n#' \n#' data(testdl)\n#' a <- extractPeriod(testdl, commonPeriod = TRUE)\n#' a1 <- list2Dataframe(a)\n#' a2 <- fillGap(a1)\n#' a3 <- fillGap(a1, corPeriod = 'monthly')\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references\n#' Gap fiiling method based on correlation and linear regression.\n#' \n#' \\itemize{\n#' \\item Hirsch, Robert M., et al. \"Statistical analysis of hydrologic data.\" Handbook of hydrology. (1992): 17-1.\n#' Salas, Jose D. \"Analysis and modeling of hydrologic time series.\" Handbook of hydrology 19 (1993): 1-72.\n#' \n#' }\n#' \n#' \n#' @export\nfillGap <- function(dataset, corPeriod = 'daily') {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n data <- data.frame(dataset[, 2:dim(dataset)[2]])\n names <- colnames(data)\n \n corN <- fillGap_cor(data, corPeriod = corPeriod, Date = Date)\n cat('\\nCorrelation Coefficient\\n')\n print(corN)\n \n corOrder <- apply(corN, MARGIN = 1, FUN = function(x) order(-x))\n corOrder <- corOrder[2:dim(corOrder)[1], ]\n corOrderName <- t(apply(corOrder, MARGIN = 2, FUN = function(x) names[x]))\n \n cat('\\nCorrelation Order\\n')\n colnames(corOrderName) <- seq(1 : dim(corOrderName)[2])\n print(corOrderName)\n \n lmCoef <- fillGap_lmCoef(data, corOrder)\n cat('\\nLinear Coefficients\\n')\n rownames(lmCoef) <- seq(1 : dim(corOrderName)[2])\n print(t(lmCoef))\n \n output <- lapply(1:dim(data)[2], fillGap_column, data = data,\n corOrder = corOrder, lmCoef = lmCoef)\n output <- data.frame(output)\n colnames(output) <- names\n \n output <- cbind(Date, output)\n \n return(output)\n}\n\n\n#' Get monthly rainfall\n#' \n#' @param TS A rainfall time series.\n#' @param year A list showing the year index of the time series.\n#' @param mon A list showing the mon index of the time series.\n#' @return the monthly rainfall matrix of the rainfall time series.\nmonthlyPreci <- function(TS, year, mon) {\n \n # monthly daily mean is used in order not to affected by missing values.\n monTS <- tapply(TS, INDEX = list(year, mon), FUN = mean, na.rm = TRUE)\n output <- t(monTS)\n dim(output) <- c(dim(monTS)[1] * dim(monTS)[2], 1)\n return(output)\n}\n\n\nfillGap_column <- function(i, data, corOrder, lmCoef) {\n TS <- data[, i] # extract target column\n l <- dim(data)[2] # length\n \n for (j in 1:l) {\n if (!any(is.na(TS))) break\n NAindex <- which(is.na(TS))\n TS[NAindex] <- round(lmCoef[j, i] * data[NAindex, corOrder[j, i]], 3)\n \n if (j == l) stop('Error: One time consists of all NA values')\n }\n \n return(TS)\n}\n\n\n#' @importFrom stats cor na.omit\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#' \n\nfillGap_cor <- function(data, corPeriod = 'daily', Date) {\n \n names <- colnames(data)\n year <- format(Date, '%Y')\n \n if (corPeriod == 'monthly') {\n #based on monthly rainfall\n mon <- format(Date, '%m')\n monthlyPreci <- lapply(data, FUN = monthlyPreci, year = year, mon = mon)\n corData <- do.call('cbind', monthlyPreci)\n } else if (corPeriod == 'yearly') {\n year <- format(Date, '%Y')\n # yearly daily mean is used in order not to affected by missing values.\n annualPreci <- lapply(data, FUN = function(x) tapply(x, INDEX = year, FUN = mean, na.rm = TRUE))\n corData <- do.call('cbind', annualPreci)\n } else if (corPeriod == 'daily') {\n corData <- data\n } else {\n stop('Pleas choose among \"daily\", \"monthly\", \"yearly\".')\n }\n \n corData <- data.frame(na.omit(corData))\n colnames(corData) <- names\n \n corN <- cor(corData)\n \n return(corN)\n \n} \n\n#' @importFrom utils combn\n#' @importFrom stats coef lm\n#' @references \n#' 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#' \nfillGap_lmCoef <- function(data, corOrder) {\n l <- dim(data)[2]\n m <- diag(l)# m is the coeficients matrix\n m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0)))\n tm <- t(m)\n \n tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0)))\n \n m <- t(tm)\n \n lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]])\n lmCoef <- do.call('rbind', lmCoef)\n rownames(lmCoef) <- colnames(data)\n \n return(t(lmCoef))\n}\n\n", + "created" : 1487522438368.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "214900332", + "id" : "6511719A", + "lastKnownWriteTime" : 1487594210, + "last_content_update" : 1487594210897, + "path" : "~/GitHub/hyfo/R/fillGap.R", + "project_path" : "R/fillGap.R", + "properties" : { + }, + "relative_order" : 16, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B b/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B index 0a5af98..3c21894 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B +++ b/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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", + "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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" : 1483876772702.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "4265558900", + "hash" : "3525032847", "id" : "6DDA2A7B", - "lastKnownWriteTime" : 1483876799, - "last_content_update" : 1483876799732, + "lastKnownWriteTime" : 1487522678, + "last_content_update" : 1487522678570, "path" : "~/GitHub/hyfo/R/getPreciBar(generic).R", "project_path" : "R/getPreciBar(generic).R", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 b/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 index f8a5986..326a453 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 +++ b/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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#' @rdname resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @rdname 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}", + "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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#' @rdname resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @rdname 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\n#' @importFrom data.table rbindlist\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 <- rbindlist(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" : 1483876700794.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1807730850", + "hash" : "4266301985", "id" : "9A428717", - "lastKnownWriteTime" : 1483876727, - "last_content_update" : 1483876727135, + "lastKnownWriteTime" : 1487522763, + "last_content_update" : 1487522763599, "path" : "~/GitHub/hyfo/R/resample(generic).R", "project_path" : "R/resample(generic).R", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 b/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 new file mode 100644 index 0000000..1205f2b --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get ensemble forecast from historical data.\n#' \n#' getHisEnsem use historical data as the forecasting input time series.\n#' \n#' @param TS A time series dataframe, with first column Date, and second column value.\n#' @param example A vector containing two strings showing the start and end date, which represent the \n#' forecasting period. Check details for more information.\n#'\n#' the program will extract every possible period in TS you provided to generate the ensemble. Check details for \n#' more information.\n#' @param interval A number representing the interval of each ensemble member. NOTE: \"interval\" takes\n#' 365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval \n#' to be 2 years, set \\code{interval = 730}, which equals 2 * 365 ; if two months, set \\code{interval = 60}; \n#' 2 days, \\code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the \n#' number as days.By defualt interval is set to be 365, a year.\n#' @param buffer A number showing how many days are used as buffer period for models. Check details for more\n#' information.\n#' \n#' @param plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\n#' \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{getEnsem_comb}.\n#' \n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \n#' \n#' \\code{example} E.g., if you have a time series from 2000 to 2010. Assuming you are in 2003,\n#' you want to forecast the period from 2003-2-1 to 2003-4-1. Then for each year in your input\n#' time series, every year from 1st Feb to 1st Apr will be extracted to generate the ensemble\n#' forecasts. In this case your input example should be \\code{example = c('2003-2-1', '2003-4-1')}\n#' \n#' \\code{interval} doesn't care about leap year and the months with 31 days, it will take 365 as a year, and 30 as a month.\n#' e.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28\n#' days.\n#' \n#' \\code{example} and \\code{interval} controls how the ensemble will be generated. e.g. if the time series is from \n#' 1990-1-1 to 2001-1-1.\n#' \n#' if \\code{example = c('1992-3-1', '1994-1-1')} and \\code{interval = 1095}, note, 1095 = 365 * 3, so the program treat\n#' this as 3 years.\n#' \n#' Then you are supposed to get the ensemble consisting of following part:\n#' \n#' 1. 1992-3-1 to 1994-1-1 first one is the example, and it's NOT start from 1990-3-1.\n#' 2. 1995-3-1 to 1997-1-1 second one starts from 1993, because \"interval\" is 3 years.\n#' 3. 1998-3-1 to 2000-1-1\n#' \n#' because the last one \"2000-3-1 to 2002-1-1\", 2002 exceeds the original TS range, so it will not be included.\n#' \n#' Sometimes, there are leap years and months with 31 days included in some ensemble part, in which case the length of the data will\n#' be different, e.g., 1999-1-1 to 1999-3-1 is 1 day less than 2000-1-1 to 2000-3-1. In this situation,\n#' the data will use example as a standard. If the example is 1999-1-1 to 1999-3-1, then the latter one\n#' will be changed to 2001-1-1 to 2000-2-29, which keeps the start Date and change the end Date.\n#' \n#' If the end date is so important that cannot be changed, try to solve this problem by resetting\n#' the example period, to make the event included in the example.\n#' \n#' Good set of example and interval can generate good ensemble.\n#' \n#' \\code{buffer}\n#' Sometimes the model needs to run for a few days to warm up, before the forecast. E.g., if a forecast starts at\n#' '1990-1-20', for some model like MIKE NAM model, the run needs to be started about 14 days. So the input timeseries\n#' should start from '1990-1-6'.\n#' \n#' Buffer is mainly used for the model hotstart. Sometimes the hot start file cannot contain all the parameters needed,\n#' only some important parameters. In this case, the model needs to run for some time, to make other parameters ready\n#' for the simulation.\n#' \n#' \n#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, name has to be assigned if \\code{output = 'ggplot'} is selected,\n#' @return A ensemble time series using historical data as forecast.\n#' \n#' @examples\n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'))\n#' \n#' # Default interval is one year, can be set to other values, check help for information.\n#' \n#' # Take 7 months as interval\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') \n#' # Take 30 days as buffer\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @importFrom reshape2 melt \n#' @importFrom grDevices rainbow\n#' @import ggplot2\n#' @references \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#' }\n#' \n#' \n#' @export\n\ngetHisEnsem <- function (TS, example, interval = 365, buffer = 0, plot = 'norm', output = 'data', \n name = NULL, mv = 0, ...) {\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 } else if (!grepl('-|/', example[1]) | !grepl('-|/', example[1])) {\n stop('Wrong date format in the example, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } else {\n \n \n \n TS[, 1] <- as.Date(TS[, 1])\n example <- as.Date(example ,tz = '')\n exL <- example[2] - example[1]\n # Test if example is in the range of the TS\n a <- which(TS[, 1] == example[1] | TS[, 1] == example[2])\n if (length(a) < 2) stop('Example is out of the time series, reset example.')\n \n \n \n if (interval %% 365 == 0) {\n d <- interval / 365\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'years')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'years'))\n\n n <- length(startDate) + length(endDate) - 1 # example is counted twice, should be subtracted. \n \n # Generate full start date series.\n startDate <- seq(min(startDate), length = n, by = paste(d, 'years'))\n endDate <- startDate + exL\n \n } else if (interval %% 30) {\n d <- interval / 30\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'months')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'months'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'months'))\n endDate <- startDate + exL\n \n } else {\n d <- interval\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'days')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'days'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'days'))\n endDate <- startDate + exL\n }\n \n data <- mapply(FUN = function(x, y) extractPeriod_dataframe(dataframe = TS, startDate = x, endDate = y),\n x = startDate, y = endDate)\n \n data <- lapply(1:n, function(x) data.frame(data[, x]))\n \n if (buffer > 0) {\n bufferStart <- example[1] - buffer\n bufferEnd <- example[1] - 1\n bufferTS <- extractPeriod_dataframe(TS, bufferStart, bufferEnd)\n \n data <- lapply(data, function(x) rbind(bufferTS, x))\n \n } else if (buffer < 0) {\n stop ('Buffer should be positive, or reset example.')\n }\n \n \n data_output <- list2Dataframe(data)\n colnames(data_output) <- c('Date', as.character(startDate))\n \n # Rearrange dataframe to make example the first column.\n ind <- match(c('Date', as.character(example[1])), colnames(data_output))\n # when use cbind, to ensure the output is also a dataframe, one inside cbind should be dataframe\n # Even output is alread a dataframe, but when ind is a single number, then output[ind] will\n # not be a dataframe, but an array.\n data_output <- cbind(data.frame(data_output[ind]), data_output[-ind])\n ex_date <- seq(from = example[1] - buffer, to = example[2], by = 1)\n data_output$Date <- ex_date\n colnames(data_output)[2] <- 'Observation'\n \n meanV <- apply(data_output[, 2:ncol(data_output)], MARGIN = 1, FUN = mean, na.rm = TRUE)\n \n data_output <- cbind(data.frame(Date = data_output[, 1]), Mean = meanV, \n data_output[, 2:ncol(data_output)])\n \n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n \n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n } else {\n stop('plot can only be \"norm\" or \"cum\", do not assign other words')\n }\n \n #generate different colors \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable, group = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_point(data = data_ggplot[NAIndex, ], size = 3, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(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 })\n print(mainLayer)\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, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n\n return(data_ggplot)\n } else {\n return(data_output)\n }\n }\n}\n\n\n\n\n\n\n#' Extract time series from forecasting data.\n#' \n#' getFrcEnsem extract timeseries from forecasting data, if forecasting data has a member session\n#' an ensemble time sereis will be returned, if forecasting data doesn't have a member session, a singe time\n#' series will be returned.\n#' \n#' @param dataset A list containing different information, should be the result of \\code{\\link{loadNcdf}}\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 plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\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{getEnsem_comb}.\n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param coord A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned,\n#' cell argument will no longer be used.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \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#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, If name is not assigned and \\code{output = 'ggplot'} is selected, then\n#' the system time will be selected as name column.\n#' \n#' @examples \n#' \n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' nc <- loadNcdf(filePath, varname)\n#' a <- getFrcEnsem(nc)\n#' \n#' # If there is no member session in the dataset, a single time sereis will be extracted.\n#' a1 <- getFrcEnsem(tgridData)\n#' \n#' \n#' # The default output is spatially averaged, if there are more than one cells in the dataset, \n#' # the mean value of the cells will be calculated. While if you are interested in special cell, \n#' # you can assign the cell value. You can also directly use longitude and latitude to extract \n#' # time series.\n#' \n#' getSpatialMap(nc, 'mean')\n#' a <- getFrcEnsem(nc, cell = c(6,2))\n#' \n#' # From the map, cell = c(6, 2) means lon = -1.4, lat = 43.2, so you can use corrd to locate\n#' # your research area and extract time series.\n#' b <- getFrcEnsem(nc, coord = c(-1.4, 43.2))\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @return A ensemble time series extracted from forecating data.\n#' \n#' @import ggplot2\n#' @importFrom reshape2 melt\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' @export\ngetFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', name = NULL,\n mv = 0, coord = NULL, ...) {\n # cell should be a vector showing the location, or mean representing the loacation averaged.\n \n checkHyfo(dataset)\n \n Date <- as.Date(dataset$Dates$start)\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 if (!is.null(coord)) {\n cell <- coord2cell(coord, dataset$xyCoords$x, dataset$xyCoords$y)\n } \n \n \n if (!any(attributes(data)$dimensions == 'member')){\n message('There is no member part in the dataset, there will be only one column of value\n returned.')\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], ]\n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n \n } else {\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], , ]\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem) \n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = c(3, 4), FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n }\n\n \n data_output <- data.frame(Date, data_ensem)\n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n \n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n \n }\n \n colors = c('brown1', rainbow(n = length(unique(data_ggplot$variable)) - 1,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6, color = 'red') +\n geom_point(data = data_ggplot[NAIndex, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n print(mainLayer)\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_ggplot$name <- rep(name, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n return(data_ggplot)\n } else {\n return(data_output)\n }\n}\n\n\n\n#' Combine ensembles together\n#' @param ... different ensembles generated by \\code{getHisEnsem(, output = 'ggplot')} \n#' or \\code{getFrcEnsem(, 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 legend A boolean representing whether you want the legend. Sometimes when you combine\n#' plots, there will be a lot of legends, if you don't like it, you can turn it off by setting\n#' \\code{legend = FALSE}, default is TRUE.\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 ensemble plot.\n#' @examples \n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' \n#' \n#' b1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot',\n#' name = 1)\n#' \n#' b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot',\n#' name = 2)\n#' \n#' getEnsem_comb(b1, b2)\n#' getEnsem_comb(list = list(b1, b2), nrow = 2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @export\n#' @import ggplot2\n#' @importFrom data.table rbindlist\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' \n\ngetEnsem_comb <- function(..., list = NULL, nrow = 1, legend = TRUE, x = '', y = '', title = '', \n output = FALSE) {\n \n if (!is.null(list)) {\n checkBind(list, 'rbind')\n data_ggplot <- rbindlist(list)\n } else {\n plots <- list(...)\n checkBind(plots, 'rbind')\n data_ggplot <- rbindlist(plots)\n } \n #data_ggplot$name <- factor(data_ggplot$name, levels = data_ggplot$name, ordered = TRUE)\n \n if (!class(data_ggplot)[1] == 'data.table') {\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 getFreEnsem() or getHisEnsem(), if \n output = \"ggplot\" is assigned, more info please check ?getFreEnsem() or ?getHisEnsem().')\n }\n \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_point(data = data_ggplot[data_ggplot$nav == 1, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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 facet_wrap( ~ name, nrow = nrow) +\n labs(x = x, y = y, title = title)\n \n })\n if (legend == FALSE) {\n mainLayer <- mainLayer + \n theme(legend.position = 'none')\n# following ones are to add label, may be added in future.\n# geom_text(data = data_ggplot[data_ggplot$Date == '2003-12-10', ], aes(label = variable), hjust = 0.7, vjust = 1)\n# geom_text(data = data_ggplot[data_ggplot$variable == 'Mean', ], aes(label = variable), hjust = 0.7, vjust = 1)\n }\n \n \n print(mainLayer)\n \n if (output == TRUE) return(data_ggplot)\n \n}", + "created" : 1487522564089.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2954610742", + "id" : "A2A68A80", + "lastKnownWriteTime" : 1487522622, + "last_content_update" : 1487522622058, + "path" : "~/GitHub/hyfo/R/getEnsemble.R", + "project_path" : "R/getEnsemble.R", + "properties" : { + }, + "relative_order" : 17, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC b/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC new file mode 100644 index 0000000..acfce39 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Collect data from different csv files.\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param fileType A string showing the file type, e.g. \"txt\", \"csv\", \"excel\".\n#' @param range A vector containing startRow, endRow, startColumn, endColumn, e.g., \n#' c(2,15,2,3)\n#' @param sheetIndex A number showing the sheetIndex in the excel file, if fileType is excel,\n#' sheetIndex has to be provided, default is 1.\n#' @return The collected data from different files in the folder.\n#' @examples \n#' \n#' #use internal data as an example.\n#' folder <- file.path(path.package(\"hyfo\"), 'extdata')\n#' # file may vary with different environment, it if doesn't work, use local way to get\n#' # folder path.\n#' \n#' a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom data.table rbindlist\ncollectData <- function(folderName, fileType = NULL, range = NULL, sheetIndex = 1){\n \n message('All the files in the folder should have the same format')\n \n if (is.null(fileType)) stop('Please enter fileType, \"txt\", \"csv\" or \"excel\".')\n \n if (length(range) > 4) {\n stop('\"range\" should be c(startRow, endRow, startCol, endCol)')\n }else if (is.null(range)) {\n stop('\"range\" can not be blank, e.g., range <- c(startRow, endRow, startCol, endCol).')\n }\n \n if (fileType == 'csv') {\n fileNames <- list.files(folderName, pattern = '*.csv', full.names = TRUE)\n if (length(fileNames) == 0) stop('No csv file in the folder.')\n \n data <- lapply(fileNames, readCsv, range = range)\n data <- rbindlist(data)\n \n } else if (fileType == 'txt') {\n fileNames <- list.files(folderName, pattern = '*.txt', full.names = TRUE)\n if (length(fileNames) == 0) {\n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n }\n if (length(fileNames) == 0) stop('No text file in the folder.')\n message('For txt file, only startRow and endRow will be considered.')\n data <- lapply(fileNames, readTxt, range = range)\n data <- unlist(data)\n \n# In order not to introduce too much trouble to user, this part has been hiden\n# Because it needs java environment installed.\n#\n } else if (fileType == 'excel') {\n \n message('This part needs java installed in your computer, so it is commentted in\n the original file, check the original R file or https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData.R\n for ideas.')\n# fileNames <- list.files(folderName, pattern = '*.xlsx', full.names = TRUE)\n# if (length(fileNames) == 0){\n# fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n# }\n# \n# if (length(fileNames) == 0) stop('No excel in the folder.')\n# data <- lapply(fileNames, readExcel, range = range, sheetIndex = sheetIndex)\n# checkBind(data, 'rbind')\n# data <- do.call('rbind', data)\n }else{\n stop('fileType should be \"txt\", \"csv\" or \"excel\".')\n }\n \n \n return(data)\n \n}\n\n# #importFrom xlsx read.xls\n# readExcel <- function(fileName, range, sheetIndex){\n# data <- read.xls(fileName, sheetIndex = sheetIndex, rowIndex = seq(range[1], range[2]),\n# colIndex = seq(range[3], range[4])) \n# colnames(data) <- seq(1, dim(data)[2])\n# \n# message(fileName) \n# return(data)\n# }\n\nreadTxt <- function(fileName, range){\n data <- readLines(fileName)\n data <- data[range[1]:range[2]]\n return(data)\n}\n\n\n\n#' @importFrom utils read.csv\n#' @references \n#' 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/.\nreadCsv <- function(fileName, range){\n \n data <- read.csv(fileName, skip = range[1] - 1, header = FALSE)\n data <- data[1:(range[2] - range[1] + 1), range[3]:range[4]]\n \n return(data)\n}\n\n\n\n\n\n", + "created" : 1487522346501.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1659278673", + "id" : "A879E0CC", + "lastKnownWriteTime" : 1487522383, + "last_content_update" : 1487522383743, + "path" : "~/GitHub/hyfo/R/collectData.R", + "project_path" : "R/collectData.R", + "properties" : { + }, + "relative_order" : 14, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C b/.Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C new file mode 100644 index 0000000..30500e9 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "# Generated by roxygen2: 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(plotTS)\nexport(plotTS_comb)\nexport(resample)\nexport(shp2cat)\nexport(writeNcdf)\nexportClasses(biasFactor)\nimport(ggplot2)\nimport(maps)\nimport(maptools)\nimport(ncdf4)\nimport(plyr)\nimport(rgdal)\nimport(rgeos)\nimportFrom(MASS,fitdistr)\nimportFrom(data.table,rbindlist)\nimportFrom(grDevices,rainbow)\nimportFrom(lmom,samlmu)\nimportFrom(methods,new)\nimportFrom(methods,setClass)\nimportFrom(methods,setGeneric)\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,combn)\nimportFrom(utils,packageDescription)\nimportFrom(utils,read.csv)\nimportFrom(utils,read.fwf)\nimportFrom(utils,tail)\nimportFrom(zoo,as.Date)\n", + "created" : 1487521274814.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3446792241", + "id" : "B4F74B5C", + "lastKnownWriteTime" : 1487594221, + "last_content_update" : 1487594221, + "path" : "~/GitHub/hyfo/NAMESPACE", + "project_path" : "NAMESPACE", + "properties" : { + }, + "relative_order" : 12, + "source_on_save" : false, + "source_window" : "", + "type" : "r_namespace" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A b/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A index a9dc2c6..ac40d83 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A +++ b/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "#' Get annual rainfall of different rainfall time series\n#' \n#' Get annual rainfall of different raninfall time series.\n#' \n#' \n#' @param data A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\n#' gauging stations. Usually an output of \\code{list2Dataframe}.\n#' @param output A string showing the output output.\n#' @param minRecords A number showing the minimum accept record number, e.g. for a normal \n#' year(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\n#' of a year, it will be ignored in the mean annual value calculation. Only valid \n#' when \\code{output = \"mean\"}, default is 355.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @return The annual rainfall and the number of missing data of each year and each rainfall gauge, which \n#' will also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n#' @details \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #datalist is provided by the package as a test.\n#' data(testdl)\n#' a <- getAnnual(testdl)\n#' #set minRecords to control the calculation of annual rainfall.\n#' b <- getAnnual(testdl, output = 'mean', minRecords = 350)\n#' c <- getAnnual(testdl, output = 'mean', minRecords = 365)\n#' \n#' a1 <- extractPeriod(testdl, comm = TRUE)\n#' a2 <- list2Dataframe(a1)\n#' getAnnual(a2)\n#' \n#' a3 <- fillGap(a2)\n#' getAnnual(a3)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom methods setGeneric\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 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#' \nsetGeneric('getAnnual', function(data, output = 'series', minRecords = 355, \n ...) {\n standardGeneric('getAnnual')\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('data.frame'), \n function(data, output, minRecords, ...) {\n result <- getAnnual.TS(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('list'),\n function(data, output, minRecords, ...) {\n result <- getAnnual.list(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n })\n\ngetAnnual.TS <- function(dataframe) {\n Date <- as.POSIXlt(dataframe[, 1])\n # Calculate how many gauging stations.\n stations <- colnames(dataframe)[2:ncol(dataframe)]\n \n data <- lapply(stations, function(x) {\n dataframe_new <- data.frame(Date, dataframe[, x])\n colnames(dataframe_new)[2] <- x\n getAnnual_dataframe(dataframe_new)\n })\n \n data <- do.call('rbind', data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n \n return(data)\n}\n\n\ngetAnnual.list <- function(datalist) {\n data <- lapply(datalist, FUN = getAnnual_dataframe)\n data <- do.call('rbind', data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n return(data)\n}\n\n#' @import ggplot2 \n#' @importFrom reshape2 melt\n#' @importFrom stats aggregate\ngetAnnual.plot <- function(data, output, minRecords, ...) {\n theme_set(theme_bw())\n \n if (output == 'mean') {\n validData <- data[data$recordNum >= minRecords,]\n \n data <- aggregate(validData$AnnualPreci, list(validData$Name), mean)\n colnames(data) <- c('Name', 'AnnualPreci')\n \n mainLayer <- with(data, {\n ggplot(data)+\n geom_bar(aes(x = Name, y = AnnualPreci, fill = Name), stat = 'identity')+\n labs(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n \n print(mainLayer)\n \n } else {\n \n plotData <- with(data, {\n subset(data, select = c(Year, Name, NANum, AnnualPreci))\n })\n \n plotData <- melt(plotData, var.id = c('Year', 'Name'))\n \n \n mainLayer <- with(plotData, {\n ggplot(plotData) +\n geom_bar(aes(x = Year, y = value , fill = Name), \n stat = 'identity') +\n facet_grid(variable ~ Name, scale = 'free') +\n xlab('Year') +\n ylab(NULL) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = 20, face = 'bold', vjust = 1)) +\n theme(axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.5)),\n axis.text.y = element_text(size = rel(1.5)))\n # grid.arrange(mainLayer, ncol = 4)\n \n })\n \n \n print(mainLayer)\n } \n}\n\n\n\n\n\n\n\n\n#' Get annual rainfall of the input time series.\n#' \n#' @param dataset A dataframe containing one time series, e.g., rainfall from one gauging station.\n#' the time should follow the format : \"1990-1-1\"\n#' @return The annual rainfall of each year of the input station.\n# @examples\n# data(testdl)\n# getAnnual_dataframe(testdl[[1]])\n#' \ngetAnnual_dataframe <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n year <- format(Date, '%Y')\n yearUnique <- unique(year)\n # yearUnique <- factor(yearUnique, levels = yearUnique, ordered = TRUE)\n calcuNum <- c(1:length(yearUnique))\n \n \n annualPreci <- tapply(dataset[, 2], INDEX = year, FUN = sum, na.rm = TRUE)\n recordNum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(!is.na(x))))\n NANum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(is.na(x))))\n \n \n name <- rep(colnames(dataset)[2], length(calcuNum))\n output <- data.frame(Year = as.numeric(yearUnique), Name = name, AnnualPreci = annualPreci,\n recordNum, NANum)\n \n #output$Year <- factor(output$Year, levels = output$Year, ordered = TRUE)\n return(output)\n}\n\n", + "contents" : "#' Get annual rainfall of different rainfall time series\n#' \n#' Get annual rainfall of different raninfall time series.\n#' \n#' \n#' @param data A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\n#' gauging stations. Usually an output of \\code{list2Dataframe}.\n#' @param output A string showing the output output.\n#' @param minRecords A number showing the minimum accept record number, e.g. for a normal \n#' year(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\n#' of a year, it will be ignored in the mean annual value calculation. Only valid \n#' when \\code{output = \"mean\"}, default is 355.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @return The annual rainfall and the number of missing data of each year and each rainfall gauge, which \n#' will also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n#' @details \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #datalist is provided by the package as a test.\n#' data(testdl)\n#' a <- getAnnual(testdl)\n#' #set minRecords to control the calculation of annual rainfall.\n#' b <- getAnnual(testdl, output = 'mean', minRecords = 350)\n#' c <- getAnnual(testdl, output = 'mean', minRecords = 365)\n#' \n#' a1 <- extractPeriod(testdl, comm = TRUE)\n#' a2 <- list2Dataframe(a1)\n#' getAnnual(a2)\n#' \n#' a3 <- fillGap(a2)\n#' getAnnual(a3)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom methods setGeneric\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 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#' \nsetGeneric('getAnnual', function(data, output = 'series', minRecords = 355, \n ...) {\n standardGeneric('getAnnual')\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('data.frame'), \n function(data, output, minRecords, ...) {\n result <- getAnnual.TS(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('list'),\n function(data, output, minRecords, ...) {\n result <- getAnnual.list(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n })\n\n#' @importFrom data.table rbindlist\ngetAnnual.TS <- function(dataframe) {\n Date <- as.POSIXlt(dataframe[, 1])\n # Calculate how many gauging stations.\n stations <- colnames(dataframe)[2:ncol(dataframe)]\n \n data <- lapply(stations, function(x) {\n dataframe_new <- data.frame(Date, dataframe[, x])\n colnames(dataframe_new)[2] <- x\n getAnnual_dataframe(dataframe_new)\n })\n \n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n \n return(data)\n}\n\n\n#' @importFrom data.table rbindlist\ngetAnnual.list <- function(datalist) {\n data <- lapply(datalist, FUN = getAnnual_dataframe)\n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n return(data)\n}\n\n#' @import ggplot2 \n#' @importFrom reshape2 melt\n#' @importFrom stats aggregate\ngetAnnual.plot <- function(data, output, minRecords, ...) {\n theme_set(theme_bw())\n \n if (output == 'mean') {\n validData <- data[data$recordNum >= minRecords,]\n \n data <- aggregate(validData$AnnualPreci, list(validData$Name), mean)\n colnames(data) <- c('Name', 'AnnualPreci')\n \n mainLayer <- with(data, {\n ggplot(data)+\n geom_bar(aes(x = Name, y = AnnualPreci, fill = Name), stat = 'identity')+\n labs(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n \n print(mainLayer)\n \n } else {\n \n plotData <- with(data, {\n subset(data, select = c(Year, Name, NANum, AnnualPreci))\n })\n \n plotData <- melt(plotData, var.id = c('Year', 'Name'))\n \n \n mainLayer <- with(plotData, {\n ggplot(plotData) +\n geom_bar(aes(x = Year, y = value , fill = Name), \n stat = 'identity') +\n facet_grid(variable ~ Name, scale = 'free') +\n xlab('Year') +\n ylab(NULL) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = 20, face = 'bold', vjust = 1)) +\n theme(axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.5)),\n axis.text.y = element_text(size = rel(1.5)))\n # grid.arrange(mainLayer, ncol = 4)\n \n })\n \n \n print(mainLayer)\n } \n}\n\n\n\n\n\n\n\n\n#' Get annual rainfall of the input time series.\n#' \n#' @param dataset A dataframe containing one time series, e.g., rainfall from one gauging station.\n#' the time should follow the format : \"1990-1-1\"\n#' @return The annual rainfall of each year of the input station.\n# @examples\n# data(testdl)\n# getAnnual_dataframe(testdl[[1]])\n#' \ngetAnnual_dataframe <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n year <- format(Date, '%Y')\n yearUnique <- unique(year)\n # yearUnique <- factor(yearUnique, levels = yearUnique, ordered = TRUE)\n calcuNum <- c(1:length(yearUnique))\n \n \n annualPreci <- tapply(dataset[, 2], INDEX = year, FUN = sum, na.rm = TRUE)\n recordNum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(!is.na(x))))\n NANum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(is.na(x))))\n \n \n name <- rep(colnames(dataset)[2], length(calcuNum))\n output <- data.frame(Year = as.numeric(yearUnique), Name = name, AnnualPreci = annualPreci,\n recordNum, NANum)\n \n #output$Year <- factor(output$Year, levels = output$Year, ordered = TRUE)\n return(output)\n}\n\n", "created" : 1483876618596.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "375535863", + "hash" : "55111109", "id" : "BFF6AE7A", - "lastKnownWriteTime" : 1483876696, - "last_content_update" : 1483876696288, + "lastKnownWriteTime" : 1487522555, + "last_content_update" : 1487522555874, "path" : "~/GitHub/hyfo/R/getAnnual(generic).R", "project_path" : "R/getAnnual(generic).R", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A b/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A index 277cad5..42b809b 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A +++ b/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A @@ -7,8 +7,8 @@ "folds" : "", "hash" : "3096661772", "id" : "CA11BD0A", - "lastKnownWriteTime" : 1484118700, - "last_content_update" : 1484118700, + "lastKnownWriteTime" : 1487594221, + "last_content_update" : 1487594221, "path" : "~/GitHub/hyfo/man/tgridData.Rd", "project_path" : "man/tgridData.Rd", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 b/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 new file mode 100644 index 0000000..eeb91d5 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Extract period from list or dataframe.\n#' \n#' Extract common period or certain period from a list of different dataframes of time series, or from a \n#' dataframe. \n#' NOTE: all the dates in the datalist should follow the format in ?as.Date{base}.\n#' @param data A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.\n#' @param startDate A Date showing the start of the extract period, default as NULL, check details.\n#' @param endDate A Date showing the end of the extract period, default as NULL, check details.\n#' @param commonPeriod A boolean showing whether the common period is extracted. If chosen, startDate and endDate\n#' should be NULL.\n#' @param year extract certain year in the entire time series. if you want to extract year 2000, set \\code{year = 2000}\n#' @param month extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, \n#' set \\code{month = c(1, 2)}.\n#' @details \n#' \\strong{startDate and endDate}\n#' \n#' If startDate and endDate are assigned, then certain period between startDate and endDate will be returned, \n#' for both datalist input and dataframe input.\n#' \n#' If startDate and endDate are NOT assigned, then,\n#' \n#' if input is a datalist, the startDate and endDate of the common period of different datalists will be assigned\n#' to the startDate and endDate.\n#' \n#' if input is a dataframe, the startDate and endDate of the input dataframe will be assigned to the startDate\n#' and endDate . Since different value columns share a common Date column in a dataframe input. \n#' \n#' \\strong{year and month}\n#' \n#' For year crossing month input, hyfo will take from the year before. E.g. if \\code{month = c(10, 11, 12, 1)},\n#' and \\code{year = 1999}, hyfo will take month 10, 11 and 12 from year 1998, and month 1 from 1999.You DO NOT \n#' have to set \\code{year = 1998 : 1999}.\n#' \n#' Well, if you set \\code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998,\n#' then, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year.\n#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @return A list or a dataframe with all the time series inside containing the same period.\n#' @examples\n#' # Generate timeseries datalist. Each data frame consists of a Date and a value.\n#' \n#' AAA <- data.frame(\n#' # date column\n#' Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1),\n#' # value column\n#' AAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE))\n#' \n#' BBB <- data.frame(\n#' Date = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), \n#' BBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE))\n#' \n#' CCC <- data.frame(\n#' Date = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), \n#' CCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) \n#' \n#' list <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file.\n#' \n#' list_com <- extractPeriod(list, commonPeriod = TRUE)\n#' \n#' # list_com is the extracted datalist.\n#' str(list_com)\n#' \n#' # If startDate and endDate is provided, the record between them will be extracted.\n#' # make sure startDate is later than any startDate in each dataframe and endDate is \n#' # earlier than any endDate in each dataframe.\n#' \n#' data(testdl)\n#' datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' \n#' dataframe <- list2Dataframe(datalist_com1)\n#' # now we have a dataframe to extract certain months and years.\n#' dataframe_new <- extractPeriod(dataframe, month = c(1,2,3))\n#' dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @importFrom zoo as.Date\n#' @references \n#' \n#' \\itemize{\n#' \\item Achim Zeileis and Gabor Grothendieck (2005). zoo: S3 Infrastructure for Regular and Irregular Time\n#' Series. Journal of Statistical Software, 14(6), 1-27. URL http://www.jstatsoft.org/v14/i06/\n#' }\n#'\n#' @export\nsetGeneric('extractPeriod', function(data, startDate = NULL, endDate = NULL, commonPeriod = FALSE, \n year = NULL, month = NULL) {\n standardGeneric('extractPeriod')\n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('data.frame'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n dataframe <- data\n dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n return(dataset)\n \n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('list'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n datalist <- data\n if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) {\n dataset <- lapply(data, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) {\n \n Dates <- lapply(datalist, extractPeriod_getDate)\n # Here don't know why rbindlist cannot work, change back to do.call\n Dates <- do.call('rbind', Dates)\n \n startDate <- as.Date(max(Dates[, 1]))\n endDate <- as.Date(min(Dates[, 2]))\n \n dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n \n } else {\n stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE')\n }\n return(dataset)\n })\n\n\n\n\nextractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, month = NULL) {\n # to check whether first column is a date format\n if (!grepl('-|/', dataframe[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 dataframe[, 1] <- as.Date(dataframe[, 1])\n \n if (is.null(startDate)) startDate <- dataframe[1, 1]\n if (is.null(endDate)) endDate <- tail(dataframe[, 1], 1)\n \n startIndex <- which(dataframe[, 1] == startDate)\n endIndex <- which(dataframe[, 1] == endDate)\n if (length(startIndex) == 0 | length(endIndex) == 0) {\n stop('startDate and endDate exceeds the date limits in dataframe. Check datalsit please.')\n }\n output <- dataframe[startIndex:endIndex, ]\n \n \n if (!is.null(year)) {\n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n if (is.null(month) || !any(sort(month) != month)) {\n DateIndex <- which(yea %in% year)\n if (length(DateIndex) == 0) stop('No input years in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n \n # if year crossing than sort(month) != month, in this case we need to\n # take months from last year.\n } else {\n \n \n startIndex <- intersect(which(yea == year[1] - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == tail(year, 1)), which(mon == tail(month, 1))), 1)\n \n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n }\n output <- output[startIndex:endIndex, ]\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again. \n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n output <- output[DateIndex, ]\n \n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n \n }\n \n \n if (!is.null(month)) {\n Date <- as.POSIXlt(output[, 1])\n mon <- Date$mon + 1\n \n # %in% can deal with multiple equalities\n DateIndex <- which(mon %in% month)\n \n if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n }\n \n \n return(output) \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#' \n#' \nextractPeriod_getDate <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 start <- as.Date(dataset[1, 1])\n end <- as.Date(tail(dataset[, 1], 1))\n \n \n return(c(start, end))\n }\n\n\n\n", + "created" : 1487522389624.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2600120742", + "id" : "D3DE8C31", + "lastKnownWriteTime" : 1487523614, + "last_content_update" : 1487523614272, + "path" : "~/GitHub/hyfo/R/extractPeriod(generic).R", + "project_path" : "R/extractPeriod(generic).R", + "properties" : { + }, + "relative_order" : 15, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 b/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 new file mode 100644 index 0000000..efc1a17 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Collect data from csv for Anarbe case.\n#' \n#' Collect data from the gauging stations in spain, catchement Anarbe\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param output A boolean showing whether the output is given, default is T.\n#' @return The collected data from different csv files.\n#' @examples\n#' \n#' #use internal data as an example.\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_csv_anarbe(folder)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\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#' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_csv_anarbe <- function(folderName, output = TRUE){\n \n fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE)\n data <- lapply(fileNames, readColumn_csv_anarbe)\n data <- rbindlist(data)\n data <- data[, 1:2]\n # cus the special structure of data.tables, here should be data[[1]], instead of data[, 1]\n data[, 1] <- as.Date(data[[1]], format = '%d/%m/%Y')\n \n #newFileName <- file.choose(new = T)\n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n if (output) return(data)\n}\n\n\nreadColumn_csv_anarbe <- function(fileName){\n data <- read.csv(fileName, skip = 4)\n endIndex <- which(data == '', arr.ind = TRUE)[1]-1\n \n data <- data[1:endIndex, ]\n \n if (!is.null(levels(data[, 2]))) {\n data[, 2] <- as.numeric(levels((data[, 2])))[data[, 2]]\n }\n \n colnames(data) <- c('Date', 'target')\n message(fileName)\n \n return(data)\n}\n\n\n\n#' Collect data from different excel files\n#' \n#' @param folderName A string showing the folder path.\n#' @param keyword A string showing the extracted column, e.g., waterLevel, waterBalance.\n#' @param output A boolean showing whether the output is given.\n#' @return The collected data from different excel files.\n#' @export\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# @importFrom utils write.table\ncollectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){\n \n message('In order to make \"hyfo\" easier to be installed, this part is commented,\n check original R file in your computer or go to \n https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData_excel.R\n for ideas.')\n \n \n # newFileName <- file.choose(new = TRUE)\n # message ('new file should be located a different location than the excel folder, \n # in order to avoid error.\n # At least 2 excels should be in the folder\\n')\n # \n # message ('this function only applies to strange spain dem operation record file, and this strange file changes\n # its format in the middle of the record. For other applications, some tiny changes needs to be made.')\n # if (is.null(keyword)) stop('key word is needed, e.g.\"waterLevel\".')\n # \n # fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n # data <- lapply(fileNames, FUN = readColumn_excel_anarbe, keyword = keyword)\n # checkBind(data, 'rbind')\n # data <- do.call('rbind', data)\n # \n # data_new <- data.frame(data)\n # \n # data_new <- data_new[order(data_new[, 1]), ]\n # \n # \n # startDate <- data_new[1, 1]\n # endDate <- data_new[length(data_new[, 1]), 1]\n # \n # Date <- as.factor(seq(startDate, endDate, by = 1))\n # \n # if (length(Date) != length(data_new[, 1])) stop('check if the excel files are continuous')\n # \n # colnames(data_new) <- c('Date', keyword)\n # \n # write.table(data_new, file = newFileName,\n # row.names = FALSE, col.names = TRUE, sep = ',')\n # if(output == TRUE) return(data_new)\n}\n\n# \n# @importFrom xlsx read.xlsx\n# readTable_excel_anarbe <- function(fileName){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]], 3)\n# raw_year <- index[1]\n# raw_mon <- index[2]\n# \n# raw <- read.xlsx(fileName, sheetName='A')\n# startRow <- which(raw == 'COTA', arr.ind = TRUE)[1]+4\n# startCol <- which(raw == 'COTA',arr.ind = TRUE)[2]-1\n# stopRow <- which(raw =='TOTAL',arr.ind = TRUE)[1]-1\n# stopCol1 <- startCol + 17\n# stopCol2 <- which(raw == 'SUPERFICIE', arr.ind = TRUE)[2]\n# data <- cbind(raw[startRow:stopRow,startCol:stopCol1], raw[startRow:stopRow,stopCol2])\n# \n# \n# yearIndex <- rep(raw_year, stopRow-startRow+1)\n# monIndex <- rep(raw_mon, stopRow-startRow+1)\n# \n# data <- cbind(yearIndex, monIndex, data)\n# return(data)\n# }\n# # \n# @importFrom utils tail\n# readColumn_excel_anarbe <- function(fileName, keyword = NULL){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]],3)\n# year <- as.numeric(index[1])\n# mon <- as.numeric(index[2])\n# \n# if (year == 99) {\n# year = year + 1900\n# } else year = year + 2000\n# \n# word = c('COTA', 'Cota\\n(m)', 'TOTAL', ' TOTAL')\n# \n# if (keyword == 'waterLevel') {\n# searchWord <- c('COTA', 'Cota\\n(m)')\n# } else if (keyword == 'discharge_ERE') {\n# searchWord <- c('AF.ERE-', 'Caudal\\n(m??/s)')\n# } else if (keyword == 'waterBalance') {\n# searchWord <- c('INCREMENTO', 'al Canal Bajo', 'AFORO',\n# 'Variaci??n\\nvolumen embalsado')\n# } else if (keyword == 'surfaceArea') {\n# searchWord <- c('SUPERFICIE', 'SUPERFICIE')\n# } else if (keyword == 'volume') {\n# searchWord <- c('EMBALSADO', 'Volumen\\n(m????)')\n# }\n# \n# \n# if (year == 1999 | year < 2009 | (year == 2009 & mon < 5)) {\n# raw <- xlsx::read.xlsx(fileName, sheetName = 'A')\n# startIndex <- which(raw == word[1], arr.ind = TRUE)\n# endIndex <- which(raw == word[3], arr.ind = TRUE)\n# startRow <- startIndex[1]+4\n# endRow <- endIndex[1]-1\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# \n# targetCol <- which(raw == searchWord[1], arr.ind = TRUE)[2]\n# \n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[3], arr.ind = TRUE)[2]\n# a <- raw[startRow:endRow, targetStart:targetEnd]\n# a <- sapply(a, function(x) as.numeric(levels(x)[x]))\n# \n# if (year == 1999 & mon == 4) {\n# \n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, rep(NA, dim(a)[1]), a[, 6] * 86.4,\n# a[, 4] * 86.4, a[, 11] * 86.4, a[, 3], a[, 7], rep(NA, dim(a)[1]), a[, 1])\n# } else {\n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, a[, 6] * 86.4, a[, 7] * 86.4, \n# a[, 4] * 86.4, a[, 12] * 86.4, a[, 3], a[, 8], rep(NA, dim(a)[1]), a[, 1])\n# } \n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# if (keyword == 'discharge_ERE') target <- as.numeric(levels(target))[target]/1000\n# }\n# \n# } else {\n# raw <- read.xlsx(fileName,sheetName = 'parte del embalse')\n# startIndex <- which(raw == word[2], arr.ind = TRUE)\n# endIndex <- which(raw == word[4], arr.ind = TRUE)\n# startRow <- startIndex[1]+1\n# endRow <- endIndex[1]-2\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# targetCol <- which(raw == searchWord[2], arr.ind=TRUE)[2]\n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[4], arr.ind=TRUE)[2]\n# target <- raw[startRow:endRow, targetStart:targetEnd]\n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# }\n# \n# }\n# \n# \n# startDate <- as.Date(paste(year, mon, day[1], sep = '-'))\n# endDate <- as.Date(paste(year, mon, tail(day,1), sep = '-'))\n# \n# Date <- seq(startDate, endDate, 1)\n# output <- data.frame(Date, as.vector(target))\n# colnames(output) <- c('Date', seq(1, dim(output)[2] - 1))\n# message(fileName) \n# return(output)\n# \n# }\n# \n\n\n\n\n\n#' collect data from different txt.\n#' \n#' @param folderName A string showing the folder path.\n#' @param output A boolean showing whether the result is given.\n#' @param rangeWord A list containing the keyword and the shift. \n#' defaut is set to be used in spain gauging station.\n#' @examples\n#' \n#' #use internal data as an example.\n#' \n#' \\dontrun{\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_txt_anarbe(folder)\n#' }\n#'\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://www4.gipuzkoa.net/oohh/web/esp/02.asp\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#' @source http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n#' @return The collected data from different txt files.\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene ', -1, \n 'Total ', -6)){\n #All the code should be ASCII encode, so there should be no strange symbol.\n if (is.null(rangeWord)) {\n stop('rangeWord consists of 4 elements:\n 1. start word which program can recognise.\n 2. shift1, the shift needs to be made. E.g. start word is in line 7, and program\n should read file from line 9, then shift is 9-7 = 2.\n 3. end word, as start word\n 4. shift2, same as shift1, sometimes can be negative\n \n E.g. rangeWord=c(\\\"aaa\\\",2,\\\"bbb\\\",-2)\n if no rangeWord, just input c(NULL,NULL,NULL,NULL)')\n \n }\n \n \n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n \n data <- lapply(fileNames, FUN = readColumn_txt_anarbe, rangeWord = rangeWord)\n \n data <- rbindlist(data)\n \n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n #newFileName <- file.choose(new = T)\n message('new file should be located a different location than the excel folder,\n in order to avoid error.\n At least 2 excels should be in the folder')\n \n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n \n \n if (output == TRUE) return(data)\n \n} \n\n\n\nanarbe_txt <- function(dataset, x1, x2){\n \n data <- as.matrix(dataset[x1:x2, 2:13])\n startYear <- data[1, 6]\n \n data <- data[5:35, ]\n \n date <- which(data != ' ', arr.ind = TRUE)\n startDate <- date[1, ]\n \n endDate <- date[length(date[, 1]), ]\n \n startDate <- as.Date(paste(startYear, startDate[2], startDate[1], sep = '-'))\n endDate <- as.Date(paste(startYear, endDate[2], endDate[1], sep = '-'))\n \n Date <- as.factor(seq(startDate, endDate, 1))\n \n dim(data) <- c(length(data), 1)\n \n data <- as.numeric(data[which(data != ' '), ])\n \n if (length(data) != length(Date)) {\n stop('check original txt file. for missing value, the symbol is \"--\", check\n if this symbol is missing somewhere')\n }\n \n output <- data.frame(Date = Date, target = data)\n \n return(output)\n }\n\n\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#' @importFrom utils read.fwf\nreadColumn_txt_anarbe <- function(fileName, keyword = NULL, rangeWord = NULL){\n \n a <- read.fwf(fileName, widths = rep(10,13))#read file with fixed width\n \n startRow <- which(a == rangeWord[1], arr.ind = TRUE)[, 1]\n startRow <- startRow + as.numeric(rangeWord[2])\n \n endRow <- which(a == rangeWord[3], arr.ind = TRUE)[, 1]\n endRow <- endRow + as.numeric(rangeWord[4])\n \n data <- mapply(FUN = function(x1, x2) anarbe_txt(dataset = a, x1, x2), startRow, endRow)\n \n data_new <- data.frame(Data = unlist(data[1, ]), target = unlist(data[2, ]))\n message(fileName)\n return(data_new)\n}\n", + "created" : 1487522240065.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "995843390", + "id" : "EC7924C8", + "lastKnownWriteTime" : 1487525974, + "last_content_update" : 1487525974318, + "path" : "~/GitHub/hyfo/R/case_anarbe.R", + "project_path" : "R/case_anarbe.R", + "properties" : { + }, + "relative_order" : 13, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB b/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB index 6f56db8..55a9bca 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB +++ b/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.8\nDate: 2017-1-8\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling,\n data resampling, gap filler of precipitation, bias correction of forecasting\n data, flexible time series plot, and spatial map generation. It is a good pre-\n processing and post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods\nSuggests:\n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\nRoxygenNote: 5.0.1\n", + "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.9\nDate: 2017-2-20\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling,\n data resampling, gap filler of precipitation, bias correction of forecasting\n data, flexible time series plot, and spatial map generation. It is a good pre-\n processing and post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods,\n data.table\nSuggests:\n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\nRoxygenNote: 5.0.1\n", "created" : 1483876827452.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "958407147", + "hash" : "1847610976", "id" : "EEC7BFEB", - "lastKnownWriteTime" : 1483876922, - "last_content_update" : 1483876922508, + "lastKnownWriteTime" : 1487525824, + "last_content_update" : 1487525824439, "path" : "~/GitHub/hyfo/DESCRIPTION", "project_path" : "DESCRIPTION", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 b/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 new file mode 100644 index 0000000..88f9b86 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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{loadNcdf}.\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#' \n#' \\dontrun{\n#' #gridData provided in the package is the result of \\code {loadNcdf}\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#' \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 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 (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#' \n#' \\dontrun{\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#' }\n#' \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#' \n#' \n#' \\dontrun{\n#' data(tgridData)# the result of \\code{\\link{loadNcdf}}\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#' \n#' \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#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n maps <- list(...)\n checkBind(maps, 'rbind')\n data_ggplot <- rbindlist(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 = unique(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" : 1487522683331.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1053965061", + "id" : "F28DEBD3", + "lastKnownWriteTime" : 1487522720, + "last_content_update" : 1487522720048, + "path" : "~/GitHub/hyfo/R/getSpatialMap.R", + "project_path" : "R/getSpatialMap.R", + "properties" : { + }, + "relative_order" : 18, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 b/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 new file mode 100644 index 0000000..9426ab6 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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 showNA A boolean representing whether the NA values should be marked, default is TRUE.\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, showNA = TRUE, \n x = NULL, 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 if (showNA == TRUE) {\n missingVLayer <- with(TS, {\n geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black')\n })\n \n mainLayer <- mainLayer + missingVLayer\n }\n \n \n plotLayer <- mainLayer + secondLayer\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\n#' @importFrom data.table rbindlist\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 data_ggplot <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n #data_ggplot <- do.call('rbind', bars)\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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" : 1487441178501.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3525693188", + "id" : "F8BC78A3", + "lastKnownWriteTime" : 1487522002, + "last_content_update" : 1487522002916, + "path" : "~/GitHub/hyfo/R/analyzeTS.R", + "project_path" : "R/analyzeTS.R", + "properties" : { + }, + "relative_order" : 11, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F index ba0fe4f..850b1d0 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F +++ b/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F @@ -7,8 +7,8 @@ "folds" : "", "hash" : "1881246410", "id" : "FFE783F", - "lastKnownWriteTime" : 1484118700, - "last_content_update" : 1484118700, + "lastKnownWriteTime" : 1487594221, + "last_content_update" : 1487594221, "path" : "~/GitHub/hyfo/man/biasCorrect.Rd", "project_path" : "man/biasCorrect.Rd", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/prop/16BD8E13 b/.Rproj.user/D1D10CF6/sdb/prop/16BD8E13 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/16BD8E13 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/1C27F867 b/.Rproj.user/D1D10CF6/sdb/prop/1C27F867 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/1C27F867 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/224CF03 b/.Rproj.user/D1D10CF6/sdb/prop/224CF03 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/224CF03 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/31175AC6 b/.Rproj.user/D1D10CF6/sdb/prop/31175AC6 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/31175AC6 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/3A3983B1 b/.Rproj.user/D1D10CF6/sdb/prop/3A3983B1 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/3A3983B1 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/715D0DA2 b/.Rproj.user/D1D10CF6/sdb/prop/715D0DA2 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/715D0DA2 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/7E5B8828 b/.Rproj.user/D1D10CF6/sdb/prop/7E5B8828 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/7E5B8828 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/ADA38099 b/.Rproj.user/D1D10CF6/sdb/prop/ADA38099 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/ADA38099 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/INDEX b/.Rproj.user/D1D10CF6/sdb/prop/INDEX index a316fe7..4ffe372 100644 --- a/.Rproj.user/D1D10CF6/sdb/prop/INDEX +++ b/.Rproj.user/D1D10CF6/sdb/prop/INDEX @@ -1,9 +1,17 @@ ~%2FGitHub%2Fhyfo%2FDESCRIPTION="1BB4BBB4" +~%2FGitHub%2Fhyfo%2FNAMESPACE="3A3983B1" ~%2FGitHub%2Fhyfo%2FNEWS="5B6E4CB4" +~%2FGitHub%2Fhyfo%2FR%2FanalyzeTS.R="ADA38099" +~%2FGitHub%2Fhyfo%2FR%2Farray_dimension.R="224CF03" ~%2FGitHub%2Fhyfo%2FR%2FbiasCorrect(generic).R="7EEE6E30" +~%2FGitHub%2Fhyfo%2FR%2Fcase_anarbe.R="7E5B8828" +~%2FGitHub%2Fhyfo%2FR%2FcollectData.R="31175AC6" ~%2FGitHub%2Fhyfo%2FR%2FextractPeriod(generic).R="2988B998" +~%2FGitHub%2Fhyfo%2FR%2FfillGap.R="1C27F867" ~%2FGitHub%2Fhyfo%2FR%2FgetAnnual(generic).R="D338C194" +~%2FGitHub%2Fhyfo%2FR%2FgetEnsemble.R="715D0DA2" ~%2FGitHub%2Fhyfo%2FR%2FgetPreciBar(generic).R="BF639043" +~%2FGitHub%2Fhyfo%2FR%2FgetSpatialMap.R="16BD8E13" ~%2FGitHub%2Fhyfo%2FR%2Fmulti-biasCorrect(generic).R="23571832" ~%2FGitHub%2Fhyfo%2FR%2Fncdf.R="DD613721" ~%2FGitHub%2Fhyfo%2FR%2Fresample(generic).R="85BAB51C" diff --git a/DESCRIPTION b/DESCRIPTION index bad2ba7..423c771 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.3.8 -Date: 2017-1-8 +Version: 1.3.9 +Date: 2017-2-20 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and @@ -28,7 +28,8 @@ Imports: rgeos (>= 0.3-8), ncdf4 (>= 1.14.1), MASS (>= 7.3-39), - methods + methods, + data.table Suggests: gridExtra, knitr, diff --git a/NAMESPACE b/NAMESPACE index 5fb35c9..1786e35 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,7 @@ import(plyr) import(rgdal) import(rgeos) importFrom(MASS,fitdistr) +importFrom(data.table,rbindlist) importFrom(grDevices,rainbow) importFrom(lmom,samlmu) importFrom(methods,new) diff --git a/NEWS b/NEWS index 899b933..eee2381 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.3.9 +========== +Date: 2017-2-20 + +- apply data.table package to facilitate data processing + + + hyfo 1.3.8 ========== Date: 2017-1-8 diff --git a/R/analyzeTS.R b/R/analyzeTS.R index 528040d..5137131 100644 --- a/R/analyzeTS.R +++ b/R/analyzeTS.R @@ -204,6 +204,7 @@ plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NU #' } #' @export #' @import ggplot2 +#' @importFrom data.table rbindlist plotTS_comb <- function(..., nrow = 1, type = 'line', list = NULL, x = 'Date', y = '', title = '', output = FALSE){ # In ploting the time series, since the data comes from outside of hyfo, @@ -213,15 +214,17 @@ plotTS_comb <- function(..., nrow = 1, type = 'line', list = NULL, x = 'Date', y if (!is.null(list)) { checkBind(list, 'rbind') - data_ggplot <- do.call('rbind', list) + #data_ggplot <- do.call('rbind', list) + data_ggplot <- rbindlist(list) } else { bars <- list(...) checkBind(bars, 'rbind') - data_ggplot <- do.call('rbind', bars) + #data_ggplot <- do.call('rbind', bars) + data_ggplot <- rbindlist(bars) } - if (!class(data_ggplot) == 'data.frame') { + if (!class(data_ggplot)[1] == 'data.table') { warning('Your input is probably a list, but you forget to add "list = " before it. Try again, or check help for more information.') } else if (is.null(data_ggplot$name)) { diff --git a/R/case_anarbe.R b/R/case_anarbe.R index 48abdce..aba675f 100644 --- a/R/case_anarbe.R +++ b/R/case_anarbe.R @@ -25,13 +25,15 @@ #' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm #' @export #' @importFrom utils tail +#' @importFrom data.table rbindlist collectData_csv_anarbe <- function(folderName, output = TRUE){ fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE) data <- lapply(fileNames, readColumn_csv_anarbe) - data <- do.call('rbind', data) + data <- rbindlist(data) data <- data[, 1:2] - data[, 1] <- as.Date(data[, 1], format = '%d/%m/%Y') + # cus the special structure of data.tables, here should be data[[1]], instead of data[, 1] + data[, 1] <- as.Date(data[[1]], format = '%d/%m/%Y') #newFileName <- file.choose(new = T) #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',') @@ -273,6 +275,7 @@ collectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){ #' @return The collected data from different txt files. #' @export #' @importFrom utils tail +#' @importFrom data.table rbindlist collectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene ', -1, 'Total ', -6)){ #All the code should be ASCII encode, so there should be no strange symbol. @@ -294,7 +297,7 @@ collectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene data <- lapply(fileNames, FUN = readColumn_txt_anarbe, rangeWord = rangeWord) - data <- do.call('rbind', data) + data <- rbindlist(data) a <- unlist(strsplit(folderName, '\\\\|/')) tarName <- tail(a, 2)[1] diff --git a/R/collectData.R b/R/collectData.R index c967b4b..bfe471d 100644 --- a/R/collectData.R +++ b/R/collectData.R @@ -19,6 +19,7 @@ #' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ #' #' @export +#' @importFrom data.table rbindlist collectData <- function(folderName, fileType = NULL, range = NULL, sheetIndex = 1){ message('All the files in the folder should have the same format') @@ -36,7 +37,7 @@ collectData <- function(folderName, fileType = NULL, range = NULL, sheetIndex = if (length(fileNames) == 0) stop('No csv file in the folder.') data <- lapply(fileNames, readCsv, range = range) - data <- do.call('rbind', data) + data <- rbindlist(data) } else if (fileType == 'txt') { fileNames <- list.files(folderName, pattern = '*.txt', full.names = TRUE) diff --git a/R/extractPeriod(generic).R b/R/extractPeriod(generic).R index 97519c5..23ba62f 100644 --- a/R/extractPeriod(generic).R +++ b/R/extractPeriod(generic).R @@ -115,7 +115,8 @@ setMethod('extractPeriod', signature('list'), month = month) } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) { - Dates <- lapply(datalist, extractPeriod_getDate) + Dates <- lapply(datalist, extractPeriod_getDate) + # Here don't know why rbindlist cannot work, change back to do.call Dates <- do.call('rbind', Dates) startDate <- as.Date(max(Dates[, 1])) diff --git a/R/getAnnual(generic).R b/R/getAnnual(generic).R index a6109a4..1f9cf3f 100644 --- a/R/getAnnual(generic).R +++ b/R/getAnnual(generic).R @@ -71,6 +71,7 @@ setMethod('getAnnual', signature('list'), return(result) }) +#' @importFrom data.table rbindlist getAnnual.TS <- function(dataframe) { Date <- as.POSIXlt(dataframe[, 1]) # Calculate how many gauging stations. @@ -82,7 +83,7 @@ getAnnual.TS <- function(dataframe) { getAnnual_dataframe(dataframe_new) }) - data <- do.call('rbind', data) + data <- rbindlist(data) # After rbind, factor level has to be reassigned in order to be well plotted. data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE) rownames(data) <- NULL @@ -91,9 +92,10 @@ getAnnual.TS <- function(dataframe) { } +#' @importFrom data.table rbindlist getAnnual.list <- function(datalist) { data <- lapply(datalist, FUN = getAnnual_dataframe) - data <- do.call('rbind', data) + data <- rbindlist(data) # After rbind, factor level has to be reassigned in order to be well plotted. data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE) rownames(data) <- NULL diff --git a/R/getEnsemble.R b/R/getEnsemble.R index a467a3a..83d325d 100644 --- a/R/getEnsemble.R +++ b/R/getEnsemble.R @@ -486,6 +486,7 @@ getFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', #' #' @export #' @import ggplot2 +#' @importFrom data.table rbindlist #' @references #' #' \itemize{ @@ -503,15 +504,15 @@ getEnsem_comb <- function(..., list = NULL, nrow = 1, legend = TRUE, x = '', y = if (!is.null(list)) { checkBind(list, 'rbind') - data_ggplot <- do.call('rbind', list) + data_ggplot <- rbindlist(list) } else { plots <- list(...) checkBind(plots, 'rbind') - data_ggplot <- do.call('rbind', plots) + data_ggplot <- rbindlist(plots) } #data_ggplot$name <- factor(data_ggplot$name, levels = data_ggplot$name, ordered = TRUE) - if (!class(data_ggplot) == 'data.frame') { + if (!class(data_ggplot)[1] == 'data.table') { warning('Your input is probably a list, but you forget to add "list = " before it. Try again, or check help for more information.') } else if (is.null(data_ggplot$name)) { diff --git a/R/getPreciBar(generic).R b/R/getPreciBar(generic).R index cd5ea67..a5ceed0 100644 --- a/R/getPreciBar(generic).R +++ b/R/getPreciBar(generic).R @@ -407,6 +407,7 @@ getPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, #' #' @export #' @import ggplot2 +#' @importFrom data.table rbindlist #' @references #' #' \itemize{ @@ -415,15 +416,15 @@ getPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, #' getPreciBar_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title = '', output = FALSE) { if (!is.null(list)) { - data_ggplot <- do.call('rbind', list) + data_ggplot <- rbindlist(list) } else { bars <- list(...) checkBind(bars, 'rbind') - data_ggplot <- do.call('rbind', bars) + data_ggplot <- rbindlist(bars) } - if (!class(data_ggplot) == 'data.frame') { + if (!class(data_ggplot)[1] == 'data.table') { warning('Your input is probably a list, but you forget to add "list = " before it. Try again, or check help for more information.') } else if (is.null(data_ggplot$Name)) { diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 399167a..9b08ced 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -415,6 +415,7 @@ getSpatialMap_mat <- function(matrix, title_d = NULL, catchment = NULL, point = #' #' @export #' @import ggplot2 maps +#' @importFrom data.table rbindlist #' @references #' #' \itemize{ @@ -425,11 +426,11 @@ getSpatialMap_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title if (!is.null(list)) { - data_ggplot <- do.call('rbind', list) + data_ggplot <- rbindlist(list) } else { maps <- list(...) checkBind(maps, 'rbind') - data_ggplot <- do.call('rbind', maps) + data_ggplot <- rbindlist(maps) } if (!class(data_ggplot) == 'data.frame') { diff --git a/R/resample(generic).R b/R/resample(generic).R index 117cf95..dfc9823 100644 --- a/R/resample(generic).R +++ b/R/resample(generic).R @@ -71,6 +71,7 @@ setMethod('resample', signature('list'), #' @importFrom stats aggregate +#' @importFrom data.table rbindlist resample.TS <- function(TS, method) { if (length(TS) != 2) { stop('Time series not correct, should be two columns, Date and value.') @@ -84,7 +85,7 @@ resample.TS <- function(TS, method) { data <- apply(TS, MARGIN = 1 , FUN = mon2day) - output <- do.call('rbind', data) + output <- rbindlist(data) } else if (method == 'day2mon') { Date <- as.Date(TS[, 1]) year <- format(Date, format = '%Y') From 0919750adb8617e1707e8fb2362d31c142e4203e Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Sat, 25 Feb 2017 18:36:31 +0800 Subject: [PATCH 09/43] change http to https --- .Rhistory | 2 +- .Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/6511719A | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/882400E4 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/9A428717 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/A879E0CC | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/EF2B4E | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 | 20 ---------- .Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 | 20 ---------- .Rproj.user/D1D10CF6/sdb/prop/11252CE5 | 2 + .Rproj.user/D1D10CF6/sdb/prop/2461C35 | 2 + .Rproj.user/D1D10CF6/sdb/prop/2E17C2F1 | 2 + .Rproj.user/D1D10CF6/sdb/prop/2E5A7688 | 2 + .Rproj.user/D1D10CF6/sdb/prop/3ED4EBC5 | 2 + .Rproj.user/D1D10CF6/sdb/prop/4F48C490 | 2 + .Rproj.user/D1D10CF6/sdb/prop/522B2964 | 2 + .Rproj.user/D1D10CF6/sdb/prop/581924DB | 2 + .Rproj.user/D1D10CF6/sdb/prop/5E3135C5 | 2 + .Rproj.user/D1D10CF6/sdb/prop/5F19AB1A | 2 + .Rproj.user/D1D10CF6/sdb/prop/614F6C89 | 2 + .Rproj.user/D1D10CF6/sdb/prop/619E744A | 2 + .Rproj.user/D1D10CF6/sdb/prop/62BD4C03 | 2 + .Rproj.user/D1D10CF6/sdb/prop/7C28B417 | 2 + .Rproj.user/D1D10CF6/sdb/prop/81E308C8 | 2 + .Rproj.user/D1D10CF6/sdb/prop/8DC54783 | 2 + .Rproj.user/D1D10CF6/sdb/prop/8F604BF1 | 2 + .Rproj.user/D1D10CF6/sdb/prop/93C6AB2B | 2 + .Rproj.user/D1D10CF6/sdb/prop/9E69FDB4 | 2 + .Rproj.user/D1D10CF6/sdb/prop/9F226FAC | 2 + .Rproj.user/D1D10CF6/sdb/prop/A698C383 | 2 + .Rproj.user/D1D10CF6/sdb/prop/A9ABBFEB | 2 + .Rproj.user/D1D10CF6/sdb/prop/AC481488 | 2 + .Rproj.user/D1D10CF6/sdb/prop/AD39FF43 | 2 + .Rproj.user/D1D10CF6/sdb/prop/B8960C40 | 2 + .Rproj.user/D1D10CF6/sdb/prop/D1BE3A89 | 2 + .Rproj.user/D1D10CF6/sdb/prop/D528021A | 2 + .Rproj.user/D1D10CF6/sdb/prop/D5D2A63B | 2 + .Rproj.user/D1D10CF6/sdb/prop/D64F2EA0 | 2 + .Rproj.user/D1D10CF6/sdb/prop/D9F093AE | 2 + .Rproj.user/D1D10CF6/sdb/prop/DB22ED13 | 2 + .Rproj.user/D1D10CF6/sdb/prop/E0A1BF84 | 2 + .Rproj.user/D1D10CF6/sdb/prop/E2A56787 | 2 + .Rproj.user/D1D10CF6/sdb/prop/EC53DD5E | 2 + .Rproj.user/D1D10CF6/sdb/prop/F74CC49C | 2 + .Rproj.user/D1D10CF6/sdb/prop/F9F4FDA9 | 2 + .Rproj.user/D1D10CF6/sdb/prop/FB3EBAAF | 2 + .Rproj.user/D1D10CF6/sdb/prop/INDEX | 37 +++++++++++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/12499DD8 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/1F14F77D | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2A6E2BEA | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2AC49E50 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2F3179D4 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/303058FC | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/3405765E | 20 ++++++++++ .../sdb/{per/t => s-DA33EA29}/390DEBE1 | 0 .../sdb/{per/t => s-DA33EA29}/47CB7F65 | 0 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/4821267A | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/4CAD519F | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/50AB644E | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/52476E6A | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/61DE20F2 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6511719A | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/666D46C7 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6DDA2A7B | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6FE223B | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/80C39737 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/819D4E19 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/882400E4 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/8E431305 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/90EB6DDD | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/92757319 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9A428717 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9CAB49AF | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9DAD3561 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A0BF5A09 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A2A68A80 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A879E0CC | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A87A7AF6 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE5809FB | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE7DF6FE | 20 ++++++++++ .../sdb/{per/t => s-DA33EA29}/B4F74B5C | 4 +- .Rproj.user/D1D10CF6/sdb/s-DA33EA29/B8E278FD | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/BFF6AE7A | 20 ++++++++++ .../sdb/{per/t => s-DA33EA29}/CA11BD0A | 4 +- .Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA271C51 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/CE991F6 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D0BF85EC | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D1FE15E0 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D22A91DA | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D3DE8C31 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/E1CE201C | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/E6AC5179 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EA6E74D8 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EB85B1DD | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EBF4F7FE | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EC7924C8 | 20 ++++++++++ .../sdb/{per/t => s-DA33EA29}/EEC7BFEB | 8 ++-- .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EF2B4E | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F28DEBD3 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F72259DF | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8BC78A3 | 20 ++++++++++ .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8CC347F | 20 ++++++++++ .../sdb/{per/t => s-DA33EA29}/FFE783F | 8 ++-- .Rproj.user/D1D10CF6/sdb/s-DA33EA29/lock_file | 0 .Rproj.user/shared/notebooks/paths | 1 + .travis.yml | 2 +- DESCRIPTION | 2 +- R/analyzeTS.R | 14 +++---- R/biasCorrect(generic).R | 4 +- R/case_anarbe.R | 10 ++--- R/classes.R | 2 +- R/collectData.R | 4 +- R/extractPeriod(generic).R | 6 +-- R/fillGap.R | 6 +-- R/getAnnual(generic).R | 4 +- R/getEnsemble.R | 6 +-- R/getPreciBar(generic).R | 6 +-- R/getSpatialMap.R | 12 +++--- R/list2dataframe.R | 2 +- R/multi-biasCorrect(generic).R | 4 +- R/ncdf.R | 18 ++++----- R/readfolders.R | 2 +- R/resample(generic).R | 6 +-- R/shp2cat.R | 6 +-- R/startup.R | 4 +- README.md | 4 +- man/applyBiasFactor.Rd | 2 +- man/biasCorrect.Rd | 2 +- man/collectData.Rd | 2 +- man/collectData_csv_anarbe.Rd | 4 +- man/collectData_txt_anarbe.Rd | 4 +- man/downscaleNcdf.Rd | 2 +- man/extractPeriod.Rd | 4 +- man/fillGap.Rd | 2 +- man/getAnnual.Rd | 4 +- man/getBiasFactor.Rd | 2 +- man/getEnsem_comb.Rd | 2 +- man/getFrcEnsem.Rd | 2 +- man/getHisEnsem.Rd | 2 +- man/getLMom.Rd | 4 +- man/getMoment.Rd | 6 +-- man/getNcdfVar.Rd | 4 +- man/getPreciBar.Rd | 4 +- man/getPreciBar_comb.Rd | 2 +- man/getSpatialMap_comb.Rd | 2 +- man/getSpatialMap_mat.Rd | 10 ++--- man/list2Dataframe.Rd | 2 +- man/loadNcdf.Rd | 2 +- man/plotTS.Rd | 2 +- man/plotTS_comb.Rd | 2 +- man/resample.Rd | 4 +- man/shp2cat.Rd | 6 +-- man/writeNcdf.Rd | 4 +- vignettes/hyfo.Rmd | 6 +-- 159 files changed, 1234 insertions(+), 382 deletions(-) delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/6511719A delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/882400E4 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/9A428717 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/A879E0CC delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/EF2B4E delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 delete mode 100644 .Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/11252CE5 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/2461C35 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/2E17C2F1 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/2E5A7688 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/3ED4EBC5 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/4F48C490 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/522B2964 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/581924DB create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/5E3135C5 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/5F19AB1A create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/614F6C89 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/619E744A create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/62BD4C03 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/7C28B417 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/81E308C8 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/8DC54783 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/8F604BF1 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/93C6AB2B create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/9E69FDB4 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/9F226FAC create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/A698C383 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/A9ABBFEB create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/AC481488 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/AD39FF43 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/B8960C40 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D1BE3A89 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D528021A create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D5D2A63B create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D64F2EA0 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/D9F093AE create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/DB22ED13 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/E0A1BF84 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/E2A56787 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/EC53DD5E create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/F74CC49C create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/F9F4FDA9 create mode 100644 .Rproj.user/D1D10CF6/sdb/prop/FB3EBAAF create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/12499DD8 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/1F14F77D create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2A6E2BEA create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2AC49E50 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/2F3179D4 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/303058FC create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/3405765E rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/390DEBE1 (100%) rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/47CB7F65 (100%) create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/4821267A create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/4CAD519F create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/50AB644E create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/52476E6A create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/61DE20F2 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6511719A create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/666D46C7 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6DDA2A7B create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/6FE223B create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/80C39737 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/819D4E19 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/882400E4 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/8E431305 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/90EB6DDD create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/92757319 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9A428717 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9CAB49AF create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/9DAD3561 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A0BF5A09 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A2A68A80 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A879E0CC create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/A87A7AF6 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE5809FB create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE7DF6FE rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/B4F74B5C (96%) create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/B8E278FD create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/BFF6AE7A rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/CA11BD0A (94%) create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA271C51 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/CE991F6 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D0BF85EC create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D1FE15E0 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D22A91DA create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/D3DE8C31 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/E1CE201C create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/E6AC5179 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EA6E74D8 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EB85B1DD create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EBF4F7FE create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EC7924C8 rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/EEC7BFEB (86%) create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EF2B4E create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F28DEBD3 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F72259DF create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8BC78A3 create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8CC347F rename .Rproj.user/D1D10CF6/sdb/{per/t => s-DA33EA29}/FFE783F (88%) create mode 100644 .Rproj.user/D1D10CF6/sdb/s-DA33EA29/lock_file diff --git a/.Rhistory b/.Rhistory index 5bc7561..358c13a 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,4 +1,3 @@ -frc <- frc - hindcastMean + obsMean } } else if (method == 'eqm') { if (preci == FALSE) { @@ -510,3 +509,4 @@ b a[[2]] a devtools::check() +devtools::build() diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA b/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA deleted file mode 100644 index 012be54..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/2A6E2BEA +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 }\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\n# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1483875773075.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1965966598", - "id" : "2A6E2BEA", - "lastKnownWriteTime" : 1484118501, - "last_content_update" : 1484118501532, - "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", - "project_path" : "R/biasCorrect(generic).R", - "properties" : { - }, - "relative_order" : 2, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/6511719A b/.Rproj.user/D1D10CF6/sdb/per/t/6511719A deleted file mode 100644 index 7d11b91..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/6511719A +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Fill gaps in the rainfall time series.\n#'\n#' @param dataset A dataframe with first column the time, the rest columns are rainfall data of different gauges\n#' @param corPeriod A string showing the period used in the correlation computing, \n#' e.g. daily, monthly, yearly.\n#' @return The filled dataframe\n#' @details\n#' the gap filler follows the rules below:\n#' \n#' 1. The correlation coefficient of every two columns (except time column) is calculated.\n#' the correlation coefficient calculation can be based on 'daily', 'monthly', 'annual',\n#' in each case, the daily data, the monthly mean daily data and annual mean daily data of \n#' each column will be taken in the correlation calculation.\n#' \n#' Then the correlation matrix is got, then based on the matrix, for each column, \n#' the 1st, 2nd, 3rd,... correlated column will be got. So if there is missing value in the\n#' column, it will get data from orderly 1st, 2nd, 3rd column.\n#' \n#' 2. The simple linear regress is calculated between every two columns. When generating the\n#' linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to \n#' y = a*x.\n#' \n#' 3. Gap filling. E.g., on a certain date, there is a missing value in column A, then the\n#' correlation order is column B, column C, column D, which means A should take values from\n#' B firstly, if B is also missing data, then C, then D.\n#' \n#' Assuming finally value from column C is taken. Then according to step 2, A = a*C, then the\n#' final value filled in column A is missing_in_A = a*value_in_C, a is the linear coeffcient.\n#' \n#' @examples\n#' b <- read.table(text = ' Date AAA BBB CCC DDD EEE\n#' 49 1999-12-15 24.8 21.4 25.6 35.0 17.4\n#' 50 1999-12-16 NA 0.6 1.5 6.3 2.5\n#' 51 1999-12-17 NA 16.3 20.3 NA 19.2\n#' 52 1999-12-18 13 1.6 NA 6.3 0.0\n#' 53 1999-12-19 10 36.4 12.5 26.8 24.9\n#' 54 1999-12-20 NA 0.0 0.0 0.2 0.0\n#' 55 1999-12-21 0.2 0.0 0.0 0.0 0.0\n#' 56 1999-12-22 0.0 0.0 0.0 0.0 0.0')\n#' \n#' b1 <- fillGap(b) # if corPeriod is missing, 'daily' is taken as default.\n#' \n#' data(testdl)\n#' a <- extractPeriod(testdl, commonPeriod = TRUE)\n#' a1 <- list2Dataframe(a)\n#' a2 <- fillGap(a1)\n#' a3 <- fillGap(a1, corPeriod = 'monthly')\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references\n#' Gap fiiling method based on correlation and linear regression.\n#' \n#' \\itemize{\n#' \\item Hirsch, Robert M., et al. \"Statistical analysis of hydrologic data.\" Handbook of hydrology. (1992): 17-1.\n#' Salas, Jose D. \"Analysis and modeling of hydrologic time series.\" Handbook of hydrology 19 (1993): 1-72.\n#' \n#' }\n#' \n#' \n#' @export\nfillGap <- function(dataset, corPeriod = 'daily') {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n data <- data.frame(dataset[, 2:dim(dataset)[2]])\n names <- colnames(data)\n \n corN <- fillGap_cor(data, corPeriod = corPeriod, Date = Date)\n cat('\\nCorrelation Coefficient\\n')\n print(corN)\n \n corOrder <- apply(corN, MARGIN = 1, FUN = function(x) order(-x))\n corOrder <- corOrder[2:dim(corOrder)[1], ]\n corOrderName <- t(apply(corOrder, MARGIN = 2, FUN = function(x) names[x]))\n \n cat('\\nCorrelation Order\\n')\n colnames(corOrderName) <- seq(1 : dim(corOrderName)[2])\n print(corOrderName)\n \n lmCoef <- fillGap_lmCoef(data, corOrder)\n cat('\\nLinear Coefficients\\n')\n rownames(lmCoef) <- seq(1 : dim(corOrderName)[2])\n print(t(lmCoef))\n \n output <- lapply(1:dim(data)[2], fillGap_column, data = data,\n corOrder = corOrder, lmCoef = lmCoef)\n output <- data.frame(output)\n colnames(output) <- names\n \n output <- cbind(Date, output)\n \n return(output)\n}\n\n\n#' Get monthly rainfall\n#' \n#' @param TS A rainfall time series.\n#' @param year A list showing the year index of the time series.\n#' @param mon A list showing the mon index of the time series.\n#' @return the monthly rainfall matrix of the rainfall time series.\nmonthlyPreci <- function(TS, year, mon) {\n \n # monthly daily mean is used in order not to affected by missing values.\n monTS <- tapply(TS, INDEX = list(year, mon), FUN = mean, na.rm = TRUE)\n output <- t(monTS)\n dim(output) <- c(dim(monTS)[1] * dim(monTS)[2], 1)\n return(output)\n}\n\n\nfillGap_column <- function(i, data, corOrder, lmCoef) {\n TS <- data[, i] # extract target column\n l <- dim(data)[2] # length\n \n for (j in 1:l) {\n if (!any(is.na(TS))) break\n NAindex <- which(is.na(TS))\n TS[NAindex] <- round(lmCoef[j, i] * data[NAindex, corOrder[j, i]], 3)\n \n if (j == l) stop('Error: One time consists of all NA values')\n }\n \n return(TS)\n}\n\n\n#' @importFrom stats cor na.omit\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#' \n\nfillGap_cor <- function(data, corPeriod = 'daily', Date) {\n \n names <- colnames(data)\n year <- format(Date, '%Y')\n \n if (corPeriod == 'monthly') {\n #based on monthly rainfall\n mon <- format(Date, '%m')\n monthlyPreci <- lapply(data, FUN = monthlyPreci, year = year, mon = mon)\n corData <- do.call('cbind', monthlyPreci)\n } else if (corPeriod == 'yearly') {\n year <- format(Date, '%Y')\n # yearly daily mean is used in order not to affected by missing values.\n annualPreci <- lapply(data, FUN = function(x) tapply(x, INDEX = year, FUN = mean, na.rm = TRUE))\n corData <- do.call('cbind', annualPreci)\n } else if (corPeriod == 'daily') {\n corData <- data\n } else {\n stop('Pleas choose among \"daily\", \"monthly\", \"yearly\".')\n }\n \n corData <- data.frame(na.omit(corData))\n colnames(corData) <- names\n \n corN <- cor(corData)\n \n return(corN)\n \n} \n\n#' @importFrom utils combn\n#' @importFrom stats coef lm\n#' @references \n#' 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#' \nfillGap_lmCoef <- function(data, corOrder) {\n l <- dim(data)[2]\n m <- diag(l)# m is the coeficients matrix\n m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0)))\n tm <- t(m)\n \n tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0)))\n \n m <- t(tm)\n \n lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]])\n lmCoef <- do.call('rbind', lmCoef)\n rownames(lmCoef) <- colnames(data)\n \n return(t(lmCoef))\n}\n\n", - "created" : 1487522438368.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "214900332", - "id" : "6511719A", - "lastKnownWriteTime" : 1487594210, - "last_content_update" : 1487594210897, - "path" : "~/GitHub/hyfo/R/fillGap.R", - "project_path" : "R/fillGap.R", - "properties" : { - }, - "relative_order" : 16, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B b/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B deleted file mode 100644 index 3c21894..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/6DDA2A7B +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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" : 1483876772702.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3525032847", - "id" : "6DDA2A7B", - "lastKnownWriteTime" : 1487522678, - "last_content_update" : 1487522678570, - "path" : "~/GitHub/hyfo/R/getPreciBar(generic).R", - "project_path" : "R/getPreciBar(generic).R", - "properties" : { - }, - "relative_order" : 7, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 b/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 deleted file mode 100644 index e8dead6..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/882400E4 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "\n\n\n\n#' Get bias factor for multi/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method. \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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\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#' @rdname 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#' @rdname 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/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' #' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 }\n#' \n#' @export\nsetGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) {\n standardGeneric('applyBiasFactor')\n})\n\n#' @rdname 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#' @rdname 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 <- grepAndMatch('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 <- grepAndMatch('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" : 1483876652911.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3103634387", - "id" : "882400E4", - "lastKnownWriteTime" : 1483876696, - "last_content_update" : 1483876696357, - "path" : "~/GitHub/hyfo/R/multi-biasCorrect(generic).R", - "project_path" : "R/multi-biasCorrect(generic).R", - "properties" : { - }, - "relative_order" : 5, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 b/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 deleted file mode 100644 index 326a453..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/9A428717 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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#' @rdname resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @rdname 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\n#' @importFrom data.table rbindlist\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 <- rbindlist(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" : 1483876700794.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "4266301985", - "id" : "9A428717", - "lastKnownWriteTime" : 1487522763, - "last_content_update" : 1487522763599, - "path" : "~/GitHub/hyfo/R/resample(generic).R", - "project_path" : "R/resample(generic).R", - "properties" : { - }, - "relative_order" : 6, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 b/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 deleted file mode 100644 index 1205f2b..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/A2A68A80 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Get ensemble forecast from historical data.\n#' \n#' getHisEnsem use historical data as the forecasting input time series.\n#' \n#' @param TS A time series dataframe, with first column Date, and second column value.\n#' @param example A vector containing two strings showing the start and end date, which represent the \n#' forecasting period. Check details for more information.\n#'\n#' the program will extract every possible period in TS you provided to generate the ensemble. Check details for \n#' more information.\n#' @param interval A number representing the interval of each ensemble member. NOTE: \"interval\" takes\n#' 365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval \n#' to be 2 years, set \\code{interval = 730}, which equals 2 * 365 ; if two months, set \\code{interval = 60}; \n#' 2 days, \\code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the \n#' number as days.By defualt interval is set to be 365, a year.\n#' @param buffer A number showing how many days are used as buffer period for models. Check details for more\n#' information.\n#' \n#' @param plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\n#' \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{getEnsem_comb}.\n#' \n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \n#' \n#' \\code{example} E.g., if you have a time series from 2000 to 2010. Assuming you are in 2003,\n#' you want to forecast the period from 2003-2-1 to 2003-4-1. Then for each year in your input\n#' time series, every year from 1st Feb to 1st Apr will be extracted to generate the ensemble\n#' forecasts. In this case your input example should be \\code{example = c('2003-2-1', '2003-4-1')}\n#' \n#' \\code{interval} doesn't care about leap year and the months with 31 days, it will take 365 as a year, and 30 as a month.\n#' e.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28\n#' days.\n#' \n#' \\code{example} and \\code{interval} controls how the ensemble will be generated. e.g. if the time series is from \n#' 1990-1-1 to 2001-1-1.\n#' \n#' if \\code{example = c('1992-3-1', '1994-1-1')} and \\code{interval = 1095}, note, 1095 = 365 * 3, so the program treat\n#' this as 3 years.\n#' \n#' Then you are supposed to get the ensemble consisting of following part:\n#' \n#' 1. 1992-3-1 to 1994-1-1 first one is the example, and it's NOT start from 1990-3-1.\n#' 2. 1995-3-1 to 1997-1-1 second one starts from 1993, because \"interval\" is 3 years.\n#' 3. 1998-3-1 to 2000-1-1\n#' \n#' because the last one \"2000-3-1 to 2002-1-1\", 2002 exceeds the original TS range, so it will not be included.\n#' \n#' Sometimes, there are leap years and months with 31 days included in some ensemble part, in which case the length of the data will\n#' be different, e.g., 1999-1-1 to 1999-3-1 is 1 day less than 2000-1-1 to 2000-3-1. In this situation,\n#' the data will use example as a standard. If the example is 1999-1-1 to 1999-3-1, then the latter one\n#' will be changed to 2001-1-1 to 2000-2-29, which keeps the start Date and change the end Date.\n#' \n#' If the end date is so important that cannot be changed, try to solve this problem by resetting\n#' the example period, to make the event included in the example.\n#' \n#' Good set of example and interval can generate good ensemble.\n#' \n#' \\code{buffer}\n#' Sometimes the model needs to run for a few days to warm up, before the forecast. E.g., if a forecast starts at\n#' '1990-1-20', for some model like MIKE NAM model, the run needs to be started about 14 days. So the input timeseries\n#' should start from '1990-1-6'.\n#' \n#' Buffer is mainly used for the model hotstart. Sometimes the hot start file cannot contain all the parameters needed,\n#' only some important parameters. In this case, the model needs to run for some time, to make other parameters ready\n#' for the simulation.\n#' \n#' \n#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, name has to be assigned if \\code{output = 'ggplot'} is selected,\n#' @return A ensemble time series using historical data as forecast.\n#' \n#' @examples\n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'))\n#' \n#' # Default interval is one year, can be set to other values, check help for information.\n#' \n#' # Take 7 months as interval\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') \n#' # Take 30 days as buffer\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @importFrom reshape2 melt \n#' @importFrom grDevices rainbow\n#' @import ggplot2\n#' @references \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#' }\n#' \n#' \n#' @export\n\ngetHisEnsem <- function (TS, example, interval = 365, buffer = 0, plot = 'norm', output = 'data', \n name = NULL, mv = 0, ...) {\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 } else if (!grepl('-|/', example[1]) | !grepl('-|/', example[1])) {\n stop('Wrong date format in the example, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } else {\n \n \n \n TS[, 1] <- as.Date(TS[, 1])\n example <- as.Date(example ,tz = '')\n exL <- example[2] - example[1]\n # Test if example is in the range of the TS\n a <- which(TS[, 1] == example[1] | TS[, 1] == example[2])\n if (length(a) < 2) stop('Example is out of the time series, reset example.')\n \n \n \n if (interval %% 365 == 0) {\n d <- interval / 365\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'years')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'years'))\n\n n <- length(startDate) + length(endDate) - 1 # example is counted twice, should be subtracted. \n \n # Generate full start date series.\n startDate <- seq(min(startDate), length = n, by = paste(d, 'years'))\n endDate <- startDate + exL\n \n } else if (interval %% 30) {\n d <- interval / 30\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'months')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'months'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'months'))\n endDate <- startDate + exL\n \n } else {\n d <- interval\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'days')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'days'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'days'))\n endDate <- startDate + exL\n }\n \n data <- mapply(FUN = function(x, y) extractPeriod_dataframe(dataframe = TS, startDate = x, endDate = y),\n x = startDate, y = endDate)\n \n data <- lapply(1:n, function(x) data.frame(data[, x]))\n \n if (buffer > 0) {\n bufferStart <- example[1] - buffer\n bufferEnd <- example[1] - 1\n bufferTS <- extractPeriod_dataframe(TS, bufferStart, bufferEnd)\n \n data <- lapply(data, function(x) rbind(bufferTS, x))\n \n } else if (buffer < 0) {\n stop ('Buffer should be positive, or reset example.')\n }\n \n \n data_output <- list2Dataframe(data)\n colnames(data_output) <- c('Date', as.character(startDate))\n \n # Rearrange dataframe to make example the first column.\n ind <- match(c('Date', as.character(example[1])), colnames(data_output))\n # when use cbind, to ensure the output is also a dataframe, one inside cbind should be dataframe\n # Even output is alread a dataframe, but when ind is a single number, then output[ind] will\n # not be a dataframe, but an array.\n data_output <- cbind(data.frame(data_output[ind]), data_output[-ind])\n ex_date <- seq(from = example[1] - buffer, to = example[2], by = 1)\n data_output$Date <- ex_date\n colnames(data_output)[2] <- 'Observation'\n \n meanV <- apply(data_output[, 2:ncol(data_output)], MARGIN = 1, FUN = mean, na.rm = TRUE)\n \n data_output <- cbind(data.frame(Date = data_output[, 1]), Mean = meanV, \n data_output[, 2:ncol(data_output)])\n \n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n \n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n } else {\n stop('plot can only be \"norm\" or \"cum\", do not assign other words')\n }\n \n #generate different colors \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable, group = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_point(data = data_ggplot[NAIndex, ], size = 3, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(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 })\n print(mainLayer)\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, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n\n return(data_ggplot)\n } else {\n return(data_output)\n }\n }\n}\n\n\n\n\n\n\n#' Extract time series from forecasting data.\n#' \n#' getFrcEnsem extract timeseries from forecasting data, if forecasting data has a member session\n#' an ensemble time sereis will be returned, if forecasting data doesn't have a member session, a singe time\n#' series will be returned.\n#' \n#' @param dataset A list containing different information, should be the result of \\code{\\link{loadNcdf}}\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 plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\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{getEnsem_comb}.\n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param coord A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned,\n#' cell argument will no longer be used.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \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#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, If name is not assigned and \\code{output = 'ggplot'} is selected, then\n#' the system time will be selected as name column.\n#' \n#' @examples \n#' \n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' nc <- loadNcdf(filePath, varname)\n#' a <- getFrcEnsem(nc)\n#' \n#' # If there is no member session in the dataset, a single time sereis will be extracted.\n#' a1 <- getFrcEnsem(tgridData)\n#' \n#' \n#' # The default output is spatially averaged, if there are more than one cells in the dataset, \n#' # the mean value of the cells will be calculated. While if you are interested in special cell, \n#' # you can assign the cell value. You can also directly use longitude and latitude to extract \n#' # time series.\n#' \n#' getSpatialMap(nc, 'mean')\n#' a <- getFrcEnsem(nc, cell = c(6,2))\n#' \n#' # From the map, cell = c(6, 2) means lon = -1.4, lat = 43.2, so you can use corrd to locate\n#' # your research area and extract time series.\n#' b <- getFrcEnsem(nc, coord = c(-1.4, 43.2))\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @return A ensemble time series extracted from forecating data.\n#' \n#' @import ggplot2\n#' @importFrom reshape2 melt\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' @export\ngetFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', name = NULL,\n mv = 0, coord = NULL, ...) {\n # cell should be a vector showing the location, or mean representing the loacation averaged.\n \n checkHyfo(dataset)\n \n Date <- as.Date(dataset$Dates$start)\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 if (!is.null(coord)) {\n cell <- coord2cell(coord, dataset$xyCoords$x, dataset$xyCoords$y)\n } \n \n \n if (!any(attributes(data)$dimensions == 'member')){\n message('There is no member part in the dataset, there will be only one column of value\n returned.')\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], ]\n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n \n } else {\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], , ]\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem) \n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = c(3, 4), FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n }\n\n \n data_output <- data.frame(Date, data_ensem)\n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n \n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n \n }\n \n colors = c('brown1', rainbow(n = length(unique(data_ggplot$variable)) - 1,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6, color = 'red') +\n geom_point(data = data_ggplot[NAIndex, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n print(mainLayer)\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_ggplot$name <- rep(name, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n return(data_ggplot)\n } else {\n return(data_output)\n }\n}\n\n\n\n#' Combine ensembles together\n#' @param ... different ensembles generated by \\code{getHisEnsem(, output = 'ggplot')} \n#' or \\code{getFrcEnsem(, 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 legend A boolean representing whether you want the legend. Sometimes when you combine\n#' plots, there will be a lot of legends, if you don't like it, you can turn it off by setting\n#' \\code{legend = FALSE}, default is TRUE.\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 ensemble plot.\n#' @examples \n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' \n#' \n#' b1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot',\n#' name = 1)\n#' \n#' b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot',\n#' name = 2)\n#' \n#' getEnsem_comb(b1, b2)\n#' getEnsem_comb(list = list(b1, b2), nrow = 2)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @export\n#' @import ggplot2\n#' @importFrom data.table rbindlist\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' \n\ngetEnsem_comb <- function(..., list = NULL, nrow = 1, legend = TRUE, x = '', y = '', title = '', \n output = FALSE) {\n \n if (!is.null(list)) {\n checkBind(list, 'rbind')\n data_ggplot <- rbindlist(list)\n } else {\n plots <- list(...)\n checkBind(plots, 'rbind')\n data_ggplot <- rbindlist(plots)\n } \n #data_ggplot$name <- factor(data_ggplot$name, levels = data_ggplot$name, ordered = TRUE)\n \n if (!class(data_ggplot)[1] == 'data.table') {\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 getFreEnsem() or getHisEnsem(), if \n output = \"ggplot\" is assigned, more info please check ?getFreEnsem() or ?getHisEnsem().')\n }\n \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_point(data = data_ggplot[data_ggplot$nav == 1, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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 facet_wrap( ~ name, nrow = nrow) +\n labs(x = x, y = y, title = title)\n \n })\n if (legend == FALSE) {\n mainLayer <- mainLayer + \n theme(legend.position = 'none')\n# following ones are to add label, may be added in future.\n# geom_text(data = data_ggplot[data_ggplot$Date == '2003-12-10', ], aes(label = variable), hjust = 0.7, vjust = 1)\n# geom_text(data = data_ggplot[data_ggplot$variable == 'Mean', ], aes(label = variable), hjust = 0.7, vjust = 1)\n }\n \n \n print(mainLayer)\n \n if (output == TRUE) return(data_ggplot)\n \n}", - "created" : 1487522564089.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2954610742", - "id" : "A2A68A80", - "lastKnownWriteTime" : 1487522622, - "last_content_update" : 1487522622058, - "path" : "~/GitHub/hyfo/R/getEnsemble.R", - "project_path" : "R/getEnsemble.R", - "properties" : { - }, - "relative_order" : 17, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC b/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC deleted file mode 100644 index acfce39..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/A879E0CC +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Collect data from different csv files.\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param fileType A string showing the file type, e.g. \"txt\", \"csv\", \"excel\".\n#' @param range A vector containing startRow, endRow, startColumn, endColumn, e.g., \n#' c(2,15,2,3)\n#' @param sheetIndex A number showing the sheetIndex in the excel file, if fileType is excel,\n#' sheetIndex has to be provided, default is 1.\n#' @return The collected data from different files in the folder.\n#' @examples \n#' \n#' #use internal data as an example.\n#' folder <- file.path(path.package(\"hyfo\"), 'extdata')\n#' # file may vary with different environment, it if doesn't work, use local way to get\n#' # folder path.\n#' \n#' a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom data.table rbindlist\ncollectData <- function(folderName, fileType = NULL, range = NULL, sheetIndex = 1){\n \n message('All the files in the folder should have the same format')\n \n if (is.null(fileType)) stop('Please enter fileType, \"txt\", \"csv\" or \"excel\".')\n \n if (length(range) > 4) {\n stop('\"range\" should be c(startRow, endRow, startCol, endCol)')\n }else if (is.null(range)) {\n stop('\"range\" can not be blank, e.g., range <- c(startRow, endRow, startCol, endCol).')\n }\n \n if (fileType == 'csv') {\n fileNames <- list.files(folderName, pattern = '*.csv', full.names = TRUE)\n if (length(fileNames) == 0) stop('No csv file in the folder.')\n \n data <- lapply(fileNames, readCsv, range = range)\n data <- rbindlist(data)\n \n } else if (fileType == 'txt') {\n fileNames <- list.files(folderName, pattern = '*.txt', full.names = TRUE)\n if (length(fileNames) == 0) {\n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n }\n if (length(fileNames) == 0) stop('No text file in the folder.')\n message('For txt file, only startRow and endRow will be considered.')\n data <- lapply(fileNames, readTxt, range = range)\n data <- unlist(data)\n \n# In order not to introduce too much trouble to user, this part has been hiden\n# Because it needs java environment installed.\n#\n } else if (fileType == 'excel') {\n \n message('This part needs java installed in your computer, so it is commentted in\n the original file, check the original R file or https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData.R\n for ideas.')\n# fileNames <- list.files(folderName, pattern = '*.xlsx', full.names = TRUE)\n# if (length(fileNames) == 0){\n# fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n# }\n# \n# if (length(fileNames) == 0) stop('No excel in the folder.')\n# data <- lapply(fileNames, readExcel, range = range, sheetIndex = sheetIndex)\n# checkBind(data, 'rbind')\n# data <- do.call('rbind', data)\n }else{\n stop('fileType should be \"txt\", \"csv\" or \"excel\".')\n }\n \n \n return(data)\n \n}\n\n# #importFrom xlsx read.xls\n# readExcel <- function(fileName, range, sheetIndex){\n# data <- read.xls(fileName, sheetIndex = sheetIndex, rowIndex = seq(range[1], range[2]),\n# colIndex = seq(range[3], range[4])) \n# colnames(data) <- seq(1, dim(data)[2])\n# \n# message(fileName) \n# return(data)\n# }\n\nreadTxt <- function(fileName, range){\n data <- readLines(fileName)\n data <- data[range[1]:range[2]]\n return(data)\n}\n\n\n\n#' @importFrom utils read.csv\n#' @references \n#' 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/.\nreadCsv <- function(fileName, range){\n \n data <- read.csv(fileName, skip = range[1] - 1, header = FALSE)\n data <- data[1:(range[2] - range[1] + 1), range[3]:range[4]]\n \n return(data)\n}\n\n\n\n\n\n", - "created" : 1487522346501.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1659278673", - "id" : "A879E0CC", - "lastKnownWriteTime" : 1487522383, - "last_content_update" : 1487522383743, - "path" : "~/GitHub/hyfo/R/collectData.R", - "project_path" : "R/collectData.R", - "properties" : { - }, - "relative_order" : 14, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A b/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A deleted file mode 100644 index ac40d83..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/BFF6AE7A +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Get annual rainfall of different rainfall time series\n#' \n#' Get annual rainfall of different raninfall time series.\n#' \n#' \n#' @param data A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\n#' gauging stations. Usually an output of \\code{list2Dataframe}.\n#' @param output A string showing the output output.\n#' @param minRecords A number showing the minimum accept record number, e.g. for a normal \n#' year(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\n#' of a year, it will be ignored in the mean annual value calculation. Only valid \n#' when \\code{output = \"mean\"}, default is 355.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @return The annual rainfall and the number of missing data of each year and each rainfall gauge, which \n#' will also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n#' @details \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #datalist is provided by the package as a test.\n#' data(testdl)\n#' a <- getAnnual(testdl)\n#' #set minRecords to control the calculation of annual rainfall.\n#' b <- getAnnual(testdl, output = 'mean', minRecords = 350)\n#' c <- getAnnual(testdl, output = 'mean', minRecords = 365)\n#' \n#' a1 <- extractPeriod(testdl, comm = TRUE)\n#' a2 <- list2Dataframe(a1)\n#' getAnnual(a2)\n#' \n#' a3 <- fillGap(a2)\n#' getAnnual(a3)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom methods setGeneric\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 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#' \nsetGeneric('getAnnual', function(data, output = 'series', minRecords = 355, \n ...) {\n standardGeneric('getAnnual')\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('data.frame'), \n function(data, output, minRecords, ...) {\n result <- getAnnual.TS(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('list'),\n function(data, output, minRecords, ...) {\n result <- getAnnual.list(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n })\n\n#' @importFrom data.table rbindlist\ngetAnnual.TS <- function(dataframe) {\n Date <- as.POSIXlt(dataframe[, 1])\n # Calculate how many gauging stations.\n stations <- colnames(dataframe)[2:ncol(dataframe)]\n \n data <- lapply(stations, function(x) {\n dataframe_new <- data.frame(Date, dataframe[, x])\n colnames(dataframe_new)[2] <- x\n getAnnual_dataframe(dataframe_new)\n })\n \n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n \n return(data)\n}\n\n\n#' @importFrom data.table rbindlist\ngetAnnual.list <- function(datalist) {\n data <- lapply(datalist, FUN = getAnnual_dataframe)\n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n return(data)\n}\n\n#' @import ggplot2 \n#' @importFrom reshape2 melt\n#' @importFrom stats aggregate\ngetAnnual.plot <- function(data, output, minRecords, ...) {\n theme_set(theme_bw())\n \n if (output == 'mean') {\n validData <- data[data$recordNum >= minRecords,]\n \n data <- aggregate(validData$AnnualPreci, list(validData$Name), mean)\n colnames(data) <- c('Name', 'AnnualPreci')\n \n mainLayer <- with(data, {\n ggplot(data)+\n geom_bar(aes(x = Name, y = AnnualPreci, fill = Name), stat = 'identity')+\n labs(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n \n print(mainLayer)\n \n } else {\n \n plotData <- with(data, {\n subset(data, select = c(Year, Name, NANum, AnnualPreci))\n })\n \n plotData <- melt(plotData, var.id = c('Year', 'Name'))\n \n \n mainLayer <- with(plotData, {\n ggplot(plotData) +\n geom_bar(aes(x = Year, y = value , fill = Name), \n stat = 'identity') +\n facet_grid(variable ~ Name, scale = 'free') +\n xlab('Year') +\n ylab(NULL) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = 20, face = 'bold', vjust = 1)) +\n theme(axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.5)),\n axis.text.y = element_text(size = rel(1.5)))\n # grid.arrange(mainLayer, ncol = 4)\n \n })\n \n \n print(mainLayer)\n } \n}\n\n\n\n\n\n\n\n\n#' Get annual rainfall of the input time series.\n#' \n#' @param dataset A dataframe containing one time series, e.g., rainfall from one gauging station.\n#' the time should follow the format : \"1990-1-1\"\n#' @return The annual rainfall of each year of the input station.\n# @examples\n# data(testdl)\n# getAnnual_dataframe(testdl[[1]])\n#' \ngetAnnual_dataframe <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n year <- format(Date, '%Y')\n yearUnique <- unique(year)\n # yearUnique <- factor(yearUnique, levels = yearUnique, ordered = TRUE)\n calcuNum <- c(1:length(yearUnique))\n \n \n annualPreci <- tapply(dataset[, 2], INDEX = year, FUN = sum, na.rm = TRUE)\n recordNum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(!is.na(x))))\n NANum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(is.na(x))))\n \n \n name <- rep(colnames(dataset)[2], length(calcuNum))\n output <- data.frame(Year = as.numeric(yearUnique), Name = name, AnnualPreci = annualPreci,\n recordNum, NANum)\n \n #output$Year <- factor(output$Year, levels = output$Year, ordered = TRUE)\n return(output)\n}\n\n", - "created" : 1483876618596.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "55111109", - "id" : "BFF6AE7A", - "lastKnownWriteTime" : 1487522555, - "last_content_update" : 1487522555874, - "path" : "~/GitHub/hyfo/R/getAnnual(generic).R", - "project_path" : "R/getAnnual(generic).R", - "properties" : { - }, - "relative_order" : 4, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 b/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 deleted file mode 100644 index eeb91d5..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/D3DE8C31 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Extract period from list or dataframe.\n#' \n#' Extract common period or certain period from a list of different dataframes of time series, or from a \n#' dataframe. \n#' NOTE: all the dates in the datalist should follow the format in ?as.Date{base}.\n#' @param data A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.\n#' @param startDate A Date showing the start of the extract period, default as NULL, check details.\n#' @param endDate A Date showing the end of the extract period, default as NULL, check details.\n#' @param commonPeriod A boolean showing whether the common period is extracted. If chosen, startDate and endDate\n#' should be NULL.\n#' @param year extract certain year in the entire time series. if you want to extract year 2000, set \\code{year = 2000}\n#' @param month extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, \n#' set \\code{month = c(1, 2)}.\n#' @details \n#' \\strong{startDate and endDate}\n#' \n#' If startDate and endDate are assigned, then certain period between startDate and endDate will be returned, \n#' for both datalist input and dataframe input.\n#' \n#' If startDate and endDate are NOT assigned, then,\n#' \n#' if input is a datalist, the startDate and endDate of the common period of different datalists will be assigned\n#' to the startDate and endDate.\n#' \n#' if input is a dataframe, the startDate and endDate of the input dataframe will be assigned to the startDate\n#' and endDate . Since different value columns share a common Date column in a dataframe input. \n#' \n#' \\strong{year and month}\n#' \n#' For year crossing month input, hyfo will take from the year before. E.g. if \\code{month = c(10, 11, 12, 1)},\n#' and \\code{year = 1999}, hyfo will take month 10, 11 and 12 from year 1998, and month 1 from 1999.You DO NOT \n#' have to set \\code{year = 1998 : 1999}.\n#' \n#' Well, if you set \\code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998,\n#' then, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year.\n#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @return A list or a dataframe with all the time series inside containing the same period.\n#' @examples\n#' # Generate timeseries datalist. Each data frame consists of a Date and a value.\n#' \n#' AAA <- data.frame(\n#' # date column\n#' Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1),\n#' # value column\n#' AAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE))\n#' \n#' BBB <- data.frame(\n#' Date = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), \n#' BBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE))\n#' \n#' CCC <- data.frame(\n#' Date = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), \n#' CCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) \n#' \n#' list <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file.\n#' \n#' list_com <- extractPeriod(list, commonPeriod = TRUE)\n#' \n#' # list_com is the extracted datalist.\n#' str(list_com)\n#' \n#' # If startDate and endDate is provided, the record between them will be extracted.\n#' # make sure startDate is later than any startDate in each dataframe and endDate is \n#' # earlier than any endDate in each dataframe.\n#' \n#' data(testdl)\n#' datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' \n#' dataframe <- list2Dataframe(datalist_com1)\n#' # now we have a dataframe to extract certain months and years.\n#' dataframe_new <- extractPeriod(dataframe, month = c(1,2,3))\n#' dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995)\n#' \n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @importFrom zoo as.Date\n#' @references \n#' \n#' \\itemize{\n#' \\item Achim Zeileis and Gabor Grothendieck (2005). zoo: S3 Infrastructure for Regular and Irregular Time\n#' Series. Journal of Statistical Software, 14(6), 1-27. URL http://www.jstatsoft.org/v14/i06/\n#' }\n#'\n#' @export\nsetGeneric('extractPeriod', function(data, startDate = NULL, endDate = NULL, commonPeriod = FALSE, \n year = NULL, month = NULL) {\n standardGeneric('extractPeriod')\n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('data.frame'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n dataframe <- data\n dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n return(dataset)\n \n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('list'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n datalist <- data\n if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) {\n dataset <- lapply(data, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) {\n \n Dates <- lapply(datalist, extractPeriod_getDate)\n # Here don't know why rbindlist cannot work, change back to do.call\n Dates <- do.call('rbind', Dates)\n \n startDate <- as.Date(max(Dates[, 1]))\n endDate <- as.Date(min(Dates[, 2]))\n \n dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n \n } else {\n stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE')\n }\n return(dataset)\n })\n\n\n\n\nextractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, month = NULL) {\n # to check whether first column is a date format\n if (!grepl('-|/', dataframe[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 dataframe[, 1] <- as.Date(dataframe[, 1])\n \n if (is.null(startDate)) startDate <- dataframe[1, 1]\n if (is.null(endDate)) endDate <- tail(dataframe[, 1], 1)\n \n startIndex <- which(dataframe[, 1] == startDate)\n endIndex <- which(dataframe[, 1] == endDate)\n if (length(startIndex) == 0 | length(endIndex) == 0) {\n stop('startDate and endDate exceeds the date limits in dataframe. Check datalsit please.')\n }\n output <- dataframe[startIndex:endIndex, ]\n \n \n if (!is.null(year)) {\n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n if (is.null(month) || !any(sort(month) != month)) {\n DateIndex <- which(yea %in% year)\n if (length(DateIndex) == 0) stop('No input years in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n \n # if year crossing than sort(month) != month, in this case we need to\n # take months from last year.\n } else {\n \n \n startIndex <- intersect(which(yea == year[1] - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == tail(year, 1)), which(mon == tail(month, 1))), 1)\n \n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n }\n output <- output[startIndex:endIndex, ]\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again. \n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n output <- output[DateIndex, ]\n \n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n \n }\n \n \n if (!is.null(month)) {\n Date <- as.POSIXlt(output[, 1])\n mon <- Date$mon + 1\n \n # %in% can deal with multiple equalities\n DateIndex <- which(mon %in% month)\n \n if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n }\n \n \n return(output) \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#' \n#' \nextractPeriod_getDate <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 start <- as.Date(dataset[1, 1])\n end <- as.Date(tail(dataset[, 1], 1))\n \n \n return(c(start, end))\n }\n\n\n\n", - "created" : 1487522389624.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2600120742", - "id" : "D3DE8C31", - "lastKnownWriteTime" : 1487523614, - "last_content_update" : 1487523614272, - "path" : "~/GitHub/hyfo/R/extractPeriod(generic).R", - "project_path" : "R/extractPeriod(generic).R", - "properties" : { - }, - "relative_order" : 15, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 b/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 deleted file mode 100644 index efc1a17..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/EC7924C8 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Collect data from csv for Anarbe case.\n#' \n#' Collect data from the gauging stations in spain, catchement Anarbe\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param output A boolean showing whether the output is given, default is T.\n#' @return The collected data from different csv files.\n#' @examples\n#' \n#' #use internal data as an example.\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_csv_anarbe(folder)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\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#' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_csv_anarbe <- function(folderName, output = TRUE){\n \n fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE)\n data <- lapply(fileNames, readColumn_csv_anarbe)\n data <- rbindlist(data)\n data <- data[, 1:2]\n # cus the special structure of data.tables, here should be data[[1]], instead of data[, 1]\n data[, 1] <- as.Date(data[[1]], format = '%d/%m/%Y')\n \n #newFileName <- file.choose(new = T)\n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n if (output) return(data)\n}\n\n\nreadColumn_csv_anarbe <- function(fileName){\n data <- read.csv(fileName, skip = 4)\n endIndex <- which(data == '', arr.ind = TRUE)[1]-1\n \n data <- data[1:endIndex, ]\n \n if (!is.null(levels(data[, 2]))) {\n data[, 2] <- as.numeric(levels((data[, 2])))[data[, 2]]\n }\n \n colnames(data) <- c('Date', 'target')\n message(fileName)\n \n return(data)\n}\n\n\n\n#' Collect data from different excel files\n#' \n#' @param folderName A string showing the folder path.\n#' @param keyword A string showing the extracted column, e.g., waterLevel, waterBalance.\n#' @param output A boolean showing whether the output is given.\n#' @return The collected data from different excel files.\n#' @export\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# @importFrom utils write.table\ncollectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){\n \n message('In order to make \"hyfo\" easier to be installed, this part is commented,\n check original R file in your computer or go to \n https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData_excel.R\n for ideas.')\n \n \n # newFileName <- file.choose(new = TRUE)\n # message ('new file should be located a different location than the excel folder, \n # in order to avoid error.\n # At least 2 excels should be in the folder\\n')\n # \n # message ('this function only applies to strange spain dem operation record file, and this strange file changes\n # its format in the middle of the record. For other applications, some tiny changes needs to be made.')\n # if (is.null(keyword)) stop('key word is needed, e.g.\"waterLevel\".')\n # \n # fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n # data <- lapply(fileNames, FUN = readColumn_excel_anarbe, keyword = keyword)\n # checkBind(data, 'rbind')\n # data <- do.call('rbind', data)\n # \n # data_new <- data.frame(data)\n # \n # data_new <- data_new[order(data_new[, 1]), ]\n # \n # \n # startDate <- data_new[1, 1]\n # endDate <- data_new[length(data_new[, 1]), 1]\n # \n # Date <- as.factor(seq(startDate, endDate, by = 1))\n # \n # if (length(Date) != length(data_new[, 1])) stop('check if the excel files are continuous')\n # \n # colnames(data_new) <- c('Date', keyword)\n # \n # write.table(data_new, file = newFileName,\n # row.names = FALSE, col.names = TRUE, sep = ',')\n # if(output == TRUE) return(data_new)\n}\n\n# \n# @importFrom xlsx read.xlsx\n# readTable_excel_anarbe <- function(fileName){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]], 3)\n# raw_year <- index[1]\n# raw_mon <- index[2]\n# \n# raw <- read.xlsx(fileName, sheetName='A')\n# startRow <- which(raw == 'COTA', arr.ind = TRUE)[1]+4\n# startCol <- which(raw == 'COTA',arr.ind = TRUE)[2]-1\n# stopRow <- which(raw =='TOTAL',arr.ind = TRUE)[1]-1\n# stopCol1 <- startCol + 17\n# stopCol2 <- which(raw == 'SUPERFICIE', arr.ind = TRUE)[2]\n# data <- cbind(raw[startRow:stopRow,startCol:stopCol1], raw[startRow:stopRow,stopCol2])\n# \n# \n# yearIndex <- rep(raw_year, stopRow-startRow+1)\n# monIndex <- rep(raw_mon, stopRow-startRow+1)\n# \n# data <- cbind(yearIndex, monIndex, data)\n# return(data)\n# }\n# # \n# @importFrom utils tail\n# readColumn_excel_anarbe <- function(fileName, keyword = NULL){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]],3)\n# year <- as.numeric(index[1])\n# mon <- as.numeric(index[2])\n# \n# if (year == 99) {\n# year = year + 1900\n# } else year = year + 2000\n# \n# word = c('COTA', 'Cota\\n(m)', 'TOTAL', ' TOTAL')\n# \n# if (keyword == 'waterLevel') {\n# searchWord <- c('COTA', 'Cota\\n(m)')\n# } else if (keyword == 'discharge_ERE') {\n# searchWord <- c('AF.ERE-', 'Caudal\\n(m??/s)')\n# } else if (keyword == 'waterBalance') {\n# searchWord <- c('INCREMENTO', 'al Canal Bajo', 'AFORO',\n# 'Variaci??n\\nvolumen embalsado')\n# } else if (keyword == 'surfaceArea') {\n# searchWord <- c('SUPERFICIE', 'SUPERFICIE')\n# } else if (keyword == 'volume') {\n# searchWord <- c('EMBALSADO', 'Volumen\\n(m????)')\n# }\n# \n# \n# if (year == 1999 | year < 2009 | (year == 2009 & mon < 5)) {\n# raw <- xlsx::read.xlsx(fileName, sheetName = 'A')\n# startIndex <- which(raw == word[1], arr.ind = TRUE)\n# endIndex <- which(raw == word[3], arr.ind = TRUE)\n# startRow <- startIndex[1]+4\n# endRow <- endIndex[1]-1\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# \n# targetCol <- which(raw == searchWord[1], arr.ind = TRUE)[2]\n# \n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[3], arr.ind = TRUE)[2]\n# a <- raw[startRow:endRow, targetStart:targetEnd]\n# a <- sapply(a, function(x) as.numeric(levels(x)[x]))\n# \n# if (year == 1999 & mon == 4) {\n# \n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, rep(NA, dim(a)[1]), a[, 6] * 86.4,\n# a[, 4] * 86.4, a[, 11] * 86.4, a[, 3], a[, 7], rep(NA, dim(a)[1]), a[, 1])\n# } else {\n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, a[, 6] * 86.4, a[, 7] * 86.4, \n# a[, 4] * 86.4, a[, 12] * 86.4, a[, 3], a[, 8], rep(NA, dim(a)[1]), a[, 1])\n# } \n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# if (keyword == 'discharge_ERE') target <- as.numeric(levels(target))[target]/1000\n# }\n# \n# } else {\n# raw <- read.xlsx(fileName,sheetName = 'parte del embalse')\n# startIndex <- which(raw == word[2], arr.ind = TRUE)\n# endIndex <- which(raw == word[4], arr.ind = TRUE)\n# startRow <- startIndex[1]+1\n# endRow <- endIndex[1]-2\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# targetCol <- which(raw == searchWord[2], arr.ind=TRUE)[2]\n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[4], arr.ind=TRUE)[2]\n# target <- raw[startRow:endRow, targetStart:targetEnd]\n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# }\n# \n# }\n# \n# \n# startDate <- as.Date(paste(year, mon, day[1], sep = '-'))\n# endDate <- as.Date(paste(year, mon, tail(day,1), sep = '-'))\n# \n# Date <- seq(startDate, endDate, 1)\n# output <- data.frame(Date, as.vector(target))\n# colnames(output) <- c('Date', seq(1, dim(output)[2] - 1))\n# message(fileName) \n# return(output)\n# \n# }\n# \n\n\n\n\n\n#' collect data from different txt.\n#' \n#' @param folderName A string showing the folder path.\n#' @param output A boolean showing whether the result is given.\n#' @param rangeWord A list containing the keyword and the shift. \n#' defaut is set to be used in spain gauging station.\n#' @examples\n#' \n#' #use internal data as an example.\n#' \n#' \\dontrun{\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_txt_anarbe(folder)\n#' }\n#'\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://www4.gipuzkoa.net/oohh/web/esp/02.asp\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#' @source http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n#' @return The collected data from different txt files.\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene ', -1, \n 'Total ', -6)){\n #All the code should be ASCII encode, so there should be no strange symbol.\n if (is.null(rangeWord)) {\n stop('rangeWord consists of 4 elements:\n 1. start word which program can recognise.\n 2. shift1, the shift needs to be made. E.g. start word is in line 7, and program\n should read file from line 9, then shift is 9-7 = 2.\n 3. end word, as start word\n 4. shift2, same as shift1, sometimes can be negative\n \n E.g. rangeWord=c(\\\"aaa\\\",2,\\\"bbb\\\",-2)\n if no rangeWord, just input c(NULL,NULL,NULL,NULL)')\n \n }\n \n \n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n \n data <- lapply(fileNames, FUN = readColumn_txt_anarbe, rangeWord = rangeWord)\n \n data <- rbindlist(data)\n \n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n #newFileName <- file.choose(new = T)\n message('new file should be located a different location than the excel folder,\n in order to avoid error.\n At least 2 excels should be in the folder')\n \n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n \n \n if (output == TRUE) return(data)\n \n} \n\n\n\nanarbe_txt <- function(dataset, x1, x2){\n \n data <- as.matrix(dataset[x1:x2, 2:13])\n startYear <- data[1, 6]\n \n data <- data[5:35, ]\n \n date <- which(data != ' ', arr.ind = TRUE)\n startDate <- date[1, ]\n \n endDate <- date[length(date[, 1]), ]\n \n startDate <- as.Date(paste(startYear, startDate[2], startDate[1], sep = '-'))\n endDate <- as.Date(paste(startYear, endDate[2], endDate[1], sep = '-'))\n \n Date <- as.factor(seq(startDate, endDate, 1))\n \n dim(data) <- c(length(data), 1)\n \n data <- as.numeric(data[which(data != ' '), ])\n \n if (length(data) != length(Date)) {\n stop('check original txt file. for missing value, the symbol is \"--\", check\n if this symbol is missing somewhere')\n }\n \n output <- data.frame(Date = Date, target = data)\n \n return(output)\n }\n\n\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#' @importFrom utils read.fwf\nreadColumn_txt_anarbe <- function(fileName, keyword = NULL, rangeWord = NULL){\n \n a <- read.fwf(fileName, widths = rep(10,13))#read file with fixed width\n \n startRow <- which(a == rangeWord[1], arr.ind = TRUE)[, 1]\n startRow <- startRow + as.numeric(rangeWord[2])\n \n endRow <- which(a == rangeWord[3], arr.ind = TRUE)[, 1]\n endRow <- endRow + as.numeric(rangeWord[4])\n \n data <- mapply(FUN = function(x1, x2) anarbe_txt(dataset = a, x1, x2), startRow, endRow)\n \n data_new <- data.frame(Data = unlist(data[1, ]), target = unlist(data[2, ]))\n message(fileName)\n return(data_new)\n}\n", - "created" : 1487522240065.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "995843390", - "id" : "EC7924C8", - "lastKnownWriteTime" : 1487525974, - "last_content_update" : 1487525974318, - "path" : "~/GitHub/hyfo/R/case_anarbe.R", - "project_path" : "R/case_anarbe.R", - "properties" : { - }, - "relative_order" : 13, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E b/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E deleted file mode 100644 index d69d971..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/EF2B4E +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "contents" : "#' Get variable name of the NetCDF file.\n#' \n#' Get variable name in the NetCDF file. After knowning the name, you can use \\code{loadNcdf} to load\n#' the target variable.\n#' \n#' @param filePath A path pointing to the netCDF file.\n#' @return The names of the varialbes in the file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' }\n#' \n#' \n#' \n#' @export\ngetNcdfVar <- function(filePath) {\n nc <- nc_open(filePath)\n names <- names(nc$var)\n return(names)\n}\n\n\n#' Load NetCDF file\n#' \n#' @param filePath A path pointing to the NetCDF file, version3.\n#' @param varname A character representing the variable name, you can use \\code{getNcdfVar} to\n#' get the basic information about the variables and select the target.\n#' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n# @param drop When the time dimension only have one value, the output data will drop\n# this dimension automatically (\\code{drop = TRUE}), default value is \\code{drop = FALSE}, then time dimension will be added.\n# This argument mainly applies to the later calculations based on hyfo file. If the dimension\n# is dropped, than some calculations may not be processed afterwards. \n#' @param ... Several arguments including Year, month, lon, lat \n#' type in \\code{?downscaleNcdf} for details.You can load while downscale, \n#' and also first load than use \\code{downscaleNcdf} to downscale.\n#' @return A list object from \\code{hyfo} containing the information to be used in the analysis, \n#' or biascorrection.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # you can directly add your downscale information to the argument.\n#' nc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), \n#' lat = c(43.2, 43.7))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \nloadNcdf <- function(filePath, varname, tz = 'GMT', ...) {\n nc <- nc_open(filePath)\n \n var <- nc$var\n # Use name to locate the variable\n call_1 <- as.call(c(\n list(as.name('$'), var, varname)\n ))\n var <- eval(call_1)\n if(is.null(var)) stop('No such variable name, check source file.')\n \n dimNames <- unlist(lapply(1:length(var$dim), function(x) var$dim[[x]]$name))\n \n # Only deals with the most common dimensions, futher dimensions will be added in future.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\n if (length(dimIndex) < 3) stop('Your file has less than 3 dimensions.')\n \n # First needs to identify the variable name, load the right data\n message('Loading data...')\n nc_data <- ncvar_get(nc, var)\n message('Processing...')\n \n gridData <- list()\n gridData$Variable$varName <- varname\n gridData$xyCoords$x <- var$dim[[dimIndex[1]]]$vals\n attributes(gridData$xyCoords$x)$name <- dimNames[dimIndex[1]]\n \n gridData$xyCoords$y <- var$dim[[dimIndex[2]]]$vals\n attributes(gridData$xyCoords$y)$name <- dimNames[dimIndex[2]]\n \n # Time part needs to be taken seperately\n \n timeUnit <- strsplit(var$dim[[dimIndex[3]]]$units, split = ' since')[[1]][1]\n timeDiff <- var$dim[[dimIndex[3]]]$vals\n # To get real time, time since when has to be grabbed from the dataset.\n timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz)\n \n \n# Date <- rep(timeSince, length(timeDiff))\n \n \n unitDic <- data.frame(weeks = 'weeks', days = 'days', hours = 'hours',\n minutes = 'mins', seconds = 'secs')\n \n timeDiff <- as.difftime(timeDiff, units = as.character(unitDic[1, timeUnit]))\n \n# if (grepl('day', timeUnit)) {\n# Date$mday <- Date$mday + timeDiff\n# } else if (grepl('second', timeUnit)) {\n# Date$sec <- Date$sec + timeDiff\n# }\n Date <- timeSince + timeDiff\n \n # data directly loaded from ncdf4 will drop the dimension with only one value.\n # the varsize shows the real dimension, without any dropping.\n dim(nc_data) <- var$varsize \n \n # Right now there is no need to add end Date, in furture, may be added as needed.\n gridData$Dates$start <- as.character(Date)\n \n # Assing data to grid data\n # At leaset should be 3 dimensions, lon, lat, time. So if less than 3, \n \n gridData$Data <- nc_data\n \n attributes(gridData$Data)$dimensions <- dimNames\n \n if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals\n \n gridData$Loaded <- 'by hyfo package, http://yuanchao-xu.github.io/hyfo/'\n nc_close(nc)\n \n output <- downscaleNcdf(gridData, ...)\n \n return(output)\n \n}\n\n\n\n\n#' Downscale NetCDF file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param year A vector of the target year. e.g. \\code{year = 2000}, \\code{year = 1980:2000}\n#' @param month A vector of the target month. e.g. \\code{month = 2}, \\code{month = 3:12}\n#' @param lon A vector of the range of the downscaled longitude, should contain a max value\n#' and a min value. e.g. \\code{lon = c(-1.5, 2,5)}\n#' @param lat A vector of the range of the downscaled latitude, should contain a max value\n#' and a min value. e.g. \\code{lat = c(32,2, 36)}\n#' @return A downscaled hyfo list file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7))\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#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \ndownscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) {\n \n \n if (!is.null(year)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n yearIndex <- Dates$year + 1900\n monIndex <- Dates$mon + 1\n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n \n if (is.null(month) || !any(sort(month) != month)) {\n targetYearIndex <- which(yearIndex %in% year)\n if (length(targetYearIndex) == 0) stop('No input years in the input ts, check your input.')\n \n \n # if year crossing than sort(month) != month\n } else {\n \n startIndex <- intersect(which(yearIndex == year[1] - 1), which(monIndex == month[1]))[1]\n endIndex <- tail(intersect(which(yearIndex == tail(year, 1)), which(monIndex == tail(month, 1))), 1)\n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n } else {\n \n targetYearIndex <- startIndex:endIndex\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again.\n # Only for special cases.\n Dates <- Dates[targetYearIndex]\n yea <- Dates$year + 1900\n mon <- Dates$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n targetYearIndex <- targetYearIndex[DateIndex]\n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n }\n \n gridData$Dates$start <- gridData$Dates$start[targetYearIndex]\n gridData$Dates$end <- gridData$Dates$end[targetYearIndex]\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetYearIndex)\n } \n \n if (!is.null(month)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n monIndex <- Dates$mon + 1\n \n targetMonIndex <- which(monIndex %in% month)\n if (length(targetMonIndex) == 0) stop('Check your input year, it may exceed the years \n in the input dataset.')\n gridData$Dates$start <- gridData$Dates$start[targetMonIndex]\n gridData$Dates$end <- gridData$Dates$end[targetMonIndex]\n \n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex)\n \n }\n \n if (!is.null(lon)) {\n \n lonIndex <- gridData$xyCoords$x\n \n lonI1 <- which(abs(lonIndex - min(lon)) == min(abs(lonIndex - min(lon)), na.rm = TRUE)) \n lonI2 <- which(abs(lonIndex - max(lon)) == min(abs(lonIndex - max(lon)), na.rm = TRUE)) \n \n # take the as large as possible range\n targetLonIndex <- lonI1[length(lonI1)]:lonI2[length(lonI2)]\n if (length(targetLonIndex) == 0) stop('Your input lon is too small, try to expand the \n longitude range.') \n gridData$xyCoords$x <- gridData$xyCoords$x[targetLonIndex]\n lonDim <- grepAndMatch('lon', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, lonDim, targetLonIndex)\n }\n \n \n if (!is.null(lat)) {\n latIndex <- gridData$xyCoords$y\n \n latI1 <- which(abs(latIndex - min(lat)) == min(abs(latIndex - min(lat)), na.rm = TRUE)) \n latI2 <- which(abs(latIndex - max(lat)) == min(abs(latIndex - max(lat)), na.rm = TRUE)) \n \n targetLatIndex <- latI1[length(latI1)]:latI2[length(latI2)]\n \n if (length(targetLonIndex) == 0) stop('Your input lat is too small, try to expand the \n latitude range.') \n gridData$xyCoords$y <- gridData$xyCoords$y[targetLatIndex]\n latDim <- grepAndMatch('lat', attributes(gridData$Data)$dimensions)\n gridData$Data <- chooseDim(gridData$Data, latDim, targetLatIndex)\n }\n \n return(gridData)\n \n}\n\n\n\n\n\n\n\n\n\n\n#' Write to NetCDF file using hyfo list file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param filePath A path of the new NetCDF file, should end with \".nc\"\n#' @param missingValue A number representing the missing value in the NetCDF file, default\n#' is 1e20\n#' #' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n#' @param units A string showing in which unit you are putting in the NetCDF file, it can be \n#' seconds or days and so on. If not specified, the function will pick up the possible largest \n#' time units from \\code{c('weeks', 'days', 'hours', 'mins', 'secs')}\n#' @param version ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.\n#' @param tz time zone, default is \"GMT\"\n#' @return An NetCDF version 3 file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' writeNcdf(nc, 'test.nc')\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' http://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' \n#' }\n#' \n#' \nwriteNcdf <- function(gridData, filePath, missingValue = 1e20, tz = 'GMT', units = NULL, version = 3) {\n \n name <- gridData$Variable$varName\n # First defines dimensions.\n lonName <- attributes(gridData$xyCoords$x)$name\n latName <- attributes(gridData$xyCoords$y)$name\n dimLon <- ncdim_def(lonName, 'degree', gridData$xyCoords$x)\n dimLat <- ncdim_def(latName, 'degree', gridData$xyCoords$y)\n dimMem <- NULL\n if (!is.null(gridData$Members)) {\n dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members))\n }\n \n \n # Time needs to be treated seperately\n dates <- as.POSIXlt(gridData$Dates$start, tz = tz)\n if (is.null(units)) {\n units <- getTimeUnit(dates)\n time <- difftime(dates, dates[1], units = units)\n } else {\n time <- difftime(dates, dates[1], units = units)\n }\n timeUnits <- paste(units, 'since', dates[1])\n # Here time needs to be numeric, as required by ncdf4 package, which is not the same\n # with ncdf\n dimTime <- ncdim_def('time', timeUnits, as.numeric(time))\n \n \n # Depending on whether there is a member part of the dataset.\n # default list\n dimList <- list(dimLon, dimLat, dimTime, dimMem)\n \n # In order to keep the dim list exactly the same with the original one, it needs to be changed.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), attributes(gridData$Data)$dimensions)\n dimIndex <- na.omit(dimIndex)\n \n # Here order is needed, cuz in the procesure above, c('lon', 'lat', 'time', 'member')\n # is the pattern, while actually, attributes(gridData$Data)$dimensions should be the pattern.\n # So here needs an order() to get the wanted result.\n dimList <- dimList[order(dimIndex)]\n \n # delete the NULL list, in order that there is no member part in the data.\n dimList <- Filter(Negate(is.null), dimList)\n # Then difines data\n var <- ncvar_def( name, \"units\", dimList, missingValue)\n \n \n # Here for ncdf4, there is an option to create version 4 ncdf, in future, it\n # may added here.\n if (version == 3) {\n nc <- nc_create(filePath, var) \n } else if (version == 4) {\n nc <- nc_create(filePath, var, force_v4 = TRUE)\n } else {\n stop(\"Which ncdf version you want? Only 3 and 4 can be selected!\")\n }\n \n # This part comes from the library downscaleR, can be deleted if you don't \n # use {ecomsUDG.Raccess}, by adding this, the file can be read by the package {ecomsUDG.Raccess}\n ncatt_put(nc, \"time\", \"standard_name\",\"time\")\n ncatt_put(nc, \"time\", \"axis\",\"T\")\n ncatt_put(nc, \"time\", \"_CoordinateAxisType\",\"Time\")\n #ncatt_put(nc, \"time\", \"_ChunkSize\",1)\n ncatt_put(nc, lonName, \"standard_name\",\"longitude\")\n ncatt_put(nc, lonName, \"_CoordinateAxisType\",\"Lon\")\n ncatt_put(nc, latName, \"standard_name\",\"latitude\")\n ncatt_put(nc, latName, \"_CoordinateAxisType\",\"Lat\")\n if (!is.null(dimMem)){\n ncatt_put(nc, \"member\", \"standard_name\",\"realization\")\n ncatt_put(nc, \"member\", \"_CoordinateAxisType\",\"Ensemble\")\n #att.put.ncdf(nc, \"member\", \"ref\",\"http://www.uncertml.org/samples/realisation\")\n }\n \n \n # This part has to be put\n ncatt_put(nc, 0, \"Conventions\",\"CF-1.4\")\n ncatt_put(nc, 0, 'WrittenBy', 'hyfo(http://yuanchao-xu.github.io/hyfo/)')\n \n #data <- aperm(gridData$Data, dimIndex) no need to do this, in the process above\n # when you define the dimlist, the order of the dimension was fixed.\n data <- gridData$Data\n ncvar_put(nc, name, data)\n nc_close(nc)\n \n}\n\n# For internaluse by writeNcdf\ngetTimeUnit <- function(dates) {\n units <- c('weeks', 'days', 'hours', 'mins', 'secs')\n output <- NULL\n for (unit in units) {\n time <- difftime(dates, dates[1], units = unit)\n rem <- sapply(time, function(x) x%%1)\n if (!any(rem != 0)) {\n output <- unit\n break\n }\n } \n return(output)\n}\n\n\n# Save for future use. \n#' @import ncdf4\n#' @references \n#' David Pierce (2014). ncdf: Interface to Unidata netCDF data files. R package version 1.6.8.\n#' http://CRAN.R-project.org/package=ncdf\ngetExtralDim <- function(...) {\n dimList <- list(...)\n \n \n}\n\n# in order to first grep than match.\n# match only provides for exactly match, \n# dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\ngrepAndMatch <- function(x, table) {\n index <- unlist(lapply(x, function(x) {\n a <- grep(x, table)\n }))\n return(index)\n}", - "created" : 1483880947871.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "2949555972", - "id" : "EF2B4E", - "lastKnownWriteTime" : 1483880994, - "last_content_update" : 1483880994072, - "path" : "~/GitHub/hyfo/R/ncdf.R", - "project_path" : "R/ncdf.R", - "properties" : { - }, - "relative_order" : 10, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 b/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 deleted file mode 100644 index 88f9b86..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/F28DEBD3 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "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{loadNcdf}.\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#' \n#' \\dontrun{\n#' #gridData provided in the package is the result of \\code {loadNcdf}\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#' \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 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 (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#' \n#' \\dontrun{\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#' }\n#' \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#' \n#' \n#' \\dontrun{\n#' data(tgridData)# the result of \\code{\\link{loadNcdf}}\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#' \n#' \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#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n maps <- list(...)\n checkBind(maps, 'rbind')\n data_ggplot <- rbindlist(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 = unique(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" : 1487522683331.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "1053965061", - "id" : "F28DEBD3", - "lastKnownWriteTime" : 1487522720, - "last_content_update" : 1487522720048, - "path" : "~/GitHub/hyfo/R/getSpatialMap.R", - "project_path" : "R/getSpatialMap.R", - "properties" : { - }, - "relative_order" : 18, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 b/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 deleted file mode 100644 index 9426ab6..0000000 --- a/.Rproj.user/D1D10CF6/sdb/per/t/F8BC78A3 +++ /dev/null @@ -1,20 +0,0 @@ -{ - "collab_server" : "", - "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 showNA A boolean representing whether the NA values should be marked, default is TRUE.\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, showNA = TRUE, \n x = NULL, 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 if (showNA == TRUE) {\n missingVLayer <- with(TS, {\n geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black')\n })\n \n mainLayer <- mainLayer + missingVLayer\n }\n \n \n plotLayer <- mainLayer + secondLayer\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\n#' @importFrom data.table rbindlist\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 data_ggplot <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n #data_ggplot <- do.call('rbind', bars)\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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" : 1487441178501.000, - "dirty" : false, - "encoding" : "ASCII", - "folds" : "", - "hash" : "3525693188", - "id" : "F8BC78A3", - "lastKnownWriteTime" : 1487522002, - "last_content_update" : 1487522002916, - "path" : "~/GitHub/hyfo/R/analyzeTS.R", - "project_path" : "R/analyzeTS.R", - "properties" : { - }, - "relative_order" : 11, - "source_on_save" : false, - "source_window" : "", - "type" : "r_source" -} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/11252CE5 b/.Rproj.user/D1D10CF6/sdb/prop/11252CE5 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/11252CE5 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/2461C35 b/.Rproj.user/D1D10CF6/sdb/prop/2461C35 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/2461C35 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/2E17C2F1 b/.Rproj.user/D1D10CF6/sdb/prop/2E17C2F1 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/2E17C2F1 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/2E5A7688 b/.Rproj.user/D1D10CF6/sdb/prop/2E5A7688 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/2E5A7688 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/3ED4EBC5 b/.Rproj.user/D1D10CF6/sdb/prop/3ED4EBC5 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/3ED4EBC5 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/4F48C490 b/.Rproj.user/D1D10CF6/sdb/prop/4F48C490 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/4F48C490 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/522B2964 b/.Rproj.user/D1D10CF6/sdb/prop/522B2964 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/522B2964 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/581924DB b/.Rproj.user/D1D10CF6/sdb/prop/581924DB new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/581924DB @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/5E3135C5 b/.Rproj.user/D1D10CF6/sdb/prop/5E3135C5 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/5E3135C5 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/5F19AB1A b/.Rproj.user/D1D10CF6/sdb/prop/5F19AB1A new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/5F19AB1A @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/614F6C89 b/.Rproj.user/D1D10CF6/sdb/prop/614F6C89 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/614F6C89 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/619E744A b/.Rproj.user/D1D10CF6/sdb/prop/619E744A new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/619E744A @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/62BD4C03 b/.Rproj.user/D1D10CF6/sdb/prop/62BD4C03 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/62BD4C03 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/7C28B417 b/.Rproj.user/D1D10CF6/sdb/prop/7C28B417 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/7C28B417 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/81E308C8 b/.Rproj.user/D1D10CF6/sdb/prop/81E308C8 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/81E308C8 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/8DC54783 b/.Rproj.user/D1D10CF6/sdb/prop/8DC54783 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/8DC54783 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/8F604BF1 b/.Rproj.user/D1D10CF6/sdb/prop/8F604BF1 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/8F604BF1 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/93C6AB2B b/.Rproj.user/D1D10CF6/sdb/prop/93C6AB2B new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/93C6AB2B @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/9E69FDB4 b/.Rproj.user/D1D10CF6/sdb/prop/9E69FDB4 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/9E69FDB4 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/9F226FAC b/.Rproj.user/D1D10CF6/sdb/prop/9F226FAC new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/9F226FAC @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/A698C383 b/.Rproj.user/D1D10CF6/sdb/prop/A698C383 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/A698C383 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/A9ABBFEB b/.Rproj.user/D1D10CF6/sdb/prop/A9ABBFEB new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/A9ABBFEB @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/AC481488 b/.Rproj.user/D1D10CF6/sdb/prop/AC481488 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/AC481488 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/AD39FF43 b/.Rproj.user/D1D10CF6/sdb/prop/AD39FF43 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/AD39FF43 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/B8960C40 b/.Rproj.user/D1D10CF6/sdb/prop/B8960C40 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/B8960C40 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D1BE3A89 b/.Rproj.user/D1D10CF6/sdb/prop/D1BE3A89 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D1BE3A89 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D528021A b/.Rproj.user/D1D10CF6/sdb/prop/D528021A new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D528021A @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D5D2A63B b/.Rproj.user/D1D10CF6/sdb/prop/D5D2A63B new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D5D2A63B @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D64F2EA0 b/.Rproj.user/D1D10CF6/sdb/prop/D64F2EA0 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D64F2EA0 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/D9F093AE b/.Rproj.user/D1D10CF6/sdb/prop/D9F093AE new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/D9F093AE @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/DB22ED13 b/.Rproj.user/D1D10CF6/sdb/prop/DB22ED13 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/DB22ED13 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/E0A1BF84 b/.Rproj.user/D1D10CF6/sdb/prop/E0A1BF84 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/E0A1BF84 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/E2A56787 b/.Rproj.user/D1D10CF6/sdb/prop/E2A56787 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/E2A56787 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/EC53DD5E b/.Rproj.user/D1D10CF6/sdb/prop/EC53DD5E new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/EC53DD5E @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/F74CC49C b/.Rproj.user/D1D10CF6/sdb/prop/F74CC49C new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/F74CC49C @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/F9F4FDA9 b/.Rproj.user/D1D10CF6/sdb/prop/F9F4FDA9 new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/F9F4FDA9 @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/FB3EBAAF b/.Rproj.user/D1D10CF6/sdb/prop/FB3EBAAF new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/prop/FB3EBAAF @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/prop/INDEX b/.Rproj.user/D1D10CF6/sdb/prop/INDEX index 4ffe372..d6e0c82 100644 --- a/.Rproj.user/D1D10CF6/sdb/prop/INDEX +++ b/.Rproj.user/D1D10CF6/sdb/prop/INDEX @@ -1,3 +1,4 @@ +~%2FGitHub%2Fhyfo%2F.travis.yml="3ED4EBC5" ~%2FGitHub%2Fhyfo%2FDESCRIPTION="1BB4BBB4" ~%2FGitHub%2Fhyfo%2FNAMESPACE="3A3983B1" ~%2FGitHub%2Fhyfo%2FNEWS="5B6E4CB4" @@ -5,6 +6,7 @@ ~%2FGitHub%2Fhyfo%2FR%2Farray_dimension.R="224CF03" ~%2FGitHub%2Fhyfo%2FR%2FbiasCorrect(generic).R="7EEE6E30" ~%2FGitHub%2Fhyfo%2FR%2Fcase_anarbe.R="7E5B8828" +~%2FGitHub%2Fhyfo%2FR%2Fclasses.R="2E17C2F1" ~%2FGitHub%2Fhyfo%2FR%2FcollectData.R="31175AC6" ~%2FGitHub%2Fhyfo%2FR%2FextractPeriod(generic).R="2988B998" ~%2FGitHub%2Fhyfo%2FR%2FfillGap.R="1C27F867" @@ -12,8 +14,43 @@ ~%2FGitHub%2Fhyfo%2FR%2FgetEnsemble.R="715D0DA2" ~%2FGitHub%2Fhyfo%2FR%2FgetPreciBar(generic).R="BF639043" ~%2FGitHub%2Fhyfo%2FR%2FgetSpatialMap.R="16BD8E13" +~%2FGitHub%2Fhyfo%2FR%2Flist2dataframe.R="D5D2A63B" ~%2FGitHub%2Fhyfo%2FR%2Fmulti-biasCorrect(generic).R="23571832" ~%2FGitHub%2Fhyfo%2FR%2Fncdf.R="DD613721" +~%2FGitHub%2Fhyfo%2FR%2Freadfolders.R="8DC54783" ~%2FGitHub%2Fhyfo%2FR%2Fresample(generic).R="85BAB51C" +~%2FGitHub%2Fhyfo%2FR%2Fshp2cat.R="2E5A7688" +~%2FGitHub%2Fhyfo%2FR%2Fstartup.R="FB3EBAAF" +~%2FGitHub%2Fhyfo%2FREADME.md="2461C35" +~%2FGitHub%2Fhyfo%2Fman%2FapplyBiasFactor.Rd="D9F093AE" ~%2FGitHub%2Fhyfo%2Fman%2FbiasCorrect.Rd="A5EB009E" +~%2FGitHub%2Fhyfo%2Fman%2FcollectData.Rd="9E69FDB4" +~%2FGitHub%2Fhyfo%2Fman%2FcollectData_csv_anarbe.Rd="F9F4FDA9" +~%2FGitHub%2Fhyfo%2Fman%2FcollectData_excel_anarbe.Rd="A9ABBFEB" +~%2FGitHub%2Fhyfo%2Fman%2FcollectData_txt_anarbe.Rd="AC481488" +~%2FGitHub%2Fhyfo%2Fman%2FdownscaleNcdf.Rd="DB22ED13" +~%2FGitHub%2Fhyfo%2Fman%2FextractPeriod.Rd="9F226FAC" +~%2FGitHub%2Fhyfo%2Fman%2FfillGap.Rd="522B2964" +~%2FGitHub%2Fhyfo%2Fman%2FgetAnnual.Rd="F74CC49C" +~%2FGitHub%2Fhyfo%2Fman%2FgetBiasFactor.Rd="5E3135C5" +~%2FGitHub%2Fhyfo%2Fman%2FgetEnsem_comb.Rd="D64F2EA0" +~%2FGitHub%2Fhyfo%2Fman%2FgetFrcEnsem.Rd="A698C383" +~%2FGitHub%2Fhyfo%2Fman%2FgetHisEnsem.Rd="D528021A" +~%2FGitHub%2Fhyfo%2Fman%2FgetLMom.Rd="11252CE5" +~%2FGitHub%2Fhyfo%2Fman%2FgetMoment.Rd="5F19AB1A" +~%2FGitHub%2Fhyfo%2Fman%2FgetNcdfVar.Rd="B8960C40" +~%2FGitHub%2Fhyfo%2Fman%2FgetPreciBar.Rd="EC53DD5E" +~%2FGitHub%2Fhyfo%2Fman%2FgetPreciBar_comb.Rd="614F6C89" +~%2FGitHub%2Fhyfo%2Fman%2FgetSpatialMap.Rd="93C6AB2B" +~%2FGitHub%2Fhyfo%2Fman%2FgetSpatialMap_comb.Rd="581924DB" +~%2FGitHub%2Fhyfo%2Fman%2FgetSpatialMap_mat.Rd="8F604BF1" +~%2FGitHub%2Fhyfo%2Fman%2Flist2Dataframe.Rd="81E308C8" +~%2FGitHub%2Fhyfo%2Fman%2FloadNcdf.Rd="E2A56787" +~%2FGitHub%2Fhyfo%2Fman%2FplotTS.Rd="4F48C490" +~%2FGitHub%2Fhyfo%2Fman%2FplotTS_comb.Rd="E0A1BF84" +~%2FGitHub%2Fhyfo%2Fman%2Fresample.Rd="D1BE3A89" +~%2FGitHub%2Fhyfo%2Fman%2Fshp2cat.Rd="619E744A" +~%2FGitHub%2Fhyfo%2Fman%2Ftestdl.Rd="7C28B417" ~%2FGitHub%2Fhyfo%2Fman%2FtgridData.Rd="E538DE4" +~%2FGitHub%2Fhyfo%2Fman%2FwriteNcdf.Rd="AD39FF43" +~%2FGitHub%2Fhyfo%2Fvignettes%2Fhyfo.Rmd="62BD4C03" diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/12499DD8 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/12499DD8 new file mode 100644 index 0000000..564dc6b --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/12499DD8 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ncdf.R\n\\name{writeNcdf}\n\\alias{writeNcdf}\n\\title{Write to NetCDF file using hyfo list file}\n\\usage{\nwriteNcdf(gridData, filePath, missingValue = 1e+20, tz = \"GMT\",\n units = NULL, version = 3)\n}\n\\arguments{\n\\item{gridData}{A hyfo list file from \\code{\\link{loadNcdf}}}\n\n\\item{filePath}{A path of the new NetCDF file, should end with \".nc\"}\n\n\\item{missingValue}{A number representing the missing value in the NetCDF file, default\nis 1e20\n#' @param tz A string representing the time zone, default is GMT, if you know what time zone is \nyou can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.}\n\n\\item{tz}{time zone, default is \"GMT\"}\n\n\\item{units}{A string showing in which unit you are putting in the NetCDF file, it can be \nseconds or days and so on. If not specified, the function will pick up the possible largest \ntime units from \\code{c('weeks', 'days', 'hours', 'mins', 'secs')}}\n\n\\item{version}{ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.}\n}\n\\value{\nAn NetCDF version 3 file.\n}\n\\description{\nWrite to NetCDF file using hyfo list file\n}\n\\examples{\n# First open the test NETcDF file.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n\n# Then if you don't know the variable name, you can use \\\\code{getNcdfVar} to get variable name\nvarname <- getNcdfVar(filePath)\n\nnc <- loadNcdf(filePath, varname)\n\n# Then write to your work directory\n\nwriteNcdf(nc, 'test.nc')\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\nEarlier) Format Data Files. R package version 1.14.1.\nhttps://CRAN.R-project.org/package=ncdf4\n\n\\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\nversion 2.2-6. http://meteo.unican.es/ecoms-udg\n\n}\n}\n\n", + "created" : 1488015015739.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1114700098", + "id" : "12499DD8", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/writeNcdf.Rd", + "project_path" : "man/writeNcdf.Rd", + "properties" : { + }, + "relative_order" : 49, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/1F14F77D b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/1F14F77D new file mode 100644 index 0000000..1669eae --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/1F14F77D @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/shp2cat.R\n\\name{shp2cat}\n\\alias{shp2cat}\n\\title{Get a catchment object from selected shape file.}\n\\usage{\nshp2cat(filePath)\n}\n\\arguments{\n\\item{filePath}{A string representing the path of the shape file.}\n}\n\\value{\nA catchment object can be used in \\code{getSpatialMap()}.\n}\n\\description{\nGet a catchment object from selected shape file.\n}\n\\details{\nThis function is based on the package \\code{rgdal} and \\code{sp}, and the output comes from the package \n\\code{sp}\n}\n\\examples{\n#open internal file\nfile <- system.file(\"extdata\", \"testCat.shp\", package = \"hyfo\")\ncatchment <- shp2cat(file)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data\nAbstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=rgdal\n\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1488014912691.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1199630483", + "id" : "1F14F77D", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/shp2cat.Rd", + "project_path" : "man/shp2cat.Rd", + "properties" : { + }, + "relative_order" : 47, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2A6E2BEA b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2A6E2BEA new file mode 100644 index 0000000..1fb51f4 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2A6E2BEA @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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#' \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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 https://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 }\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\n# Since in new version of roxygen2, describeIn was changed, https://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1483875773075.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3009424597", + "id" : "2A6E2BEA", + "lastKnownWriteTime" : 1488015187, + "last_content_update" : 1488015187937, + "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", + "project_path" : "R/biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 2, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2AC49E50 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2AC49E50 new file mode 100644 index 0000000..f955053 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2AC49E50 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ncdf.R\n\\name{downscaleNcdf}\n\\alias{downscaleNcdf}\n\\title{Downscale NetCDF file}\n\\usage{\ndownscaleNcdf(gridData, year = NULL, month = NULL, lon = NULL,\n lat = NULL)\n}\n\\arguments{\n\\item{gridData}{A hyfo list file from \\code{\\link{loadNcdf}}}\n\n\\item{year}{A vector of the target year. e.g. \\code{year = 2000}, \\code{year = 1980:2000}}\n\n\\item{month}{A vector of the target month. e.g. \\code{month = 2}, \\code{month = 3:12}}\n\n\\item{lon}{A vector of the range of the downscaled longitude, should contain a max value\nand a min value. e.g. \\code{lon = c(-1.5, 2,5)}}\n\n\\item{lat}{A vector of the range of the downscaled latitude, should contain a max value\nand a min value. e.g. \\code{lat = c(32,2, 36)}}\n}\n\\value{\nA downscaled hyfo list file.\n}\n\\description{\nDownscale NetCDF file\n}\n\\examples{\n# First open the test NETcDF file.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n\n# Then if you don't know the variable name, you can use \\\\code{getNcdfVar} to get variable name\nvarname <- getNcdfVar(filePath)\n\nnc <- loadNcdf(filePath, varname)\n\n# Then write to your work directory\n\nnc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\nnc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\n\\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\nversion 2.2-6. http://meteo.unican.es/ecoms-udg\n}\n}\n\n", + "created" : 1487956113315.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2788518444", + "id" : "2AC49E50", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/downscaleNcdf.Rd", + "project_path" : "man/downscaleNcdf.Rd", + "properties" : { + }, + "relative_order" : 26, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2F3179D4 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2F3179D4 new file mode 100644 index 0000000..02e91e4 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/2F3179D4 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "# Sample .travis.yml for R projects\n\nlanguage: r\nwarnings_are_errors: true\nsudo: required\ndist: precise\ngroup: edge\nenv:\n global:\n - NOT_CRAN = true\nbefore_install: \n echo \"options(repos = c(CRAN='https://cran.rstudio.com'))\" > ~/.Rprofile\n# - sudo apt-get autoclean\n# - sudo aptitude install libgdal-dev\napt_packages:\n - libnetcdf-dev\n - udunits-bin\n - libudunits2-dev\n - netcdf-bin\n# - libproj-dev\n# - libcurl4-gnutls-dev\n# - libdap-dev\n# - libgdal-dev\n# - libgdal1h\n# - libhdf5-7=1.8.11-3ubuntu1~precise1~ppa1\n# - libhdf5-dev\n# - libhdf5-serial-dev\n# - libgdal-dev\n# - libgdal1-dev\nr_binary_packages:\n - rgdal\n - rgeos\n", + "created" : 1487955784861.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "385747178", + "id" : "2F3179D4", + "lastKnownWriteTime" : 1487955804, + "last_content_update" : 1487955804585, + "path" : "~/GitHub/hyfo/.travis.yml", + "project_path" : ".travis.yml", + "properties" : { + }, + "relative_order" : 20, + "source_on_save" : false, + "source_window" : "", + "type" : "yaml" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/303058FC b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/303058FC new file mode 100644 index 0000000..7cec6da --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/303058FC @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "## For package updates information\n\n#' @importFrom utils packageDescription\nhyfoUpdates <- function(){\n page <- readLines('https://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 \n \n # the first tow digit is the most important part of the version\n version12 <- unlist(strsplit(version, split = \"[.]\"))[1:2]\n version_local12 <- unlist(strsplit(version_local, split = \"[.]\"))[1:2]\n \n sameVersion <- version12 == version_local12\n \n if (any(sameVersion == FALSE)) {\n # generate message\n version_msg <- strsplit(strsplit(page[versionLine], split = '

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

')[[1]]\n infoLine_start <- versionLine + 2\n infoLine_end <- grep('

For historical releases and the introduction of updates about each version', page) - 1\n info_msg <- character()\n for (infoLine in infoLine_start:infoLine_end) {\n info_line <- strsplit(strsplit(page[infoLine], split = '>')[[1]][2], split = '<')[[1]][1]\n if (!is.na(info_line)) info_msg <- c(info_msg, info_line)\n }\n \n install_msg <- 'More details on https://yuanchao-xu.github.io/hyfo/'\n \n message_out <- paste(version_msg, paste(info_msg, collapse = '\\n'), install_msg, sep = '\\n')\n } else message_out <- NULL\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" : 1488018121300.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1326432164", + "id" : "303058FC", + "lastKnownWriteTime" : 1488018146, + "last_content_update" : 1488018146748, + "path" : "~/GitHub/hyfo/R/startup.R", + "project_path" : "R/startup.R", + "properties" : { + }, + "relative_order" : 54, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/3405765E b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/3405765E new file mode 100644 index 0000000..a5daf2c --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/3405765E @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ncdf.R\n\\name{loadNcdf}\n\\alias{loadNcdf}\n\\title{Load NetCDF file}\n\\usage{\nloadNcdf(filePath, varname, tz = \"GMT\", ...)\n}\n\\arguments{\n\\item{filePath}{A path pointing to the NetCDF file, version3.}\n\n\\item{varname}{A character representing the variable name, you can use \\code{getNcdfVar} to\nget the basic information about the variables and select the target.}\n\n\\item{tz}{A string representing the time zone, default is GMT, if you know what time zone is \nyou can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.}\n\n\\item{...}{Several arguments including Year, month, lon, lat \ntype in \\code{?downscaleNcdf} for details.You can load while downscale, \nand also first load than use \\code{downscaleNcdf} to downscale.}\n}\n\\value{\nA list object from \\code{hyfo} containing the information to be used in the analysis, \nor biascorrection.\n}\n\\description{\nLoad NetCDF file\n}\n\\examples{\n# First open the test NETcDF file.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n# Then if you don't know the variable name, you can use \\\\code{getNcdfVar} to get variable name\nvarname <- getNcdfVar(filePath)\n\nnc <- loadNcdf(filePath, varname)\n\n# you can directly add your downscale information to the argument.\nnc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\nnc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), \nlat = c(43.2, 43.7))\n\n# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\nEarlier) Format Data Files. R package version 1.14.1.\nhttps://CRAN.R-project.org/package=ncdf4\n\n\\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\nversion 2.2-6. http://meteo.unican.es/ecoms-udg\n}\n}\n\n", + "created" : 1487956431502.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "431613459", + "id" : "3405765E", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/loadNcdf.Rd", + "project_path" : "man/loadNcdf.Rd", + "properties" : { + }, + "relative_order" : 43, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/390DEBE1 similarity index 100% rename from .Rproj.user/D1D10CF6/sdb/per/t/390DEBE1 rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/390DEBE1 diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/47CB7F65 similarity index 100% rename from .Rproj.user/D1D10CF6/sdb/per/t/47CB7F65 rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/47CB7F65 diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4821267A b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4821267A new file mode 100644 index 0000000..67898d5 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4821267A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/fillGap.R\n\\name{fillGap}\n\\alias{fillGap}\n\\title{Fill gaps in the rainfall time series.}\n\\usage{\nfillGap(dataset, corPeriod = \"daily\")\n}\n\\arguments{\n\\item{dataset}{A dataframe with first column the time, the rest columns are rainfall data of different gauges}\n\n\\item{corPeriod}{A string showing the period used in the correlation computing, \ne.g. daily, monthly, yearly.}\n}\n\\value{\nThe filled dataframe\n}\n\\description{\nFill gaps in the rainfall time series.\n}\n\\details{\nthe gap filler follows the rules below:\n\n 1. The correlation coefficient of every two columns (except time column) is calculated.\nthe correlation coefficient calculation can be based on 'daily', 'monthly', 'annual',\nin each case, the daily data, the monthly mean daily data and annual mean daily data of \neach column will be taken in the correlation calculation.\n\nThen the correlation matrix is got, then based on the matrix, for each column, \nthe 1st, 2nd, 3rd,... correlated column will be got. So if there is missing value in the\ncolumn, it will get data from orderly 1st, 2nd, 3rd column.\n\n 2. The simple linear regress is calculated between every two columns. When generating the\n linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to \n y = a*x.\n \n 3. Gap filling. E.g., on a certain date, there is a missing value in column A, then the\n correlation order is column B, column C, column D, which means A should take values from\n B firstly, if B is also missing data, then C, then D.\n \n Assuming finally value from column C is taken. Then according to step 2, A = a*C, then the\n final value filled in column A is missing_in_A = a*value_in_C, a is the linear coeffcient.\n}\n\\examples{\nb <- read.table(text = ' Date AAA BBB CCC DDD EEE\n49 1999-12-15 24.8 21.4 25.6 35.0 17.4\n50 1999-12-16 NA 0.6 1.5 6.3 2.5\n51 1999-12-17 NA 16.3 20.3 NA 19.2\n52 1999-12-18 13 1.6 NA 6.3 0.0\n53 1999-12-19 10 36.4 12.5 26.8 24.9\n54 1999-12-20 NA 0.0 0.0 0.2 0.0\n55 1999-12-21 0.2 0.0 0.0 0.0 0.0\n56 1999-12-22 0.0 0.0 0.0 0.0 0.0')\n\nb1 <- fillGap(b) # if corPeriod is missing, 'daily' is taken as default.\n\ndata(testdl)\na <- extractPeriod(testdl, commonPeriod = TRUE)\na1 <- list2Dataframe(a)\na2 <- fillGap(a1)\na3 <- fillGap(a1, corPeriod = 'monthly')\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\nGap fiiling method based on correlation and linear regression.\n\n\\itemize{\n\\item Hirsch, Robert M., et al. \"Statistical analysis of hydrologic data.\" Handbook of hydrology. (1992): 17-1.\nSalas, Jose D. \"Analysis and modeling of hydrologic time series.\" Handbook of hydrology 19 (1993): 1-72.\n\n}\n}\n\n", + "created" : 1487956216135.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4132485011", + "id" : "4821267A", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/fillGap.Rd", + "project_path" : "man/fillGap.Rd", + "properties" : { + }, + "relative_order" : 28, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4CAD519F b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4CAD519F new file mode 100644 index 0000000..989002f --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/4CAD519F @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/analyzeTS.R\n\\name{getLMom}\n\\alias{getLMom}\n\\title{get L moment analysis of the input distribution}\n\\usage{\ngetLMom(dis)\n}\n\\arguments{\n\\item{dis}{A distribution, for hydrology usually a time series with only data column without time.}\n}\n\\value{\nThe mean, L-variation, L-skewness and L-kurtosis of the input distribution\n}\n\\description{\nget L moment analysis of the input distribution\n}\n\\examples{\ndis <- seq(1, 100)\ngetLMom(dis)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item J. R. M. Hosking (2015). L-moments. R package, version 2.5. URL:\nhttps://CRAN.R-project.org/package=lmom.\n}\n}\n\n", + "created" : 1487956293261.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1948723556", + "id" : "4CAD519F", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getLMom.Rd", + "project_path" : "man/getLMom.Rd", + "properties" : { + }, + "relative_order" : 34, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/50AB644E b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/50AB644E new file mode 100644 index 0000000..55298c6 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/50AB644E @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getSpatialMap.R\n\\name{getSpatialMap_comb}\n\\alias{getSpatialMap_comb}\n\\title{Combine maps together}\n\\usage{\ngetSpatialMap_comb(..., list = NULL, nrow = 1, x = \"\", y = \"\",\n title = \"\", output = FALSE)\n}\n\\arguments{\n\\item{...}{different maps generated by \\code{getSpatialMap(, output = 'ggplot')}, see details.}\n\n\\item{list}{If input is a list containing different ggplot data, use \\code{list = inputlist}.}\n\n\\item{nrow}{A number showing the number of rows.}\n\n\\item{x}{A string of x axis name.}\n\n\\item{y}{A string of y axis name.}\n\n\\item{title}{A string of the title.}\n\n\\item{output}{A boolean, if chosen TRUE, the output will be given.}\n}\n\\value{\nA combined map.\n}\n\\description{\nCombine maps together\n}\n\\details{\nFor \\code{getSpatialMap_comb}, the maps to be compared should be with same size and resolution, \nin other words, they should be fully overlapped by each other.\n\nIf they have different resolutions, use \\code{interpGridData{ecomsUDG.Raccess}} to interpolate.\n}\n\\examples{\n\n\n\\dontrun{\ndata(tgridData)# the result of \\\\code{\\\\link{loadNcdf}}\n#The output should be 'ggplot'\na1 <- getSpatialMap(tgridData, method = 'summer', output = 'ggplot', name = 'a1')\na2 <- getSpatialMap(tgridData, method = 'winter', output = 'ggplot', name = 'a2')\na3 <- getSpatialMap(tgridData, method = 'mean', output = 'ggplot', name = 'a3')\na4 <- getSpatialMap(tgridData, method = 'max', output = 'ggplot', name = 'a4')\ngetSpatialMap_comb(a1, a2)\n\n# or you can put them into a list.\ngetSpatialMap_comb(list = list(a1, a2), nrow = 2)\n}\n\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n}\n}\n\n", + "created" : 1487956380629.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1689511535", + "id" : "50AB644E", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getSpatialMap_comb.Rd", + "project_path" : "man/getSpatialMap_comb.Rd", + "properties" : { + }, + "relative_order" : 40, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/52476E6A b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/52476E6A new file mode 100644 index 0000000..8ab2859 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/52476E6A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "\nreadData_folder <- function(folderName, keyword) {\n \n folderName <- paste(folderName, keyword, sep = '\\\\')\n \n fileNames <- list.files(folderName, pattern = '*.csv', full.names = TRUE)\n \n if (length(fileNames)==0) {\n fileNames <- list.files(folderName, pattern = '.TXT', full.names = TRUE)\n if (length(fileNames)==0) stop('Wrong keyword, initial has to be Upper-case')\n \n data <- collectData_txt_anarbe(folderName, rangeWord = c('D?a ', -1, 'M?x. ', -5))\n rownames(data) <- NULL\n } else {\n data <- collectData_csv_anarbe(folderName)\n }\n \n return(data)\n}\n\n\n# @importFrom utils choose.dir\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 https://www.R-project.org/.\n#' }\n#' \n\nreadData <- function(keyword, folderName) {\n message('This function is only windows based, if you are using windows platform (real\n operational system, not virtual machine), and want to use this function, please\n contact the author (xuyuanchao37@gmail.com) for the windows version.')\n# message('Choose the main folder that, in it, there are different folders representing different gauging stations,\n# all the gauging stations have precipitation data, some of them also have discharge data,\n# this function is to open different gauging folders and read the data, arragen them together.')\n# message('\\n\\n\n# new file is a list based file and needs to be read by dget()')\n \n# fileNames <- list.files(folderName, full.names = TRUE)\n# data <- lapply(fileNames, FUN = readData_folder, keyword = keyword)\n# \n# names <- sapply(c(1:length(data)), function(x) colnames(data[[x]])[2])\n# names(data) <- names\n# \n# fileName <- file.choose(new = TRUE)\n# dput(data, file = fileName)\n# \n# return(data)\n}\n", + "created" : 1488018081708.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "392692864", + "id" : "52476E6A", + "lastKnownWriteTime" : 1488018115, + "last_content_update" : 1488018115819, + "path" : "~/GitHub/hyfo/R/readfolders.R", + "project_path" : "R/readfolders.R", + "properties" : { + }, + "relative_order" : 52, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/61DE20F2 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/61DE20F2 new file mode 100644 index 0000000..b40f0ad --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/61DE20F2 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getSpatialMap.R\n\\name{getSpatialMap}\n\\alias{getSpatialMap}\n\\title{Get spatial map of the input dataset.}\n\\usage{\ngetSpatialMap(dataset, method = NULL, member = \"mean\", ...)\n}\n\\arguments{\n\\item{dataset}{A list containing different information, should be the result of reading netcdf file using\n\\code{loadNcdf}.}\n\n\\item{method}{A string showing different calculating method for the map. More information please refer to\ndetails.}\n\n\\item{member}{A number showing which member is selected to get, if the dataset has a \"member\" dimension. Default\nis NULL, if no member assigned, and there is a \"member\" in dimensions, the mean value of the members will be\ntaken.}\n\n\\item{...}{several arguments including x, y, title, catchment, point, output, name, info, scale, color, \ntype in \\code{?getSpatialMap_mat} for details.}\n}\n\\value{\nA matrix representing the raster map is returned, and the map is plotted.\n}\n\\description{\nGet spatial map of the input dataset.\n}\n\\details{\nThere 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.\nMonth(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}\n\\examples{\n\n\n\\dontrun{\n#gridData provided in the package is the result of \\\\code {loadNcdf}\ndata(tgridData)\ngetSpatialMap(tgridData, method = 'meanAnnual')\ngetSpatialMap(tgridData, method = 'winter')\n\n\ngetSpatialMap(tgridData, method = 'winter', catchment = testCat)\n\nfile <- system.file(\"extdata\", \"point.txt\", package = \"hyfo\")\npoint <- read.table(file, header = TRUE, sep = ',' )\ngetSpatialMap(tgridData, method = 'winter', catchment = testCat, point = point)\n}\n\n\n# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n\n}\n\n", + "created" : 1487956375440.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3319896544", + "id" : "61DE20F2", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getSpatialMap.Rd", + "project_path" : "man/getSpatialMap.Rd", + "properties" : { + }, + "relative_order" : 39, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6511719A b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6511719A new file mode 100644 index 0000000..7e9b50d --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6511719A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Fill gaps in the rainfall time series.\n#'\n#' @param dataset A dataframe with first column the time, the rest columns are rainfall data of different gauges\n#' @param corPeriod A string showing the period used in the correlation computing, \n#' e.g. daily, monthly, yearly.\n#' @return The filled dataframe\n#' @details\n#' the gap filler follows the rules below:\n#' \n#' 1. The correlation coefficient of every two columns (except time column) is calculated.\n#' the correlation coefficient calculation can be based on 'daily', 'monthly', 'annual',\n#' in each case, the daily data, the monthly mean daily data and annual mean daily data of \n#' each column will be taken in the correlation calculation.\n#' \n#' Then the correlation matrix is got, then based on the matrix, for each column, \n#' the 1st, 2nd, 3rd,... correlated column will be got. So if there is missing value in the\n#' column, it will get data from orderly 1st, 2nd, 3rd column.\n#' \n#' 2. The simple linear regress is calculated between every two columns. When generating the\n#' linear coefficient, the incept should be force to 0. i.e. y = a*x + b should be forec to \n#' y = a*x.\n#' \n#' 3. Gap filling. E.g., on a certain date, there is a missing value in column A, then the\n#' correlation order is column B, column C, column D, which means A should take values from\n#' B firstly, if B is also missing data, then C, then D.\n#' \n#' Assuming finally value from column C is taken. Then according to step 2, A = a*C, then the\n#' final value filled in column A is missing_in_A = a*value_in_C, a is the linear coeffcient.\n#' \n#' @examples\n#' b <- read.table(text = ' Date AAA BBB CCC DDD EEE\n#' 49 1999-12-15 24.8 21.4 25.6 35.0 17.4\n#' 50 1999-12-16 NA 0.6 1.5 6.3 2.5\n#' 51 1999-12-17 NA 16.3 20.3 NA 19.2\n#' 52 1999-12-18 13 1.6 NA 6.3 0.0\n#' 53 1999-12-19 10 36.4 12.5 26.8 24.9\n#' 54 1999-12-20 NA 0.0 0.0 0.2 0.0\n#' 55 1999-12-21 0.2 0.0 0.0 0.0 0.0\n#' 56 1999-12-22 0.0 0.0 0.0 0.0 0.0')\n#' \n#' b1 <- fillGap(b) # if corPeriod is missing, 'daily' is taken as default.\n#' \n#' data(testdl)\n#' a <- extractPeriod(testdl, commonPeriod = TRUE)\n#' a1 <- list2Dataframe(a)\n#' a2 <- fillGap(a1)\n#' a3 <- fillGap(a1, corPeriod = 'monthly')\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @references\n#' Gap fiiling method based on correlation and linear regression.\n#' \n#' \\itemize{\n#' \\item Hirsch, Robert M., et al. \"Statistical analysis of hydrologic data.\" Handbook of hydrology. (1992): 17-1.\n#' Salas, Jose D. \"Analysis and modeling of hydrologic time series.\" Handbook of hydrology 19 (1993): 1-72.\n#' \n#' }\n#' \n#' \n#' @export\nfillGap <- function(dataset, corPeriod = 'daily') {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n data <- data.frame(dataset[, 2:dim(dataset)[2]])\n names <- colnames(data)\n \n corN <- fillGap_cor(data, corPeriod = corPeriod, Date = Date)\n cat('\\nCorrelation Coefficient\\n')\n print(corN)\n \n corOrder <- apply(corN, MARGIN = 1, FUN = function(x) order(-x))\n corOrder <- corOrder[2:dim(corOrder)[1], ]\n corOrderName <- t(apply(corOrder, MARGIN = 2, FUN = function(x) names[x]))\n \n cat('\\nCorrelation Order\\n')\n colnames(corOrderName) <- seq(1 : dim(corOrderName)[2])\n print(corOrderName)\n \n lmCoef <- fillGap_lmCoef(data, corOrder)\n cat('\\nLinear Coefficients\\n')\n rownames(lmCoef) <- seq(1 : dim(corOrderName)[2])\n print(t(lmCoef))\n \n output <- lapply(1:dim(data)[2], fillGap_column, data = data,\n corOrder = corOrder, lmCoef = lmCoef)\n output <- data.frame(output)\n colnames(output) <- names\n \n output <- cbind(Date, output)\n \n return(output)\n}\n\n\n#' Get monthly rainfall\n#' \n#' @param TS A rainfall time series.\n#' @param year A list showing the year index of the time series.\n#' @param mon A list showing the mon index of the time series.\n#' @return the monthly rainfall matrix of the rainfall time series.\nmonthlyPreci <- function(TS, year, mon) {\n \n # monthly daily mean is used in order not to affected by missing values.\n monTS <- tapply(TS, INDEX = list(year, mon), FUN = mean, na.rm = TRUE)\n output <- t(monTS)\n dim(output) <- c(dim(monTS)[1] * dim(monTS)[2], 1)\n return(output)\n}\n\n\nfillGap_column <- function(i, data, corOrder, lmCoef) {\n TS <- data[, i] # extract target column\n l <- dim(data)[2] # length\n \n for (j in 1:l) {\n if (!any(is.na(TS))) break\n NAindex <- which(is.na(TS))\n TS[NAindex] <- round(lmCoef[j, i] * data[NAindex, corOrder[j, i]], 3)\n \n if (j == l) stop('Error: One time consists of all NA values')\n }\n \n return(TS)\n}\n\n\n#' @importFrom stats cor na.omit\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 https://www.R-project.org/.\n#' }\n#' \n#' \n\nfillGap_cor <- function(data, corPeriod = 'daily', Date) {\n \n names <- colnames(data)\n year <- format(Date, '%Y')\n \n if (corPeriod == 'monthly') {\n #based on monthly rainfall\n mon <- format(Date, '%m')\n monthlyPreci <- lapply(data, FUN = monthlyPreci, year = year, mon = mon)\n corData <- do.call('cbind', monthlyPreci)\n } else if (corPeriod == 'yearly') {\n year <- format(Date, '%Y')\n # yearly daily mean is used in order not to affected by missing values.\n annualPreci <- lapply(data, FUN = function(x) tapply(x, INDEX = year, FUN = mean, na.rm = TRUE))\n corData <- do.call('cbind', annualPreci)\n } else if (corPeriod == 'daily') {\n corData <- data\n } else {\n stop('Pleas choose among \"daily\", \"monthly\", \"yearly\".')\n }\n \n corData <- data.frame(na.omit(corData))\n colnames(corData) <- names\n \n corN <- cor(corData)\n \n return(corN)\n \n} \n\n#' @importFrom utils combn\n#' @importFrom stats coef lm\n#' @references \n#' R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n#' \nfillGap_lmCoef <- function(data, corOrder) {\n l <- dim(data)[2]\n m <- diag(l)# m is the coeficients matrix\n m[lower.tri(m)] <- combn(data, 2, function(x) coef(lm(x[, 2] ~ x[, 1] + 0)))\n tm <- t(m)\n \n tm[lower.tri(tm)] <- combn(data, 2, function(x) coef(lm(x[, 1] ~ x[, 2] + 0)))\n \n m <- t(tm)\n \n lmCoef <- lapply(1 : l, function(x) m[x,corOrder[, x]])\n lmCoef <- do.call('rbind', lmCoef)\n rownames(lmCoef) <- colnames(data)\n \n return(t(lmCoef))\n}\n\n", + "created" : 1487522438368.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2101638457", + "id" : "6511719A", + "lastKnownWriteTime" : 1488015924, + "last_content_update" : 1488015924965, + "path" : "~/GitHub/hyfo/R/fillGap.R", + "project_path" : "R/fillGap.R", + "properties" : { + }, + "relative_order" : 16, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/666D46C7 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/666D46C7 new file mode 100644 index 0000000..c50e81f --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/666D46C7 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getPreciBar(generic).R\n\\name{getPreciBar_comb}\n\\alias{getPreciBar_comb}\n\\title{Combine bars together}\n\\usage{\ngetPreciBar_comb(..., list = NULL, nrow = 1, x = \"\", y = \"\",\n title = \"\", output = FALSE)\n}\n\\arguments{\n\\item{...}{different barplots generated by \\code{getPreciBar(, output = 'ggplot')}, refer to details.}\n\n\\item{list}{If input is a list containing different ggplot data, use l\\code{list = inputlist}.\nNOTE: yOU HAVE TO PUT A \\code{list = }, before your list.}\n\n\\item{nrow}{A number showing the number of rows.}\n\n\\item{x}{A string of x axis name.}\n\n\\item{y}{A string of y axis name.}\n\n\\item{title}{A string of the title.}\n\n\\item{output}{A boolean, if chosen TRUE, the output will be given.}\n}\n\\value{\nA combined barplot.\n}\n\\description{\nCombine bars together\n}\n\\details{\n..., representing different ouput generated by \\code{getPreciBar(, output = 'ggplot')}, they \nhave to be of the same type, e.g., \n1. Jan precipitation of different years, Feb precipitation of different years, and... \nThey are both monthly precipitation, and they share x axis.\n\n2. Mean monthly precipitation of different dataset. e.g., long term mean monthly precipitation\nand short term mean monthly precipitation. They are both mean monthly precipitation.\n}\n\\examples{\n\ndata(tgridData)# the result of \\\\code{\\\\link{loadNcdf}}\n#output type of getPreciBar() has to be 'ggplot'.\nb1 <- getPreciBar(tgridData, method = 2, output = 'ggplot', name = 'b1')\nb2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2')\n\ngetPreciBar_comb(b1, b2)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n}\n}\n\n", + "created" : 1487956369629.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "360658630", + "id" : "666D46C7", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getPreciBar_comb.Rd", + "project_path" : "man/getPreciBar_comb.Rd", + "properties" : { + }, + "relative_order" : 38, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6DDA2A7B b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6DDA2A7B new file mode 100644 index 0000000..475bdd1 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6DDA2A7B @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' data(testdl)\n#' TS <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \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 https://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\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n ...) {\n standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n TS <- getPreciBar.list(data, cell, member)\n # for hyfo file, in order to process the data, year and month index need to be provided.\n startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n yearIndex <- startTime$year + 1900\n monthIndex <- startTime$mon + 1\n \n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n monthIndex, ...)\n return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n Date <- as.POSIXlt(TS[, 1])\n yearIndex <- Date$year + 1900\n monthIndex <- Date$mon + 1\n TS <- getPreciBar.TS(data)\n result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n yearIndex, monthIndex, ...)\n return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n #check input dataset\n checkHyfo(dataset)\n \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 if (identical(cell, 'mean')) {\n TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n } else {\n TS <- data[cell[1], cell[2], ]\n }\n \n return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\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 return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n yearIndex = NULL, monthIndex = NULL, ...) {\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\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{\\link{loadNcdf}}\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 https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ggplot2\n#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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" : 1483876772702.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "399598286", + "id" : "6DDA2A7B", + "lastKnownWriteTime" : 1488015924, + "last_content_update" : 1488015924767, + "path" : "~/GitHub/hyfo/R/getPreciBar(generic).R", + "project_path" : "R/getPreciBar(generic).R", + "properties" : { + }, + "relative_order" : 7, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6FE223B b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6FE223B new file mode 100644 index 0000000..e04b29e --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/6FE223B @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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, https://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" : 1488015182774.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2581869872", + "id" : "6FE223B", + "lastKnownWriteTime" : 1488015188, + "last_content_update" : 1488015188093, + "path" : "~/GitHub/hyfo/R/classes.R", + "project_path" : "R/classes.R", + "properties" : { + }, + "relative_order" : 50, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/80C39737 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/80C39737 new file mode 100644 index 0000000..e65cbe9 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/80C39737 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "---\ntitle: '[hyfo Easy Start](https://yuanchao-xu.github.io/hyfo/)'\nauthor: '[Yuanchao Xu](https://dk.linkedin.com/in/xuyuanchao37)'\ndate: '`r Sys.Date()`'\noutput: \n pdf_document:\n toc: yes\n toc_depth: 3\n html_document:\n toc: yes\nvignette: > \n %\\VignetteIndexEntry{hyfo easy start} \n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{ASCII}\n---\n\n# Introduction\n\n**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo), where manuals and more details can be found.**\n\nhyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate.\n\nThis package mainly focuses on data process and visulization in hydrology and climate forecasting. Main function includes NetCDF file processing, data extraction, data downscaling, data resampling, gap filler of precipitation, bias correction of forecasting data, flexible time series plot, and spatial map generation. It is a good pre-processing and post-processing tool for hydrological and hydraulic modellers.\n\n**If you feel hyfo is of a little help, please cite it as following:**\n\nXu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from https://yuanchao-xu.github.io/hyfo/\n\n\n#### TIPS\n* For the hydrology tools part, the minimum time unit is a day, i.e., it mainly focuses on water resource and some long term analysis. For flood analysis part, it will be added in future.\n\n\n* One important characteristic by which hyfo can be distinguished from others is its convenience in multiple plots and series plots. Most data visualization tool in hyfo provides the output that can be directly re-plot by `ggplot2`, if `output = 'ggplot'` is assigned in the argument of the function, which will be easier for the users to generated series/multiple plots afterwards. When `output = 'ggplot'` is selected, you also have to assigne a `name = 'yourname'` in the argument, for the convenience of generating multiplots in future. All the functions ending with `_comb` can generated series/multiple plots, details can be found in the user mannual. \n\n\n* For the forecasting tools part, `hyfo` mainly focuses on the post processing of the gridData derived from forecasts or other sources. The input is a list file, usually an NetCDF file. There are `getNcdfVar()`, `loadNcdf()` and `writeNcdf()` prepared in hyfo, for you to deal with NetCDF file. \n\n* If you don't like the tile, x axis, y axis of the plot, just set them as '', e.g. `title = ''`\n\n* For R beginners, R provides different functions to write to file. `write.table` is a popular choice, and after write the results to a file, you can directly copy paste to your model or to other uses.\n\n* The functions end with `_anarbe` are the functions designed specially for some case in Spain, those functions mostly are about data collection of the anarbe catchment, which will be introduced in the end of this mannual.\n", + "created" : 1488018162434.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1977312637", + "id" : "80C39737", + "lastKnownWriteTime" : 1488018183, + "last_content_update" : 1488018183932, + "path" : "~/GitHub/hyfo/vignettes/hyfo.Rmd", + "project_path" : "vignettes/hyfo.Rmd", + "properties" : { + }, + "relative_order" : 56, + "source_on_save" : false, + "source_window" : "", + "type" : "r_markdown" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/819D4E19 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/819D4E19 new file mode 100644 index 0000000..9f9767e --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/819D4E19 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/collectData.R\n\\name{collectData}\n\\alias{collectData}\n\\title{Collect data from different csv files.}\n\\usage{\ncollectData(folderName, fileType = NULL, range = NULL, sheetIndex = 1)\n}\n\\arguments{\n\\item{folderName}{A string showing the path of the folder holding different csv files.}\n\n\\item{fileType}{A string showing the file type, e.g. \"txt\", \"csv\", \"excel\".}\n\n\\item{range}{A vector containing startRow, endRow, startColumn, endColumn, e.g., \nc(2,15,2,3)}\n\n\\item{sheetIndex}{A number showing the sheetIndex in the excel file, if fileType is excel,\nsheetIndex has to be provided, default is 1.}\n}\n\\value{\nThe collected data from different files in the folder.\n}\n\\description{\nCollect data from different csv files.\n}\n\\examples{\n\n#use internal data as an example.\nfolder <- file.path(path.package(\"hyfo\"), 'extdata')\n# file may vary with different environment, it if doesn't work, use local way to get\n# folder path.\n\na <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2))\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\n", + "created" : 1487955954255.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1044217710", + "id" : "819D4E19", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/collectData.Rd", + "project_path" : "man/collectData.Rd", + "properties" : { + }, + "relative_order" : 22, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/882400E4 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/882400E4 new file mode 100644 index 0000000..0527428 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/882400E4 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "\n\n\n\n#' Get bias factor for multi/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method. \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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 https://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 }\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#' @rdname 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#' @rdname 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/operational/real time bias correction.\n#' \n#' When you do multi/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#' @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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' #' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \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 scaling\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 https://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 }\n#' \n#' @export\nsetGeneric('applyBiasFactor', function(frc, biasFactor, obs = NULL) {\n standardGeneric('applyBiasFactor')\n})\n\n#' @rdname 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#' @rdname 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 <- grepAndMatch('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 <- grepAndMatch('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" : 1483876652911.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1721961410", + "id" : "882400E4", + "lastKnownWriteTime" : 1488017859, + "last_content_update" : 1488017859911, + "path" : "~/GitHub/hyfo/R/multi-biasCorrect(generic).R", + "project_path" : "R/multi-biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 5, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/8E431305 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/8E431305 new file mode 100644 index 0000000..0afb3cc --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/8E431305 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/case_anarbe.R\n\\name{collectData_csv_anarbe}\n\\alias{collectData_csv_anarbe}\n\\title{Collect data from csv for Anarbe case.}\n\\source{\nhttp://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n}\n\\usage{\ncollectData_csv_anarbe(folderName, output = TRUE)\n}\n\\arguments{\n\\item{folderName}{A string showing the path of the folder holding different csv files.}\n\n\\item{output}{A boolean showing whether the output is given, default is T.}\n}\n\\value{\nThe collected data from different csv files.\n}\n\\description{\nCollect data from the gauging stations in spain, catchement Anarbe\n}\n\\examples{\n\n#use internal data as an example.\nfile <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\nfolder <- strsplit(file, '1999')[[1]][1]\na <- collectData_csv_anarbe(folder)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1487955962873.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1757137851", + "id" : "8E431305", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/collectData_csv_anarbe.Rd", + "project_path" : "man/collectData_csv_anarbe.Rd", + "properties" : { + }, + "relative_order" : 23, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/90EB6DDD b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/90EB6DDD new file mode 100644 index 0000000..7cf6b4a --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/90EB6DDD @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getEnsemble.R\n\\name{getFrcEnsem}\n\\alias{getFrcEnsem}\n\\title{Extract time series from forecasting data.}\n\\usage{\ngetFrcEnsem(dataset, cell = \"mean\", plot = \"norm\", output = \"data\",\n name = NULL, mv = 0, coord = NULL, ...)\n}\n\\arguments{\n\\item{dataset}{A list containing different information, should be the result of \\code{\\link{loadNcdf}}}\n\n\\item{cell}{A vector containing the locaton of the cell, e.g. c(2, 3), default is \"mean\", representing\nthe spatially averaged value. Check details for more information.}\n\n\\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.}\n\n\\item{output}{A string showing which type of output you want. Default is \"data\", if \"ggplot\", the \ndata that can be directly plotted by ggplot2 will be returned, which is easier for you to make series\nplots afterwards. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\nbe replaced by \\code{mv}, if assigned, default mv is 0.}\n\n\\item{name}{If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\ndifferent outputs in the later multiplot using \\code{getEnsem_comb}.}\n\n\\item{mv}{A number showing representing the missing value. When calculating the cumulative value, \nmissing value will be replaced by mv, default is 0.}\n\n\\item{coord}{A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned,\ncell argument will no longer be used.}\n\n\\item{...}{\\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}}\n}\n\\value{\nA ensemble time series extracted from forecating data.\n}\n\\description{\ngetFrcEnsem extract timeseries from forecasting data, if forecasting data has a member session\nan ensemble time sereis will be returned, if forecasting data doesn't have a member session, a singe time\nseries will be returned.\n}\n\\details{\n\\code{cell} representing the location of the cell, NOTE: this location means the index of the cell,\nIT IS NOT THE LONGITUDE AND LATITUDE. e.g., \\code{cell = c(2, 3)}, the program will take the 2nd longitude\nand 3rd latitude, by the increasing order. Longitude comes first.\n\n\\code{name}\nAssuming you have two ggplot outputs, you want to plot them together. In this situation, you\nneed a name column to differentiate one ggplot output from the other. You can assigne this name\nby the argument directly, If name is not assigned and \\code{output = 'ggplot'} is selected, then\nthe system time will be selected as name column.\n}\n\\examples{\n\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n# Then if you don't know the variable name, you can use \\\\code{getNcdfVar} to get variable name\nvarname <- getNcdfVar(filePath)\nnc <- loadNcdf(filePath, varname)\na <- getFrcEnsem(nc)\n\n# If there is no member session in the dataset, a single time sereis will be extracted.\na1 <- getFrcEnsem(tgridData)\n\n\n# The default output is spatially averaged, if there are more than one cells in the dataset, \n# the mean value of the cells will be calculated. While if you are interested in special cell, \n# you can assign the cell value. You can also directly use longitude and latitude to extract \n# time series.\n\ngetSpatialMap(nc, 'mean')\na <- getFrcEnsem(nc, cell = c(6,2))\n\n# From the map, cell = c(6, 2) means lon = -1.4, lat = 43.2, so you can use corrd to locate\n# your research area and extract time series.\nb <- getFrcEnsem(nc, coord = c(-1.4, 43.2))\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n\\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/.\n\\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\nstatistical downscaling. R package version 0.6-0.\nhttps://github.com/SantanderMetGroup/downscaleR/wiki\n}\n}\n\n", + "created" : 1487956260627.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "124886659", + "id" : "90EB6DDD", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getFrcEnsem.Rd", + "project_path" : "man/getFrcEnsem.Rd", + "properties" : { + }, + "relative_order" : 32, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/92757319 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/92757319 new file mode 100644 index 0000000..06e95c7 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/92757319 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/case_anarbe.R\n\\name{collectData_txt_anarbe}\n\\alias{collectData_txt_anarbe}\n\\title{collect data from different txt.}\n\\source{\nhttp://www4.gipuzkoa.net/oohh/web/esp/02.asp\n}\n\\usage{\ncollectData_txt_anarbe(folderName, output = TRUE,\n rangeWord = c(\"Ene \", -1, \"Total \", -6))\n}\n\\arguments{\n\\item{folderName}{A string showing the folder path.}\n\n\\item{output}{A boolean showing whether the result is given.}\n\n\\item{rangeWord}{A list containing the keyword and the shift. \ndefaut is set to be used in spain gauging station.}\n}\n\\value{\nThe collected data from different txt files.\n}\n\\description{\ncollect data from different txt.\n}\n\\examples{\n \n#use internal data as an example.\n\n\\dontrun{\nfile <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\nfolder <- strsplit(file, '1999')[[1]][1]\na <- collectData_txt_anarbe(folder)\n}\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1487956065089.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3252535590", + "id" : "92757319", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/collectData_txt_anarbe.Rd", + "project_path" : "man/collectData_txt_anarbe.Rd", + "properties" : { + }, + "relative_order" : 25, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9A428717 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9A428717 new file mode 100644 index 0000000..d65b23c --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9A428717 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Resample your time series or ncdf files.\n#' \n#' Resameple your time series or ncdf files, more info pleae see details.\n#' \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#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \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 https://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 https://www.R-project.org/.\n#' }\n#' \nsetGeneric('resample', function(data, method) {\n standardGeneric('resample')\n})\n\n\n#' @rdname resample\nsetMethod('resample', signature('data.frame'),\n function(data, method) {\n result <- resample.TS(data, method)\n return(result)\n })\n\n#' @rdname 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\n#' @importFrom data.table rbindlist\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 <- rbindlist(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 https://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" : 1483876700794.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3646914081", + "id" : "9A428717", + "lastKnownWriteTime" : 1488018115, + "last_content_update" : 1488018115688, + "path" : "~/GitHub/hyfo/R/resample(generic).R", + "project_path" : "R/resample(generic).R", + "properties" : { + }, + "relative_order" : 6, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9CAB49AF b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9CAB49AF new file mode 100644 index 0000000..f23fe99 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9CAB49AF @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/analyzeTS.R\n\\name{plotTS}\n\\alias{plotTS}\n\\title{plot time series, with marks on missing value.}\n\\usage{\nplotTS(..., type = \"line\", output = \"data\", plot = \"norm\", name = NULL,\n showNA = TRUE, x = NULL, y = NULL, title = NULL, list = NULL)\n}\n\\arguments{\n\\item{...}{input time series.}\n\n\\item{type}{A string representing the type of the time series, e.g. 'line' or 'bar'.}\n\n\\item{output}{A string showing which type of output you want. Default is \"data\", if \"ggplot\", the \ndata that can be directly plotted by ggplot2 will be returned, which is easier for you to make series\nplots afterwards.}\n\n\\item{plot}{representing the plot type, there are two types, \"norm\" and \"cum\", \"norm\" gives an normal\nplot, and \"cum\" gives a cumulative plot. Default is \"norm\".}\n\n\\item{name}{If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\ndifferent outputs in the later multiplot using \\code{plotTS_comb}.}\n\n\\item{showNA}{A boolean representing whether the NA values should be marked, default is TRUE.}\n\n\\item{x}{label for x axis.}\n\n\\item{y}{label for y axis.}\n\n\\item{title}{plot title.}\n\n\\item{list}{If your input is a list of time series, then use \\code{list = your time sereis list}}\n}\n\\value{\nA plot of the input time series.\n}\n\\description{\nplot time series, with marks on missing value.\n}\n\\details{\nIf your input has more than one time series, the program will only plot the common period of \ndifferent time series.\n}\n\\examples{\nplotTS(testdl[[1]])\nplotTS(testdl[[1]], x = 'xxx', y = 'yyy', title = 'aaa')\n\n# If input is a datalist\nplotTS(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.\nplotTS(testdl[[1]], testdl[[2]], plot = 'cum')\n\n# You can also directly plot multicolumn dataframe\ndataframe <- list2Dataframe(extractPeriod(testdl, commonPeriod = TRUE))\nplotTS(dataframe, plot = 'cum')\n\n# Sometimes you may want to process the dataframe and compare with the original one\ndataframe1 <- dataframe\ndataframe1[, 2:4] <- dataframe1[, 2:4] + 3\nplotTS(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 https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n}\n}\n\n", + "created" : 1488014892948.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "921047716", + "id" : "9CAB49AF", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/plotTS.Rd", + "project_path" : "man/plotTS.Rd", + "properties" : { + }, + "relative_order" : 44, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9DAD3561 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9DAD3561 new file mode 100644 index 0000000..0129592 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/9DAD3561 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/multi-biasCorrect(generic).R\n\\docType{methods}\n\\name{getBiasFactor}\n\\alias{getBiasFactor}\n\\alias{getBiasFactor,data.frame,data.frame-method}\n\\alias{getBiasFactor,list,list-method}\n\\title{Get bias factor for multi/operational/real time bias correction.}\n\\usage{\ngetBiasFactor(hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{getBiasFactor}{data.frame,data.frame}(hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{getBiasFactor}{list,list}(hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'...,default method is 'scaling'.}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method, default is 'multi'. More info check \ndetails.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nWhen you do multi/operational/real time bias correction. It's too expensive\nto input hindcast and obs every time. Especially when you have a long period of hindcast\nand obs, but only a short period of frc, it's too unecessary to read and compute hindcast\nand obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\nget the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \napply the biasFactor to different forecasts.\n}\n\\details{\nInformation about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n\n\\strong{why use biasFactor}\n\nAs for forecasting, for daily data, there is usually no need to have\ndifferent bias factor every different day. You can calculate one bisa factor using a long\nperiod of hindcast and obs, and apply that factor to different frc.\n\nFor example,\n\nYou have 10 years of hindcast and observation. you want to do bias correction for some \nforecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\nabout the future 6 months. So if you want to do the real time bias correction, you have to\ntake the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\ntime you get a new forecast. That's too expensive.\n\nFor some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\nMaybe for February and March, you can use the same biasFactor, no need to do the computation \nagain. \n \nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\n\nbiasFactor <- getBiasFactor(nc, tgridData)\nnewFrc <- applyBiasFactor(nc, biasFactor)\n \nbiasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\npreci = TRUE)\n# This method needs obs input.\nnewFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n\nbiasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nbiasFactor <- getBiasFactor(hindcast, obs)\nfrc_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\nbiasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\nfrc_new1 <- applyBiasFactor(frc, biasFactor)\n\n# You can use other methods to biascorrect, e.g. delta method. \nbiasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n# delta method needs obs input.\nfrc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n\n# \nbiasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n# eqm needs obs input\nfrc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n\nbiasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\nfrc_new4 <- applyBiasFactor(frc, biasFactor)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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 https://yuanchao-xu.github.io/hyfo/\n\n\n}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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\\seealso{\n\\code{\\link{biasCorrect}} for method used in bias correction.\n\\code{\\link{applyBiasFactor}}, for the second part.\n}\n\n", + "created" : 1487956242592.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "670227453", + "id" : "9DAD3561", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getBiasFactor.Rd", + "project_path" : "man/getBiasFactor.Rd", + "properties" : { + }, + "relative_order" : 30, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A0BF5A09 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A0BF5A09 new file mode 100644 index 0000000..4694180 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A0BF5A09 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/ncdf.R\n\\name{getNcdfVar}\n\\alias{getNcdfVar}\n\\title{Get variable name of the NetCDF file.}\n\\usage{\ngetNcdfVar(filePath)\n}\n\\arguments{\n\\item{filePath}{A path pointing to the netCDF file.}\n}\n\\value{\nThe names of the varialbes in the file.\n}\n\\description{\nGet variable name in the NetCDF file. After knowning the name, you can use \\code{loadNcdf} to load\nthe target variable.\n}\n\\examples{\n# First open the test NETcDF file.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n# Then if you don't know the variable name, you can use \\\\code{getNcdfVar} to get variable name\nvarname <- getNcdfVar(filePath)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\nEarlier) Format Data Files. R package version 1.14.1.\nhttps://CRAN.R-project.org/package=ncdf4\n}\n}\n\n", + "created" : 1487956333313.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2643611823", + "id" : "A0BF5A09", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getNcdfVar.Rd", + "project_path" : "man/getNcdfVar.Rd", + "properties" : { + }, + "relative_order" : 36, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A2A68A80 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A2A68A80 new file mode 100644 index 0000000..ed24e01 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A2A68A80 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get ensemble forecast from historical data.\n#' \n#' getHisEnsem use historical data as the forecasting input time series.\n#' \n#' @param TS A time series dataframe, with first column Date, and second column value.\n#' @param example A vector containing two strings showing the start and end date, which represent the \n#' forecasting period. Check details for more information.\n#'\n#' the program will extract every possible period in TS you provided to generate the ensemble. Check details for \n#' more information.\n#' @param interval A number representing the interval of each ensemble member. NOTE: \"interval\" takes\n#' 365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval \n#' to be 2 years, set \\code{interval = 730}, which equals 2 * 365 ; if two months, set \\code{interval = 60}; \n#' 2 days, \\code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the \n#' number as days.By defualt interval is set to be 365, a year.\n#' @param buffer A number showing how many days are used as buffer period for models. Check details for more\n#' information.\n#' \n#' @param plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\n#' \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{getEnsem_comb}.\n#' \n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \n#' \n#' \\code{example} E.g., if you have a time series from 2000 to 2010. Assuming you are in 2003,\n#' you want to forecast the period from 2003-2-1 to 2003-4-1. Then for each year in your input\n#' time series, every year from 1st Feb to 1st Apr will be extracted to generate the ensemble\n#' forecasts. In this case your input example should be \\code{example = c('2003-2-1', '2003-4-1')}\n#' \n#' \\code{interval} doesn't care about leap year and the months with 31 days, it will take 365 as a year, and 30 as a month.\n#' e.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28\n#' days.\n#' \n#' \\code{example} and \\code{interval} controls how the ensemble will be generated. e.g. if the time series is from \n#' 1990-1-1 to 2001-1-1.\n#' \n#' if \\code{example = c('1992-3-1', '1994-1-1')} and \\code{interval = 1095}, note, 1095 = 365 * 3, so the program treat\n#' this as 3 years.\n#' \n#' Then you are supposed to get the ensemble consisting of following part:\n#' \n#' 1. 1992-3-1 to 1994-1-1 first one is the example, and it's NOT start from 1990-3-1.\n#' 2. 1995-3-1 to 1997-1-1 second one starts from 1993, because \"interval\" is 3 years.\n#' 3. 1998-3-1 to 2000-1-1\n#' \n#' because the last one \"2000-3-1 to 2002-1-1\", 2002 exceeds the original TS range, so it will not be included.\n#' \n#' Sometimes, there are leap years and months with 31 days included in some ensemble part, in which case the length of the data will\n#' be different, e.g., 1999-1-1 to 1999-3-1 is 1 day less than 2000-1-1 to 2000-3-1. In this situation,\n#' the data will use example as a standard. If the example is 1999-1-1 to 1999-3-1, then the latter one\n#' will be changed to 2001-1-1 to 2000-2-29, which keeps the start Date and change the end Date.\n#' \n#' If the end date is so important that cannot be changed, try to solve this problem by resetting\n#' the example period, to make the event included in the example.\n#' \n#' Good set of example and interval can generate good ensemble.\n#' \n#' \\code{buffer}\n#' Sometimes the model needs to run for a few days to warm up, before the forecast. E.g., if a forecast starts at\n#' '1990-1-20', for some model like MIKE NAM model, the run needs to be started about 14 days. So the input timeseries\n#' should start from '1990-1-6'.\n#' \n#' Buffer is mainly used for the model hotstart. Sometimes the hot start file cannot contain all the parameters needed,\n#' only some important parameters. In this case, the model needs to run for some time, to make other parameters ready\n#' for the simulation.\n#' \n#' \n#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, name has to be assigned if \\code{output = 'ggplot'} is selected,\n#' @return A ensemble time series using historical data as forecast.\n#' \n#' @examples\n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'))\n#' \n#' # Default interval is one year, can be set to other values, check help for information.\n#' \n#' # Take 7 months as interval\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') \n#' # Take 30 days as buffer\n#' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30)\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @importFrom reshape2 melt \n#' @importFrom grDevices rainbow\n#' @import ggplot2\n#' @references \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#' }\n#' \n#' \n#' @export\n\ngetHisEnsem <- function (TS, example, interval = 365, buffer = 0, plot = 'norm', output = 'data', \n name = NULL, mv = 0, ...) {\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 } else if (!grepl('-|/', example[1]) | !grepl('-|/', example[1])) {\n stop('Wrong date format in the example, check the format in ?as.Date{base} \n and use as.Date to convert.')\n } else {\n \n \n \n TS[, 1] <- as.Date(TS[, 1])\n example <- as.Date(example ,tz = '')\n exL <- example[2] - example[1]\n # Test if example is in the range of the TS\n a <- which(TS[, 1] == example[1] | TS[, 1] == example[2])\n if (length(a) < 2) stop('Example is out of the time series, reset example.')\n \n \n \n if (interval %% 365 == 0) {\n d <- interval / 365\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'years')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'years'))\n\n n <- length(startDate) + length(endDate) - 1 # example is counted twice, should be subtracted. \n \n # Generate full start date series.\n startDate <- seq(min(startDate), length = n, by = paste(d, 'years'))\n endDate <- startDate + exL\n \n } else if (interval %% 30) {\n d <- interval / 30\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'months')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'months'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'months'))\n endDate <- startDate + exL\n \n } else {\n d <- interval\n \n # Get sequence of start and end date.\n \n startDate <- rev(seq(from = example[1], to = min(TS[, 1]), by = paste(-d, 'days')))\n endDate <- seq(from = example[2], to = max(TS[, 1]), by = paste(d, 'days'))\n \n n <- length(startDate) + length(endDate) - 1\n \n startDate <- seq(min(startDate), length = n, by = paste(d, 'days'))\n endDate <- startDate + exL\n }\n \n data <- mapply(FUN = function(x, y) extractPeriod_dataframe(dataframe = TS, startDate = x, endDate = y),\n x = startDate, y = endDate)\n \n data <- lapply(1:n, function(x) data.frame(data[, x]))\n \n if (buffer > 0) {\n bufferStart <- example[1] - buffer\n bufferEnd <- example[1] - 1\n bufferTS <- extractPeriod_dataframe(TS, bufferStart, bufferEnd)\n \n data <- lapply(data, function(x) rbind(bufferTS, x))\n \n } else if (buffer < 0) {\n stop ('Buffer should be positive, or reset example.')\n }\n \n \n data_output <- list2Dataframe(data)\n colnames(data_output) <- c('Date', as.character(startDate))\n \n # Rearrange dataframe to make example the first column.\n ind <- match(c('Date', as.character(example[1])), colnames(data_output))\n # when use cbind, to ensure the output is also a dataframe, one inside cbind should be dataframe\n # Even output is alread a dataframe, but when ind is a single number, then output[ind] will\n # not be a dataframe, but an array.\n data_output <- cbind(data.frame(data_output[ind]), data_output[-ind])\n ex_date <- seq(from = example[1] - buffer, to = example[2], by = 1)\n data_output$Date <- ex_date\n colnames(data_output)[2] <- 'Observation'\n \n meanV <- apply(data_output[, 2:ncol(data_output)], MARGIN = 1, FUN = mean, na.rm = TRUE)\n \n data_output <- cbind(data.frame(Date = data_output[, 1]), Mean = meanV, \n data_output[, 2:ncol(data_output)])\n \n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n \n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n } else {\n stop('plot can only be \"norm\" or \"cum\", do not assign other words')\n }\n \n #generate different colors \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable, group = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_point(data = data_ggplot[NAIndex, ], size = 3, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(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 })\n print(mainLayer)\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, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n\n return(data_ggplot)\n } else {\n return(data_output)\n }\n }\n}\n\n\n\n\n\n\n#' Extract time series from forecasting data.\n#' \n#' getFrcEnsem extract timeseries from forecasting data, if forecasting data has a member session\n#' an ensemble time sereis will be returned, if forecasting data doesn't have a member session, a singe time\n#' series will be returned.\n#' \n#' @param dataset A list containing different information, should be the result of \\code{\\link{loadNcdf}}\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 plot A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n#' 'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.\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. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\n#' be replaced by \\code{mv}, if assigned, default mv is 0.\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{getEnsem_comb}.\n#' @param mv A number showing representing the missing value. When calculating the cumulative value, \n#' missing value will be replaced by mv, default is 0.\n#' @param coord A coordinate of longitude and latitude. e.g. corrd = c(lon, lat). If coord is assigned,\n#' cell argument will no longer be used.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' \n#' @details \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#' \\code{name}\n#' Assuming you have two ggplot outputs, you want to plot them together. In this situation, you\n#' need a name column to differentiate one ggplot output from the other. You can assigne this name\n#' by the argument directly, If name is not assigned and \\code{output = 'ggplot'} is selected, then\n#' the system time will be selected as name column.\n#' \n#' @examples \n#' \n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n\n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' nc <- loadNcdf(filePath, varname)\n#' a <- getFrcEnsem(nc)\n#' \n#' # If there is no member session in the dataset, a single time sereis will be extracted.\n#' a1 <- getFrcEnsem(tgridData)\n#' \n#' \n#' # The default output is spatially averaged, if there are more than one cells in the dataset, \n#' # the mean value of the cells will be calculated. While if you are interested in special cell, \n#' # you can assign the cell value. You can also directly use longitude and latitude to extract \n#' # time series.\n#' \n#' getSpatialMap(nc, 'mean')\n#' a <- getFrcEnsem(nc, cell = c(6,2))\n#' \n#' # From the map, cell = c(6, 2) means lon = -1.4, lat = 43.2, so you can use corrd to locate\n#' # your research area and extract time series.\n#' b <- getFrcEnsem(nc, coord = c(-1.4, 43.2))\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @return A ensemble time series extracted from forecating data.\n#' \n#' @import ggplot2\n#' @importFrom reshape2 melt\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' @export\ngetFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', name = NULL,\n mv = 0, coord = NULL, ...) {\n # cell should be a vector showing the location, or mean representing the loacation averaged.\n \n checkHyfo(dataset)\n \n Date <- as.Date(dataset$Dates$start)\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 if (!is.null(coord)) {\n cell <- coord2cell(coord, dataset$xyCoords$x, dataset$xyCoords$y)\n } \n \n \n if (!any(attributes(data)$dimensions == 'member')){\n message('There is no member part in the dataset, there will be only one column of value\n returned.')\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], ]\n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n \n } else {\n \n if (length(cell) == 2) {\n data_ensem <- data[cell[1], cell[2], , ]\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem) \n \n } else if (cell == 'mean') {\n data_ensem <- apply(data, MARGIN = c(3, 4), FUN = mean, na.rm = TRUE)\n # colnames <- 1:ncol(data_ensem)\n meanV <- apply(data_ensem, MARGIN = 1, FUN = mean, na.rm = TRUE)\n data_ensem <- data.frame('Mean' = meanV, data_ensem)\n \n } else {\n stop('Wrong cell input, check help for information.')\n }\n }\n\n \n data_output <- data.frame(Date, data_ensem)\n data_ggplot <- melt(data_output, id.var = 'Date')\n NAIndex <- is.na(data_ggplot$value)\n \n \n if (plot == 'norm') {\n data_ggplot$value[NAIndex] <- mv\n } else if (plot == 'cum') {\n data_output[is.na(data_output)] <- mv\n cum <- cbind(data.frame(Date = data_output$Date), cumsum(data_output[2:ncol(data_output)]))\n \n data_ggplot <- melt(cum, id.var = 'Date')\n \n }\n \n colors = c('brown1', rainbow(n = length(unique(data_ggplot$variable)) - 1,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6, color = 'red') +\n geom_point(data = data_ggplot[NAIndex, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n print(mainLayer)\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_ggplot$name <- rep(name, nrow(data_ggplot)) \n data_ggplot$nav <- rep(0, nrow(data_ggplot))\n data_ggplot$nav[NAIndex] <- 1\n return(data_ggplot)\n } else {\n return(data_output)\n }\n}\n\n\n\n#' Combine ensembles together\n#' @param ... different ensembles generated by \\code{getHisEnsem(, output = 'ggplot')} \n#' or \\code{getFrcEnsem(, 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 legend A boolean representing whether you want the legend. Sometimes when you combine\n#' plots, there will be a lot of legends, if you don't like it, you can turn it off by setting\n#' \\code{legend = FALSE}, default is TRUE.\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 ensemble plot.\n#' @examples \n#' \n#' data(testdl)\n#' \n#' a <- testdl[[1]]\n#' \n#' # Choose example from \"1994-2-4\" to \"1996-1-4\"\n#' \n#' \n#' b1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot',\n#' name = 1)\n#' \n#' b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot',\n#' name = 2)\n#' \n#' getEnsem_comb(b1, b2)\n#' getEnsem_comb(list = list(b1, b2), nrow = 2)\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' \n#' @export\n#' @import ggplot2\n#' @importFrom data.table rbindlist\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' \\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\n#' statistical downscaling. R package version 0.6-0.\n#' https://github.com/SantanderMetGroup/downscaleR/wiki\n#' }\n#' \n#' \n#' \n\ngetEnsem_comb <- function(..., list = NULL, nrow = 1, legend = TRUE, x = '', y = '', title = '', \n output = FALSE) {\n \n if (!is.null(list)) {\n checkBind(list, 'rbind')\n data_ggplot <- rbindlist(list)\n } else {\n plots <- list(...)\n checkBind(plots, 'rbind')\n data_ggplot <- rbindlist(plots)\n } \n #data_ggplot$name <- factor(data_ggplot$name, levels = data_ggplot$name, ordered = TRUE)\n \n if (!class(data_ggplot)[1] == 'data.table') {\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 getFreEnsem() or getHisEnsem(), if \n output = \"ggplot\" is assigned, more info please check ?getFreEnsem() or ?getHisEnsem().')\n }\n \n colors = c('brown1', 'dodgerblue3', rainbow(n = length(unique(data_ggplot$variable)) - 2,\n start = 0.1))\n \n theme_set(theme_bw())\n mainLayer <- with(data_ggplot, {\n ggplot(data = data_ggplot) +\n aes(x = Date, y = value, color = variable) +\n geom_line(size = 0.5) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Mean', ], size = 1.6) +\n geom_line(data = data_ggplot[data_ggplot$variable == 'Observation', ], size = 1.6) +\n geom_point(data = data_ggplot[data_ggplot$nav == 1, ], size = 2, shape = 4, color = 'black') +\n scale_color_manual(values = colors) +\n theme(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 facet_wrap( ~ name, nrow = nrow) +\n labs(x = x, y = y, title = title)\n \n })\n if (legend == FALSE) {\n mainLayer <- mainLayer + \n theme(legend.position = 'none')\n# following ones are to add label, may be added in future.\n# geom_text(data = data_ggplot[data_ggplot$Date == '2003-12-10', ], aes(label = variable), hjust = 0.7, vjust = 1)\n# geom_text(data = data_ggplot[data_ggplot$variable == 'Mean', ], aes(label = variable), hjust = 0.7, vjust = 1)\n }\n \n \n print(mainLayer)\n \n if (output == TRUE) return(data_ggplot)\n \n}", + "created" : 1487522564089.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3298987581", + "id" : "A2A68A80", + "lastKnownWriteTime" : 1488015925, + "last_content_update" : 1488015925019, + "path" : "~/GitHub/hyfo/R/getEnsemble.R", + "project_path" : "R/getEnsemble.R", + "properties" : { + }, + "relative_order" : 17, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A879E0CC b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A879E0CC new file mode 100644 index 0000000..3f29698 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A879E0CC @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Collect data from different csv files.\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param fileType A string showing the file type, e.g. \"txt\", \"csv\", \"excel\".\n#' @param range A vector containing startRow, endRow, startColumn, endColumn, e.g., \n#' c(2,15,2,3)\n#' @param sheetIndex A number showing the sheetIndex in the excel file, if fileType is excel,\n#' sheetIndex has to be provided, default is 1.\n#' @return The collected data from different files in the folder.\n#' @examples \n#' \n#' #use internal data as an example.\n#' folder <- file.path(path.package(\"hyfo\"), 'extdata')\n#' # file may vary with different environment, it if doesn't work, use local way to get\n#' # folder path.\n#' \n#' a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2))\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom data.table rbindlist\ncollectData <- function(folderName, fileType = NULL, range = NULL, sheetIndex = 1){\n \n message('All the files in the folder should have the same format')\n \n if (is.null(fileType)) stop('Please enter fileType, \"txt\", \"csv\" or \"excel\".')\n \n if (length(range) > 4) {\n stop('\"range\" should be c(startRow, endRow, startCol, endCol)')\n }else if (is.null(range)) {\n stop('\"range\" can not be blank, e.g., range <- c(startRow, endRow, startCol, endCol).')\n }\n \n if (fileType == 'csv') {\n fileNames <- list.files(folderName, pattern = '*.csv', full.names = TRUE)\n if (length(fileNames) == 0) stop('No csv file in the folder.')\n \n data <- lapply(fileNames, readCsv, range = range)\n data <- rbindlist(data)\n \n } else if (fileType == 'txt') {\n fileNames <- list.files(folderName, pattern = '*.txt', full.names = TRUE)\n if (length(fileNames) == 0) {\n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n }\n if (length(fileNames) == 0) stop('No text file in the folder.')\n message('For txt file, only startRow and endRow will be considered.')\n data <- lapply(fileNames, readTxt, range = range)\n data <- unlist(data)\n \n# In order not to introduce too much trouble to user, this part has been hiden\n# Because it needs java environment installed.\n#\n } else if (fileType == 'excel') {\n \n message('This part needs java installed in your computer, so it is commentted in\n the original file, check the original R file or https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData.R\n for ideas.')\n# fileNames <- list.files(folderName, pattern = '*.xlsx', full.names = TRUE)\n# if (length(fileNames) == 0){\n# fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n# }\n# \n# if (length(fileNames) == 0) stop('No excel in the folder.')\n# data <- lapply(fileNames, readExcel, range = range, sheetIndex = sheetIndex)\n# checkBind(data, 'rbind')\n# data <- do.call('rbind', data)\n }else{\n stop('fileType should be \"txt\", \"csv\" or \"excel\".')\n }\n \n \n return(data)\n \n}\n\n# #importFrom xlsx read.xls\n# readExcel <- function(fileName, range, sheetIndex){\n# data <- read.xls(fileName, sheetIndex = sheetIndex, rowIndex = seq(range[1], range[2]),\n# colIndex = seq(range[3], range[4])) \n# colnames(data) <- seq(1, dim(data)[2])\n# \n# message(fileName) \n# return(data)\n# }\n\nreadTxt <- function(fileName, range){\n data <- readLines(fileName)\n data <- data[range[1]:range[2]]\n return(data)\n}\n\n\n\n#' @importFrom utils read.csv\n#' @references \n#' R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.\nreadCsv <- function(fileName, range){\n \n data <- read.csv(fileName, skip = range[1] - 1, header = FALSE)\n data <- data[1:(range[2] - range[1] + 1), range[3]:range[4]]\n \n return(data)\n}\n\n\n\n\n\n", + "created" : 1487522346501.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "279517550", + "id" : "A879E0CC", + "lastKnownWriteTime" : 1488015924, + "last_content_update" : 1488015924823, + "path" : "~/GitHub/hyfo/R/collectData.R", + "project_path" : "R/collectData.R", + "properties" : { + }, + "relative_order" : 14, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A87A7AF6 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A87A7AF6 new file mode 100644 index 0000000..162c2d7 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/A87A7AF6 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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 https://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. https://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 https://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" : 1488018106706.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2883532208", + "id" : "A87A7AF6", + "lastKnownWriteTime" : 1488018115, + "last_content_update" : 1488018115762, + "path" : "~/GitHub/hyfo/R/shp2cat.R", + "project_path" : "R/shp2cat.R", + "properties" : { + }, + "relative_order" : 53, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE5809FB b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE5809FB new file mode 100644 index 0000000..cede58a --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE5809FB @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getEnsemble.R\n\\name{getHisEnsem}\n\\alias{getHisEnsem}\n\\title{Get ensemble forecast from historical data.}\n\\usage{\ngetHisEnsem(TS, example, interval = 365, buffer = 0, plot = \"norm\",\n output = \"data\", name = NULL, mv = 0, ...)\n}\n\\arguments{\n\\item{TS}{A time series dataframe, with first column Date, and second column value.}\n\n\\item{example}{A vector containing two strings showing the start and end date, which represent the \nforecasting period. Check details for more information.\n\nthe program will extract every possible period in TS you provided to generate the ensemble. Check details for \nmore information.}\n\n\\item{interval}{A number representing the interval of each ensemble member. NOTE: \"interval\" takes\n365 as a year, and 30 as a month, regardless of leap year and months with 31 days. So if you want the interval \nto be 2 years, set \\code{interval = 730}, which equals 2 * 365 ; if two months, set \\code{interval = 60}; \n2 days, \\code{interval = 2}, for other numbers that cannot be divided by 365 or 30 without remainder, it will treat the \nnumber as days.By defualt interval is set to be 365, a year.}\n\n\\item{buffer}{A number showing how many days are used as buffer period for models. Check details for more\ninformation.}\n\n\\item{plot}{A string showing whether the plot will be shown, e.g., 'norm' means normal plot (without any process), \n'cum' means cummulative plot, default is 'norm'. For other words there will be no plot.}\n\n\\item{output}{A string showing which type of output you want. Default is \"data\", if \"ggplot\", the \ndata that can be directly plotted by ggplot2 will be returned, which is easier for you to make series\nplots afterwards. NOTE: If \\code{output = 'ggplot'}, the missing value in the data will\nbe replaced by \\code{mv}, if assigned, default mv is 0.}\n\n\\item{name}{If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\ndifferent outputs in the later multiplot using \\code{getEnsem_comb}.}\n\n\\item{mv}{A number showing representing the missing value. When calculating the cumulative value, \nmissing value will be replaced by mv, default is 0.}\n\n\\item{...}{\\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}}\n}\n\\value{\nA ensemble time series using historical data as forecast.\n}\n\\description{\ngetHisEnsem use historical data as the forecasting input time series.\n}\n\\details{\n\\code{example} E.g., if you have a time series from 2000 to 2010. Assuming you are in 2003,\nyou want to forecast the period from 2003-2-1 to 2003-4-1. Then for each year in your input\ntime series, every year from 1st Feb to 1st Apr will be extracted to generate the ensemble\nforecasts. In this case your input example should be \\code{example = c('2003-2-1', '2003-4-1')}\n\n\\code{interval} doesn't care about leap year and the months with 31 days, it will take 365 as a year, and 30 as a month.\ne.g., if the interval is from 1999-2-1 to 1999-3-1, you should just set interval to 30, although the real interval is 28\ndays.\n\n\\code{example} and \\code{interval} controls how the ensemble will be generated. e.g. if the time series is from \n1990-1-1 to 2001-1-1.\n\nif \\code{example = c('1992-3-1', '1994-1-1')} and \\code{interval = 1095}, note, 1095 = 365 * 3, so the program treat\nthis as 3 years.\n\nThen you are supposed to get the ensemble consisting of following part:\n\n1. 1992-3-1 to 1994-1-1 first one is the example, and it's NOT start from 1990-3-1.\n2. 1995-3-1 to 1997-1-1 second one starts from 1993, because \"interval\" is 3 years.\n3. 1998-3-1 to 2000-1-1\n\nbecause the last one \"2000-3-1 to 2002-1-1\", 2002 exceeds the original TS range, so it will not be included.\n\nSometimes, there are leap years and months with 31 days included in some ensemble part, in which case the length of the data will\nbe different, e.g., 1999-1-1 to 1999-3-1 is 1 day less than 2000-1-1 to 2000-3-1. In this situation,\nthe data will use example as a standard. If the example is 1999-1-1 to 1999-3-1, then the latter one\nwill be changed to 2001-1-1 to 2000-2-29, which keeps the start Date and change the end Date.\n\nIf the end date is so important that cannot be changed, try to solve this problem by resetting\nthe example period, to make the event included in the example.\n\nGood set of example and interval can generate good ensemble.\n\n\\code{buffer}\nSometimes the model needs to run for a few days to warm up, before the forecast. E.g., if a forecast starts at\n'1990-1-20', for some model like MIKE NAM model, the run needs to be started about 14 days. So the input timeseries\nshould start from '1990-1-6'.\n\nBuffer is mainly used for the model hotstart. Sometimes the hot start file cannot contain all the parameters needed,\nonly some important parameters. In this case, the model needs to run for some time, to make other parameters ready\nfor the simulation.\n\n\n\\code{name}\nAssuming you have two ggplot outputs, you want to plot them together. In this situation, you\nneed a name column to differentiate one ggplot output from the other. You can assigne this name\nby the argument directly, name has to be assigned if \\code{output = 'ggplot'} is selected,\n}\n\\examples{\n\ndata(testdl)\n\na <- testdl[[1]]\n\n# Choose example from \"1994-2-4\" to \"1996-1-4\"\nb <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'))\n\n# Default interval is one year, can be set to other values, check help for information.\n\n# Take 7 months as interval\nb <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = 'cum') \n# Take 30 days as buffer\nb <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30)\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n\n}\n\\references{\n\\itemize{\n\\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n21(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}\n}\n\n", + "created" : 1487956279845.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "439558619", + "id" : "AE5809FB", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getHisEnsem.Rd", + "project_path" : "man/getHisEnsem.Rd", + "properties" : { + }, + "relative_order" : 33, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE7DF6FE b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE7DF6FE new file mode 100644 index 0000000..acf39e9 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/AE7DF6FE @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/case_anarbe.R\n\\name{collectData_excel_anarbe}\n\\alias{collectData_excel_anarbe}\n\\title{Collect data from different excel files}\n\\usage{\ncollectData_excel_anarbe(folderName, keyword = NULL, output = TRUE)\n}\n\\arguments{\n\\item{folderName}{A string showing the folder path.}\n\n\\item{keyword}{A string showing the extracted column, e.g., waterLevel, waterBalance.}\n\n\\item{output}{A boolean showing whether the output is given.}\n}\n\\value{\nThe collected data from different excel files.\n}\n\\description{\nCollect data from different excel files\n}\n\\references{\n\\itemize{\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL http://www.R-project.org/.\n}\n}\n\n", + "created" : 1487956055852.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2294040637", + "id" : "AE7DF6FE", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/collectData_excel_anarbe.Rd", + "project_path" : "man/collectData_excel_anarbe.Rd", + "properties" : { + }, + "relative_order" : 24, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/B4F74B5C similarity index 96% rename from .Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/B4F74B5C index 30500e9..db1c515 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/B4F74B5C +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/B4F74B5C @@ -7,8 +7,8 @@ "folds" : "", "hash" : "3446792241", "id" : "B4F74B5C", - "lastKnownWriteTime" : 1487594221, - "last_content_update" : 1487594221, + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, "path" : "~/GitHub/hyfo/NAMESPACE", "project_path" : "NAMESPACE", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/B8E278FD b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/B8E278FD new file mode 100644 index 0000000..4d0735e --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/B8E278FD @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/dataDocument.R\n\\docType{data}\n\\name{testdl}\n\\alias{testdl}\n\\title{testdl}\n\\format{A list consists of 3 different lists.\n\\describe{\n \\item{AAA}{AAA, a dataframe containing a date column and a value column. }\n \\item{BBB}{BBB, a dataframe containing a date column and a value column.}\n \\item{CCC}{CCC, a dataframe containing a date column and a value column.}\n ...\n}}\n\\source{\nhttp://meteo.navarra.es/estaciones/mapadeestaciones.cfm\nhttp://www4.gipuzkoa.net/oohh/web/esp/02.asp\n}\n\\usage{\ntestdl\n}\n\\description{\nA list containing different precipitation time series.\n}\n\\references{\n\\itemize{\n\\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n\\item #' http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n}\n}\n\\keyword{datasets}\n\n", + "created" : 1488014925949.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3744290800", + "id" : "B8E278FD", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/testdl.Rd", + "project_path" : "man/testdl.Rd", + "properties" : { + }, + "relative_order" : 48, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/BFF6AE7A b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/BFF6AE7A new file mode 100644 index 0000000..e312b36 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/BFF6AE7A @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get annual rainfall of different rainfall time series\n#' \n#' Get annual rainfall of different raninfall time series.\n#' \n#' \n#' @param data A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\n#' gauging stations. Usually an output of \\code{list2Dataframe}.\n#' @param output A string showing the output output.\n#' @param minRecords A number showing the minimum accept record number, e.g. for a normal \n#' year(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\n#' of a year, it will be ignored in the mean annual value calculation. Only valid \n#' when \\code{output = \"mean\"}, default is 355.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @return The annual rainfall and the number of missing data of each year and each rainfall gauge, which \n#' will also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n#' @details \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #datalist is provided by the package as a test.\n#' data(testdl)\n#' a <- getAnnual(testdl)\n#' #set minRecords to control the calculation of annual rainfall.\n#' b <- getAnnual(testdl, output = 'mean', minRecords = 350)\n#' c <- getAnnual(testdl, output = 'mean', minRecords = 365)\n#' \n#' a1 <- extractPeriod(testdl, comm = TRUE)\n#' a2 <- list2Dataframe(a1)\n#' getAnnual(a2)\n#' \n#' a3 <- fillGap(a2)\n#' getAnnual(a3)\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @importFrom methods setGeneric\n#' \n#' @references \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\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 R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n#' }\n#' \n#' \nsetGeneric('getAnnual', function(data, output = 'series', minRecords = 355, \n ...) {\n standardGeneric('getAnnual')\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('data.frame'), \n function(data, output, minRecords, ...) {\n result <- getAnnual.TS(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n})\n\n#' @rdname getAnnual\n#' @importFrom methods setMethod\nsetMethod('getAnnual', signature('list'),\n function(data, output, minRecords, ...) {\n result <- getAnnual.list(data)\n getAnnual.plot(result, output, minRecords, ...)\n return(result)\n })\n\n#' @importFrom data.table rbindlist\ngetAnnual.TS <- function(dataframe) {\n Date <- as.POSIXlt(dataframe[, 1])\n # Calculate how many gauging stations.\n stations <- colnames(dataframe)[2:ncol(dataframe)]\n \n data <- lapply(stations, function(x) {\n dataframe_new <- data.frame(Date, dataframe[, x])\n colnames(dataframe_new)[2] <- x\n getAnnual_dataframe(dataframe_new)\n })\n \n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n \n return(data)\n}\n\n\n#' @importFrom data.table rbindlist\ngetAnnual.list <- function(datalist) {\n data <- lapply(datalist, FUN = getAnnual_dataframe)\n data <- rbindlist(data)\n # After rbind, factor level has to be reassigned in order to be well plotted.\n data$Year <- factor(data$Year, levels = sort(unique(data$Year)), ordered = TRUE)\n rownames(data) <- NULL\n return(data)\n}\n\n#' @import ggplot2 \n#' @importFrom reshape2 melt\n#' @importFrom stats aggregate\ngetAnnual.plot <- function(data, output, minRecords, ...) {\n theme_set(theme_bw())\n \n if (output == 'mean') {\n validData <- data[data$recordNum >= minRecords,]\n \n data <- aggregate(validData$AnnualPreci, list(validData$Name), mean)\n colnames(data) <- c('Name', 'AnnualPreci')\n \n mainLayer <- with(data, {\n ggplot(data)+\n geom_bar(aes(x = Name, y = AnnualPreci, fill = Name), stat = 'identity')+\n labs(empty = NULL, ...)#in order to pass \"...\", arguments shouldn't be empty.\n \n })\n \n print(mainLayer)\n \n } else {\n \n plotData <- with(data, {\n subset(data, select = c(Year, Name, NANum, AnnualPreci))\n })\n \n plotData <- melt(plotData, var.id = c('Year', 'Name'))\n \n \n mainLayer <- with(plotData, {\n ggplot(plotData) +\n geom_bar(aes(x = Year, y = value , fill = Name), \n stat = 'identity') +\n facet_grid(variable ~ Name, scale = 'free') +\n xlab('Year') +\n ylab(NULL) +\n labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n theme(plot.title = element_text(size = 20, face = 'bold', vjust = 1)) +\n theme(axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.5)),\n axis.text.y = element_text(size = rel(1.5)))\n # grid.arrange(mainLayer, ncol = 4)\n \n })\n \n \n print(mainLayer)\n } \n}\n\n\n\n\n\n\n\n\n#' Get annual rainfall of the input time series.\n#' \n#' @param dataset A dataframe containing one time series, e.g., rainfall from one gauging station.\n#' the time should follow the format : \"1990-1-1\"\n#' @return The annual rainfall of each year of the input station.\n# @examples\n# data(testdl)\n# getAnnual_dataframe(testdl[[1]])\n#' \ngetAnnual_dataframe <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 Date <- as.Date(dataset[, 1])\n year <- format(Date, '%Y')\n yearUnique <- unique(year)\n # yearUnique <- factor(yearUnique, levels = yearUnique, ordered = TRUE)\n calcuNum <- c(1:length(yearUnique))\n \n \n annualPreci <- tapply(dataset[, 2], INDEX = year, FUN = sum, na.rm = TRUE)\n recordNum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(!is.na(x))))\n NANum <- tapply(dataset[, 2], INDEX = year, function(x) length(which(is.na(x))))\n \n \n name <- rep(colnames(dataset)[2], length(calcuNum))\n output <- data.frame(Year = as.numeric(yearUnique), Name = name, AnnualPreci = annualPreci,\n recordNum, NANum)\n \n #output$Year <- factor(output$Year, levels = output$Year, ordered = TRUE)\n return(output)\n}\n\n", + "created" : 1483876618596.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1161286313", + "id" : "BFF6AE7A", + "lastKnownWriteTime" : 1488015924, + "last_content_update" : 1488015924693, + "path" : "~/GitHub/hyfo/R/getAnnual(generic).R", + "project_path" : "R/getAnnual(generic).R", + "properties" : { + }, + "relative_order" : 4, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA11BD0A similarity index 94% rename from .Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA11BD0A index 42b809b..eef58bb 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/CA11BD0A +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA11BD0A @@ -7,8 +7,8 @@ "folds" : "", "hash" : "3096661772", "id" : "CA11BD0A", - "lastKnownWriteTime" : 1487594221, - "last_content_update" : 1487594221, + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, "path" : "~/GitHub/hyfo/man/tgridData.Rd", "project_path" : "man/tgridData.Rd", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA271C51 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA271C51 new file mode 100644 index 0000000..7e34f3b --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CA271C51 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getAnnual(generic).R\n\\docType{methods}\n\\name{getAnnual}\n\\alias{getAnnual}\n\\alias{getAnnual,data.frame-method}\n\\alias{getAnnual,list-method}\n\\title{Get annual rainfall of different rainfall time series}\n\\usage{\ngetAnnual(data, output = \"series\", minRecords = 355, ...)\n\n\\S4method{getAnnual}{data.frame}(data, output = \"series\", minRecords = 355,\n ...)\n\n\\S4method{getAnnual}{list}(data, output = \"series\", minRecords = 355, ...)\n}\n\\arguments{\n\\item{data}{A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different\ngauging stations. Usually an output of \\code{list2Dataframe}.}\n\n\\item{output}{A string showing the output output.}\n\n\\item{minRecords}{A number showing the minimum accept record number, e.g. for a normal \nyear(365 days), if \\code{minRecords = 360}, it means if a year has less than 360 records\nof a year, it will be ignored in the mean annual value calculation. Only valid \nwhen \\code{output = \"mean\"}, default is 355.}\n\n\\item{...}{\\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}}\n}\n\\value{\nThe annual rainfall and the number of missing data of each year and each rainfall gauge, which \nwill also be plotted. If output \"mean\" is seleted, the mean annual rainfall will be returned.\n}\n\\description{\nGet annual rainfall of different raninfall time series.\n}\n\\details{\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\n}\n\\examples{\n#datalist is provided by the package as a test.\ndata(testdl)\na <- getAnnual(testdl)\n#set minRecords to control the calculation of annual rainfall.\nb <- getAnnual(testdl, output = 'mean', minRecords = 350)\nc <- getAnnual(testdl, output = 'mean', minRecords = 365)\n\na1 <- extractPeriod(testdl, comm = TRUE)\na2 <- list2Dataframe(a1)\ngetAnnual(a2)\n\na3 <- fillGap(a2)\ngetAnnual(a3)\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n\\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/.\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1487956221717.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3081706177", + "id" : "CA271C51", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getAnnual.Rd", + "project_path" : "man/getAnnual.Rd", + "properties" : { + }, + "relative_order" : 29, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CE991F6 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CE991F6 new file mode 100644 index 0000000..6afb391 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/CE991F6 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/analyzeTS.R\n\\name{getMoment}\n\\alias{getMoment}\n\\title{get moment analysis of the input distribution}\n\\usage{\ngetMoment(dis)\n}\n\\arguments{\n\\item{dis}{A distribution, for hydrology usually a time series with only data column without time.}\n}\n\\value{\nThe mean, variation, skewness and kurtosis of the input distribution\n}\n\\description{\nget moment analysis of the input distribution\n}\n\\examples{\ndis <- seq(1, 100)\ngetMoment(dis)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item Lukasz Komsta and Frederick Novomestky (2015). moments: Moments, cumulants, skewness, kurtosis and\nrelated tests. R package version 0.14. https://CRAN.R-project.org/package=moments\n\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1487956303573.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4150439112", + "id" : "CE991F6", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getMoment.Rd", + "project_path" : "man/getMoment.Rd", + "properties" : { + }, + "relative_order" : 35, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D0BF85EC b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D0BF85EC new file mode 100644 index 0000000..5f3f316 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D0BF85EC @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getEnsemble.R\n\\name{getEnsem_comb}\n\\alias{getEnsem_comb}\n\\title{Combine ensembles together}\n\\usage{\ngetEnsem_comb(..., list = NULL, nrow = 1, legend = TRUE, x = \"\",\n y = \"\", title = \"\", output = FALSE)\n}\n\\arguments{\n\\item{...}{different ensembles generated by \\code{getHisEnsem(, output = 'ggplot')} \nor \\code{getFrcEnsem(, output = 'ggplot')}, see details.}\n\n\\item{list}{If input is a list containing different ggplot data, use \\code{list = inputlist}.}\n\n\\item{nrow}{A number showing the number of rows.}\n\n\\item{legend}{A boolean representing whether you want the legend. Sometimes when you combine\nplots, there will be a lot of legends, if you don't like it, you can turn it off by setting\n\\code{legend = FALSE}, default is TRUE.}\n\n\\item{x}{A string of x axis name.}\n\n\\item{y}{A string of y axis name.}\n\n\\item{title}{A string of the title.}\n\n\\item{output}{A boolean, if chosen TRUE, the output will be given.}\n}\n\\value{\nA combined ensemble plot.\n}\n\\description{\nCombine ensembles together\n}\n\\examples{\n\ndata(testdl)\n\na <- testdl[[1]]\n\n# Choose example from \"1994-2-4\" to \"1996-1-4\"\n\n\nb1<- getHisEnsem(a, example = c('1995-2-4', '1996-1-4'), plot = 'cum', output = 'ggplot',\n name = 1)\n \nb2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = 'ggplot',\n name = 2)\n\ngetEnsem_comb(b1, b2)\ngetEnsem_comb(list = list(b1, b2), nrow = 2)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n\\item Santander Meteorology Group (2015). downscaleR: Climate data manipulation and\nstatistical downscaling. R package version 0.6-0.\nhttps://github.com/SantanderMetGroup/downscaleR/wiki\n}\n}\n\n", + "created" : 1487956253621.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "814409775", + "id" : "D0BF85EC", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getEnsem_comb.Rd", + "project_path" : "man/getEnsem_comb.Rd", + "properties" : { + }, + "relative_order" : 31, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D1FE15E0 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D1FE15E0 new file mode 100644 index 0000000..7318996 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D1FE15E0 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getPreciBar(generic).R\n\\docType{methods}\n\\name{getPreciBar}\n\\alias{getPreciBar}\n\\alias{getPreciBar,data.frame-method}\n\\alias{getPreciBar,list-method}\n\\title{get mean rainfall bar plot of the input dataset or time series.}\n\\usage{\ngetPreciBar(data, method, cell = \"mean\", output = \"data\", name = NULL,\n plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE, ...)\n\n\\S4method{getPreciBar}{list}(data, method, cell = \"mean\", output = \"data\",\n name = NULL, plotRange = TRUE, member = NULL, omitNA = TRUE,\n info = FALSE, ...)\n\n\\S4method{getPreciBar}{data.frame}(data, method, cell = \"mean\",\n output = \"data\", name = NULL, plotRange = TRUE, member = NULL,\n omitNA = TRUE, info = FALSE, ...)\n}\n\\arguments{\n\\item{data}{A list containing different information, should be the result of reading netcdf file using\n\\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\nTime series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.}\n\n\\item{method}{A string showing the calculating method of the input time series. More information\nplease refer to the details.}\n\n\\item{cell}{A vector containing the locaton of the cell, e.g. c(2, 3), default is \"mean\", representing\nthe spatially averaged value. Check details for more information.}\n\n\\item{output}{A string showing the type of the output, if \\code{output = 'ggplot'}, the returned \ndata can be used in ggplot and \\code{getPreciBar_comb()}; if \\code{output = 'plot'}, the returned data is the plot containing all \nlayers' information, and can be plot directly or used in grid.arrange; if not set, the data\nwill be returned.}\n\n\\item{name}{If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\ndifferent outputs in the later multiplot using \\code{getSpatialMap_comb}.}\n\n\\item{plotRange}{A boolean showing whether the range will be plotted.}\n\n\\item{member}{A number showing which member is selected to get, if the dataset has a \"member\" dimension. Default\nis NULL, if no member assigned, and there is a \"member\" in dimensions, the mean value of the members will be\ntaken.}\n\n\\item{omitNA}{A boolean showing whether the missing value is omitted.}\n\n\\item{info}{A boolean showing whether the information of the map, e.g., max, mean ..., default is FALSE.}\n\n\\item{...}{\\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}}\n}\n\\value{\nThe calculated mean value of the input time series and the plot of the result.\n}\n\\description{\nget mean rainfall bar plot of the input dataset or time series.\n}\n\\details{\nThere 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.\nMonth(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,\nIT IS NOT THE LONGITUDE AND LATITUDE. e.g., \\code{cell = c(2, 3)}, the program will take the 2nd longitude\nand 3rd latitude, by the increasing order. Longitude comes first.\n\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\n}\n\\examples{\n#gridData provided by package is the result of \\\\code{loadNcdf()}\ndata(tgridData)\nb1 <- getPreciBar(tgridData, method = 'annual')\nb2 <- getPreciBar(tgridData, method = 'meanMonthly')\n\ndata(testdl)\nTS <- testdl[[1]]\na <- getPreciBar(TS, method = 'spring')\n# if info = T, the information will be given at the bottom.\na <- getPreciBar(TS, method = 'spring', info = TRUE)\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n21(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\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1487956352900.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "665375225", + "id" : "D1FE15E0", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getPreciBar.Rd", + "project_path" : "man/getPreciBar.Rd", + "properties" : { + }, + "relative_order" : 37, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D22A91DA b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D22A91DA new file mode 100644 index 0000000..696978f --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D22A91DA @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/multi-biasCorrect(generic).R\n\\docType{methods}\n\\name{applyBiasFactor}\n\\alias{applyBiasFactor}\n\\alias{applyBiasFactor,data.frame,biasFactor-method}\n\\alias{applyBiasFactor,list,biasFactor.hyfo-method}\n\\title{Apply bias factor to different forecasts for multi/operational/real time bias correction.}\n\\usage{\napplyBiasFactor(frc, biasFactor, obs = NULL)\n\n\\S4method{applyBiasFactor}{data.frame,biasFactor}(frc, biasFactor, obs = NULL)\n\n\\S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, obs = NULL)\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting the frc data. Check details for more information.}\n\n\\item{biasFactor}{a file containing all the information of the calibration, will be\napplied to different forecasts.}\n\n\\item{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, \nrepresenting the observation data. Default value is NULL.}\n}\n\\description{\nWhen you do multi/operational/real time bias correction. It's too expensive\nto input hindcast and obs every time. Especially when you have a long period of hindcast\nand obs, but only a short period of frc, it's too unecessary to read and compute hindcast\nand obs everytime. Therefore, biasFactor is designed. Using \\code{getBiasFactor}, you can\nget the biasFactor with hindcast and observation, then you can use \\code{applyBiasFactor} to \napply the biasFactor to different forecasts.\n}\n\\details{\nInformation about the method and how biasCorrect works can be found in \\code{\\link{biasCorrect}}\n\n\\strong{why use biasFactor}\n\nAs for forecasting, for daily data, there is usually no need to have\ndifferent bias factor every different day. You can calculate one bisa factor using a long\nperiod of hindcast and obs, and apply that factor to different frc.\n\nFor example,\n\nYou have 10 years of hindcast and observation. you want to do bias correction for some \nforecasting product, e.g. system 4. For system 4, each month, you will get a new forecast\nabout the future 6 months. So if you want to do the real time bias correction, you have to\ntake the 10 years of hindcast and observation data with you, and run \\code{biasCorrect} every\ntime you get a new forecast. That's too expensive.\n\nFor some practical use in forecasting, there isn't a so high demand for accuracy. E.g.,\nMaybe for February and March, you can use the same biasFactor, no need to do the computation \nagain. \n\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n#' # Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\n\nbiasFactor <- getBiasFactor(nc, tgridData)\nnewFrc <- applyBiasFactor(nc, biasFactor)\n \nbiasFactor <- getBiasFactor(nc, tgridData, method = 'eqm', extrapolate = 'constant',\npreci = TRUE)\n# This method needs obs input.\nnewFrc <- applyBiasFactor(nc, biasFactor, obs = tgridData)\n\nbiasFactor <- getBiasFactor(nc, tgridData, method = 'gqm', preci = TRUE)\nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nbiasFactor <- getBiasFactor(hindcast, obs)\nfrc_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\nbiasFactor <- getBiasFactor(hindcast, obs, preci = TRUE)\nfrc_new1 <- applyBiasFactor(frc, biasFactor)\n\n# You can use other methods to biascorrect, e.g. delta method. \nbiasFactor <- getBiasFactor(hindcast, obs, method = 'delta')\n# delta method needs obs input.\nfrc_new2 <- applyBiasFactor(frc, biasFactor, obs = obs)\n\n# \nbiasFactor <- getBiasFactor(hindcast, obs, method = 'eqm', preci = TRUE)\n# eqm needs obs input\nfrc_new3 <- applyBiasFactor(frc, biasFactor, obs = obs)\n\nbiasFactor <- getBiasFactor(hindcast, obs, method = 'gqm', preci = TRUE)\nfrc_new4 <- applyBiasFactor(frc, biasFactor)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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 https://yuanchao-xu.github.io/hyfo/\n\n\n}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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\\seealso{\n\\code{\\link{biasCorrect}} for method used in bias correction. \n\\code{\\link{getBiasFactor}}, for the first part.\n}\n\n", + "created" : 1487955904024.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1640022767", + "id" : "D22A91DA", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/applyBiasFactor.Rd", + "project_path" : "man/applyBiasFactor.Rd", + "properties" : { + }, + "relative_order" : 21, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D3DE8C31 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D3DE8C31 new file mode 100644 index 0000000..4ef0544 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/D3DE8C31 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Extract period from list or dataframe.\n#' \n#' Extract common period or certain period from a list of different dataframes of time series, or from a \n#' dataframe. \n#' NOTE: all the dates in the datalist should follow the format in ?as.Date{base}.\n#' @param data A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.\n#' @param startDate A Date showing the start of the extract period, default as NULL, check details.\n#' @param endDate A Date showing the end of the extract period, default as NULL, check details.\n#' @param commonPeriod A boolean showing whether the common period is extracted. If chosen, startDate and endDate\n#' should be NULL.\n#' @param year extract certain year in the entire time series. if you want to extract year 2000, set \\code{year = 2000}\n#' @param month extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, \n#' set \\code{month = c(1, 2)}.\n#' @details \n#' \\strong{startDate and endDate}\n#' \n#' If startDate and endDate are assigned, then certain period between startDate and endDate will be returned, \n#' for both datalist input and dataframe input.\n#' \n#' If startDate and endDate are NOT assigned, then,\n#' \n#' if input is a datalist, the startDate and endDate of the common period of different datalists will be assigned\n#' to the startDate and endDate.\n#' \n#' if input is a dataframe, the startDate and endDate of the input dataframe will be assigned to the startDate\n#' and endDate . Since different value columns share a common Date column in a dataframe input. \n#' \n#' \\strong{year and month}\n#' \n#' For year crossing month input, hyfo will take from the year before. E.g. if \\code{month = c(10, 11, 12, 1)},\n#' and \\code{year = 1999}, hyfo will take month 10, 11 and 12 from year 1998, and month 1 from 1999.You DO NOT \n#' have to set \\code{year = 1998 : 1999}.\n#' \n#' Well, if you set \\code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998,\n#' then, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year.\n#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @return A list or a dataframe with all the time series inside containing the same period.\n#' @examples\n#' # Generate timeseries datalist. Each data frame consists of a Date and a value.\n#' \n#' AAA <- data.frame(\n#' # date column\n#' Date = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1),\n#' # value column\n#' AAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE))\n#' \n#' BBB <- data.frame(\n#' Date = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), \n#' BBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE))\n#' \n#' CCC <- data.frame(\n#' Date = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), \n#' CCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) \n#' \n#' list <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file.\n#' \n#' list_com <- extractPeriod(list, commonPeriod = TRUE)\n#' \n#' # list_com is the extracted datalist.\n#' str(list_com)\n#' \n#' # If startDate and endDate is provided, the record between them will be extracted.\n#' # make sure startDate is later than any startDate in each dataframe and endDate is \n#' # earlier than any endDate in each dataframe.\n#' \n#' data(testdl)\n#' datalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n#' \n#' \n#' dataframe <- list2Dataframe(datalist_com1)\n#' # now we have a dataframe to extract certain months and years.\n#' dataframe_new <- extractPeriod(dataframe, month = c(1,2,3))\n#' dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995)\n#' \n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @importFrom zoo as.Date\n#' @references \n#' \n#' \\itemize{\n#' \\item Achim Zeileis and Gabor Grothendieck (2005). zoo: S3 Infrastructure for Regular and Irregular Time\n#' Series. Journal of Statistical Software, 14(6), 1-27. URL https://www.jstatsoft.org/v14/i06/\n#' }\n#'\n#' @export\nsetGeneric('extractPeriod', function(data, startDate = NULL, endDate = NULL, commonPeriod = FALSE, \n year = NULL, month = NULL) {\n standardGeneric('extractPeriod')\n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('data.frame'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n dataframe <- data\n dataset <- extractPeriod_dataframe(dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n return(dataset)\n \n})\n\n\n#' @rdname extractPeriod\n#' @importFrom methods setMethod\nsetMethod('extractPeriod', signature('list'),\n function(data, startDate, endDate, commonPeriod, year, month) {\n datalist <- data\n if (!is.null(startDate) & !is.null(endDate) & commonPeriod == FALSE) {\n dataset <- lapply(data, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n } else if (is.null(startDate) & is.null(endDate) & commonPeriod == TRUE) {\n \n Dates <- lapply(datalist, extractPeriod_getDate)\n # Here don't know why rbindlist cannot work, change back to do.call\n Dates <- do.call('rbind', Dates)\n \n startDate <- as.Date(max(Dates[, 1]))\n endDate <- as.Date(min(Dates[, 2]))\n \n dataset <- lapply(datalist, extractPeriod_dataframe, startDate = startDate, endDate = endDate, year = year,\n month = month)\n \n } else {\n stop('Enter startDate and endDate, set commonPeriod as False, or simply set commonPeriod as TRUE')\n }\n return(dataset)\n })\n\n\n\n\nextractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, month = NULL) {\n # to check whether first column is a date format\n if (!grepl('-|/', dataframe[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 dataframe[, 1] <- as.Date(dataframe[, 1])\n \n if (is.null(startDate)) startDate <- dataframe[1, 1]\n if (is.null(endDate)) endDate <- tail(dataframe[, 1], 1)\n \n startIndex <- which(dataframe[, 1] == startDate)\n endIndex <- which(dataframe[, 1] == endDate)\n if (length(startIndex) == 0 | length(endIndex) == 0) {\n stop('startDate and endDate exceeds the date limits in dataframe. Check datalsit please.')\n }\n output <- dataframe[startIndex:endIndex, ]\n \n \n if (!is.null(year)) {\n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n if (is.null(month) || !any(sort(month) != month)) {\n DateIndex <- which(yea %in% year)\n if (length(DateIndex) == 0) stop('No input years in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n \n # if year crossing than sort(month) != month, in this case we need to\n # take months from last year.\n } else {\n \n \n startIndex <- intersect(which(yea == year[1] - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == tail(year, 1)), which(mon == tail(month, 1))), 1)\n \n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n }\n output <- output[startIndex:endIndex, ]\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again. \n Date <- as.POSIXlt(output[, 1])\n yea <- Date$year + 1900\n mon <- Date$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n output <- output[DateIndex, ]\n \n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n \n }\n \n \n if (!is.null(month)) {\n Date <- as.POSIXlt(output[, 1])\n mon <- Date$mon + 1\n \n # %in% can deal with multiple equalities\n DateIndex <- which(mon %in% month)\n \n if (length(DateIndex) == 0) stop('No input months in the input ts, check your input.')\n \n output <- output[DateIndex, ]\n }\n \n \n return(output) \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 https://www.R-project.org/.\n#' }\n#' \n#' \nextractPeriod_getDate <- function(dataset) {\n \n if (!grepl('-|/', dataset[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 start <- as.Date(dataset[1, 1])\n end <- as.Date(tail(dataset[, 1], 1))\n \n \n return(c(start, end))\n }\n\n\n\n", + "created" : 1487522389624.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "760401439", + "id" : "D3DE8C31", + "lastKnownWriteTime" : 1488015924, + "last_content_update" : 1488015924894, + "path" : "~/GitHub/hyfo/R/extractPeriod(generic).R", + "project_path" : "R/extractPeriod(generic).R", + "properties" : { + }, + "relative_order" : 15, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E1CE201C b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E1CE201C new file mode 100644 index 0000000..81807b8 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E1CE201C @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "# hyfo\n[![Travis-CI Build Status](https://travis-ci.org/Yuanchao-Xu/hyfo.svg?branch=master)](https://travis-ci.org/Yuanchao-Xu/hyfo)\n[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/hyfo)](https://cran.r-project.org/package=hyfo)\n\n## Installation\n\nReleased version from CRAN, for beginners and normal users:\n\n```R\ninstall.packages(\"hyfo\")\n```\n\nDevelopment version from github, for experienced users and those who are interested in investigating:\n\n```R\ninstall.packages(\"devtools\")\n# You can ignore the line above, if you have already installed devtools\ndevtools::install_github(\"Yuanchao-Xu/hyfo\")\n```\n\n**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo)**\n\nhyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate.\n\nThis package mainly focuses on data process and visulization in hydrology and climate forecasting. Main function includes NetCDF file processing, data extraction, data downscaling, data resampling, gap filler of precipitation, bias correction of forecasting data, flexible time series plot, and spatial map generation. It is a good pre-processing and post-processing tool for hydrological and hydraulic modellers.\n\n**If you feel hyfo is of a little help, please cite it as following:**\n\nXu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/\n\n\n\n\n", + "created" : 1488018138822.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3806014512", + "id" : "E1CE201C", + "lastKnownWriteTime" : 1488018159, + "last_content_update" : 1488018159966, + "path" : "~/GitHub/hyfo/README.md", + "project_path" : "README.md", + "properties" : { + }, + "relative_order" : 55, + "source_on_save" : false, + "source_window" : "", + "type" : "markdown" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E6AC5179 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E6AC5179 new file mode 100644 index 0000000..691fc9b --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/E6AC5179 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/resample(generic).R\n\\docType{methods}\n\\name{resample}\n\\alias{resample}\n\\alias{resample,data.frame-method}\n\\alias{resample,list-method}\n\\title{Resample your time series or ncdf files.}\n\\usage{\nresample(data, method)\n\n\\S4method{resample}{data.frame}(data, method)\n\n\\S4method{resample}{list}(data, method)\n}\n\\arguments{\n\\item{data}{a hyfo grid data or a time series, with first column date, and second column value. The date column should\nfollow the format in \\code{as.Date}, i.e. seperate with \"-\" or \"/\". Check details for more information.}\n\n\\item{method}{A string showing whether you want to change a daily data to monthly data or monthly\ndata to daily data.e.g. \"mon2day\" and \"day2mon\".}\n}\n\\value{\nconverted time series.\n}\n\\description{\nResameple your time series or ncdf files, more info pleae see details.\n}\n\\details{\nNote, when you want to change daily data to monthly data, a new date column will be generated,\nusually the date column will be the middle date of each month, 15th, or 16th. However, if your \ntime series doesn't start from the beginning of a month or ends to the end of a month, e.g. \nfrom 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 \nnot calculating based on a intact month. \n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\n}\n\\examples{\n# Daily to monthly\ndata(testdl)\nTS <- testdl[[2]] # Get daily data\nstr(TS)\nTS_new <- resample(TS, method = 'day2mon')\n\n# Monthly to daily\nTS <- data.frame(Date = seq(as.Date('1999-9-15'), length = 30, by = '1 month'), \nrunif(30, 3, 10))\nTS_new <- resample(TS, method = 'mon2day')\n\n#' # First load ncdf file.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\nnc_new <- resample(nc, 'day2mon')\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n}\n}\n\n", + "created" : 1488014904885.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4112848040", + "id" : "E6AC5179", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/resample.Rd", + "project_path" : "man/resample.Rd", + "properties" : { + }, + "relative_order" : 46, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EA6E74D8 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EA6E74D8 new file mode 100644 index 0000000..6a2ef5a --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EA6E74D8 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Convert a list to a dataframe.\n#' \n#' Convert a list of different time series to a dataframe. Usually the list is the output of\n#' \\code{extractPeriod}\n#' NOTE: Since it's dataframe, so the dataframes in the input datalist should have the same \n#' date, if not, please use \\code{extractPeriod} to process.\n#'\n#' @param datalist A list containing different time series, each sub list has to have the same length.\n#' @return The converted dataframe\n#' \n#' @examples\n#' # open file attached in the package.\n#' file <- system.file(\"extdata\", \"testdl.txt\", package = \"hyfo\")\n#' datalist <- dget(file) # read list file.\n#' datalist_new <- extractPeriod(datalist, commonPeriod = TRUE)\n#' \n#' dataframe <- list2Dataframe(datalist_new)\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\nlist2Dataframe <- function(datalist) {\n \n data <- lapply(datalist, function(x) x[, 2:ncol(x)])\n names <- lapply(datalist, function(x) colnames(x)[2:ncol(x)])\n names <- do.call('cbind', names)\n Date <- datalist[[1]][, 1]\n data <- data.frame(data)\n colnames(data) <- names\n data <- data.frame(cbind(Date, data))\n \n return(data)\n}", + "created" : 1488017839502.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "3317985071", + "id" : "EA6E74D8", + "lastKnownWriteTime" : 1488017860, + "last_content_update" : 1488017860413, + "path" : "~/GitHub/hyfo/R/list2dataframe.R", + "project_path" : "R/list2dataframe.R", + "properties" : { + }, + "relative_order" : 51, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EB85B1DD b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EB85B1DD new file mode 100644 index 0000000..ede9f38 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EB85B1DD @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/list2dataframe.R\n\\name{list2Dataframe}\n\\alias{list2Dataframe}\n\\title{Convert a list to a dataframe.}\n\\usage{\nlist2Dataframe(datalist)\n}\n\\arguments{\n\\item{datalist}{A list containing different time series, each sub list has to have the same length.}\n}\n\\value{\nThe converted dataframe\n}\n\\description{\nConvert a list of different time series to a dataframe. Usually the list is the output of\n\\code{extractPeriod}\nNOTE: Since it's dataframe, so the dataframes in the input datalist should have the same \ndate, if not, please use \\code{extractPeriod} to process.\n}\n\\examples{\n# open file attached in the package.\nfile <- system.file(\"extdata\", \"testdl.txt\", package = \"hyfo\")\ndatalist <- dget(file) # read list file.\ndatalist_new <- extractPeriod(datalist, commonPeriod = TRUE)\n\ndataframe <- list2Dataframe(datalist_new)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\n", + "created" : 1487956425806.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1268507476", + "id" : "EB85B1DD", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/list2Dataframe.Rd", + "project_path" : "man/list2Dataframe.Rd", + "properties" : { + }, + "relative_order" : 42, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EBF4F7FE b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EBF4F7FE new file mode 100644 index 0000000..75a2aac --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EBF4F7FE @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/getSpatialMap.R\n\\name{getSpatialMap_mat}\n\\alias{getSpatialMap_mat}\n\\title{Replot raster matrix}\n\\usage{\ngetSpatialMap_mat(matrix, title_d = NULL, catchment = NULL, point = NULL,\n output = \"data\", name = NULL, info = FALSE, scale = \"identity\",\n color = NULL, ...)\n}\n\\arguments{\n\\item{matrix}{A matrix raster, should be the result of \\code{getSpatialMap()}, output should be default\nor 'data'}\n\n\\item{title_d}{A string showing the title of the plot, defaut is NULL.}\n\n\\item{catchment}{A catchment file geting from \\code{shp2cat()} in the package, if a catchment is available for background.}\n\n\\item{point}{A dataframe, showing other information, e.g., location of the gauging stations. The \nthe data.frame should be with columes \"name, lon, lat, z, value\".}\n\n\\item{output}{A string showing the type of the output, if \\code{output = 'ggplot'}, the returned \ndata can be used in ggplot and \\code{getSpatialMap_comb()}; if \\code{output = 'plot'}, the returned data is the plot containing all \nlayers' information, and can be plot directly or used in grid.arrange; if not set, the raster matrix data\nwill be returned.}\n\n\\item{name}{If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\ndifferent outputs in the later multiplot using \\code{getSpatialMap_comb}.}\n\n\\item{info}{A boolean showing whether the information of the map, e.g., max, mean ..., default is FALSE.}\n\n\\item{scale}{A string showing the plot scale, 'identity' or 'sqrt'.}\n\n\\item{color}{Most of time you don't have to set this, but if you are not satisfied with the \ndefault color, you can set your own palette here. e.g., \\code{color = c('red', 'blue')}, then\nthe value from lowest to highest, will have the color from red to blue. More info about color,\nplease check ?palette().}\n\n\\item{...}{\\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\ndefault is about precipitation.}\n}\n\\value{\nA matrix representing the raster map is returned, and the map is plotted.\n}\n\\description{\nreplot the matrix output from \\code{getSpatialMap}, when \\code{output = 'data'} or output is default\nvalue.\n}\n\\examples{\n\n\\dontrun{\ndata(tgridData)# the result of \\\\code{loadNcdf}\n#the output type of has to be default or 'data'.\na1 <- getSpatialMap(tgridData, method = 'mean')\na2 <- getSpatialMap(tgridData, method = 'max')\na3 <- getSpatialMap(tgridData, method = 'winter')\na4 <- getSpatialMap(tgridData, method = 'summer')\n#For example, if we want to investigate the difference between mean value and max.\n\na5 <- a2 - a1\ngetSpatialMap_mat(a4)\n\n#Or to investigate the difference between winter value and summer value.\na6 <- a3 - a4\ngetSpatialMap_mat(a6)\n\n}\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\nStatistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n\n\\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n21(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\nSoftware, 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\nby Thomas P Minka (2015). maps: Draw Geographical Maps. R package version\n2.3-11. https://CRAN.R-project.org/package=maps\n\n\\item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial\nObjects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools\n\n\\item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R\npackage version 0.3-11. https://CRAN.R-project.org/package=rgeos\n\n}\n}\n\n", + "created" : 1487956385696.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "644387789", + "id" : "EBF4F7FE", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/getSpatialMap_mat.Rd", + "project_path" : "man/getSpatialMap_mat.Rd", + "properties" : { + }, + "relative_order" : 41, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EC7924C8 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EC7924C8 new file mode 100644 index 0000000..488d374 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EC7924C8 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Collect data from csv for Anarbe case.\n#' \n#' Collect data from the gauging stations in spain, catchement Anarbe\n#' \n#' @param folderName A string showing the path of the folder holding different csv files.\n#' @param output A boolean showing whether the output is given, default is T.\n#' @return The collected data from different csv files.\n#' @examples\n#' \n#' #use internal data as an example.\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_csv_anarbe(folder)\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n#' }\n#' \n#' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_csv_anarbe <- function(folderName, output = TRUE){\n \n fileNames <- list.files(folderName, pattern='*.csv', full.names = TRUE)\n data <- lapply(fileNames, readColumn_csv_anarbe)\n data <- rbindlist(data)\n data <- data[, 1:2]\n # cus the special structure of data.tables, here should be data[[1]], instead of data[, 1]\n data[, 1] <- as.Date(data[[1]], format = '%d/%m/%Y')\n \n #newFileName <- file.choose(new = T)\n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n if (output) return(data)\n}\n\n\nreadColumn_csv_anarbe <- function(fileName){\n data <- read.csv(fileName, skip = 4)\n endIndex <- which(data == '', arr.ind = TRUE)[1]-1\n \n data <- data[1:endIndex, ]\n \n if (!is.null(levels(data[, 2]))) {\n data[, 2] <- as.numeric(levels((data[, 2])))[data[, 2]]\n }\n \n colnames(data) <- c('Date', 'target')\n message(fileName)\n \n return(data)\n}\n\n\n\n#' Collect data from different excel files\n#' \n#' @param folderName A string showing the folder path.\n#' @param keyword A string showing the extracted column, e.g., waterLevel, waterBalance.\n#' @param output A boolean showing whether the output is given.\n#' @return The collected data from different excel files.\n#' @export\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# @importFrom utils write.table\ncollectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){\n \n message('In order to make \"hyfo\" easier to be installed, this part is commented,\n check original R file in your computer or go to \n https://github.com/Yuanchao-Xu/hyfo/blob/master/R/collectData_excel.R\n for ideas.')\n \n \n # newFileName <- file.choose(new = TRUE)\n # message ('new file should be located a different location than the excel folder, \n # in order to avoid error.\n # At least 2 excels should be in the folder\\n')\n # \n # message ('this function only applies to strange spain dem operation record file, and this strange file changes\n # its format in the middle of the record. For other applications, some tiny changes needs to be made.')\n # if (is.null(keyword)) stop('key word is needed, e.g.\"waterLevel\".')\n # \n # fileNames <- list.files(folderName, pattern = '*.xls', full.names = TRUE)\n # data <- lapply(fileNames, FUN = readColumn_excel_anarbe, keyword = keyword)\n # checkBind(data, 'rbind')\n # data <- do.call('rbind', data)\n # \n # data_new <- data.frame(data)\n # \n # data_new <- data_new[order(data_new[, 1]), ]\n # \n # \n # startDate <- data_new[1, 1]\n # endDate <- data_new[length(data_new[, 1]), 1]\n # \n # Date <- as.factor(seq(startDate, endDate, by = 1))\n # \n # if (length(Date) != length(data_new[, 1])) stop('check if the excel files are continuous')\n # \n # colnames(data_new) <- c('Date', keyword)\n # \n # write.table(data_new, file = newFileName,\n # row.names = FALSE, col.names = TRUE, sep = ',')\n # if(output == TRUE) return(data_new)\n}\n\n# \n# @importFrom xlsx read.xlsx\n# readTable_excel_anarbe <- function(fileName){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]], 3)\n# raw_year <- index[1]\n# raw_mon <- index[2]\n# \n# raw <- read.xlsx(fileName, sheetName='A')\n# startRow <- which(raw == 'COTA', arr.ind = TRUE)[1]+4\n# startCol <- which(raw == 'COTA',arr.ind = TRUE)[2]-1\n# stopRow <- which(raw =='TOTAL',arr.ind = TRUE)[1]-1\n# stopCol1 <- startCol + 17\n# stopCol2 <- which(raw == 'SUPERFICIE', arr.ind = TRUE)[2]\n# data <- cbind(raw[startRow:stopRow,startCol:stopCol1], raw[startRow:stopRow,stopCol2])\n# \n# \n# yearIndex <- rep(raw_year, stopRow-startRow+1)\n# monIndex <- rep(raw_mon, stopRow-startRow+1)\n# \n# data <- cbind(yearIndex, monIndex, data)\n# return(data)\n# }\n# # \n# @importFrom utils tail\n# readColumn_excel_anarbe <- function(fileName, keyword = NULL){\n# \n# index <- tail(strsplit(fileName, '\\\\.|\\\\ ')[[1]],3)\n# year <- as.numeric(index[1])\n# mon <- as.numeric(index[2])\n# \n# if (year == 99) {\n# year = year + 1900\n# } else year = year + 2000\n# \n# word = c('COTA', 'Cota\\n(m)', 'TOTAL', ' TOTAL')\n# \n# if (keyword == 'waterLevel') {\n# searchWord <- c('COTA', 'Cota\\n(m)')\n# } else if (keyword == 'discharge_ERE') {\n# searchWord <- c('AF.ERE-', 'Caudal\\n(m??/s)')\n# } else if (keyword == 'waterBalance') {\n# searchWord <- c('INCREMENTO', 'al Canal Bajo', 'AFORO',\n# 'Variaci??n\\nvolumen embalsado')\n# } else if (keyword == 'surfaceArea') {\n# searchWord <- c('SUPERFICIE', 'SUPERFICIE')\n# } else if (keyword == 'volume') {\n# searchWord <- c('EMBALSADO', 'Volumen\\n(m????)')\n# }\n# \n# \n# if (year == 1999 | year < 2009 | (year == 2009 & mon < 5)) {\n# raw <- xlsx::read.xlsx(fileName, sheetName = 'A')\n# startIndex <- which(raw == word[1], arr.ind = TRUE)\n# endIndex <- which(raw == word[3], arr.ind = TRUE)\n# startRow <- startIndex[1]+4\n# endRow <- endIndex[1]-1\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# \n# targetCol <- which(raw == searchWord[1], arr.ind = TRUE)[2]\n# \n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[3], arr.ind = TRUE)[2]\n# a <- raw[startRow:endRow, targetStart:targetEnd]\n# a <- sapply(a, function(x) as.numeric(levels(x)[x]))\n# \n# if (year == 1999 & mon == 4) {\n# \n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, rep(NA, dim(a)[1]), a[, 6] * 86.4,\n# a[, 4] * 86.4, a[, 11] * 86.4, a[, 3], a[, 7], rep(NA, dim(a)[1]), a[, 1])\n# } else {\n# target <- data.frame(a[, 2] * 86.4, a[, 5] * 86.4, a[, 6] * 86.4, a[, 7] * 86.4, \n# a[, 4] * 86.4, a[, 12] * 86.4, a[, 3], a[, 8], rep(NA, dim(a)[1]), a[, 1])\n# } \n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# if (keyword == 'discharge_ERE') target <- as.numeric(levels(target))[target]/1000\n# }\n# \n# } else {\n# raw <- read.xlsx(fileName,sheetName = 'parte del embalse')\n# startIndex <- which(raw == word[2], arr.ind = TRUE)\n# endIndex <- which(raw == word[4], arr.ind = TRUE)\n# startRow <- startIndex[1]+1\n# endRow <- endIndex[1]-2\n# \n# dayCol <- endIndex[2]\n# day <- raw[startRow:endRow, dayCol]\n# targetCol <- which(raw == searchWord[2], arr.ind=TRUE)[2]\n# if (is.na(targetCol)) stop(sprintf('capture nothing in %s', fileName))\n# \n# if (keyword == 'waterBalance') {\n# targetStart <- targetCol\n# targetEnd <- which(raw == searchWord[4], arr.ind=TRUE)[2]\n# target <- raw[startRow:endRow, targetStart:targetEnd]\n# \n# } else {\n# target <- raw[startRow:endRow, targetCol]\n# }\n# \n# }\n# \n# \n# startDate <- as.Date(paste(year, mon, day[1], sep = '-'))\n# endDate <- as.Date(paste(year, mon, tail(day,1), sep = '-'))\n# \n# Date <- seq(startDate, endDate, 1)\n# output <- data.frame(Date, as.vector(target))\n# colnames(output) <- c('Date', seq(1, dim(output)[2] - 1))\n# message(fileName) \n# return(output)\n# \n# }\n# \n\n\n\n\n\n#' collect data from different txt.\n#' \n#' @param folderName A string showing the folder path.\n#' @param output A boolean showing whether the result is given.\n#' @param rangeWord A list containing the keyword and the shift. \n#' defaut is set to be used in spain gauging station.\n#' @examples\n#' \n#' #use internal data as an example.\n#' \n#' \\dontrun{\n#' file <- system.file(\"extdata\", \"1999.csv\", package = \"hyfo\")\n#' folder <- strsplit(file, '1999')[[1]][1]\n#' a <- collectData_txt_anarbe(folder)\n#' }\n#'\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \\itemize{\n#' \\item http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/.\n#' }\n#' \n#' \n#' @source http://www4.gipuzkoa.net/oohh/web/esp/02.asp\n#' @return The collected data from different txt files.\n#' @export\n#' @importFrom utils tail\n#' @importFrom data.table rbindlist\ncollectData_txt_anarbe <- function(folderName, output = TRUE, rangeWord = c('Ene ', -1, \n 'Total ', -6)){\n #All the code should be ASCII encode, so there should be no strange symbol.\n if (is.null(rangeWord)) {\n stop('rangeWord consists of 4 elements:\n 1. start word which program can recognise.\n 2. shift1, the shift needs to be made. E.g. start word is in line 7, and program\n should read file from line 9, then shift is 9-7 = 2.\n 3. end word, as start word\n 4. shift2, same as shift1, sometimes can be negative\n \n E.g. rangeWord=c(\\\"aaa\\\",2,\\\"bbb\\\",-2)\n if no rangeWord, just input c(NULL,NULL,NULL,NULL)')\n \n }\n \n \n fileNames <- list.files(folderName, pattern = '*.TXT', full.names = TRUE)\n \n data <- lapply(fileNames, FUN = readColumn_txt_anarbe, rangeWord = rangeWord)\n \n data <- rbindlist(data)\n \n a <- unlist(strsplit(folderName, '\\\\\\\\|/'))\n tarName <- tail(a, 2)[1]\n colnames(data) <- c('Date', tarName)\n \n #newFileName <- file.choose(new = T)\n message('new file should be located a different location than the excel folder,\n in order to avoid error.\n At least 2 excels should be in the folder')\n \n #write.table(data_new,file=newFileName,row.names = F, col.names = F,sep=',')\n \n \n if (output == TRUE) return(data)\n \n} \n\n\n\nanarbe_txt <- function(dataset, x1, x2){\n \n data <- as.matrix(dataset[x1:x2, 2:13])\n startYear <- data[1, 6]\n \n data <- data[5:35, ]\n \n date <- which(data != ' ', arr.ind = TRUE)\n startDate <- date[1, ]\n \n endDate <- date[length(date[, 1]), ]\n \n startDate <- as.Date(paste(startYear, startDate[2], startDate[1], sep = '-'))\n endDate <- as.Date(paste(startYear, endDate[2], endDate[1], sep = '-'))\n \n Date <- as.factor(seq(startDate, endDate, 1))\n \n dim(data) <- c(length(data), 1)\n \n data <- as.numeric(data[which(data != ' '), ])\n \n if (length(data) != length(Date)) {\n stop('check original txt file. for missing value, the symbol is \"--\", check\n if this symbol is missing somewhere')\n }\n \n output <- data.frame(Date = Date, target = data)\n \n return(output)\n }\n\n\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 https://www.R-project.org/.\n#' }\n#' \n#' @importFrom utils read.fwf\nreadColumn_txt_anarbe <- function(fileName, keyword = NULL, rangeWord = NULL){\n \n a <- read.fwf(fileName, widths = rep(10,13))#read file with fixed width\n \n startRow <- which(a == rangeWord[1], arr.ind = TRUE)[, 1]\n startRow <- startRow + as.numeric(rangeWord[2])\n \n endRow <- which(a == rangeWord[3], arr.ind = TRUE)[, 1]\n endRow <- endRow + as.numeric(rangeWord[4])\n \n data <- mapply(FUN = function(x1, x2) anarbe_txt(dataset = a, x1, x2), startRow, endRow)\n \n data_new <- data.frame(Data = unlist(data[1, ]), target = unlist(data[2, ]))\n message(fileName)\n return(data_new)\n}\n", + "created" : 1487522240065.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2673469439", + "id" : "EC7924C8", + "lastKnownWriteTime" : 1488015187, + "last_content_update" : 1488015188001, + "path" : "~/GitHub/hyfo/R/case_anarbe.R", + "project_path" : "R/case_anarbe.R", + "properties" : { + }, + "relative_order" : 13, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EEC7BFEB similarity index 86% rename from .Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/EEC7BFEB index 55a9bca..09a4c0d 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/EEC7BFEB +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EEC7BFEB @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.9\nDate: 2017-2-20\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling,\n data resampling, gap filler of precipitation, bias correction of forecasting\n data, flexible time series plot, and spatial map generation. It is a good pre-\n processing and post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods,\n data.table\nSuggests:\n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: http://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\nRoxygenNote: 5.0.1\n", + "contents" : "Package: hyfo\nType: Package\nTitle: Hydrology and Climate Forecasting\nVersion: 1.3.9\nDate: 2017-2-20\nAuthors@R: person(\"Yuanchao\", \"Xu\", email = \"xuyuanchao37@gmail.com\",\n role = c(\"aut\", \"cre\"))\nDescription: Focuses on data processing and visualization in hydrology and\n climate forecasting. Main function includes data extraction, data downscaling,\n data resampling, gap filler of precipitation, bias correction of forecasting\n data, flexible time series plot, and spatial map generation. It is a good pre-\n processing and post-processing tool for hydrological and hydraulic modellers.\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.8-16),\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 ncdf4 (>= 1.14.1),\n MASS (>= 7.3-39),\n methods,\n data.table\nSuggests:\n gridExtra,\n knitr,\n rmarkdown\nVignetteBuilder: knitr\nLazyData: true\nURL: https://yuanchao-xu.github.io/hyfo/\nBugReports: https://github.com/Yuanchao-Xu/hyfo/issues\nRepository: CRAN\nRoxygenNote: 5.0.1\n", "created" : 1483876827452.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1847610976", + "hash" : "844478590", "id" : "EEC7BFEB", - "lastKnownWriteTime" : 1487525824, - "last_content_update" : 1487525824439, + "lastKnownWriteTime" : 1487955768, + "last_content_update" : 1487955768902, "path" : "~/GitHub/hyfo/DESCRIPTION", "project_path" : "DESCRIPTION", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EF2B4E b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EF2B4E new file mode 100644 index 0000000..0def84e --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/EF2B4E @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "#' Get variable name of the NetCDF file.\n#' \n#' Get variable name in the NetCDF file. After knowning the name, you can use \\code{loadNcdf} to load\n#' the target variable.\n#' \n#' @param filePath A path pointing to the netCDF file.\n#' @return The names of the varialbes in the file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' https://CRAN.R-project.org/package=ncdf4\n#' }\n#' \n#' \n#' \n#' @export\ngetNcdfVar <- function(filePath) {\n nc <- nc_open(filePath)\n names <- names(nc$var)\n return(names)\n}\n\n\n#' Load NetCDF file\n#' \n#' @param filePath A path pointing to the NetCDF file, version3.\n#' @param varname A character representing the variable name, you can use \\code{getNcdfVar} to\n#' get the basic information about the variables and select the target.\n#' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n# @param drop When the time dimension only have one value, the output data will drop\n# this dimension automatically (\\code{drop = TRUE}), default value is \\code{drop = FALSE}, then time dimension will be added.\n# This argument mainly applies to the later calculations based on hyfo file. If the dimension\n# is dropped, than some calculations may not be processed afterwards. \n#' @param ... Several arguments including Year, month, lon, lat \n#' type in \\code{?downscaleNcdf} for details.You can load while downscale, \n#' and also first load than use \\code{downscaleNcdf} to downscale.\n#' @return A list object from \\code{hyfo} containing the information to be used in the analysis, \n#' or biascorrection.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # you can directly add your downscale information to the argument.\n#' nc1 <- loadNcdf(filePath, varname, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- loadNcdf(filePath, varname, year = 2005, month = 3:8, lon = c(-2, -0.5), \n#' lat = c(43.2, 43.7))\n#' \n#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' https://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \nloadNcdf <- function(filePath, varname, tz = 'GMT', ...) {\n nc <- nc_open(filePath)\n \n var <- nc$var\n # Use name to locate the variable\n call_1 <- as.call(c(\n list(as.name('$'), var, varname)\n ))\n var <- eval(call_1)\n if(is.null(var)) stop('No such variable name, check source file.')\n \n dimNames <- unlist(lapply(1:length(var$dim), function(x) var$dim[[x]]$name))\n \n # Only deals with the most common dimensions, futher dimensions will be added in future.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\n if (length(dimIndex) < 3) stop('Your file has less than 3 dimensions.')\n \n # First needs to identify the variable name, load the right data\n message('Loading data...')\n nc_data <- ncvar_get(nc, var)\n message('Processing...')\n \n gridData <- list()\n gridData$Variable$varName <- varname\n gridData$xyCoords$x <- var$dim[[dimIndex[1]]]$vals\n attributes(gridData$xyCoords$x)$name <- dimNames[dimIndex[1]]\n \n gridData$xyCoords$y <- var$dim[[dimIndex[2]]]$vals\n attributes(gridData$xyCoords$y)$name <- dimNames[dimIndex[2]]\n \n # Time part needs to be taken seperately\n \n timeUnit <- strsplit(var$dim[[dimIndex[3]]]$units, split = ' since')[[1]][1]\n timeDiff <- var$dim[[dimIndex[3]]]$vals\n # To get real time, time since when has to be grabbed from the dataset.\n timeSince <- as.POSIXlt(strsplit(var$dim[[dimIndex[3]]]$units, split = 'since')[[1]][2], tz = tz)\n \n \n# Date <- rep(timeSince, length(timeDiff))\n \n \n unitDic <- data.frame(weeks = 'weeks', days = 'days', hours = 'hours',\n minutes = 'mins', seconds = 'secs')\n \n timeDiff <- as.difftime(timeDiff, units = as.character(unitDic[1, timeUnit]))\n \n# if (grepl('day', timeUnit)) {\n# Date$mday <- Date$mday + timeDiff\n# } else if (grepl('second', timeUnit)) {\n# Date$sec <- Date$sec + timeDiff\n# }\n Date <- timeSince + timeDiff\n \n # data directly loaded from ncdf4 will drop the dimension with only one value.\n # the varsize shows the real dimension, without any dropping.\n dim(nc_data) <- var$varsize \n \n # Right now there is no need to add end Date, in furture, may be added as needed.\n gridData$Dates$start <- as.character(Date)\n \n # Assing data to grid data\n # At leaset should be 3 dimensions, lon, lat, time. So if less than 3, \n \n gridData$Data <- nc_data\n \n attributes(gridData$Data)$dimensions <- dimNames\n \n if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals\n \n gridData$Loaded <- 'by hyfo package, https://yuanchao-xu.github.io/hyfo/'\n nc_close(nc)\n \n output <- downscaleNcdf(gridData, ...)\n \n return(output)\n \n}\n\n\n\n\n#' Downscale NetCDF file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param year A vector of the target year. e.g. \\code{year = 2000}, \\code{year = 1980:2000}\n#' @param month A vector of the target month. e.g. \\code{month = 2}, \\code{month = 3:12}\n#' @param lon A vector of the range of the downscaled longitude, should contain a max value\n#' and a min value. e.g. \\code{lon = c(-1.5, 2,5)}\n#' @param lat A vector of the range of the downscaled latitude, should contain a max value\n#' and a min value. e.g. \\code{lat = c(32,2, 36)}\n#' @return A downscaled hyfo list file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7))\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export \n#' @references \n#' \n#' \\itemize{\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' }\n#' \n#' \ndownscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) {\n \n \n if (!is.null(year)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n yearIndex <- Dates$year + 1900\n monIndex <- Dates$mon + 1\n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n \n if (is.null(month) || !any(sort(month) != month)) {\n targetYearIndex <- which(yearIndex %in% year)\n if (length(targetYearIndex) == 0) stop('No input years in the input ts, check your input.')\n \n \n # if year crossing than sort(month) != month\n } else {\n \n startIndex <- intersect(which(yearIndex == year[1] - 1), which(monIndex == month[1]))[1]\n endIndex <- tail(intersect(which(yearIndex == tail(year, 1)), which(monIndex == tail(month, 1))), 1)\n \n if (is.na(startIndex) || length(endIndex) == 0 || startIndex > endIndex) {\n stop('Cannot find input months and input years in the input time series.')\n } else {\n \n targetYearIndex <- startIndex:endIndex\n \n if (any(diff(year) != 1)) {\n # if year is not continuous, like 1999, 2003, 2005, than we have to sift again.\n # Only for special cases.\n Dates <- Dates[targetYearIndex]\n yea <- Dates$year + 1900\n mon <- Dates$mon + 1\n \n DateIndex <- unlist(sapply(year, function(x) {\n startIndex <- intersect(which(yea == x - 1), which(mon == month[1]))[1]\n endIndex <- tail(intersect(which(yea == x), which(mon == tail(month, 1))), 1)\n index <- startIndex:endIndex\n return(index)\n }))\n \n \n targetYearIndex <- targetYearIndex[DateIndex]\n # cannot directly return output here, because sometimes, month can be incontinuous,\n # we still need the next process to sift month.\n }\n }\n }\n \n gridData$Dates$start <- gridData$Dates$start[targetYearIndex]\n gridData$Dates$end <- gridData$Dates$end[targetYearIndex]\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetYearIndex)\n } \n \n if (!is.null(month)) {\n Dates <- as.POSIXlt(gridData$Dates$start)\n monIndex <- Dates$mon + 1\n \n targetMonIndex <- which(monIndex %in% month)\n if (length(targetMonIndex) == 0) stop('Check your input year, it may exceed the years \n in the input dataset.')\n gridData$Dates$start <- gridData$Dates$start[targetMonIndex]\n gridData$Dates$end <- gridData$Dates$end[targetMonIndex]\n \n timeDim <- match('time', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, timeDim, targetMonIndex)\n \n }\n \n if (!is.null(lon)) {\n \n lonIndex <- gridData$xyCoords$x\n \n lonI1 <- which(abs(lonIndex - min(lon)) == min(abs(lonIndex - min(lon)), na.rm = TRUE)) \n lonI2 <- which(abs(lonIndex - max(lon)) == min(abs(lonIndex - max(lon)), na.rm = TRUE)) \n \n # take the as large as possible range\n targetLonIndex <- lonI1[length(lonI1)]:lonI2[length(lonI2)]\n if (length(targetLonIndex) == 0) stop('Your input lon is too small, try to expand the \n longitude range.') \n gridData$xyCoords$x <- gridData$xyCoords$x[targetLonIndex]\n lonDim <- grepAndMatch('lon', attributes(gridData$Data)$dimensions)\n \n gridData$Data <- chooseDim(gridData$Data, lonDim, targetLonIndex)\n }\n \n \n if (!is.null(lat)) {\n latIndex <- gridData$xyCoords$y\n \n latI1 <- which(abs(latIndex - min(lat)) == min(abs(latIndex - min(lat)), na.rm = TRUE)) \n latI2 <- which(abs(latIndex - max(lat)) == min(abs(latIndex - max(lat)), na.rm = TRUE)) \n \n targetLatIndex <- latI1[length(latI1)]:latI2[length(latI2)]\n \n if (length(targetLonIndex) == 0) stop('Your input lat is too small, try to expand the \n latitude range.') \n gridData$xyCoords$y <- gridData$xyCoords$y[targetLatIndex]\n latDim <- grepAndMatch('lat', attributes(gridData$Data)$dimensions)\n gridData$Data <- chooseDim(gridData$Data, latDim, targetLatIndex)\n }\n \n return(gridData)\n \n}\n\n\n\n\n\n\n\n\n\n\n#' Write to NetCDF file using hyfo list file\n#' @param gridData A hyfo list file from \\code{\\link{loadNcdf}}\n#' @param filePath A path of the new NetCDF file, should end with \".nc\"\n#' @param missingValue A number representing the missing value in the NetCDF file, default\n#' is 1e20\n#' #' @param tz A string representing the time zone, default is GMT, if you know what time zone is \n#' you can assign it in the argument. If \\code{tz = ''}, current time zone will be taken.\n#' @param units A string showing in which unit you are putting in the NetCDF file, it can be \n#' seconds or days and so on. If not specified, the function will pick up the possible largest \n#' time units from \\code{c('weeks', 'days', 'hours', 'mins', 'secs')}\n#' @param version ncdf file versions, default is 3, if 4 is chosen, output file will be foreced to version 4.\n#' @param tz time zone, default is \"GMT\"\n#' @return An NetCDF version 3 file.\n#' @examples \n#' # First open the test NETcDF file.\n#' filePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\n#' \n#' \n#' # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name\n#' varname <- getNcdfVar(filePath)\n#' \n#' nc <- loadNcdf(filePath, varname)\n#' \n#' # Then write to your work directory\n#' \n#' writeNcdf(nc, 'test.nc')\n#' \n#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export \n#' @import ncdf4\n#' @references \n#' \n#' \\itemize{\n#' \\item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or\n#' Earlier) Format Data Files. R package version 1.14.1.\n#' https://CRAN.R-project.org/package=ncdf4\n#' \n#' \\item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package\n#' version 2.2-6. http://meteo.unican.es/ecoms-udg\n#' \n#' }\n#' \n#' \nwriteNcdf <- function(gridData, filePath, missingValue = 1e20, tz = 'GMT', units = NULL, version = 3) {\n \n name <- gridData$Variable$varName\n # First defines dimensions.\n lonName <- attributes(gridData$xyCoords$x)$name\n latName <- attributes(gridData$xyCoords$y)$name\n dimLon <- ncdim_def(lonName, 'degree', gridData$xyCoords$x)\n dimLat <- ncdim_def(latName, 'degree', gridData$xyCoords$y)\n dimMem <- NULL\n if (!is.null(gridData$Members)) {\n dimMem <- ncdim_def('member', 'members', 1:length(gridData$Members))\n }\n \n \n # Time needs to be treated seperately\n dates <- as.POSIXlt(gridData$Dates$start, tz = tz)\n if (is.null(units)) {\n units <- getTimeUnit(dates)\n time <- difftime(dates, dates[1], units = units)\n } else {\n time <- difftime(dates, dates[1], units = units)\n }\n timeUnits <- paste(units, 'since', dates[1])\n # Here time needs to be numeric, as required by ncdf4 package, which is not the same\n # with ncdf\n dimTime <- ncdim_def('time', timeUnits, as.numeric(time))\n \n \n # Depending on whether there is a member part of the dataset.\n # default list\n dimList <- list(dimLon, dimLat, dimTime, dimMem)\n \n # In order to keep the dim list exactly the same with the original one, it needs to be changed.\n dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), attributes(gridData$Data)$dimensions)\n dimIndex <- na.omit(dimIndex)\n \n # Here order is needed, cuz in the procesure above, c('lon', 'lat', 'time', 'member')\n # is the pattern, while actually, attributes(gridData$Data)$dimensions should be the pattern.\n # So here needs an order() to get the wanted result.\n dimList <- dimList[order(dimIndex)]\n \n # delete the NULL list, in order that there is no member part in the data.\n dimList <- Filter(Negate(is.null), dimList)\n # Then difines data\n var <- ncvar_def( name, \"units\", dimList, missingValue)\n \n \n # Here for ncdf4, there is an option to create version 4 ncdf, in future, it\n # may added here.\n if (version == 3) {\n nc <- nc_create(filePath, var) \n } else if (version == 4) {\n nc <- nc_create(filePath, var, force_v4 = TRUE)\n } else {\n stop(\"Which ncdf version you want? Only 3 and 4 can be selected!\")\n }\n \n # This part comes from the library downscaleR, can be deleted if you don't \n # use {ecomsUDG.Raccess}, by adding this, the file can be read by the package {ecomsUDG.Raccess}\n ncatt_put(nc, \"time\", \"standard_name\",\"time\")\n ncatt_put(nc, \"time\", \"axis\",\"T\")\n ncatt_put(nc, \"time\", \"_CoordinateAxisType\",\"Time\")\n #ncatt_put(nc, \"time\", \"_ChunkSize\",1)\n ncatt_put(nc, lonName, \"standard_name\",\"longitude\")\n ncatt_put(nc, lonName, \"_CoordinateAxisType\",\"Lon\")\n ncatt_put(nc, latName, \"standard_name\",\"latitude\")\n ncatt_put(nc, latName, \"_CoordinateAxisType\",\"Lat\")\n if (!is.null(dimMem)){\n ncatt_put(nc, \"member\", \"standard_name\",\"realization\")\n ncatt_put(nc, \"member\", \"_CoordinateAxisType\",\"Ensemble\")\n #att.put.ncdf(nc, \"member\", \"ref\",\"http://www.uncertml.org/samples/realisation\")\n }\n \n \n # This part has to be put\n ncatt_put(nc, 0, \"Conventions\",\"CF-1.4\")\n ncatt_put(nc, 0, 'WrittenBy', 'hyfo(https://yuanchao-xu.github.io/hyfo/)')\n \n #data <- aperm(gridData$Data, dimIndex) no need to do this, in the process above\n # when you define the dimlist, the order of the dimension was fixed.\n data <- gridData$Data\n ncvar_put(nc, name, data)\n nc_close(nc)\n \n}\n\n# For internaluse by writeNcdf\ngetTimeUnit <- function(dates) {\n units <- c('weeks', 'days', 'hours', 'mins', 'secs')\n output <- NULL\n for (unit in units) {\n time <- difftime(dates, dates[1], units = unit)\n rem <- sapply(time, function(x) x%%1)\n if (!any(rem != 0)) {\n output <- unit\n break\n }\n } \n return(output)\n}\n\n\n# Save for future use. \n#' @import ncdf4\n#' @references \n#' David Pierce (2014). ncdf: Interface to Unidata netCDF data files. R package version 1.6.8.\n#' https://CRAN.R-project.org/package=ncdf\ngetExtralDim <- function(...) {\n dimList <- list(...)\n \n \n}\n\n# in order to first grep than match.\n# match only provides for exactly match, \n# dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames)\ngrepAndMatch <- function(x, table) {\n index <- unlist(lapply(x, function(x) {\n a <- grep(x, table)\n }))\n return(index)\n}", + "created" : 1483880947871.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "4267879418", + "id" : "EF2B4E", + "lastKnownWriteTime" : 1488018076, + "last_content_update" : 1488018076214, + "path" : "~/GitHub/hyfo/R/ncdf.R", + "project_path" : "R/ncdf.R", + "properties" : { + }, + "relative_order" : 10, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F28DEBD3 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F28DEBD3 new file mode 100644 index 0000000..75f7e4a --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F28DEBD3 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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{loadNcdf}.\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#' \n#' \\dontrun{\n#' #gridData provided in the package is the result of \\code {loadNcdf}\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#' \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 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 (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#' \n#' \\dontrun{\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#' }\n#' \n#' \n#' # More examples can be found in the user manual on https://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 https://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. https://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. https://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. https://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#' \n#' \n#' \\dontrun{\n#' data(tgridData)# the result of \\code{\\link{loadNcdf}}\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#' \n#' \n#' \n#' # More examples can be found in the user manual on https://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#' @importFrom data.table rbindlist\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 <- rbindlist(list)\n } else {\n maps <- list(...)\n checkBind(maps, 'rbind')\n data_ggplot <- rbindlist(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 = unique(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" : 1487522683331.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "431235859", + "id" : "F28DEBD3", + "lastKnownWriteTime" : 1488017859, + "last_content_update" : 1488017859979, + "path" : "~/GitHub/hyfo/R/getSpatialMap.R", + "project_path" : "R/getSpatialMap.R", + "properties" : { + }, + "relative_order" : 18, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F72259DF b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F72259DF new file mode 100644 index 0000000..08abd01 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F72259DF @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/analyzeTS.R\n\\name{plotTS_comb}\n\\alias{plotTS_comb}\n\\title{Combine time seires plot together}\n\\usage{\nplotTS_comb(..., nrow = 1, type = \"line\", list = NULL, x = \"Date\",\n y = \"\", title = \"\", output = FALSE)\n}\n\\arguments{\n\\item{...}{different time series plots generated by \\code{plotTS(, output = 'ggplot')}, refer to details.}\n\n\\item{nrow}{A number showing the number of rows.}\n\n\\item{type}{A string showing 'line' or 'bar'.}\n\n\\item{list}{If input is a list containing different ggplot data, use l\\code{list = inputlist}.}\n\n\\item{x}{A string of x axis name.}\n\n\\item{y}{A string of y axis name.}\n\n\\item{title}{A string of the title.}\n\n\\item{output}{A boolean, if chosen TRUE, the output will be given.\nNOTE: yOU HAVE TO PUT A \\code{list = }, before your list.}\n}\n\\value{\nA combined time series plot.\n}\n\\description{\nCombine time seires plot together\n}\n\\details{\n..., representing different ouput file generated by \\code{plotTS(, output = 'ggplot'), name = yourname}, \ndifferent names must be assigned when generating different output.\n\ne.g.\na1, a2, a3 are different files generated by \\code{plotTS(, output = 'ggplot'), name = yourname}, you can\nset \\code{plotTS(a1,a2,a3)} or \\code{plotTS(list = list(a1,a2,a3))}\n}\n\\examples{\na1 <- plotTS(testdl[[1]], output = 'ggplot', name = 1)\na2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2)\n\nplotTS_comb(a1, a2)\nplotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2)\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n}\n}\n\n", + "created" : 1488014900544.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1328983654", + "id" : "F72259DF", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/plotTS_comb.Rd", + "project_path" : "man/plotTS_comb.Rd", + "properties" : { + }, + "relative_order" : 45, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8BC78A3 b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8BC78A3 new file mode 100644 index 0000000..1e819d2 --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8BC78A3 @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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 showNA A boolean representing whether the NA values should be marked, default is TRUE.\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 https://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, showNA = TRUE, \n x = NULL, 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 if (showNA == TRUE) {\n missingVLayer <- with(TS, {\n geom_point(data = data_plot[NAIndex, ], group = 1, size = 3, shape = 4, color = 'black')\n })\n \n mainLayer <- mainLayer + missingVLayer\n }\n \n \n plotLayer <- mainLayer + secondLayer\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 https://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\n#' @importFrom data.table rbindlist\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 data_ggplot <- rbindlist(list)\n } else {\n \n bars <- list(...)\n checkBind(bars, 'rbind')\n #data_ggplot <- do.call('rbind', bars)\n data_ggplot <- rbindlist(bars)\n }\n \n if (!class(data_ggplot)[1] == 'data.table') {\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 https://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#' https://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 https://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. https://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 https://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" : 1487441178501.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "2041803482", + "id" : "F8BC78A3", + "lastKnownWriteTime" : 1488015065, + "last_content_update" : 1488015065997, + "path" : "~/GitHub/hyfo/R/analyzeTS.R", + "project_path" : "R/analyzeTS.R", + "properties" : { + }, + "relative_order" : 11, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8CC347F b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8CC347F new file mode 100644 index 0000000..7f2be6b --- /dev/null +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/F8CC347F @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/extractPeriod(generic).R\n\\docType{methods}\n\\name{extractPeriod}\n\\alias{extractPeriod}\n\\alias{extractPeriod,data.frame-method}\n\\alias{extractPeriod,list-method}\n\\title{Extract period from list or dataframe.}\n\\usage{\nextractPeriod(data, startDate = NULL, endDate = NULL,\n commonPeriod = FALSE, year = NULL, month = NULL)\n\n\\S4method{extractPeriod}{data.frame}(data, startDate = NULL, endDate = NULL,\n commonPeriod = FALSE, year = NULL, month = NULL)\n\n\\S4method{extractPeriod}{list}(data, startDate = NULL, endDate = NULL,\n commonPeriod = FALSE, year = NULL, month = NULL)\n}\n\\arguments{\n\\item{data}{A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.}\n\n\\item{startDate}{A Date showing the start of the extract period, default as NULL, check details.}\n\n\\item{endDate}{A Date showing the end of the extract period, default as NULL, check details.}\n\n\\item{commonPeriod}{A boolean showing whether the common period is extracted. If chosen, startDate and endDate\nshould be NULL.}\n\n\\item{year}{extract certain year in the entire time series. if you want to extract year 2000, set \\code{year = 2000}}\n\n\\item{month}{extract certain months in a year. e.g. if you want to extract Jan, Feb of each year, \nset \\code{month = c(1, 2)}.}\n}\n\\value{\nA list or a dataframe with all the time series inside containing the same period.\n}\n\\description{\nExtract common period or certain period from a list of different dataframes of time series, or from a \ndataframe. \nNOTE: all the dates in the datalist should follow the format in ?as.Date{base}.\n}\n\\details{\n\\strong{startDate and endDate}\n\nIf startDate and endDate are assigned, then certain period between startDate and endDate will be returned, \nfor both datalist input and dataframe input.\n\nIf startDate and endDate are NOT assigned, then,\n\n if input is a datalist, the startDate and endDate of the common period of different datalists will be assigned\n to the startDate and endDate.\n\n if input is a dataframe, the startDate and endDate of the input dataframe will be assigned to the startDate\n and endDate . Since different value columns share a common Date column in a dataframe input. \n\n\\strong{year and month}\n\nFor year crossing month input, hyfo will take from the year before. E.g. if \\code{month = c(10, 11, 12, 1)},\nand \\code{year = 1999}, hyfo will take month 10, 11 and 12 from year 1998, and month 1 from 1999.You DO NOT \nhave to set \\code{year = 1998 : 1999}.\n\nWell, if you set \\code{year = 1998 : 1999}, hyfo will take month 10, 11 and 12 from year 1997, and month 1 from 1998,\nthen, take month 10, 11 and 12 from year 1998, month 1 from 1999. So you only have to care about the latter year.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\n}\n\\examples{\n# Generate timeseries datalist. Each data frame consists of a Date and a value.\n\nAAA <- data.frame(\n# date column\nDate = seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1),\n # value column\nAAA = sample(1:100,length(seq(as.Date('1990-10-28'),as.Date('1997-4-1'),1)), repl = TRUE))\n\nBBB <- data.frame(\nDate = seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1), \nBBB = sample(1:100,length(seq(as.Date('1993-3-28'),as.Date('1999-1-1'),1)), repl = TRUE))\n \nCCC <- data.frame(\nDate = seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1), \nCCC = sample(1:100,length(seq(as.Date('1988-2-2'),as.Date('1996-1-1'),1)), repl = TRUE)) \n\nlist <- list(AAA, BBB, CCC)# dput() and dget() can be used to save and load list file.\n\nlist_com <- extractPeriod(list, commonPeriod = TRUE)\n\n# list_com is the extracted datalist.\nstr(list_com)\n\n# If startDate and endDate is provided, the record between them will be extracted.\n# make sure startDate is later than any startDate in each dataframe and endDate is \n# earlier than any endDate in each dataframe.\n\ndata(testdl)\ndatalist_com1 <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\n\ndataframe <- list2Dataframe(datalist_com1)\n# now we have a dataframe to extract certain months and years.\ndataframe_new <- extractPeriod(dataframe, month = c(1,2,3))\ndataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995)\n\n\n# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/\n\n}\n\\references{\n\\itemize{\n\\item Achim Zeileis and Gabor Grothendieck (2005). zoo: S3 Infrastructure for Regular and Irregular Time\nSeries. Journal of Statistical Software, 14(6), 1-27. URL https://www.jstatsoft.org/v14/i06/\n}\n}\n\n", + "created" : 1487956160878.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "992803177", + "id" : "F8CC347F", + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, + "path" : "~/GitHub/hyfo/man/extractPeriod.Rd", + "project_path" : "man/extractPeriod.Rd", + "properties" : { + }, + "relative_order" : 27, + "source_on_save" : false, + "source_window" : "", + "type" : "r_doc" +} \ No newline at end of file diff --git a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/FFE783F similarity index 88% rename from .Rproj.user/D1D10CF6/sdb/per/t/FFE783F rename to .Rproj.user/D1D10CF6/sdb/s-DA33EA29/FFE783F index 850b1d0..1e6da70 100644 --- a/.Rproj.user/D1D10CF6/sdb/per/t/FFE783F +++ b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/FFE783F @@ -1,14 +1,14 @@ { "collab_server" : "", - "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/biasCorrect(generic).R\n\\docType{methods}\n\\name{biasCorrect}\n\\alias{biasCorrect}\n\\alias{biasCorrect,data.frame,data.frame,data.frame-method}\n\\alias{biasCorrect,list,list,list-method}\n\\title{Biascorrect the input timeseries or hyfo dataset}\n\\usage{\nbiasCorrect(frc, hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the forecast to be calibrated.}\n\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \ndetails. Default scaleType is 'multi'.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nBiascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\nobservation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\nwill be returned. If the input is a time series, first column should be date column and rest columns should be \nthe value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\nfile with the same format.\n}\n\\details{\nSince climate forecast is based on global condition, when downscaling to different regions, it may include\nsome bias, biascorrection is used then to fix the bias.\n\n\\strong{Hindcast}\n\nIn order to bias correct, we need to pick up some data from the forecast to train with\nthe observation, which is called hindcast in this function. Using hindcast and observation, \nthe program can analyze the bias and correct the bias in the forecast. \n\nHindcast should have \\strong{EVERY} attributes that forecast has.\n\nHindcast 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\nis the hindcast period, and 2005-2010, this period is the forecast period.\n\nHindcast 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\nForecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \nforecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \ndata (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n\nE.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \nperiod (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\nThe program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \nmodification to the forecast data.\n\nThe more categorized input, the more accurate result you will get. E.g., if you want to \nbias correct a forecast for winter season. So you'd better to extract all the winter period\nin the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n\n\\strong{method}\n\nDifferent methods used in the bias correction. Among which, delta, scaling can be applied\nto different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\nit needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\ndesigned for rainfall data, so \\code{preci = TRUE} needs to be set.\n\n\\strong{delta}\n\nThis method consists on adding to the observations the mean change signal (delta method). \nThis 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 \nThis method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \nbetween the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\ncorrection is defined by parameter \\code{scaling.type} (default is \\code{additive}).\nThe additive version is preferably applicable to unbounded variables (e.g. temperature) \nand the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n \n \\strong{eqm}\n \nEmpirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \nby adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \nThis method is applicable to any kind of variable.\n\nIt can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\nthat the extreme value is an error.\n \n \\strong{gqm}\n \nGamma 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\nand simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \nthat uses the theorical instead of the empirical distribution. \n \nIt can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\nBetter have a long period of training, and the if the forecast system is relatively stable.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\n\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\nnewFrc <- biasCorrect(nc, nc, tgridData) \nnewFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \nnewFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \npreci = TRUE) \nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nfrc_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\nfrc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n\n# You can use other scaling methods to biascorrect.\nfrc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n\n# \nfrc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\nfrc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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", + "contents" : "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/biasCorrect(generic).R\n\\docType{methods}\n\\name{biasCorrect}\n\\alias{biasCorrect}\n\\alias{biasCorrect,data.frame,data.frame,data.frame-method}\n\\alias{biasCorrect,list,list,list-method}\n\\title{Biascorrect the input timeseries or hyfo dataset}\n\\usage{\nbiasCorrect(frc, hindcast, obs, method = \"scaling\", scaleType = \"multi\",\n preci = FALSE, prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs,\n method = \"scaling\", scaleType = \"multi\", preci = FALSE,\n prThreshold = 0, extrapolate = \"no\")\n\n\\S4method{biasCorrect}{list,list,list}(frc, hindcast, obs, method = \"scaling\",\n scaleType = \"multi\", preci = FALSE, prThreshold = 0,\n extrapolate = \"no\")\n}\n\\arguments{\n\\item{frc}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the forecast to be calibrated.}\n\n\\item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, \nrepresenting 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\nobservation data. Check details for more information.}\n\n\\item{obs}{a hyfo grid data output or a dataframe (time series) consists of Date column and one or more value columns, \nrepresenting the observation data.}\n\n\\item{method}{bias correct method, including 'delta', 'scaling'..., default is 'scaling'}\n\n\\item{scaleType}{only when the method \"scaling\" is chosen, scaleType will be available. Two different types\nof scaling method, 'add' and 'multi', which means additive and multiplicative scaling method. More info check \ndetails. Default scaleType is 'multi'.}\n\n\\item{preci}{If the precipitation is biascorrected, then you have to assign \\code{preci = TRUE}. Since for\nprecipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. \nDefault is FALSE, refer to details.}\n\n\\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).}\n\n\\item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs.\nIf 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.}\n}\n\\description{\nBiascorrect the input time series or dataset, the input time series or dataset should consist of observation, hindcast, and forecast.\nobservation and hindcast should belong to the same period, in order to calibrate. Then the modified forecast\nwill be returned. If the input is a time series, first column should be date column and rest columns should be \nthe value column. If the input is a hyfo dataset, the dataset should be the result of \\code{loadNcdf}, or a list\nfile with the same format.\n}\n\\details{\nSince climate forecast is based on global condition, when downscaling to different regions, it may include\nsome bias, biascorrection is used then to fix the bias.\n\n\\strong{Hindcast}\n\nIn order to bias correct, we need to pick up some data from the forecast to train with\nthe observation, which is called hindcast in this function. Using hindcast and observation, \nthe program can analyze the bias and correct the bias in the forecast. \n\nHindcast should have \\strong{EVERY} attributes that forecast has.\n\nHindcast 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\nis the hindcast period, and 2005-2010, this period is the forecast period.\n\nHindcast 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\nForecast product has to be calibrated, usually the system is doing forecast in real time. So, e.g., if the \nforecast starts from year 2000, assuming you are in year 2003, then you will have 3 years' hindcast \ndata (year 2000-2003), which can be used to calibrate. And your forecast period is (2003-2004)\n\nE.g. you have observation from 2001-2002, this is your input obs. Then you can take the same \nperiod (2001-2002) from the forecast, which is the hindcast period. For forecast, you can take any period.\nThe program will evaluate the obs and hindcast, to get the modification of the forecast, and then add the \nmodification to the forecast data.\n\nThe more categorized input, the more accurate result you will get. E.g., if you want to \nbias correct a forecast for winter season. So you'd better to extract all the winter period\nin the hindcast and observation to train. \\code{extractPeriod} can be used for this purpose.\n\n\\strong{method}\n\nDifferent methods used in the bias correction. Among which, delta, scaling can be applied\nto different kinds of parameters, with no need to set \\code{preci}; eqm has two conditions for rainfall data and other data,\nit needs user to input \\code{preci = TRUE/FALSE} to point to different conditions; gqm is\ndesigned for rainfall data, so \\code{preci = TRUE} needs to be set.\n\n\\strong{delta}\n\nThis method consists on adding to the observations the mean change signal (delta method). \nThis 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 \nThis method consists on scaling the simulation with the difference (additive) or quotient (multiplicative) \nbetween the observed and simulated means in the train period. The \\code{additive} or \\code{multiplicative}\ncorrection is defined by parameter \\code{scaling.type} (default is \\code{additive}).\nThe additive version is preferably applicable to unbounded variables (e.g. temperature) \nand the multiplicative to variables with a lower bound (e.g. precipitation, because it also preserves the frequency). \n \n \\strong{eqm}\n \nEmpirical Quantile Mapping. This is a very extended bias correction method which consists on calibrating the simulated Cumulative Distribution Function (CDF) \nby adding to the observed quantiles both the mean delta change and the individual delta changes in the corresponding quantiles. \nThis method is applicable to any kind of variable.\n\nIt can keep the extreme value, if you choose constant extrapolation method. But then you will face the risk\nthat the extreme value is an error.\n \n \\strong{gqm}\n \nGamma 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\nand simulated intensity distributions are well approximated by the gamma distribution, therefore is a parametric q-q map \nthat uses the theorical instead of the empirical distribution. \n \nIt can somehow filter some extreme values caused by errors, while keep the extreme value. Seems more reasonable.\nBetter have a long period of training, and the if the forecast system is relatively stable.\n\nIt is a generic function, if in your case you need to debug, please see \\code{?debug()} \nfor how to debug S4 method.\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.\nfilePath <- system.file(\"extdata\", \"tnc.nc\", package = \"hyfo\")\nvarname <- getNcdfVar(filePath) \nnc <- loadNcdf(filePath, varname)\n\ndata(tgridData)\n# Since the example data, has some NA values, the process will include some warning #message, \n# which can be ignored in this case.\n\n\n\n\n# Then we will use nc data as forecasting data, and use itself as hindcast data,\n# use tgridData as observation.\nnewFrc <- biasCorrect(nc, nc, tgridData) \nnewFrc <- biasCorrect(nc, nc, tgridData, scaleType = 'add') \nnewFrc <- biasCorrect(nc, nc, tgridData, method = 'eqm', extrapolate = 'constant', \npreci = TRUE) \nnewFrc <- 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.\ndata(testdl)\n\n# common period has to be extracted in order to better train the forecast.\n\ndatalist <- extractPeriod(testdl, startDate = '1994-1-1', endDate = '1995-10-1')\n\nfrc <- datalist[[1]]\nhindcast <- datalist[[2]]\nobs <- 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\nfrc_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\nfrc_new1 <- biasCorrect(frc, hindcast, obs, preci = TRUE)\n\n# You can use other scaling methods to biascorrect.\nfrc_new2 <- biasCorrect(frc, hindcast, obs, scaleType = 'add')\n\n# \nfrc_new3 <- biasCorrect(frc, hindcast, obs, method = 'eqm', preci = TRUE)\nfrc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE)\n\nplotTS(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.\nTSlist <- list(obs, frc, frc_new, frc_new1, frc_new2, frc_new3, frc_new4)\nnames(TSlist) <- c('obs', 'frc', 'delta', 'delta_preci', 'scale', 'eqm', 'gqm')\nplotTS(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 https://yuanchao-xu.github.io/hyfo/\n\n\n}\n\\author{\nYuanchao Xu \\email{xuyuanchao37@gmail.com }\n}\n\\references{\nBias 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\npackage 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", "created" : 1483875745269.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1881246410", + "hash" : "3811662291", "id" : "FFE783F", - "lastKnownWriteTime" : 1487594221, - "last_content_update" : 1487594221, + "lastKnownWriteTime" : 1488018205, + "last_content_update" : 1488018205, "path" : "~/GitHub/hyfo/man/biasCorrect.Rd", "project_path" : "man/biasCorrect.Rd", "properties" : { diff --git a/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/lock_file b/.Rproj.user/D1D10CF6/sdb/s-DA33EA29/lock_file new file mode 100644 index 0000000..e69de29 diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index 3b1c0c8..5130502 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1 +1,2 @@ C:/Users/user/Documents/GitHub/hyfo/R/extractPeriod(generic).R="35D21910" +C:/Users/user/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="E84A6BF8" diff --git a/.travis.yml b/.travis.yml index 71f1854..e4b1735 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,7 +9,7 @@ env: global: - NOT_CRAN = true before_install: - echo "options(repos = c(CRAN='http://cran.rstudio.com'))" > ~/.Rprofile + echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: diff --git a/DESCRIPTION b/DESCRIPTION index 423c771..6567622 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,7 +36,7 @@ Suggests: rmarkdown VignetteBuilder: knitr LazyData: true -URL: http://yuanchao-xu.github.io/hyfo/ +URL: https://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN RoxygenNote: 5.0.1 diff --git a/R/analyzeTS.R b/R/analyzeTS.R index 5137131..b6f9ca1 100644 --- a/R/analyzeTS.R +++ b/R/analyzeTS.R @@ -41,7 +41,7 @@ #' # and compare them using plotTS_comb. If all data are in one plot, there might be too messy. #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' \itemize{ @@ -196,7 +196,7 @@ plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NU #' plotTS_comb(a1, a2) #' plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' \itemize{ @@ -278,14 +278,14 @@ plotTS_comb <- function(..., nrow = 1, type = 'line', list = NULL, x = 'Date', y #' dis <- seq(1, 100) #' getLMom(dis) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @references #' #' \itemize{ #' \item J. R. M. Hosking (2015). L-moments. R package, version 2.5. URL: -#' http://CRAN.R-project.org/package=lmom. +#' https://CRAN.R-project.org/package=lmom. #' } #' #' @@ -312,17 +312,17 @@ getLMom <- function(dis){ #' dis <- seq(1, 100) #' getMoment(dis) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @references #' #' \itemize{ #' \item Lukasz Komsta and Frederick Novomestky (2015). moments: Moments, cumulants, skewness, kurtosis and -#' related tests. R package version 0.14. http://CRAN.R-project.org/package=moments +#' related tests. R package version 0.14. https://CRAN.R-project.org/package=moments #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @importFrom moments skewness kurtosis diff --git a/R/biasCorrect(generic).R b/R/biasCorrect(generic).R index dc3c3e5..8089c74 100644 --- a/R/biasCorrect(generic).R +++ b/R/biasCorrect(generic).R @@ -183,7 +183,7 @@ #' #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' #' @references @@ -213,7 +213,7 @@ setGeneric('biasCorrect', function(frc, hindcast, obs, method = 'scaling', scale }) -# Since in new version of roxygen2, describeIn was changed, http://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2 +# Since in new version of roxygen2, describeIn was changed, https://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2 # so use rdname instead #' @rdname biasCorrect #' diff --git a/R/case_anarbe.R b/R/case_anarbe.R index aba675f..cc347c9 100644 --- a/R/case_anarbe.R +++ b/R/case_anarbe.R @@ -12,14 +12,14 @@ #' folder <- strsplit(file, '1999')[[1]][1] #' a <- collectData_csv_anarbe(folder) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' #' \itemize{ #' \item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @source http://meteo.navarra.es/estaciones/mapadeestaciones.cfm @@ -260,14 +260,14 @@ collectData_excel_anarbe <- function(folderName, keyword = NULL, output = TRUE){ #' } #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' #' \itemize{ #' \item http://www4.gipuzkoa.net/oohh/web/esp/02.asp #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @@ -353,7 +353,7 @@ anarbe_txt <- function(dataset, x1, x2){ #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @importFrom utils read.fwf diff --git a/R/classes.R b/R/classes.R index bbcbe44..dccb495 100644 --- a/R/classes.R +++ b/R/classes.R @@ -111,7 +111,7 @@ setClass("biasFactor.hyfo", representation(lonLatDim = 'integer'), contains = 'b # #' @exportClass # setClass("hyfo", representation(varName = "character", xyCoords = 'list', Dates = 'list', # Data = 'array', Loaded = 'character'), -# prototype(Loaded = 'by hyfo package, http://yuanchao-xu.github.io/hyfo/'), +# prototype(Loaded = 'by hyfo package, https://yuanchao-xu.github.io/hyfo/'), # validity = checkHyfo) # # diff --git a/R/collectData.R b/R/collectData.R index bfe471d..229c43c 100644 --- a/R/collectData.R +++ b/R/collectData.R @@ -16,7 +16,7 @@ #' #' a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2)) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @importFrom data.table rbindlist @@ -96,7 +96,7 @@ readTxt <- function(fileName, range){ #' @importFrom utils read.csv #' @references #' 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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. readCsv <- function(fileName, range){ data <- read.csv(fileName, skip = range[1] - 1, header = FALSE) diff --git a/R/extractPeriod(generic).R b/R/extractPeriod(generic).R index 23ba62f..e1ced40 100644 --- a/R/extractPeriod(generic).R +++ b/R/extractPeriod(generic).R @@ -76,14 +76,14 @@ #' 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/ +#' # More examples can be found in the user manual on https://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/ +#' Series. Journal of Statistical Software, 14(6), 1-27. URL https://www.jstatsoft.org/v14/i06/ #' } #' #' @export @@ -224,7 +224,7 @@ extractPeriod_dataframe <- function(dataframe, startDate, endDate, year = NULL, #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' diff --git a/R/fillGap.R b/R/fillGap.R index 5ad64a8..506df44 100644 --- a/R/fillGap.R +++ b/R/fillGap.R @@ -47,7 +47,7 @@ #' a3 <- fillGap(a1, corPeriod = 'monthly') #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' Gap fiiling method based on correlation and linear regression. @@ -135,7 +135,7 @@ fillGap_column <- function(i, data, corOrder, lmCoef) { #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @@ -174,7 +174,7 @@ fillGap_cor <- function(data, corPeriod = 'daily', Date) { #' @importFrom stats coef lm #' @references #' 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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' fillGap_lmCoef <- function(data, corOrder) { l <- dim(data)[2] diff --git a/R/getAnnual(generic).R b/R/getAnnual(generic).R index 1f9cf3f..c6c96b3 100644 --- a/R/getAnnual(generic).R +++ b/R/getAnnual(generic).R @@ -33,7 +33,7 @@ #' getAnnual(a3) #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @importFrom methods setGeneric @@ -44,7 +44,7 @@ #' \item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software, #' 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' diff --git a/R/getEnsemble.R b/R/getEnsemble.R index 83d325d..83f7320 100644 --- a/R/getEnsemble.R +++ b/R/getEnsemble.R @@ -98,7 +98,7 @@ #' b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30) #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' #' @importFrom reshape2 melt @@ -330,7 +330,7 @@ getHisEnsem <- function (TS, example, interval = 365, buffer = 0, plot = 'norm', #' b <- getFrcEnsem(nc, coord = c(-1.4, 43.2)) #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @return A ensemble time series extracted from forecating data. #' @@ -481,7 +481,7 @@ getFrcEnsem <- function(dataset, cell = 'mean', plot = 'norm', output = 'data', #' getEnsem_comb(b1, b2) #' getEnsem_comb(list = list(b1, b2), nrow = 2) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' #' @export diff --git a/R/getPreciBar(generic).R b/R/getPreciBar(generic).R index a5ceed0..e1e07f2 100644 --- a/R/getPreciBar(generic).R +++ b/R/getPreciBar(generic).R @@ -55,7 +55,7 @@ #' a <- getPreciBar(TS, method = 'spring', info = TRUE) #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @references #' @@ -65,7 +65,7 @@ #' 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. #' \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' @@ -403,7 +403,7 @@ getPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, #' #' getPreciBar_comb(b1, b2) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @import ggplot2 diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 9b08ced..8f39170 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -220,7 +220,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' } #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @import ggplot2 plyr maps maptools rgeos @@ -230,7 +230,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' #' \item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software, #' 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. @@ -240,13 +240,13 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' #' \item Original S code by Richard A. Becker and Allan R. Wilks. R version by Ray Brownrigg. Enhancements #' by Thomas P Minka (2015). maps: Draw Geographical Maps. R package version -#' 2.3-11. http://CRAN.R-project.org/package=maps +#' 2.3-11. https://CRAN.R-project.org/package=maps #' #' \item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial -#' Objects. R package version 0.8-36. http://CRAN.R-project.org/package=maptools +#' Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools #' #' \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R -#' package version 0.3-11. http://CRAN.R-project.org/package=rgeos +#' package version 0.3-11. https://CRAN.R-project.org/package=rgeos #' #' } #' @@ -405,7 +405,7 @@ getSpatialMap_mat <- function(matrix, title_d = NULL, catchment = NULL, point = #' #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @details #' For \code{getSpatialMap_comb}, the maps to be compared should be with same size and resolution, diff --git a/R/list2dataframe.R b/R/list2dataframe.R index bc54620..175db02 100644 --- a/R/list2dataframe.R +++ b/R/list2dataframe.R @@ -16,7 +16,7 @@ #' #' dataframe <- list2Dataframe(datalist_new) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export list2Dataframe <- function(datalist) { diff --git a/R/multi-biasCorrect(generic).R b/R/multi-biasCorrect(generic).R index b128380..348d953 100644 --- a/R/multi-biasCorrect(generic).R +++ b/R/multi-biasCorrect(generic).R @@ -147,7 +147,7 @@ #' #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' #' @references @@ -335,7 +335,7 @@ setMethod('getBiasFactor', signature('list', 'list'), #' #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' #' @references diff --git a/R/ncdf.R b/R/ncdf.R index e201c28..0fb5e93 100644 --- a/R/ncdf.R +++ b/R/ncdf.R @@ -12,7 +12,7 @@ #' # Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name #' varname <- getNcdfVar(filePath) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @import ncdf4 #' @references @@ -20,7 +20,7 @@ #' \itemize{ #' \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or #' Earlier) Format Data Files. R package version 1.14.1. -#' http://CRAN.R-project.org/package=ncdf4 +#' https://CRAN.R-project.org/package=ncdf4 #' } #' #' @@ -72,7 +72,7 @@ getNcdfVar <- function(filePath) { #' \itemize{ #' \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or #' Earlier) Format Data Files. R package version 1.14.1. -#' http://CRAN.R-project.org/package=ncdf4 +#' https://CRAN.R-project.org/package=ncdf4 #' #' \item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package #' version 2.2-6. http://meteo.unican.es/ecoms-udg @@ -148,7 +148,7 @@ loadNcdf <- function(filePath, varname, tz = 'GMT', ...) { if (!is.na(dimIndex[4])) gridData$Members <- var$dim[[dimIndex[4]]]$vals - gridData$Loaded <- 'by hyfo package, http://yuanchao-xu.github.io/hyfo/' + gridData$Loaded <- 'by hyfo package, https://yuanchao-xu.github.io/hyfo/' nc_close(nc) output <- downscaleNcdf(gridData, ...) @@ -184,7 +184,7 @@ loadNcdf <- function(filePath, varname, tz = 'GMT', ...) { #' nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7)) #' nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7)) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @references @@ -340,7 +340,7 @@ downscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = #' #' writeNcdf(nc, 'test.nc') #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @import ncdf4 @@ -349,7 +349,7 @@ downscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = #' \itemize{ #' \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or #' Earlier) Format Data Files. R package version 1.14.1. -#' http://CRAN.R-project.org/package=ncdf4 +#' https://CRAN.R-project.org/package=ncdf4 #' #' \item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package #' version 2.2-6. http://meteo.unican.es/ecoms-udg @@ -433,7 +433,7 @@ writeNcdf <- function(gridData, filePath, missingValue = 1e20, tz = 'GMT', units # This part has to be put ncatt_put(nc, 0, "Conventions","CF-1.4") - ncatt_put(nc, 0, 'WrittenBy', 'hyfo(http://yuanchao-xu.github.io/hyfo/)') + ncatt_put(nc, 0, 'WrittenBy', 'hyfo(https://yuanchao-xu.github.io/hyfo/)') #data <- aperm(gridData$Data, dimIndex) no need to do this, in the process above # when you define the dimlist, the order of the dimension was fixed. @@ -463,7 +463,7 @@ getTimeUnit <- function(dates) { #' @import ncdf4 #' @references #' David Pierce (2014). ncdf: Interface to Unidata netCDF data files. R package version 1.6.8. -#' http://CRAN.R-project.org/package=ncdf +#' https://CRAN.R-project.org/package=ncdf getExtralDim <- function(...) { dimList <- list(...) diff --git a/R/readfolders.R b/R/readfolders.R index ecee624..940a82f 100644 --- a/R/readfolders.R +++ b/R/readfolders.R @@ -24,7 +24,7 @@ readData_folder <- function(folderName, keyword) { #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' diff --git a/R/resample(generic).R b/R/resample(generic).R index dfc9823..ad974f5 100644 --- a/R/resample(generic).R +++ b/R/resample(generic).R @@ -38,7 +38,7 @@ #' nc_new <- resample(nc, 'day2mon') #' #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export #' @importFrom stats aggregate @@ -46,7 +46,7 @@ #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' setGeneric('resample', function(data, method) { @@ -134,7 +134,7 @@ resample.list <- function(hyfo, method) { #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' mon2day <- function(monData) { diff --git a/R/shp2cat.R b/R/shp2cat.R index d84977c..fc5a8bf 100644 --- a/R/shp2cat.R +++ b/R/shp2cat.R @@ -9,7 +9,7 @@ #' file <- system.file("extdata", "testCat.shp", package = "hyfo") #' catchment <- shp2cat(file) #' -#' # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +#' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @import rgdal #' @importFrom utils tail @@ -17,10 +17,10 @@ #' #' \itemize{ #' \item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data -#' Abstraction Library. R package version 1.0-4. http://CRAN.R-project.org/package=rgdal +#' Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=rgdal #' #' \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/. +#' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. #' } #' #' diff --git a/R/startup.R b/R/startup.R index 5e3ad52..28a46f0 100644 --- a/R/startup.R +++ b/R/startup.R @@ -2,7 +2,7 @@ #' @importFrom utils packageDescription hyfoUpdates <- function(){ - page <- readLines('http://yuanchao-xu.github.io/hyfo/') + page <- readLines('https://yuanchao-xu.github.io/hyfo/') updatesLine <- grep('id=\\"updates"', page) versionLine <- updatesLine + 2 @@ -27,7 +27,7 @@ hyfoUpdates <- function(){ if (!is.na(info_line)) info_msg <- c(info_msg, info_line) } - install_msg <- 'More details on http://yuanchao-xu.github.io/hyfo/' + install_msg <- 'More details on https://yuanchao-xu.github.io/hyfo/' message_out <- paste(version_msg, paste(info_msg, collapse = '\n'), install_msg, sep = '\n') } else message_out <- NULL diff --git a/README.md b/README.md index d3e018c..5f92802 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # hyfo [![Travis-CI Build Status](https://travis-ci.org/Yuanchao-Xu/hyfo.svg?branch=master)](https://travis-ci.org/Yuanchao-Xu/hyfo) -[![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/hyfo)](http://cran.r-project.org/package=hyfo) +[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/hyfo)](https://cran.r-project.org/package=hyfo) ## Installation @@ -18,7 +18,7 @@ install.packages("devtools") devtools::install_github("Yuanchao-Xu/hyfo") ``` -**Official Website is [http://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo)** +**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo)** hyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate. diff --git a/man/applyBiasFactor.Rd b/man/applyBiasFactor.Rd index 8287dce..3ab3a49 100644 --- a/man/applyBiasFactor.Rd +++ b/man/applyBiasFactor.Rd @@ -148,7 +148,7 @@ plotTS(list = TSlist, plot = 'cum') -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 11c0072..10bcd00 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -206,7 +206,7 @@ plotTS(list = TSlist, plot = 'cum') -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/collectData.Rd b/man/collectData.Rd index eedbb4d..4f2e567 100644 --- a/man/collectData.Rd +++ b/man/collectData.Rd @@ -32,7 +32,7 @@ folder <- file.path(path.package("hyfo"), 'extdata') a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2)) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/collectData_csv_anarbe.Rd b/man/collectData_csv_anarbe.Rd index f8c3ad9..28ec9a4 100644 --- a/man/collectData_csv_anarbe.Rd +++ b/man/collectData_csv_anarbe.Rd @@ -27,14 +27,14 @@ file <- system.file("extdata", "1999.csv", package = "hyfo") folder <- strsplit(file, '1999')[[1]][1] a <- collectData_csv_anarbe(folder) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item http://meteo.navarra.es/estaciones/mapadeestaciones.cfm \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/collectData_txt_anarbe.Rd b/man/collectData_txt_anarbe.Rd index 795ecde..c61ac2c 100644 --- a/man/collectData_txt_anarbe.Rd +++ b/man/collectData_txt_anarbe.Rd @@ -35,14 +35,14 @@ a <- collectData_txt_anarbe(folder) } -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item http://www4.gipuzkoa.net/oohh/web/esp/02.asp \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/downscaleNcdf.Rd b/man/downscaleNcdf.Rd index b4e66ac..3523aca 100644 --- a/man/downscaleNcdf.Rd +++ b/man/downscaleNcdf.Rd @@ -41,7 +41,7 @@ nc <- loadNcdf(filePath, varname) nc1 <- downscaleNcdf(nc, year = 2006, lon = c(-2, -0.5), lat = c(43.2, 43.7)) nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43.2, 43.7)) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index 825c673..e3b5ca0 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -103,13 +103,13 @@ 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/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \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/ +Series. Journal of Statistical Software, 14(6), 1-27. URL https://www.jstatsoft.org/v14/i06/ } } diff --git a/man/fillGap.Rd b/man/fillGap.Rd index 1ceb056..716939a 100644 --- a/man/fillGap.Rd +++ b/man/fillGap.Rd @@ -61,7 +61,7 @@ a2 <- fillGap(a1) a3 <- fillGap(a1, corPeriod = 'monthly') -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/getAnnual.Rd b/man/getAnnual.Rd index 506bf9e..720a249 100644 --- a/man/getAnnual.Rd +++ b/man/getAnnual.Rd @@ -54,7 +54,7 @@ a3 <- fillGap(a2) getAnnual(a3) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ @@ -63,7 +63,7 @@ getAnnual(a3) \item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software, 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/getBiasFactor.Rd b/man/getBiasFactor.Rd index 74697e3..d9ba59c 100644 --- a/man/getBiasFactor.Rd +++ b/man/getBiasFactor.Rd @@ -165,7 +165,7 @@ plotTS(list = TSlist, plot = 'cum') -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/getEnsem_comb.Rd b/man/getEnsem_comb.Rd index 4459a74..d7b20a8 100644 --- a/man/getEnsem_comb.Rd +++ b/man/getEnsem_comb.Rd @@ -51,7 +51,7 @@ b2 <- getHisEnsem(a, example = c('1995-4-4', '1996-3-4'), plot = 'cum', output = getEnsem_comb(b1, b2) getEnsem_comb(list = list(b1, b2), nrow = 2) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/getFrcEnsem.Rd b/man/getFrcEnsem.Rd index 1585b5f..003d6df 100644 --- a/man/getFrcEnsem.Rd +++ b/man/getFrcEnsem.Rd @@ -76,7 +76,7 @@ a <- getFrcEnsem(nc, cell = c(6,2)) b <- getFrcEnsem(nc, coord = c(-1.4, 43.2)) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/getHisEnsem.Rd b/man/getHisEnsem.Rd index 18c836b..b9f92fe 100644 --- a/man/getHisEnsem.Rd +++ b/man/getHisEnsem.Rd @@ -113,7 +113,7 @@ b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, plot = b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer = 30) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/getLMom.Rd b/man/getLMom.Rd index 9ea245a..7c9b15c 100644 --- a/man/getLMom.Rd +++ b/man/getLMom.Rd @@ -19,13 +19,13 @@ get L moment analysis of the input distribution dis <- seq(1, 100) getLMom(dis) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item J. R. M. Hosking (2015). L-moments. R package, version 2.5. URL: -http://CRAN.R-project.org/package=lmom. +https://CRAN.R-project.org/package=lmom. } } diff --git a/man/getMoment.Rd b/man/getMoment.Rd index a0fae96..e24bb5c 100644 --- a/man/getMoment.Rd +++ b/man/getMoment.Rd @@ -19,16 +19,16 @@ get moment analysis of the input distribution dis <- seq(1, 100) getMoment(dis) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item Lukasz Komsta and Frederick Novomestky (2015). moments: Moments, cumulants, skewness, kurtosis and -related tests. R package version 0.14. http://CRAN.R-project.org/package=moments +related tests. R package version 0.14. https://CRAN.R-project.org/package=moments \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/getNcdfVar.Rd b/man/getNcdfVar.Rd index 1701587..ea26a00 100644 --- a/man/getNcdfVar.Rd +++ b/man/getNcdfVar.Rd @@ -23,14 +23,14 @@ filePath <- system.file("extdata", "tnc.nc", package = "hyfo") # Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or Earlier) Format Data Files. R package version 1.14.1. -http://CRAN.R-project.org/package=ncdf4 +https://CRAN.R-project.org/package=ncdf4 } } diff --git a/man/getPreciBar.Rd b/man/getPreciBar.Rd index 2aad764..c033e8d 100644 --- a/man/getPreciBar.Rd +++ b/man/getPreciBar.Rd @@ -87,7 +87,7 @@ a <- getPreciBar(TS, method = 'spring') a <- getPreciBar(TS, method = 'spring', info = TRUE) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ @@ -96,7 +96,7 @@ a <- getPreciBar(TS, method = 'spring', info = TRUE) 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/getPreciBar_comb.Rd b/man/getPreciBar_comb.Rd index dadd8a2..1bed03a 100644 --- a/man/getPreciBar_comb.Rd +++ b/man/getPreciBar_comb.Rd @@ -47,7 +47,7 @@ b2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2') getPreciBar_comb(b1, b2) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/getSpatialMap_comb.Rd b/man/getSpatialMap_comb.Rd index c2b50d9..d179f6f 100644 --- a/man/getSpatialMap_comb.Rd +++ b/man/getSpatialMap_comb.Rd @@ -52,7 +52,7 @@ getSpatialMap_comb(list = list(a1, a2), nrow = 2) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index 4b6fbcb..81b8e94 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -67,13 +67,13 @@ getSpatialMap_mat(a6) } -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. \item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software, 21(12), 1-20. URL http://www.jstatsoft.org/v21/i12/. @@ -83,13 +83,13 @@ Software, 40(1), 1-29. URL http://www.jstatsoft.org/v40/i01/. \item Original S code by Richard A. Becker and Allan R. Wilks. R version by Ray Brownrigg. Enhancements by Thomas P Minka (2015). maps: Draw Geographical Maps. R package version -2.3-11. http://CRAN.R-project.org/package=maps +2.3-11. https://CRAN.R-project.org/package=maps \item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial -Objects. R package version 0.8-36. http://CRAN.R-project.org/package=maptools +Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R -package version 0.3-11. http://CRAN.R-project.org/package=rgeos +package version 0.3-11. https://CRAN.R-project.org/package=rgeos } } diff --git a/man/list2Dataframe.Rd b/man/list2Dataframe.Rd index 255ef42..564f81b 100644 --- a/man/list2Dataframe.Rd +++ b/man/list2Dataframe.Rd @@ -26,7 +26,7 @@ datalist_new <- extractPeriod(datalist, commonPeriod = TRUE) dataframe <- list2Dataframe(datalist_new) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } diff --git a/man/loadNcdf.Rd b/man/loadNcdf.Rd index 085a427..97888d1 100644 --- a/man/loadNcdf.Rd +++ b/man/loadNcdf.Rd @@ -47,7 +47,7 @@ lat = c(43.2, 43.7)) \itemize{ \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or Earlier) Format Data Files. R package version 1.14.1. -http://CRAN.R-project.org/package=ncdf4 +https://CRAN.R-project.org/package=ncdf4 \item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package version 2.2-6. http://meteo.unican.es/ecoms-udg diff --git a/man/plotTS.Rd b/man/plotTS.Rd index 75da04c..22e533d 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -65,7 +65,7 @@ plotTS(dataframe, dataframe1, plot = 'cum') # and compare them using plotTS_comb. If all data are in one plot, there might be too messy. -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/plotTS_comb.Rd b/man/plotTS_comb.Rd index 582bd9a..83ae77d 100644 --- a/man/plotTS_comb.Rd +++ b/man/plotTS_comb.Rd @@ -46,7 +46,7 @@ a2 <- plotTS(testdl[[2]], output = 'ggplot', name = 2) plotTS_comb(a1, a2) plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ diff --git a/man/resample.Rd b/man/resample.Rd index d45f3f6..c83c3f4 100644 --- a/man/resample.Rd +++ b/man/resample.Rd @@ -56,13 +56,13 @@ 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/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/shp2cat.Rd b/man/shp2cat.Rd index 6c60613..13bb763 100644 --- a/man/shp2cat.Rd +++ b/man/shp2cat.Rd @@ -24,16 +24,16 @@ This function is based on the package \code{rgdal} and \code{sp}, and the output file <- system.file("extdata", "testCat.shp", package = "hyfo") catchment <- shp2cat(file) -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data -Abstraction Library. R package version 1.0-4. http://CRAN.R-project.org/package=rgdal +Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=rgdal \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/. +Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } diff --git a/man/writeNcdf.Rd b/man/writeNcdf.Rd index 5becb22..596a64f 100644 --- a/man/writeNcdf.Rd +++ b/man/writeNcdf.Rd @@ -45,14 +45,14 @@ nc <- loadNcdf(filePath, varname) writeNcdf(nc, 'test.nc') -# More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ +# More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } \references{ \itemize{ \item David Pierce (2015). ncdf4: Interface to Unidata netCDF (Version 4 or Earlier) Format Data Files. R package version 1.14.1. -http://CRAN.R-project.org/package=ncdf4 +https://CRAN.R-project.org/package=ncdf4 \item Santander MetGroup (2015). ecomsUDG.Raccess: R interface to the ECOMS User Data Gateway. R package version 2.2-6. http://meteo.unican.es/ecoms-udg diff --git a/vignettes/hyfo.Rmd b/vignettes/hyfo.Rmd index d11546e..ae26955 100644 --- a/vignettes/hyfo.Rmd +++ b/vignettes/hyfo.Rmd @@ -1,5 +1,5 @@ --- -title: '[hyfo Easy Start](http://yuanchao-xu.github.io/hyfo/)' +title: '[hyfo Easy Start](https://yuanchao-xu.github.io/hyfo/)' author: '[Yuanchao Xu](https://dk.linkedin.com/in/xuyuanchao37)' date: '`r Sys.Date()`' output: @@ -16,7 +16,7 @@ vignette: > # Introduction -**Official Website is [http://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo), where manuals and more details can be found.** +**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo), where manuals and more details can be found.** hyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate. @@ -24,7 +24,7 @@ This package mainly focuses on data process and visulization in hydrology and cl **If you feel hyfo is of a little help, please cite it as following:** -Xu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/ +Xu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from https://yuanchao-xu.github.io/hyfo/ #### TIPS From 112823d9dcda3c4480a3b6abbf9d220b35a123b4 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Fri, 24 Mar 2017 11:48:06 +0800 Subject: [PATCH 10/43] change prThreshold to 0 --- .Rhistory | 20 +++++++++---------- .Rproj.user/7DCFFB88/cpp-definition-cache | 2 ++ .../7DCFFB88/pcs/debug-breakpoints.pper | 6 ++++++ .Rproj.user/7DCFFB88/pcs/files-pane.pper | 9 +++++++++ .Rproj.user/7DCFFB88/pcs/find-in-files.pper | 10 ++++++++++ .Rproj.user/7DCFFB88/pcs/source-pane.pper | 3 +++ .../7DCFFB88/pcs/windowlayoutstate.pper | 14 +++++++++++++ .Rproj.user/7DCFFB88/pcs/workbench-pane.pper | 6 ++++++ .Rproj.user/7DCFFB88/rmd-outputs | 5 +++++ .Rproj.user/7DCFFB88/saved_source_markers | 1 + .Rproj.user/7DCFFB88/sdb/per/t/B4594EC | 20 +++++++++++++++++++ .Rproj.user/7DCFFB88/sdb/prop/284FBADF | 2 ++ .Rproj.user/7DCFFB88/sdb/prop/INDEX | 1 + .Rproj.user/7DCFFB88/session-persistent-state | 1 + DESCRIPTION | 2 +- R/biasCorrect(generic).R | 4 +++- man/applyBiasFactor.Rd | 7 +++---- man/biasCorrect.Rd | 11 +++++----- man/checkBind.Rd | 1 - man/collectData.Rd | 1 - man/collectData_csv_anarbe.Rd | 1 - man/collectData_excel_anarbe.Rd | 1 - man/collectData_txt_anarbe.Rd | 1 - man/coord2cell.Rd | 1 - man/downscaleNcdf.Rd | 1 - man/extractPeriod.Rd | 1 - man/fillGap.Rd | 1 - man/getAnnual.Rd | 1 - man/getAnnual_dataframe.Rd | 1 - man/getBiasFactor.Rd | 7 +++---- man/getEnsem_comb.Rd | 1 - man/getFrcEnsem.Rd | 1 - man/getHisEnsem.Rd | 1 - man/getLMom.Rd | 1 - man/getMeanPreci.Rd | 1 - man/getMoment.Rd | 1 - man/getNcdfVar.Rd | 1 - man/getPreciBar.Rd | 3 +-- man/getPreciBar_comb.Rd | 1 - man/getSpatialMap.Rd | 1 - man/getSpatialMap_comb.Rd | 1 - man/getSpatialMap_mat.Rd | 1 - man/list2Dataframe.Rd | 1 - man/loadNcdf.Rd | 1 - man/monthlyPreci.Rd | 1 - man/plotTS.Rd | 1 - man/plotTS_comb.Rd | 1 - man/resample.Rd | 1 - man/shp2cat.Rd | 1 - man/testCat.Rd | 1 - man/testdl.Rd | 1 - man/tgridData.Rd | 1 - man/writeNcdf.Rd | 1 - 53 files changed, 107 insertions(+), 60 deletions(-) create mode 100644 .Rproj.user/7DCFFB88/cpp-definition-cache create mode 100644 .Rproj.user/7DCFFB88/pcs/debug-breakpoints.pper create mode 100644 .Rproj.user/7DCFFB88/pcs/files-pane.pper create mode 100644 .Rproj.user/7DCFFB88/pcs/find-in-files.pper create mode 100644 .Rproj.user/7DCFFB88/pcs/source-pane.pper create mode 100644 .Rproj.user/7DCFFB88/pcs/windowlayoutstate.pper create mode 100644 .Rproj.user/7DCFFB88/pcs/workbench-pane.pper create mode 100644 .Rproj.user/7DCFFB88/rmd-outputs create mode 100644 .Rproj.user/7DCFFB88/saved_source_markers create mode 100644 .Rproj.user/7DCFFB88/sdb/per/t/B4594EC create mode 100644 .Rproj.user/7DCFFB88/sdb/prop/284FBADF create mode 100644 .Rproj.user/7DCFFB88/sdb/prop/INDEX create mode 100644 .Rproj.user/7DCFFB88/session-persistent-state diff --git a/.Rhistory b/.Rhistory index 358c13a..ce015ed 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,13 +1,3 @@ -} -} else if (method == 'eqm') { -if (preci == FALSE) { -frc <- biasCorrect_core_eqm_nonPreci(frc, hindcast, obs, extrapolate, prThreshold) -} else { -frc <- biasCorrect_core_eqm_preci(frc, hindcast, obs, minHindcastPreci, extrapolate, -prThreshold) -} -} else if (method == 'gqm') { -if (preci == FALSE) stop ('gqm method only applys to precipitation, please set preci = T') frc <- biasCorrect_core_gqm(frc, hindcast, obs, prThreshold, minHindcastPreci) } return(frc) @@ -510,3 +500,13 @@ a[[2]] a devtools::check() devtools::build() +rm(a) +rm(b) +rm(filePath) +rm(name) +rm(nc) +rm(varname) +rm(writePath) +devtools::document() +devtools::check(cran = T, manual manual = T) +devtools::check(cran = T, manual = T) diff --git a/.Rproj.user/7DCFFB88/cpp-definition-cache b/.Rproj.user/7DCFFB88/cpp-definition-cache new file mode 100644 index 0000000..32960f8 --- /dev/null +++ b/.Rproj.user/7DCFFB88/cpp-definition-cache @@ -0,0 +1,2 @@ +[ +] \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/debug-breakpoints.pper b/.Rproj.user/7DCFFB88/pcs/debug-breakpoints.pper new file mode 100644 index 0000000..5528aea --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/debug-breakpoints.pper @@ -0,0 +1,6 @@ +{ + "debugBreakpointsState" : { + "breakpoints" : [ + ] + } +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/files-pane.pper b/.Rproj.user/7DCFFB88/pcs/files-pane.pper new file mode 100644 index 0000000..10314bb --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/files-pane.pper @@ -0,0 +1,9 @@ +{ + "path" : "~/GitHub/hyfo/R", + "sortOrder" : [ + { + "ascending" : true, + "columnIndex" : 2 + } + ] +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/find-in-files.pper b/.Rproj.user/7DCFFB88/pcs/find-in-files.pper new file mode 100644 index 0000000..ad22e37 --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/find-in-files.pper @@ -0,0 +1,10 @@ +{ + "dialog-state" : { + "caseSensitive" : false, + "filePatterns" : [ + ], + "path" : "~/GitHub/hyfo", + "query" : "gtable", + "regex" : false + } +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/source-pane.pper b/.Rproj.user/7DCFFB88/pcs/source-pane.pper new file mode 100644 index 0000000..1743e40 --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/source-pane.pper @@ -0,0 +1,3 @@ +{ + "activeTab" : 0 +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/windowlayoutstate.pper b/.Rproj.user/7DCFFB88/pcs/windowlayoutstate.pper new file mode 100644 index 0000000..5d66c60 --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/windowlayoutstate.pper @@ -0,0 +1,14 @@ +{ + "left" : { + "panelheight" : 943, + "splitterpos" : 392, + "topwindowstate" : "NORMAL", + "windowheight" : 981 + }, + "right" : { + "panelheight" : 943, + "splitterpos" : 588, + "topwindowstate" : "NORMAL", + "windowheight" : 981 + } +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/pcs/workbench-pane.pper b/.Rproj.user/7DCFFB88/pcs/workbench-pane.pper new file mode 100644 index 0000000..0e24b84 --- /dev/null +++ b/.Rproj.user/7DCFFB88/pcs/workbench-pane.pper @@ -0,0 +1,6 @@ +{ + "TabSet1" : 0, + "TabSet2" : 0, + "TabZoom" : { + } +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/rmd-outputs b/.Rproj.user/7DCFFB88/rmd-outputs new file mode 100644 index 0000000..3f2ff2d --- /dev/null +++ b/.Rproj.user/7DCFFB88/rmd-outputs @@ -0,0 +1,5 @@ + + + + + diff --git a/.Rproj.user/7DCFFB88/saved_source_markers b/.Rproj.user/7DCFFB88/saved_source_markers new file mode 100644 index 0000000..2b1bef1 --- /dev/null +++ b/.Rproj.user/7DCFFB88/saved_source_markers @@ -0,0 +1 @@ +{"active_set":"","sets":[]} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC b/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC new file mode 100644 index 0000000..01b1306 --- /dev/null +++ b/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC @@ -0,0 +1,20 @@ +{ + "collab_server" : "", + "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#' \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 0 (assuming mm). If you want \n#' to use precipitation biascorrect, you should consider carefully how to set this threshold, usually is 1. But you \n#' can try with different numbers to see the results.\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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 https://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 }\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\n# Since in new version of roxygen2, describeIn was changed, https://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1490325226249.000, + "dirty" : false, + "encoding" : "ASCII", + "folds" : "", + "hash" : "1881778702", + "id" : "B4594EC", + "lastKnownWriteTime" : 1490325381, + "last_content_update" : 1490325381151, + "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", + "project_path" : "R/biasCorrect(generic).R", + "properties" : { + }, + "relative_order" : 1, + "source_on_save" : false, + "source_window" : "", + "type" : "r_source" +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/sdb/prop/284FBADF b/.Rproj.user/7DCFFB88/sdb/prop/284FBADF new file mode 100644 index 0000000..7a73a41 --- /dev/null +++ b/.Rproj.user/7DCFFB88/sdb/prop/284FBADF @@ -0,0 +1,2 @@ +{ +} \ No newline at end of file diff --git a/.Rproj.user/7DCFFB88/sdb/prop/INDEX b/.Rproj.user/7DCFFB88/sdb/prop/INDEX new file mode 100644 index 0000000..41aae6b --- /dev/null +++ b/.Rproj.user/7DCFFB88/sdb/prop/INDEX @@ -0,0 +1 @@ +~%2FGitHub%2Fhyfo%2FR%2FbiasCorrect(generic).R="284FBADF" diff --git a/.Rproj.user/7DCFFB88/session-persistent-state b/.Rproj.user/7DCFFB88/session-persistent-state new file mode 100644 index 0000000..7b8d0ff --- /dev/null +++ b/.Rproj.user/7DCFFB88/session-persistent-state @@ -0,0 +1 @@ +virtual-session-id="22D464B7" diff --git a/DESCRIPTION b/DESCRIPTION index 6567622..7695ac0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,4 +39,4 @@ LazyData: true URL: https://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN -RoxygenNote: 5.0.1 +RoxygenNote: 6.0.1 diff --git a/R/biasCorrect(generic).R b/R/biasCorrect(generic).R index 8089c74..72c1c22 100644 --- a/R/biasCorrect(generic).R +++ b/R/biasCorrect(generic).R @@ -24,7 +24,9 @@ #' @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. -#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm). +#' @param prThreshold The minimum value that is considered as a non-zero precipitation. Default to 0 (assuming mm). If you want +#' to use precipitation biascorrect, you should consider carefully how to set this threshold, usually is 1. But you +#' can try with different numbers to see the results. #' @param extrapolate When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs. #' If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'. #' @details diff --git a/man/applyBiasFactor.Rd b/man/applyBiasFactor.Rd index 3ab3a49..dfba56d 100644 --- a/man/applyBiasFactor.Rd +++ b/man/applyBiasFactor.Rd @@ -151,9 +151,6 @@ plotTS(list = TSlist, plot = 'cum') # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ -} -\author{ -Yuanchao Xu \email{xuyuanchao37@gmail.com } } \references{ Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} @@ -176,4 +173,6 @@ package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki \code{\link{biasCorrect}} for method used in bias correction. \code{\link{getBiasFactor}}, for the first part. } - +\author{ +Yuanchao Xu \email{xuyuanchao37@gmail.com } +} diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 10bcd00..0f608fc 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -39,7 +39,9 @@ details. Default scaleType is 'multi'.} precipitation, some biascorrect methods may not apply to, or some methods are specially for precipitation. Default is FALSE, refer to details.} -\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 1 (assuming mm).} +\item{prThreshold}{The minimum value that is considered as a non-zero precipitation. Default to 0 (assuming mm). If you want +to use precipitation biascorrect, you should consider carefully how to set this threshold, usually is 1. But you +can try with different numbers to see the results.} \item{extrapolate}{When use 'eqm' method, and 'no' is set, modified frc is bounded by the range of obs. If 'constant' is set, modified frc is not bounded by the range of obs. Default is 'no'.} @@ -209,9 +211,6 @@ plotTS(list = TSlist, plot = 'cum') # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ -} -\author{ -Yuanchao Xu \email{xuyuanchao37@gmail.com } } \references{ Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} @@ -230,4 +229,6 @@ package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki \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 } } - +\author{ +Yuanchao Xu \email{xuyuanchao37@gmail.com } +} diff --git a/man/checkBind.Rd b/man/checkBind.Rd index 50108ab..914bfdb 100644 --- a/man/checkBind.Rd +++ b/man/checkBind.Rd @@ -30,4 +30,3 @@ checkBind(testdl, 'rbind') # Since the colnames in testdl are not the same, so it cannot be bound. # } - diff --git a/man/collectData.Rd b/man/collectData.Rd index 4f2e567..5369824 100644 --- a/man/collectData.Rd +++ b/man/collectData.Rd @@ -35,4 +35,3 @@ a <- collectData(folder, fileType = 'csv', range = c(10, 20, 1,2)) # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } - diff --git a/man/collectData_csv_anarbe.Rd b/man/collectData_csv_anarbe.Rd index 28ec9a4..ea3fa58 100644 --- a/man/collectData_csv_anarbe.Rd +++ b/man/collectData_csv_anarbe.Rd @@ -37,4 +37,3 @@ a <- collectData_csv_anarbe(folder) Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/collectData_excel_anarbe.Rd b/man/collectData_excel_anarbe.Rd index 3e2d3d4..d9ca391 100644 --- a/man/collectData_excel_anarbe.Rd +++ b/man/collectData_excel_anarbe.Rd @@ -25,4 +25,3 @@ Collect data from different excel files Statistical Computing, Vienna, Austria. URL http://www.R-project.org/. } } - diff --git a/man/collectData_txt_anarbe.Rd b/man/collectData_txt_anarbe.Rd index c61ac2c..771f563 100644 --- a/man/collectData_txt_anarbe.Rd +++ b/man/collectData_txt_anarbe.Rd @@ -45,4 +45,3 @@ a <- collectData_txt_anarbe(folder) Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/coord2cell.Rd b/man/coord2cell.Rd index 46d5f27..3cdd597 100644 --- a/man/coord2cell.Rd +++ b/man/coord2cell.Rd @@ -19,4 +19,3 @@ A cell coordinate \description{ Change lon lat coordinates to cell coordinates } - diff --git a/man/downscaleNcdf.Rd b/man/downscaleNcdf.Rd index 3523aca..32d0031 100644 --- a/man/downscaleNcdf.Rd +++ b/man/downscaleNcdf.Rd @@ -51,4 +51,3 @@ nc2 <- downscaleNcdf(nc, year = 2005, month = 3:8, lon = c(-2, -0.5), lat = c(43 version 2.2-6. http://meteo.unican.es/ecoms-udg } } - diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index e3b5ca0..d8c5bd2 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -112,4 +112,3 @@ dataframe_new <- extractPeriod(dataframe, month = c(12,1,2), year = 1995) Series. Journal of Statistical Software, 14(6), 1-27. URL https://www.jstatsoft.org/v14/i06/ } } - diff --git a/man/fillGap.Rd b/man/fillGap.Rd index 716939a..d682b39 100644 --- a/man/fillGap.Rd +++ b/man/fillGap.Rd @@ -73,4 +73,3 @@ Salas, Jose D. "Analysis and modeling of hydrologic time series." Handbook of hy } } - diff --git a/man/getAnnual.Rd b/man/getAnnual.Rd index 720a249..b5e013e 100644 --- a/man/getAnnual.Rd +++ b/man/getAnnual.Rd @@ -66,4 +66,3 @@ getAnnual(a3) Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/getAnnual_dataframe.Rd b/man/getAnnual_dataframe.Rd index 4d663cb..ca8955b 100644 --- a/man/getAnnual_dataframe.Rd +++ b/man/getAnnual_dataframe.Rd @@ -16,4 +16,3 @@ The annual rainfall of each year of the input station. \description{ Get annual rainfall of the input time series. } - diff --git a/man/getBiasFactor.Rd b/man/getBiasFactor.Rd index d9ba59c..a68c835 100644 --- a/man/getBiasFactor.Rd +++ b/man/getBiasFactor.Rd @@ -168,9 +168,6 @@ plotTS(list = TSlist, plot = 'cum') # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ -} -\author{ -Yuanchao Xu \email{xuyuanchao37@gmail.com } } \references{ Bias correction methods come from \code{biasCorrection} from \code{dowscaleR} @@ -193,4 +190,6 @@ package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki \code{\link{biasCorrect}} for method used in bias correction. \code{\link{applyBiasFactor}}, for the second part. } - +\author{ +Yuanchao Xu \email{xuyuanchao37@gmail.com } +} diff --git a/man/getEnsem_comb.Rd b/man/getEnsem_comb.Rd index d7b20a8..2563858 100644 --- a/man/getEnsem_comb.Rd +++ b/man/getEnsem_comb.Rd @@ -63,4 +63,3 @@ statistical downscaling. R package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki } } - diff --git a/man/getFrcEnsem.Rd b/man/getFrcEnsem.Rd index 003d6df..c9347ff 100644 --- a/man/getFrcEnsem.Rd +++ b/man/getFrcEnsem.Rd @@ -89,4 +89,3 @@ statistical downscaling. R package version 0.6-0. https://github.com/SantanderMetGroup/downscaleR/wiki } } - diff --git a/man/getHisEnsem.Rd b/man/getHisEnsem.Rd index b9f92fe..0a68297 100644 --- a/man/getHisEnsem.Rd +++ b/man/getHisEnsem.Rd @@ -124,4 +124,3 @@ b <- getHisEnsem(a, example = c('1994-2-4', '1996-1-4'), interval = 210, buffer \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. } } - diff --git a/man/getLMom.Rd b/man/getLMom.Rd index 7c9b15c..516e2cc 100644 --- a/man/getLMom.Rd +++ b/man/getLMom.Rd @@ -28,4 +28,3 @@ getLMom(dis) https://CRAN.R-project.org/package=lmom. } } - diff --git a/man/getMeanPreci.Rd b/man/getMeanPreci.Rd index 43284cf..bb53b46 100644 --- a/man/getMeanPreci.Rd +++ b/man/getMeanPreci.Rd @@ -42,4 +42,3 @@ Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfa Since "winter" is a crossing year, 12, 1, 2, 12 is in former year, and 1, 2 are in latter year. so winter belongs to the latter year. } - diff --git a/man/getMoment.Rd b/man/getMoment.Rd index e24bb5c..4f962b1 100644 --- a/man/getMoment.Rd +++ b/man/getMoment.Rd @@ -31,4 +31,3 @@ related tests. R package version 0.14. https://CRAN.R-project.org/package=moment Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/getNcdfVar.Rd b/man/getNcdfVar.Rd index ea26a00..842cef1 100644 --- a/man/getNcdfVar.Rd +++ b/man/getNcdfVar.Rd @@ -33,4 +33,3 @@ Earlier) Format Data Files. R package version 1.14.1. https://CRAN.R-project.org/package=ncdf4 } } - diff --git a/man/getPreciBar.Rd b/man/getPreciBar.Rd index c033e8d..a5a1a11 100644 --- a/man/getPreciBar.Rd +++ b/man/getPreciBar.Rd @@ -3,8 +3,8 @@ \docType{methods} \name{getPreciBar} \alias{getPreciBar} -\alias{getPreciBar,data.frame-method} \alias{getPreciBar,list-method} +\alias{getPreciBar,data.frame-method} \title{get mean rainfall bar plot of the input dataset or time series.} \usage{ getPreciBar(data, method, cell = "mean", output = "data", name = NULL, @@ -99,4 +99,3 @@ a <- getPreciBar(TS, method = 'spring', info = TRUE) Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/getPreciBar_comb.Rd b/man/getPreciBar_comb.Rd index 1bed03a..945abe9 100644 --- a/man/getPreciBar_comb.Rd +++ b/man/getPreciBar_comb.Rd @@ -55,4 +55,3 @@ getPreciBar_comb(b1, b2) \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. } } - diff --git a/man/getSpatialMap.Rd b/man/getSpatialMap.Rd index 6fe3722..f68d710 100644 --- a/man/getSpatialMap.Rd +++ b/man/getSpatialMap.Rd @@ -54,4 +54,3 @@ getSpatialMap(tgridData, method = 'winter', catchment = testCat, point = point) # More examples can be found in the user manual on http://yuanchao-xu.github.io/hyfo/ } - diff --git a/man/getSpatialMap_comb.Rd b/man/getSpatialMap_comb.Rd index d179f6f..4552a51 100644 --- a/man/getSpatialMap_comb.Rd +++ b/man/getSpatialMap_comb.Rd @@ -60,4 +60,3 @@ getSpatialMap_comb(list = list(a1, a2), nrow = 2) \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. } } - diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index 81b8e94..e783753 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -93,4 +93,3 @@ package version 0.3-11. https://CRAN.R-project.org/package=rgeos } } - diff --git a/man/list2Dataframe.Rd b/man/list2Dataframe.Rd index 564f81b..6bdc641 100644 --- a/man/list2Dataframe.Rd +++ b/man/list2Dataframe.Rd @@ -29,4 +29,3 @@ dataframe <- list2Dataframe(datalist_new) # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ } - diff --git a/man/loadNcdf.Rd b/man/loadNcdf.Rd index 97888d1..ad4b617 100644 --- a/man/loadNcdf.Rd +++ b/man/loadNcdf.Rd @@ -53,4 +53,3 @@ https://CRAN.R-project.org/package=ncdf4 version 2.2-6. http://meteo.unican.es/ecoms-udg } } - diff --git a/man/monthlyPreci.Rd b/man/monthlyPreci.Rd index b5dd206..0da6004 100644 --- a/man/monthlyPreci.Rd +++ b/man/monthlyPreci.Rd @@ -19,4 +19,3 @@ the monthly rainfall matrix of the rainfall time series. \description{ Get monthly rainfall } - diff --git a/man/plotTS.Rd b/man/plotTS.Rd index 22e533d..b77530f 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -73,4 +73,3 @@ plotTS(dataframe, dataframe1, plot = 'cum') \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. } } - diff --git a/man/plotTS_comb.Rd b/man/plotTS_comb.Rd index 83ae77d..55e84e3 100644 --- a/man/plotTS_comb.Rd +++ b/man/plotTS_comb.Rd @@ -54,4 +54,3 @@ plotTS_comb(list = list(a1, a2), y = 'y axis', nrow = 2) \item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009. } } - diff --git a/man/resample.Rd b/man/resample.Rd index c83c3f4..e6f7edb 100644 --- a/man/resample.Rd +++ b/man/resample.Rd @@ -65,4 +65,3 @@ nc_new <- resample(nc, 'day2mon') Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/shp2cat.Rd b/man/shp2cat.Rd index 13bb763..1231889 100644 --- a/man/shp2cat.Rd +++ b/man/shp2cat.Rd @@ -36,4 +36,3 @@ Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. } } - diff --git a/man/testCat.Rd b/man/testCat.Rd index e203f3c..883b60b 100644 --- a/man/testCat.Rd +++ b/man/testCat.Rd @@ -16,4 +16,3 @@ testCat testCat } \keyword{datasets} - diff --git a/man/testdl.Rd b/man/testdl.Rd index 93cfa83..010c840 100644 --- a/man/testdl.Rd +++ b/man/testdl.Rd @@ -28,4 +28,3 @@ A list containing different precipitation time series. } } \keyword{datasets} - diff --git a/man/tgridData.Rd b/man/tgridData.Rd index 22bcf0b..db4fb2c 100644 --- a/man/tgridData.Rd +++ b/man/tgridData.Rd @@ -30,4 +30,3 @@ over Spain (Spain02). International Journal of Climatology } } \keyword{datasets} - diff --git a/man/writeNcdf.Rd b/man/writeNcdf.Rd index 596a64f..fefd14b 100644 --- a/man/writeNcdf.Rd +++ b/man/writeNcdf.Rd @@ -59,4 +59,3 @@ version 2.2-6. http://meteo.unican.es/ecoms-udg } } - From 3f7470a1ee8d89deb38e95b685a03e68f19ea835 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Fri, 24 Mar 2017 12:12:42 +0800 Subject: [PATCH 11/43] clear the data --- .RData | Bin 122403 -> 2586 bytes .Rhistory | 16 ++++++++-------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/.RData b/.RData index 2cf2d705a30d6fc365facc318a6f35ae9b5746dd..57e33ec8b9c139ae68107823c9b37f80b2b6b193 100644 GIT binary patch literal 2586 zcmV+#3gz`5iwFP!000001_1*K{Pj{qSTYJ&3IG5A0ssR80ssO7000040ssI20RRL5 z2><{93@%b(Ze(w5E^}pNWB>pF4FCWFasU7UlK=n!3XL}&H~Yp#EtCK*L}s}&YVm*{ z)mY?-ZyCQtc06&9pl#_`V^LTA0V^p`aDVdr4sm@Pc@`n83#AlAIy(APJbIbqe}tqk z)y&w0?6koiLT`0(of94;7Zw?Les6@IIE-1?8#txec?8P;$n$oi_B;djF~d&KV;SM_ zGPm=Mgu35z$999Zo&Qwc6oKlbx`G4|1sFt<-~BSbW>BBj@MH8Y6A6juvA3-SwbA&;wZvqdlsB0LW#6cKSBm!4mLjaT3Tq+jn0ig^d3^>H|b zPwnawR!(*?0HC0RLz85O;p|dpP}y8rt}cn!S&}Z@Ynq{i+EbQ|oM}C=pPG7;_2Q($ zjIkNVVhm)rJ#6fcx2c63Uf?HDnD{TW`-a~DnIFS(C__C5)`tY7QMR|w1M{Uuk~`|e zBu7$;=SoB0J!*+xv{@-c8rXTCWhf^>|63yrhSot45C*4Gvm#p2QE6te03VR^-bb7u zDVC78+d#Y|>c}Gkj3|*E&jTw_g$&7RJkc|c61(X14dL-WN3>r3E(N)Kh!mdbi-_~_ zXkd-FX83G zHspl+VAEa!qYj+H!7>F}u(TOf&iM=pIU)chOM~}r`X!AY{1*mP`EG)z? z0+WjS-LeU`*WD0-zS_NG__HZj+eln0In^8Mh;J(!HWXM1akV}pqm^Xx^7GOXM2f;a z2X=YH-5@$K)OFI7`o}KJMewRzpAY6fCRkNEuvWt-Qz?)laoaF&pdfz7KI~J@Nzm~s z`=bw9%H`%vEHx>VFK9x%uzuI(uVfP^R3ZY={l5lyQ2fQvUfJ;4%JG%w_f7 zpg$;ag1W*$=(wut?43QGJgcPWa^R7IaFW2$(50x^JbWnglp5Ce zf=7qzz&N~iJg$O)kY;+QB0kZr2(-}%jOE799ELlbk}|N3fPxb+6iMu-DB~oCI`z!S z(DzFrY}Ch_v>*9$5~Nyp;9lez%qGZK;4Yw)A_#r^C=3;<3{Rj_Jd0?j^2E$y@HTkr zM9kIJSf>m(I;HV9@JlR;ytI}j6byxI!b_iwU@!mOd@)#`(BIq%A}E*csGB(-jN(g# zytWdvG6(+FKtQ#$w5E2x>py}l@%yKWvV7L?~ z!pFknC~nBXtWi=mJi&fLavoL1FatK?!4|l=CG^(lY$-V5l%TOevuuAXX1Af=QB2 z=wlPO?10z)JkGacaw=%XaD!$nBz7uaIArGlnuJqE&{LcwyaF1^l-EI8g8EL-z-Kt+ zJn<=rkQ`I~A|7IT2owv|3^0XaoQ9%S5@8%MfS&B46sR!1C@GA=I_5T;&=(-iY+0Xs zG@WBIl6ijxV2=iMOljTY;D^H>qBam8s51%gj1(CB@MIf|L~I-FSW!Yy zI&roGa3}N>JeB3E6m&j~!jnV{;Ebnte5OFtZd$r2P}RxT#`aS}%otkS&{Heq-;fODGjSP1SLvdO)H?xbtu> zVX{b+6YXsxG@K2@Li-(jSD7D|q4riNW|dL!WVuI+l^j_-zl^2qSepdcc4T-+gGMQ+ z#Su6q;)?r>P^jVMd4{E0tFSl%9AKGUO8BBhKdD{Ai85<@p6yQBOkB*o9n*Ccr%F=j z(0yilZmXpw8(qd8ePPG!YHuHz2;I01u@fU|BZY%cB=Ws?((8$oCtje=aZQVKwuW8w zR6nW=SgCkI!6O1? zbAqe(luQ`|A~~Q=HxZrN0VTd72B$oLL|>hebrxiF-;4-IIK>wb7C0jSBTsf8<#H=( z0>{X>aOmp}8F0bS3uqmR{6n=HDhK$@Uyydh>AuO+{!Q2K>?UeEJtdj92keC|@R_!b zj`b9XyWd#6o#s1mN@y|?XsoE7QKUxYLmA=JME-78@`eoF$KMp>k-cpi7MnpxbY6Q) z1+NuhPahVeNZcP1=EJE36Z=Jbbzh_#QZUO4pnHp6i40pRyMZ#14A1Lqnp0_V4~E_r zSw>5$?zDfQeCjdL?bcA9m;b#vV4L3wN;^jZzJlx|~X7_>By~p>ttpQy18# zbS|0b0;#u>m%KB)VI94grc@dTq}IK`RWR~l|ChcPnC>D4wqN(|L$|w=g~-qNB4{1^ z5Ncl5xe>mrYiy{3Tp?p$itXQzet@D-7B(c=NTA75E)ULE~(o< w+skNuz2$U^Dpf;+$V%LR@z(QxW7<|qWW~WLlEc8k<^TWy{y>3Ym;(v`0LiY#jQ{`u literal 122403 zcmcfoc{tQx_&<&(A%yJ7GDWiUDr)SLkdQ42*%Db&_AtiGShK}YmdY}gN@d@PnNi4Y zL>TMXM~rQZ8O)6NcKv>TzyEu`Kj*s7^|-Ec|8cJC`8@YI=W*`G4M;tE>i^f+i6{<- z2YnMa&DdFF&2z4rf6lAG*{$V=NDOLuo0tryYp+RMBjhi$hny~+kq{pgv*{u}#iZ`& z?6*t|4Gde+v>Wb!e!*e|d}JkCL()ozN_8mH>Ti zCVad6!SWY**F(gEPUF=3Mn1RTKXX$>yW!k`ug($pPv&pV;_pK)H-DKMD>)0x)AE~2G=^4&nwC`+RIn z@1&YtfArwZ?~*sKMY25`zFa9amK9U^UvLS?g12qn5TyRE;5wGk(`=NrqQWl=Ha9ZA zW8UD|@P7|ocYob^?fLxw8U}HPdlmvpVk)(7e*ZrJIWh5|H?{o#$8g)4_im=TV2>3VW|Bf?7R^a_7k7YRcZI@ZtvnR4TH)`J$d~oQq zw5aebyZW%sR#0i`YjQU6&;J{@vCa+VX4Mir;5VfH2q#=A(;n~4zy`XaNvAu4cd&A)HMc+gmX<7hhjDt|GuQvx2sN<( zp~K>r${GKauR=$4xh`!@b^CQg?F9qmGsdI7AP}h(VHEL)+ z4xu;P_8Rt7YDp^?>r%rv0CE*%1n-+9lj_J8eKkG9#iH&PYW=0qP_KbIr@fY1UQ$qJ1i;CWdd+^qn>j#F zBkUUX`x2&S%ciumX5zmW7aV+@8=)NyN9^_mxvDmKZ@$Tv7P_wUieWJa|4VzmD|>5h z>%vI$kkskc7t{Anp$e$}$<}uP*OeWsn02OkMq2R|4>^k9o*qtb@DWKtNz|W94FhPn z;8yUBTw`rwa-&7cIrz=dPfCZr>E6Y2sm9sAK?K?z@{Z=`=xHaDBF6kRY*+B&&*_sV zS`ggdddv99HRKuQ)XS!i(XLmH&T8hx7NY;SCl-B(i7WtkcIpQ=SOLX1gTFH<6HWh$KJ&~xpA1} zEyo|JTI|8(hkV*xk?-YllR|MV>)}sYiySqC$*28r9hNLJ?5U($R=j`d$!sZKO{vw6 zO-*Vug=MOZsC=u3-c*B}8M7%`{$Bm?{x$OQwWj1EQD_N(Y>gscem5#a^4hB5U?wPv zJJNPN>>u;Js1b>TN35_O4mXMs8`r2`uB^8m=c3)74NYIw{wdrSOjpa*k>0?1@#gXB z3E6Q!233nBUhZkkuZ?a?|CZWmbsH2QjS48_JCyJLVY%%RcibS^^LAw#Su3S{dl9#t z@3u&l8MXkR1rC;fmC6}_AaK5grhvjE(yjnt54N-x;`N!%amYC5?Fd5@yY)xojbKE_ zhjO)rPkRci6w~!TeIKQbOplm6$LhDuvqZUx?&ySlF1u49n!d&ni&yG-5zPk+H-b`9 z?>1na#dDN@%DRLnw`ANPogzLK3P?WQDfgqNF_^AWf~7B{UHn@b*aPdgFDe4JzY6}X zC{Ngv@eISVoV>)!_wFz5@$Opr)rixrwA}UkRXJ9RqK>o66uK9x=Y0}`RL}?^X>?Vf z`~CRT(D6i7vCjfhAC$+CE>&?mXY+1AT)sIoDi^NTBnJAWI$+m`Fk^~hgq$402yNxf zlZ4q&UYQB(*ut#X_U=J?xKFw1{n*KInF?kJJm|K~@PPK}*Lly$mTY$SKIAC4jF08O{QQo-uGOShhTWT43X7yv{NjlFPcrl0?kt5yz zV~$FFc#9d4bB?hYFOZM<-Q1_7z=FF0jN5=ePTQz+XpsX*>gx0C6g1+! zntzEKg?$j>@R@L(44U<6aZt_IyBL3rov^TG7FwJ}E4s67s3YNOIeI+HSEIKl?JyL5 zxGVnbe~^G?AxFq~)IG|y4PRKT_$+H!U8PXj`Qpu={542(!bXWi`=5ixjDg7LM{;rj z_p;fF1YH89TI~Hkm}D!M?<%f(P3%=Cw6F7W(IFdaG%CV()=B1USsX;I7ZvD56ful%QIkCVB;vaeqAV!dPnWv1+>ewd8YEi0hT#YEL`*G^YKDLzBU zkY*H>`4tW7bc{r>NDGCD=w_A^WJMd<8t$VK^%TEroLUJeG?+i70?j?${~Hp4m4VdZ zXPQjA7qF7&d|iBU4K|H(?Jc5p01uNiXExKouL2jj)+C>o2kY&cSGnC^SwCveXFH0z z=%L?7f#cY~!&G?%IX-c{_3~bm5hBClq5krXG(!)x(#lyR#T6>qRDN76bUC zOhc7F6y9q6yLofLwsKoMHpbQla4}NyKTlq=ss!GN#brDFuIekgz|nO3j~%m-oL9`< zvg5X=?uA`0xjM0GZ8&wdKyvW9aJI!})0b9+_09(3;9~f2Cp9})zm{{=Qa!Q6WeT5W zp!Q#z&PE(UsFDxr3%&5%`xM&1u61-k*6b&bT*BD9l zPd?&8yskW}&;OyU2oN;KMwaTfSfLvi% zVRS+q3k>K*Vm^J1afbBpO%^3~e!WrS^xhj@j3JynERiC%3QnvlL$1(o-y4qvD;_7R z3DfF>9ieZc6HhLWx<6w!J^-9%c45l-biT>J2i{-K>;TX#S&&Y=S|w4lGx}#pO0R}q z>EF#_caRVI$8mGye+* zqA-{SEtWQs!3ebttd#Cm(Ac=_j1gnJ`om+o&~Oi4ju{&@>l0Pfn=2miIVH3OQubCp z+;&)CCTQ~JKy=%ggHw2dH|dg`zxEU7(7Cg z+O~K`=dc!E94?E|uQBNk5b20>-M$UA78G6Jt*kKCYJqm}EL@F28fmq-PtSUG+=LqE zL!pb&Fs=i;k^OHsPSa<-hE3p;O_Fa{RuuGj_U~=~5!m6Bg4-vO4ySO)rLd=q%}Y12 zSEDgD!?#9&7m|Gh-Xa)f4TX+y7#weRWN2Jenxw9b1IpfF!+Jo_6RC|qIfxkd9xrN%`W>ZDQb%Ftae0gcf~o2gB>0# z6$ECNM>vVI=_ysT8P{a<5XJq{p&U{n^4wuT?`?SxhE3N-)De?$&R8jr`Qf>=;Ud)L zr`DQOrn=6^Uci4s5zahHBgu?=v}^h=|DuQ}8tZYZ@i^=Dvr{0I0jVr@{oF|Rg6?6C zcS)h~tbKAem?oQ3G+1@F8h>$^$@MqQ zh(YvFyM*}Fo+8fyp-uYq9t7VL{i9X~drfgH*Z!gU*_-&7Z~3EzwipylN0EF)L2YV8 z0^>b}yIm(fc7E%SXCY*kB(~5MjI$Ef@R&A019=8wnYO8{K1j?BG0O1x)~gd0=Rclm z;TNrR!sTvZ$i9RT=0fOUL41gk#7ZFtka2IhCqgw1iK<{-chOAS`Th~wA~}(&`&^## z0{p3#O#AjH^4j`gWf?xxO@X)>MEFx1{fYUL8v7I(jr{QRW+ZP5sPqgG3JZns*PV>5 zDHSozSw}d<;$NQOL$`8Jmeo{Q2xVMujy`r(TWYA*|lQ7_?{Jqn?QkoM^`fXfJFZ&ees5*gjUPl-bJNuzV@9`dGBN6WI~wBFh}_ z#*SaY_`=}0z6ka${JX8S5&Xwt9vgoV9LtHCfw&_Nd1wBo?yCY{>r;``9(U+qL#{92 z=ap8L^^2|gtS+`{#J0fFI2^~SWk{v<_Ph9(GE{&-8VuH)8yzqeA{d>U7Qu2{?eF0h ztyhu77uEMGd<5io0fl$IzJ1%DAltCx+}O>5Lw$R8bEC4Z4{pCi4bG^atpnXfj(pYD zg22SmsA5Vurl-Dke+ob)bT&I3q%}$@B(oeVEN_zPZSCO9Wn3D>IvczQ~|kg-k^l5+h6L(-!*{!vv*>$A@+ zY4cyl`!Mdu48=ao7qyi^$s0UTQq5%t)G@ys)>Y*-jDWSnT)hpIYnCkAH0xp4e>@7& zb1Z)r$bzxeDJizv(9fr4?m{Th!&aV?C5)LFUOV@mh6iwRH7SQ!t^zqv0T&)89hd8i zn&{trJo~b@6uhBC@&<7Kii5%aLrvb7LvS!`!|QA?Mn|U^^=~A*gKw7jHa{SP!a0K1 z60(er>Sa70PipC0wW0C-DALjRC`&ABHQUkZdFs?fnJw-Kw2|@`rW+G`R4j)%m^92J zyW3W>WszUhZ9|Ifkgbpj=ra4J!y-9BtOF&Lz&fcIRF!(;i`}bfnr?z#TiZ}^tPg+G1puJuDO$aBE8qQiOU>P#L*4 z4?25{D31l_7CCydYH?R}0*2-vEi#4*;Yf~mV@LI0_<+fdoZ7E)`%}q|q@?$z>ll>e zanG3?X-4M){!MSdJm+$5UKA?v1gfF>2ZS7kYG^U9ux$;5vf_O=sU7nlz8}>v8-?pf z0tlAVqDo&z&V&tb0y&R`gmfR=IywKy>bQa~83i4zzYGu5p<70bD6kQqJiALXxMN-e z=$dooGeT|hM*&*`(%L$pP4>pL6o!*v#R2as%pFpU*l}*}c~1#Hl);_C^pmjFY+D|! z$01~Hkn!fH-I2g`P*FjwA-*iJ$W5>r?8&Dly8c%}*o2(*q%r1r|3t9{@$lvS;rZvJ zk}XfXeu2Tx)h+Q_4-xxlxVSABh2Byo-A}Uum{DMR{Hu_iM$rQS)pJwaG%3^lQ>gmS zlLpMJ8x*$qhKIYIbr<~D0$(^(;ShP7XoG+;e(uNkI+bhHt1(}Be(XHG;kVn0d3tK) zE5lRwfa+ZYteX$7Gr71m&;;7LeLVFTk8q4qdxZQFSu#Immwk`&gGx7n(9aQA#AyNz zKaOOi)DgeT@1==m;1yb{aD_S(FDA#KO$ezwfGqT=T*E9R<97=dlXb8$uDvHl zv4!PDW!bzmllHD8HXlG+{BTJ3MDwk-j+DeAs}A;ng{sTIUFUpIMS@-=y!5E)^Cc0w zx6|(-dAWrr<_aBw~!*{7eSA&O#b6}#QQ%f8UwBRi1*ZOBP9imYHtbK`9Hm)jY#TTI%@PJ97$y5$xo>6~`%MSkd`206sGi{!D1(w$R$ycOvb z1NaL=2;_x#*373bBbL6`cvmwMsVvRvo!>KODoT%DeeUL32R8B#%hn{=UQ^?*yXlVZ zRe9Z3iu!xqqt~69MDJ>9^MUT+UK0cN*QyJUcZ2S7Fe~mJGH~}WDO@;p0fJMjeZ1fy z7&gqZtyzHH=dB#Oi%ee$uT3jr0BF~%FPCkF9QuNjGe9F)qEMk=+Z&mrE!=cw-HA_f zR8wsOyu!}7h`I8dXwUh<_3{%P%I6r7U{Iqx$)tz(G-&zW;a*Eml-n&TZ>taWnG|tA zD(Y8=J3xPdIy|2+dPH;rdqUyXVX_5;K8Y8%TW$=u zalNk(+>YLwC&}%ms-u3Wfnnymlh4g9-<0CzF4DSU*YxJgpZkbRAY$*B6QrP{yi4H2 zEW1-yE#FxwcMtc`xOCdXAKznX&p%w9F3`cha?8z~zra1aKKHOe{hj5G&1OtPwWn_y z_ILiy?~MhwMT+IF5<^}s`~{7j>=KKJMQ?o83LJM^y<~4{bv*32Z6BKs z_VU=hwv|rfo%IRjA*%=Wv4FZI1_xRvbt+OFCS0_ub*tCR8i2cP(Il)4mh~p^<|}BU zlqS6A;oMgQ<^AM;u2(2Ssy0$s1qSYn4R6j7JAo(OF2_Cw05oMqz1^w>4TYh4jxH`P zh2%56+{#BGq|TZjBR%j?i{4FYpbpu(sdNWD%1hO3QS=Zce!Up?Qp5iHi2mJ`1T!D+ ziCeOV2xdHZzuVe!g z#(~!hdm*sq_S~Cwy>B#fL82}2AC;4BfiT3n@TEM*JrB0{zW)ZSw;L_JiRwiAG7Uy8H}~? zP9x^7o!YuF&}4`(^(fnn=2KxkGI3g-e^WF?m85H@cfqoX8dVc1>JLYc9$8d?c7v5Z z+=t2!SJ&jcH}A08oMt&-P)5PV7XISBW5i9Pk;%vfeIA|Z1ayygSX*yD2t?qY_AdAd z$y*hpbG=>*m^IZF;UjZy>^6ybk!h6%Dy803`(v z8=i<>b{k<;TF)V z6lMq=TxDJ3*Au3sIyy*I+BfpQ+c7Jg{1$^=M;={bWvD-?!6*}btT1t-;oO&+$Go&f zU!bGu+|2Sox{2b-7paFa1^~?>&~^XMvKOxuSrox->K$& zg15a=AV%o=G*&<<6>O4=C7loWgHuiBGbW#F91%!n1*f8JZp#vbmKBFN>I`j5SpqaA zV)dwqPvFC5%()o&z3!d2;(2^$T;j4P)|t<^CVYto+fKEGp9YJLp5=rK_xjq45PZ0L z@=h}fN`0Yr)93erlo#$EyGIc$u<#t6#~cgG(`DU}{!gnx)s(PAT90b$Z_po2HzKkEKR-JpmiIwi~F|R~^LxZC3fk@VIQKd1<1& zn%bci`;!vty4V>s=!ct$IyAt=Dd3py_H}B-u*c19eHnzyTWVn59xc@E<4W5U8SFRp zcZuBZfgXLTvWpz6S2q{ryv1n??U)Q-GuW7{QV`#R-iwxmT-)if!$GciOab({rWgq& zZbfaj>{`e#4U`rj3{FkUH0bxzp@PJ%Lq_pkgpTva5bIA@f1}L(0%Z8Tv1*2Z9NX

fkPmkpP-$A*HF z;)h3d?)-4wR@gT_o~;Bz-Gqh~00h@gPzNltbG=PU>^2^ZC`5P6E!Rk`c@5BtP^Rq( z`KXrPpSjn)t^cjeBW*$217c@#oIG&9bl>1t&vbA9OtJTG8YYW)sFW{it$Ql<-Yniz zT%^NI&QtNiuA{*U@{j!5DYvguYE7bb6+W;?u%ytW%SVc4Ez@AkV8 z`H67;QSL? z;8{pI8Iuyi`~0;4)#%L7o$pxZEz{poy1N&Mf`{ADyb+!a`KT#@mmv+`dO~9RsSTRr_V;^4<@XOU%&`o{suscei)B@2m)I zgECdO0%jVOSj_cWc-CuJ@qYfGZz-1BM`;CH1{7yYLVBgz5_C{S2NNri{=4i_b=>7& zT2Av%HTSARSdNFm2&zHx$@>~Bl50Mzh=!A#;XFsqTX(|1)M0u}tcXRC{rsOkAEwVO z>FGIKa!B25vr57Kz7{9whW!Zic9lFU^Sl!%dpp4M;YU6Kf|53*6zkU(T?k#p7hwui zhQHR2J*^G6^zq@{1l`mg4@r4Xiyu&lo9H5qM7nJsQY!a0EUx93P=GXrs`&3ar|;(o zKnfMpXj8WzvCfVyZKO3=-fu46cYaEsb6z;SCK|d0FF!Y{`bT8z^ct3x%#7V^XB;K_8bruCo2uc#08#gWgxYbFq z&;lgp-xGbGurr#$;qfP8;X!H{94b8qW>TKFY5Fh6cKDq^`D8O%df3Jf#dUGJ&nzo; zPk-n zb%nCTYheln9OKG8y7@!j8UU2Bh)ht}RHY_Pu3TYhu!iAOQ>~njbOewk1ZvV3C|(*> z>iME6*0|bpC(=!ySttVugK6jmKg<*UmB!5khR1euBaplsGLjO-+}y$ROtuuh>bSw} zZ-7Xc95$SX*iB7%Ilp9fuokNCx2Sr!7hl06>(1=78z^B+3BK#8 z5tRAM2&en1_4RmpBe zG)L z^wh~n{y7DF`dFv=v8&2QYzNfz>Yr}9y{5`Js|1GP&@I{nyx)jgG@EyTLy{9e<7X=t*96E{K6>IO};S z1rne_d`)CcnkWCGxgC!7F8ThrqX(u`*tW4WuMm*OknZOn${th&9x0&6^L=}*>81Oh zU{G7cW99BRXkL8#Ch_Tl_eh%ywD>MkQVnA8abN&*CyLD#HZIZtZ_ZmfKwFkYl-XbC zcDMR_FKBd|Mu;h#NLX4s;w^(@>Qm(lm)~;g8ATF@Z**C>@2lD9R#c2}DqN?y=atFm z=LGsHZ#$_EO*TvG75Ai+8F^n@;;(xvmL?p`cpE0oY%6LU$f^eognay$wD!7Bx9q03 zM!N!nu=#TA=me?N02^4eS*l_YdNkVa30!I~nlx$rr#}vrZz1^@UZ%YA^@*CjG*ce( z*Z}M*f!m3uObE$Y--uqCDW@x_Iv&{wC%IiA)Pa?zp4kh;~W$?r01tZkzu*T}A7M&JvB=EDiIS2sKFKPAf4PBIif z*EBbAF3pgF=TvW_gSY>s`R<-Xjqvzd1WhVFYc@ouIA!9aA$O#!gu|IBkk`tDfv}OW z{5!7lP43)Fp4{&Xx!$p^OHb>v`>c#n@yg4i(!(Bn()x0Ut?Yd1 zNqmqX=~Q51aTar%vHIzWPL4OsRPLu!^>pfi@{6;pe$!j8TU>v3=k+H33d?_Vcq>(er0?}1%)&0NUHXtez zBaU@PcV)@nYGRlC?S1~7qU<)_juqHekA|6Kn$mu&jxN6cA_|muI~@s|ci^Gux&eX& z<5}H%#pM=7r<0e)6P!DCUX{PP-~Pz%Z1;{5ym0Bi9Kg#nQFHT!($M?frTR77*E*v0 zLIWB@pL2`^UB5H`Kni#vNHW5C>XDBjjW2tc}JNBsuk7D=8H_7hpSotC6i1ZKu2|B}G=q>avpi8RF`4dX&H{Wbheo$olugEF@I& zkc)1H*oq6YJQ#>`>l@Dkb}8;D9vidGMeBaknOFdZ=#i>9Kh!09u2x&K1#v|@`Qg4` zW0EOXXmY@3ox}*B7`JnUU7?x=5xa-#j&Jk6EtI`$W!uFmXesBCxy)2|b_qO1-DIoW z2!4~Vr%uyK4o!He+N;zhOr>05eHbEm@K|i?#E2$&GciR56AzouN-f%t`p818MYEFF zINy(-N7{~_5cOAF1bCU0CQUN@RY-kA|G3Vt7ym(`Sv66OW49Da(#8Z0{&L>(kK$alOcy4q!&*R*@B>SHh?4yj6 z7=>OBSsy9l&5Yt6b7BOGkE>to-9#tYohTvyYt?B<^$om9hRXTZ=UI+lJylTap4{t= z>zcnK!zT#IG}s%IQkCS5m=oFq!n{C@!!K?5)9E%F`LJH3O_EF%`gqv6%UH4N+ORC8 zmki-Ox_QoeU;@wGEbzBh{V2(#cOG3F5mEh2>u<_sKz*Rm$*Z4u{3#p2L1me~@xgH2 zmK(4;!jq2=DYWWdZfa=PH~=KYM#E^+rZ%e`WYbH^(S@T$O@gG5mXTb<8;i zAjp3;CTe5$2>=zIRv|AnMSYZ2EvL41X$&L-X-Xh3zOlmh3N_&{k;jplV;jC_w-fr%zrjahV>jQa-kKA(Srp z%R>&>j=teKc^NTq1*!$HhwE70Hl-M2gqJs5DPQ=e*Lg1GcOg%HD%Epw2e5Y?m#rtn z;ca1>QXXCwr!`&hyp4rYBZZfUQq~JGh6Gkqd)xX4@{3yTm}LWrqDSY!hAl2H`T+r( z*R7xT_*3ra3Wcrwbtc>D-{Ix{Q{uZa)K)PDcNXXzz(1^Xtg1FKD!7(Mc1T*$ceU{hQCp zFevWapWgj${hh;Cq?A$xB(ysx3DemrkUHUBo&ikPQSH`E(Frw~?ML>hWd=Bm->J#H zv#cP8F@huZy)p)%`b*Qh!IhcR_*|vzwBs5RAm>E){*u18LVB@Pyy!{;tyG=dP?<*e z(536F%JA*HK1Az2-{4v(277gMLgxihAO%2^jdxf1Q#?jS|BVqEXDUPmHAyV}-F;V< zWZvzO^F+VLjx$NHFI!FCvX$~7`wNFSQ-|aoWY?#ZVgCN%?G^0AnM0yl4qyD^7u_SusEEVD{`IwM8Qbw7-uMj;3JO$LfyZ0GgSsG#cTek2v z=1ZwmN2!zzz2}QDTal;@Hzq&|y{x(Ju>UYx*54Wid3uKKt$SULCG_6l@ac=6txrY^ zpkDt(DderEBiK5ol8vjsyYZ&O+td~B|2FO&@kfn%#Z*~6W;q6ZI5zu;_1DFbnMry9 z+uigWNhSBQdUQj%7!3Y-KV)U<73l^z%NTu?5_oFKrPfb}kCmx$4)!7kBL@C7)yUFz zc_%&K4wL_AUQFr~(tfTwISSl&aBw+S7@l&B%@N|*gR*rQdrqezPMN&;(H@U_U|ooy z2`Z>k-+s=rKOD{w^`WkxU1e=^WP|BW=*5u;zG#_Y&9<;GfsODR#<~F$qa?(GUc##= z$=T~!beFXr2it|fIvFbdyr$7=#T!Pn@tSDsy)b`J8 z-re>`9A?iRNUegETh2>2d4Tc%IMW29@rhP*L#$gOt-(YBz73toT|byo*yuyuG`>3U zm)0F{i);O+NxrEo>;pSvAVht)@trxIuYPyKhZ>~}<4~rV0(?B?l*m`4 zS?fOO-Kna|U!$bP5ZjZSDt-C+iB8zqs&@ZY2|uuK=Hh+*quwx~YK>8Uf%UH8BC6AK zSzIQhUF6gp;+|nEqX85>(^$cS3K4JMK=!O<5stT!Sph5L98FzBrAsElu*GvuatkTd z3F96+ve9>cyJ2_>`(GZ6;0MQZ&^*&ikEYxn&U8l_*rqP6iU*X^)nDCs9g}Nb93`}R zu{m1bW+*c^&&2VB9rdR&+(7N+*TkCKf#dP$;ke`ERpRjd!x)@tn#zjgWGczgPsGO) zY0vGRaJoetl_=h>)~`lU&z-Jw&RRuGv0)wp}OSA@ojrvX7LUK4n9)7s_dhd(XBden~jbVJz0nV`p>4AS~ zX1x$O@gV1^uT3NxAS_Kms-m()Y`ywKGAK7;P%!c7fsLLa-Mi}1#G?vAa;d1`0~@q5 zLTF`gaT}HC9Zl2vbt?eRZyqhKR;CMkwO84pw)I|?2oLu3>z!)-%^E2sk_B?`jfFZ% zwE~X5fTc$t3g51t%aHq=nO-EukU~{Us{*N(x|UIVHd5klY)jg~_>t)^)b}XvRbj=) zdcOoi#7p6WT8HD{!QPyV9Y0$*j@h{);zOuAeN@pJQr%QU@PM(c&O;Y=n7>_>gQ9Qf zA+3q^bO)w-{*Bp}K;af(H^6@>NmnWXgScMef&)sD9P6xj%Z-kv(uG#?M6a8T?M#C& zEoJYIN`RFklC#OE>uQO*ITa5)`l(;-en(a>u#`({;mS(= z!l%yjR=LoNCPzj4RGV458Hq!gRtufOPc3q#hb2-ILT(yS{EP1RJspn^j)~o{pNG5N z3pD#q{3Xn1_93^pIlfZph{NFx@I5DvtRCFMIP}rYL)V&Fv%Zo-W#TuLzk=749e)+h zRsok%LuP_|+d8jrOY7Iw4CT$cnc@|g=@Y!*oIj#t10n}K;ddF^LZm>UY3}7clVi{l z@u$T!c7D?tKxcq7q;b4p$*DZak3C~!nxdEfB150c%7H0jz2l-?Bl=HVfh+c21E4t* z=)#a1On_PKs~c&(tKymWAkGGM^@#A! zJII#t0cT@0yNNT-q;m8(ub30Qrb~S4K%fEaoPS;ZFn48P64dhYz9uQ^3qUsk-@PMF~Ve?XKi{t`rNF2qAw@n&ZAMduUM{?5Nb5q?I zK=YNpq?QdefHEEQXhWg`bpM_P2 zN8d%XWo^sk?2l4?QU1Zt1p`Y(?CxSsv#=^mYx_*}@uncrUN{}zPKABLZ#<}Iiy!RF zq7H;c*qjIpS1y%9LXeF+*v_pqvgqfR2C%tPl6Eh?`*X;b_<^8Ih!%es;17gz&jakw1j&9jd z_7*~yDQ^;=YaO+QKh`dKqTMY=eGz-aP1TAI(YrU6MncgYp^`-Vr@#Fqk8`1CjyMv3 zswwzvryI~F{9TgK-1LSG=O*3vWUL`%*+Dzti`{SVm-jF0-PJ5K(F9PxTqbb4Ixw~! zg+p@KcSpV9cySfZNL({?Pi(fmDVkd7$3Au0&XSU95nEodmd(rWcDNrI=GQ-A*z-t7s%1qb+qel2W#Cur^-^N#-;5)8XO)o?VprAw zn|CC6w#%Ivx=93?t*F_jQS1fupTHBu-|?JgV)IFH1&#(=2usY__VVw}ipP16k@@4U z^!z}0f6sZ$OWBoltJ^To;ff5k#B#*Tdzp*ahn8_5r{3!y+v}81ftOp4*;iH0)vk2J z(JDFgmU*;_0vvp=5CtYbY42)I;%xwE3@e$7s>>Z27MF>AHS_Ri>qAZ^sO*7lhrWvs zs5#E!rXHVo1s1mwqV&cFpZbfLq2FtA)yMx|1*1t9pENzna9wPKlMva$1oxNSw?&DO z#zTvvRKA7db{4-K^kRnWUTs-d&8l-pMy@XaR<@nWqAiOSHL^HDjZY#A0}~1ZetQ0U zi+7Ukcl-Oy@JMN>${J?y7Tv3MSc=yDzI9_Hxv3NEHT?a#?0U+6z3y7n`Q3LmS%giy zGpl0I{}80+U%Ulr$GFGsYF8-FflLp@K$Afw2ZZt=oNZ|GJ^S^oR_J5>qAi^Y_*7}} zurxGmd4%BEN=bRN3k<2|4fO{G&PvqLYS-p*hEand*wqzNl zxAzJa@)4nL-y$uf_V~#f&_%b$5Vw(|_uSABV>B_^+Mk#k6Xf zY5*c#LSbX5bUT1!d!&(dW2;oA3-+99u)-~>dXfwVK$gr;N_BVxode@s$%Tw3dOR&y z&M3DQt3ZqOJlnM4InPE#7YT?N5%?SWQjrL3dM_{MV-r&T{1vDypcSWyp`X4dvmT)zMtw0X5K6WY;)K!$h$-wa?L?LZP^+Gqgm zFI!y{7c<@A7z*l#AHl8-KdlFf;pA36DfdKU#xM4(`@1I}0D&%P(3fE<8r;FpF-g#? zls~PUyKTt7C|aPz(Lt53R4M&;w?@I)fH2=vt-z?_Blpj&!@2*tBm)=VsyzFECJ)Uy zOz+vB$BRrdLs0LJ;r~0MGeuXLfI635-&yFbKo<2goz9mHKw?l;ntPZqRQ{DFQB|~S z!r`N_=iZm3-hJlp-hV_q{r&btMP*V?V}++}7omS+-sGy_-^+mKfRl^81WYQl;C-$=S zW^bjoV2PzSR)2$g)>4j13$K!92I43(7*#bt%)f%mM4h79ySJR5`j3q2n_8l~HiW26 z^fHcxkVT!PZ`_bklhXiMT@%Pqro4@6*yBeHckMN+zpx&mmOmKscGr3MzwBGidI2|g{aFU^3 z_7QmKseeb;&mZr}TO>Jp?&5BIPnM{hdyx2o@btI=lPj#$0IRnlKiwvFkAKq<#$ePK zZad%#pgw=k9fmzp(W04>QHP0XI5%8Da!?1?XBn8}fO*~r=lqk&91JU_U?%Oded`(X zH_U{KB$`z*eH0d;{UbelIuoVX-RVknvQM!(4BC4+G9}13OIDk>Lyv6Q_07Op_C9+1 z=KeYGN!c>7`~PF@yuaE0-~V4#w6&_J)=E)ZX=~4D6;&-&YE&f@jSgE8D^%60t<;S1 zQeDK}#1@-sZDNGjAxI>Viy=M~ zya!6ut#(M_pWeUv7f}-N2qgA~ z`i!qNSsiOj++M#ic4$0rL~s#VYi-@u;@QnHlZ)%yjP-wa%=DRA>@Y_CL=aHWQ2&Wj z7WR)zIS!aRzWgP|_ZObOCv1KNe^ZkrN&cw!+oVE`T7EL2SHTRtOR5d^`4m}ho)Ekw zr26U>CMIq%#$V0zk~usxcb3y1h5!6X*RoE6p7{}M$4p*e@xS&tOw7jq1L(oapC>vE zWbKuQzQ-PM%4IPHA^xDk7@Lt$RQ|=!$P|KgRsUYunS7H*CKDCE&vGEv_A^#h=1M}M+-ED|H|4$le zqu6->BH6(*+*QrG?Z{cRRRrJp(*%r=KNDHoMg4vwweAk%T%Msu^7D=5h$-C?YFo7V zPu@*&B)W|$K6MODr@US&smAN0UpJm1GqLcEsuYNNhFhvu{^u zkiFNEQ?=R);tBxJ^9O&RF7PL)oUDAQdrt3B9GX4FjZsL{~h<+kTRqg13OJ30U!A(hl@Vr zWZashRz1Y|6m@f@=EB}>+=_~MYYj?GBLWWT^ZZcuX-ZFgVdgRq+x;UU{3XCT$#nvo49RFjSGP{dX?p!{ME8B z+pn)r>6K}&yk{?cIGkKEr3!82YKVPUP6zfhTI%&g`|Fq;6e3y7KePenM6b+MD#go= zzPw95p`ZKTZ_xM()zv-trTxT-nxSA7bDTY&)S97+nZS0mqk7)9?UDVyy+L zmOI;5*6^b%u;-p)8~s{`-Dd!u@5(U5e3c^t0G^-gKB+J0|hjeJV_aeAFU+~eB1vR^malJh4t*oC4(C_Urqb|*C zs`6a0y$(_4CVO0j$UMO@big6aQ+lvJ*z1wIh1v4_tW}<{E^-@%?WFz{&$_2;^puvE z7lusd{wm^<-;Fy`O#vi{v|2HJZ%V(>2d?eoJALM``o5xzYoOlCTWbye4l)%!s|_6- z0PKbz>m+F<9P2di%nIPmwUy=91TfgG>`w(Y%j}aTx%EXMMLJDU!mzsiB_{?+6?V63 zy8LOr#L*AG2z(3)XwJNcJ`dfUE+)!tKo1Kp?hc~84MRy;sDRFA0qd7?p{)MZ?B8_8 z)DV4gVRzxM-$)2!IJkc)nHZ6oWA(wY@qT)6tr&FRTuGr$pyugoooPOr%3e)6USGps z>4MI0>dXzEPx+kYQJ{FC;?|#vlM^p0S)g5wos4f60+fX4eHzx=z+mDP^!09uHeQ1s z1`csyIM;5AECW`5HgnyFU0EYhbiAV(j~4I&3E@osFC6^2UTqENsAPTXCUXe>DW@SR zYn^k=beCwKW2H$775QXf245x?AU!3X11ZAy+Ztf@`H6~oX%U$!56NF>uWe)i+x=N6 z;{nk+qcC}Y_ZA@x(YLfkt<5^%fD(-67`U#I{RErWa_&SY6MqXW12aue6WQ<3aHU*9^H44byto(+QGat* z>zd}MKK5~Dee&UJ6%u;UgTS1ZY3whnn*IXU?g!c%qhZM6G$K^Hb z`#on})V6S=#8wY=?NjP#mIGdaO!+gu~g`?p2&RRLaZA(9F+E{uM&t5H zruazPv*h8vfds~zg;}JYakmel!pda7k$i5OHN!G{u`df?8cC~_st?C~jXAyP_G*>X*);CweD6Q{}0%A`C8vtv=7jy1G zYlQElaA(gcb?I?7w+5&m={UXlp1ekk!~gtceJvbJa)m{hlURRzPnvK9e(8Jc#;ivJ zV2kGI_2wH`p$8;#$hQEa)_U$WRjWs4Y$JMI;LaI;V7ko?@_dNgYPQrkrofNJ& z3Joed60mPtg(HbAAzxY=rz9rxoBQKyVQ>y=v@`m1a4Rl4%+<{579(+QQx((IGb;+o z;k9-K8;m{jy9XpTsTLx0gj(y{{uQ(&0$`qJ!qg1DJDB9SFF_bo)T$cmNCo)s_0P(p z{O9R-^J8|^0-c|X7CafMz7^-w!}OWmzaH<0@_t^4uqF7|nNUC@t;-PCBzQ8NMyM+B zA)H(r`7N-x)c))kb5gygUa6$u@~i|0-RMx14F_$CkN7__20_HSewlcmFgkwQp}b^d zIi~!Q)3>`%t89_pv=+WbLZ&fWIPL`#w4N>tywGaso>8KYbX^eZThQjdOMhgE!D1}9 zrVJY!wm$Q33A{sag;sNYkMDwiL4*KyYYRoH@LT*<2X@jvmjTu!PrzuKY%XqQj_=?bRn3mqsF!n zOkDyvLX3|L8VBPJ!be&KH@fjkz4EEoZ4?NwhJ!lZ@9MuJj&IEggunmfRp_0btG87e zx-2c;;L6;`Xvubh0v+|Um%Je1KW4^G4R{y|6+X{MdAKOtY^jyUpy3)q< zR%#T0yBV@ehsKs=FIqps;Y=i8NHd4P+OkyZ>xI`YATzOhtMAj^i>qMtdd6+U&7*il z9xPtMl$@4Qp{JR5DvVDFMlUtrR>?h#Cf})MFa>Z2R}^=@nx94dsogF5P5xt^(L!+S zltyOHu(aph<{HG9y~d2Lm398tcFFK@_2s^0ep-7#y3G^K(ikf8^uYSR(Tn~pany!b zFnf)%PBvTEB)ZbG-8pt4D^L@R0*1>q=#W(~D?MKG4OT7u(`{W5B zit+p!$t+zPaKen2H>R_MJ>)0R<-o=7UDon6fL-oa^SCS9ZVUS1tV%-)r6UL8Lo~T% zuDji0#~WL>w`3Y)8a^OknL*)U0>pcZy}^l624M(b>e^9KBj6M5_Tg)^rAARVC%^P;zaipJY0|{f%whzKRK5Q#@v+#)ZslH(lJ2x#IaJ0u<;w z=1bd=Ur{L08}_XJ@TN2_aBH)p-MlQYIJp>`W|8Npf)A(`0w^*B9$uS?NSCCXzMtVE zl~0D418up7qyycqtXE#9Sy1vX?JO&9^}Gt|Kr6bXf6*^J^u&sM}&?q51eq^t^OdZjuq94M1C5h`b?jnNVtlK!QKaj~Kr2$Z!_1l$_MXSRVM z|B@clG8cg}X+=od$L>Pg+pSP(_C87*I)ahDKXuj(0UzXVp_jdO$Gt?+B}VQI2xHqNT!`=+c((Mr`R;qb4$jlJqgOA`YMV2!%y}bTXw_Su@yutRM{}WXf^O#$)aA0BVUexuJtTdC96xlvF=bA3 z3EiAW$_b>WDuu|*NbGpL-$%Hakfuq@@_+jX%GWncxBHb;H*rlahqXRPm6YPI3%`!%QCu(2C>}K+rUKRfGE?aD*weF1dMRkk5w%of+y4w! zfTc`qJ&)c1+nVYqn(zGK(O4wz^Q(oF_(93Dg zrF8=HxL(7;^>ntpme{b^*ONcOWfT=`tXM(*D^iuZ!Tz7{Zy?d?ccJfoJvfTLIb)F? zIj6a3*f<=!?nADWHbkd1OCC_Ly=gD+=L*RwMu2Dh|LHSaAJ#k&P3vEU;C1HHMf#7{ z8>cpAy=@W6uKzK3E3=YY2>u#tvn8RbMtRJIO4Df3h>3E8k??vAWIN|mwzxG$$x*$1 z9{N}ey=phDy4s2ePbPM_d$#}Lz2!082YJ@6j^?F#`a1_{TY&s4rZTJ= zX~d_wOrwh$?4-8yW#h=}o~&dfzySMiai;^Ss@AN$%l+neC2$1vUl(j>&)8|PFC+0I z(h{|0g1hT$dSchmzm--24{g33?k~njN*&l|qc!RLVQOk6lT&MhxKCn)`uGv+JxLZ}-0Dk+W72v35eYrrrC`xIkP}6w3|2w7BG3h%A;0QlIxEsDq zz1?QJxZb#Qcq&60ZZ-Fmy80?9?341QXnXxP$uV=DTdZrK@@qw)dGB~Q3a-r&92xX$ zjBUfyo6L<;FS)aZn5yXuJJ&oRe)Y&~@*_Omm^FvVNLcW^TZXrg-=ikZE61;9Lp6xQ zschpRz(Y6KMstwRZl-qTH(cxl)o9Gw*Hj0x{O3`yg`WR`*dELI=7dE3e17}pjyAi4 zX)tv>|1xFq`9o~u)7peHNsw~ZR^G$?Hkan9vU6eHiM%J&uoJb-;Ho?Oh+;2LPUv*R z;jB)9(4L(a{qqadE;h-RFdrZ{V&a?RpaC9TFixY-`ty-E9}bIf1!Ei(!$rW;YLbm- z-NL-HTf`C-FMv@i@d0xEOAJc~5%DmTswg}(|5vem{ zgr%$^XIiScX%8~$iJT|EsijjD?FBBZdX$wfqpZfJ<|j(Uv*%VrlKdw~xEzaprD}Gz z(6KO2dA$6NZ0sSrvj>gxbjvfvR^6ok=R4~?fr5$j^}|G_clj|~4S)FpE3QpC>wKT$ z8iUz4f02x z4U!SF!RBX?iS}>rg3A8AuQAt(q}WGoN2$8O>jZGmmNAKuFR3spl^B>ereMJqmezL$ zmfOnfvygu+OJO3P(&xuN*oaQ`s~JSPozwI|_7%_#v~$g!Y`{}#yPjUTcSn>c0Spb9 z3s?uRdKd_<;8HXG-kQLiKRQCm&F?FiC~|0Yvd`6qfWgZ&mYm%S^!S3xx3NKo4!DlK znh}l~?bn}!pLZT4@+>uX3vWZk-YSfM_ubTZeeSR2T^fY8TVvm@Bw<5jrc%GB)#y>4L^Z-~T=&2D~iYUb; z+E+>e`Ox8y=VPX=T?+i1NK*BEbg1Zt>CxsBF7&gz_7}sLCo#84%r&lW1~-*9f!&_U zvu{0C8Y|HdCmQI47A%(GD^zmvv}_d2Fp7?x&qcqq^NQx%Lhg%W-tVLn~_ zMhKx9Za(>^@d{!F=QMQ(nSxebvR3Jc^UKFzM0k(PDQSDUqH(>Un#(UleD@DGYA@lN zrQ1gb9;bOLW(YOUgwt!Uao#7tg8;PV0X8Lv&EgwK}|l)`vFzQ`t+f0Yd2&V zU|soLb`jUfTS3FP<1OO$fhcc{To72M&JkJWMO&6NhL^3ejp_ORjGj((ADq3QaBKTq zBVLPA2G16?Szca1{Cm!&-#oQRawE!QuSazl3}+ zL#cYV%aP6PlGqVo_|g-%c$8=H;u~(JBTFMwDc7EhQbn_-+yx)bo;&_GLNhu&tJII* z#%QD*RaSk}>)Laqn~%NF`b^HjYU}SgyPt<$wG|C1Z|pLcC=95%LrNOW{Rm6a)?Nwj z&GSQujaCb}WWF=Pa*Wu*?oyna6(dLgt*Sfq-7LP`1w?h3%l$VM%r=iFJxw)_!YOc112Q=_8aW!EObgM418`EhXq#Ze^=&BvJ8}-=CkJkBVlDWl&U65^5@TIWwLf8q>maf(SzwQS5ChM|u ztel&r=#csdZ+;G>YQhvWTeW&WXiL~MptIPE2DktCDDuU((z9c4$SMX-+nw|)5bal`bp3+9$6Sj`Y?n2XpiW@f#PI?bK3tSaWyoy>{Qd(HXI`t(r4 zCIscxrCmB&Wsb8cdiz@8JOs~N1$Hs>-Wly(sJb6KJa1i;`+E_a<)Q@E8ol-H$o3Cp z!YxHK=b!uaT4Fo#>zv{n@w(L#MeB#D#h%(3gyaSsR!62=)3wefBTy1KQ0Iil^izM zvBC9`pN4PaWOIS@_p~8zwWfCbB9B6CR9SaHYp<9PZ4|_f8txlZHWyqZExXS?{1-Qf zwVd;s(jQk3_P5EQUtj|>IVB=VcPVLa#mB>%nF;YxpT7)>MN@^F5N|U-Qgzg}t8V7Q zdoNI26_iD{!A`BLVP`W`9j|U>K6huOQf$27kq)AQ=cn(TzfSXrbhH5)G|{)_II*7s ze@Nz?DJ!nrdl~)VwTEXo_^i+qN6w=*ynD#ynNMVb)6zUH9Sb z4VcBc8t!jbt1cel{*a9QgKmu=s^7}rroYnWUTPEG_C-bI+vtt-@85xX-tDt|z_R!C z@)@c~P-|2hx7^Ft?()B-hqyjph(4S*5<%Vdrn%FdAJuXB=oV7qxre>-vmIJvDID)6 zV^xl((iOu)Oh>08!|WV3UMz+$9lM|*X@#)8y09hs$+YGn`~|CDM_|UE+e>N1_Dz_)bJMCc-Ssaz(*bN7tdG4jssY-8 zg4jP%zN=Pa5|u)eb2{T93=CHH)1-Qw^nP=ddE1fpu%{7n?hf}(`;>2=!x1sBG9!O5 zcz*jOOSEu-@uF!HK(ARaPklUHi;33E>jkuL2rSn=%F^gc+oHFVyy^x%Pp)P`TgPBO z48><5oYRVUXIZ6Jm-cEd`>-XJab4X%hpmEk_4*~2iSXnE@=P1Q7#O(PYdSGoY7_-ywo~u=~7&K=yL*5wh!>Ro|gLQ%a zGa@Zns`|11vw59!|5(`xi7PWoTcFRfkc#9cXmwjuQwu7K6iP%{N39DxuemOPr)h-p6bkTXi%MG2$JjLl!XX)m#MvET(6Wzus4?J4t4}$0Ox8O(LUa7!tJ&*7e z+$qs6!{L&|UCF00BV+X5 z8+og(!AUjAmYZ|0+$3txveJzo6U0d^}?PPwm z+W09o*MU=$lr@$&vYodGeStZIY0)x7w+jDnJ~Xs}heOVaR%YP-vlfBQ-Isf-`Jc`~N8ly6565%`fJoy~ph4R<{@ZQ{;s%*4;QkI1o{{y771xV=F~CLGEc zp?Evw(PYNpv6g8f!seIdm4*oyjO1$K;}rAcP+U@A@y>+ceDO=fTXFiW;06(*+6+;4 z*D2H782cd+($oJ^lPL3#uYsbCfnz*g&yC?8LkEES7!S#)+z=;a9%6cQn{lr2-WZXo zAXI$i8r2H<)Oka%v^Mw#ruA9vZOo(NUow3-<2i~GxeEmah9Bu(N1*`1!v&fdKU&R z?RE^7TAyphGqV*hs-8VyZ8#L*g0joOnHE~a;EtK_v;MsI1U?;&?~n|d2pwu> ztq{Q8NbN`&FYsgDjMV{ z+?$h>Eg)8MFEEGJ`^4S*NKvY}ROqF5?P%sS%S4>7Y9zW)uO84-3w`0PzK;`ai0;$- zR~i`RK>zP#_c<@iY+0^dQZZ62!PmFB@ujZ%jIf#Cr>J;*g}t#XJ>J{1TYK%(dW-;B zIe0(Za6x~HuHA!;S1;1Y@TOcsMn|Lu<$s3}V^&FGP?@G2Oh& z=T^^5UB$s^&Pk6bcx&)gR<4&4BMkVM>C7W~1Cj)b^VPQL&cvt*Z0dTr(k`uCk*AOK z*Fdmx5{PiG?}95<4>x2>)gQC`J}I>wp%RoV&Sc#F=#UPebSVzpOjqhTGPquFpn%a_ z=Yelsdej+6`*9jKmCkK9{(0rVi1@9=bUbcS9O&-{z&|_>`6ksr@OJF)!|oZZHcESV zVauZNm-cLBb2jr!nExj`DSm@|Mr1L_@tHy&V7LuKAA%KR@yllHo^j*~2lY$RW(_AP zD=fd8?hyl&5v#$6%0ch25qm|8_sDz<+es0)=7F&W4P=)~qbrVxa_zA+B6h)SG{9#W z#fiDEb44JXCNg|XeQP2m9b5>8(A+mlkAri`@>CqImy+d>*ctHnDNt_b%*NZq@!)yi z_m6q7qEs2cg!X%rb{owY@R2jjV=acLT0c$h*Z&6U#C4?ih>w(GuJRcJ2#z`{*Q(`h z9*bp;8^ujPo?O5=)V*O@kvpG7yajLuKeP~T`4ETp6CV;a@D5VCX`mySk@fI^(?+R4 zBR{y*QBUT@1E_QM$UZEm zZBAjpd2e<^h9MOSc*0J?ejG|5TCUAf>PD^%HjaA7+3@NLK@FjP|Egc=P9$^&r#O6# z&{*5i?Zonr6vM^ZSb~W^5^URjx-LPm#^jx__m}|4>?9xLX6w|Qzqk->A^ciP$w^Z7 z0(K2U`O%iadC5FA2iViJ1}8u=o1cIPniqCmb}iMect3(J-4U_?f(Aw|jJ=ugPq(?F zKYtH&Ak`xq5Q5bIuTR9xF{J8n@b)MVVRZUz(9e!hzwo7>5z*{3;CC^VxevP zR9LAL5wqPRCHYriSJLg1ga@lVk#k#7tlHZ&g-giwv&cAt$R|{@w`3#3G;Ep&;RMolA>e)Nli-#u!WF z>Xb2Fd&(DMglrlXJDW`Y08hkMy7!l4x)YqZ^T=`3nSURK8Cl$qmQ&3&gJo%1Pq+E$ zb0`6U2~#t$zZ@kIW&A+I99r@-FD|O>Uj{_(zU?;)poQn&=CivB5E4Ze`C74O2KzHQ zhI{xKyKy1RYbS7@{W+QA_(~bG{%HCNca_;UKKS#u{735EG+#6~{Z5SiF54)myw@WL|zU(DDvpMiIw+Qkpp}ww) z>wPa8wODo^rM?z&Z&?~pBZ0_;`S<>^+Uu_2Lg8tV&RcIZ!A^ zjZZz|2r*NUyi^4|@OXo7i@BaFy7jDxOqly3b9bq;k~o`Bimk)+ z{>WM6SUx7;{P+oT03tog-$QLMcBDgT4A)j6mW0vk@A2N?LX$Vn~loxD}$h`-_B55 z>r4Cb=KpH==h#cvpZ|xN84SI!mg&E}&RDY{VwwW(q-BJ9AGvZr-}|6rle+Bb+Ar-a zmh?(~u`87jnGO3}sAq34Ofey=H~9)vYvaE89MK(er>sIuc$^Z<4=;Eck$B%2nX&F! zOy2vO+1%PJj>qn;T{2E@&T8e|^r8&iZr{yd*uWRqDS|Hw-`@wCv(h<;75N4Fl$4ue zBjw-Vwxg4(GR)LF&BizS`vs1@&z~5%&%_XL?lPi;oQJ3hiX~N;peU``N6=@8Ka(N3 zp(jrZH3&{~hdk0xQ5$<-&q61L)2@4(#u>m`h1MuDzARx2@bR=Ux}XaGzCn)jf7ntF zt@bigC&WeCniH~nJ7#LoSy%=HK6)LO=60BT`c~4ITVQY|Gh!O;%(A_1P#zpB%a}b- zIn!ZErru7#+HWUc3nxX!fiCUPeM?~Jsrc5K!S(2pGtJ)d8GPu|VsFjq1BZ8j>3`&B zA}D9gO`elnOGc6(y){@4o8CNrSoz`-t>6?p7p=Hdfx}?ZUrxt2Z>=*mz1uxQlXD(O zE1Ji#HyU{QNuusN0pxumUQZJJ%S8xWDvlJj*`YsFWJS^ut2_FnNE7j}wqE!TpJSHl zL#9Ks%*R&>$-jdyZW;8-aCGC)VFPJaMNZl^!8{R6JwEGYS2in*4<(p9L(+$hhuoX5 z!=#n|xhfVc?>ykC@*Kt%f%~#9vdr3RUuBRvnWgN>Zx@-mMP6OgMKi27v?CqNNz*Uj z08r=t3rDre3;5rB<WdD zkuIGm5qv%~4V#?`#&tZ23x=*$?2wzhLOr5sKdYXF+tl3?4FGL2^{^|!G6~)TqeY<{ zJ&)e3J|RjA;krTTaHr-SSK5G$jSs3=*!>`FtmtwMcTLYi!H*t zPmfQ@>cCOL%g|kDtoE_tyotvu!Q%f5pPM%O(k?{9pN2vmxuk`muVIsLU9E7EV)GBR zPrAzG66G}&H$^GzIt6Ffe2>79Eq3#zcX}QZ7td*%Y^;5KNo~J_xS6)vr^{t2Y)v#t z_uLL<|1B_G`U90Vq&xaFUn2>+*v|P-{Zj}W))f-fx1cPhpAn13ZsF_s; zjQC~7q4ODEQqUOQkx@Pz7fCJd3-vs=eP%`hrEWA8H;d@Nk>Pkq0PL;gR*zYIJMM$7 zSK%o*6DjAiTdAjF_DVf1oKkc)@ZX~v(mq@>~)jsyNR3x%2GfST&ldz3Tf?n2A~7p!j#_B+o?@>4%^K4(%- zEDl^`wZkCph(?^=nICg1u|B`B4(uKI$@bzKE{CG=P2WW>XFv~p{|6Rru zjXdORcO zeO=C69wapdcfT6>{&VtXJe5b(J7Z+?{{1nWdtYV12Hc5o)*tnofn!dZm-<3qE1MV7 zFkkqKbZ00_j_JtPbJo(Oh=GYKM_;m@IZ9{Nrz0lp0xg9@X%4w1M#F4j&!bNNz1x3> z(G^gsUye>i31M4>@I9cgbB!WeY9HnaDPKLS0!$swfR(`48TTuI4xA%s{V;89V+M9V z?21P~_9=fNZ!$VpTji(A^@;r5#oLcQcJ^#`_>jE-|Gx0?1SxfD+WPPFlEuwO zkZ+at>Niy}$Hgs2spMoaaG~*jo>?5Y5b!S_uXkTl)ci^z0daA1bmhUnA^n3pIa{ z_o3z3S_<1O^VOe<=}7yvxIpSWRBCNmX2JhHUTNbn={RZOQP|8hdPC<`ZB3DHujxK* zDZ+P_iTfn*GQP*EkZ9-EVYRU6rv|zKXj|hM=n~lw&Il?LY-m!$XH+A~|3{hs zH3YE|pi^Q?I6&K3njbIT^HyHo&7CyclvC{5VLuGCX3sKK=Cdof@oCNZ6kjp9-{)hW zd80iQYo7{AOrMfn=fLY!dOu4xw;EHpM_Yi;M3+6GOW}E|Y!|>)o*T)&$;ueBa~MUc z<2kR=JfsSmX1=-;D2s98H&g37fdE1u#vJcBOx*vAUF>TU4Zds!P29dlmz+Fo3Xt*q zVl0KX^dgpwJ`tsKbCG)#e|!i!4jy{j7_TU`fzt)U93M{c<4V%S~B!1vzD-}3W-M>Fo*vJ_jcOb2(a1w z%b}gb)!?BnU7LF_+_iL~T}sla^-fsYXtJsHIc!hXH>S3n&KkiJk;>o33x=9ejRKka z=)C3>qTvI0-IEbf#+^2GYDK56V8#e5XxZF_xSmVC2VJk8BAglW1IZ5bB!n>3o`5)C zjdxkn_<{>|yEz+}4fEM2>F77N@IfX!t__O(yKR!VE1O=?asCyVq5aKEz8H6lwlV=! zeGgeR8u)yyC4vs_RB{*GlRhu)`BL=2lDe>H5hhdSllvg^{Sn#hc+%4XS#twVxM;_m z8V0F~w%f6OX0R&k}Dc=QiFO^pXXtH2=p zsP6$7uzK1V`9BR8G~LfPfBYz(1PFe4k2W%A^E1}3F+i3qD#yxJoOj%CT=Ao53gF^wSoOh)$j(biE1aC!d@Pq^MXSji%EOtYp(GGsl`l+<*&YqXfuxVe+k?}vXTNC zk&>s1^WHZ`NZ!%e8pJ;L>=0Jiwhd}xm@_By3=%PO6`&B%tiH6GhH@St1kR*|<}C26 zIVCAr7T}I^pC;3txK1HEyMbfr z_Z);{{rAnq2&Uxei5l8&C04|R-!6ZA<-dJ1HbpqADL#LBQ=^T`|9W36!& zb)!zmu{0S7_vI@c9#Kfpey~b_BpDs(>AYW$q>Flj7snYrly*b`1iBwER_(TPV=nC9 zPord|!#&;_b-~X%vGeWUR513{PFMda8H4V4%zZs2mS~(3A2}N%u`~H)u^_`-iOYB3 zmihZ%OFYN)zC{3+`8NXus9Z?!-rA!>*HOx5(Tn*qc0y#suPu|*&n=fp(SJWbNp8K} z25ns3XGpFiUn46Y-pH3nywtqB*72rkl&9uO*gKFG7o~Z=|J-Vn_Tx}Cs)+r6g|J)O z7Jv14k1Yc9igeywA;1IuF5-Fc8@=fLkSg^*Z4jwO%fKvu4B&vHjU&`ubHP}4ZSQyT zM5*D~Q?3t_3HYemH%+--ncA{FmB#ShedNXLkP}ZksjDf=NHO!03ZGC2O1tBi;+CrAN?~aikLC1W z*qxDURT68g#k6Rl_UFZ7+TTzzShn^wifg0E`N#Z;OA8d=cCe+vODx1gEAg}&~yFy zzpbIe;D_@n%qoC}vt&>MTl4u~({ZBX=^bW~qr61l;;pG=RI#kvv;CY~5MK;LJ{N}C zo2q6$oNz)OdZ4O@GWvkVl;32(Foj!9w@=sRICACm7uRJAus-4 zbwK1m!NPXXzH_yCo|{85a*UrmH!M!iao5JMKs-msbavLX1>3MESzCf#P?5d6O_!W;bvv_MG-cDe1#$3~+Xvamjcqog1%^4mdn-Le1OCw*su4 zgF3Kv0R|o9QUFtJG{Mx-$aP+kfPe=^!Sa}DD;ViRaCOv?>!B$vrrMhW+j(wSJhytq zI(VnO^!~!|Sit*K*;z=w1!DzntVktY+$}XPd{nP4YRAb8TD!Zb6eZ$r-i{n1hXTxY z!F}QA0^o8czsk%Jtx7hEc&&ah+!wo3$a{Kw=gr**awqD4i(ua_hr20Q&ZEZPmISTgY+*Xg(tMypYwmPBd=H0Lyb;uZNK{w9X zZPc$GdWwsPQ7TR+dd!!XXu=E{A?3148VQ@+Zt&VVhUMKic zvd*-$o4@JCYx^l~d}dq|cjybwjoe&ct;xpuQ0BZrU!i#(pRAJ<7;672DO&DbjXv_C z`$n^{5wS7wJ1bGWp-1+!fd|2!ZwKuuyWaXiD)UsVQsi|gg43QuYf*Qj<(D{nn2G;C zC*`B(o}b?<2@O#nAe)bZx0hApndtaatb0uJdM*Ro6b6DO}Q$u21>R?*CHTiDv6L*8e;4(5#bO zS9NG1+7Q22damhHJaxJnV^Pt($Ft^~f2ZKe0X<=|BUE)7$*1B;KTF+H-AifZSfam# zz@@_Jh32->zL_H41vs67bH_8|Ib%x2Hj>j~e^ORF?hjoDwy$lASRfm2@4c;h_F69) zcxWxVj|0XWO|Uul__#6vQKZ2U&BI(e{op=aR)q3x`~&{r3pn?`z?F9W$coz1e&t%2Hb4OI_~a8^}<%9rYTR-ucxuS9CW`MMwmgiCKu& z8G1KYD6>C04Pz#VI9!I7uy3biW|bYaxBX0ZP5VIeZAybFZnNj1K^xPTMwQ-5lO#jl zu7rpYXCi#1S}Y`HJ>Pb_As^4cc<%yFkbygV!^?a6CVeW0% zJj)XtKBZ{E9keTZm7OM#KTdsL8n1yE6cGSfqo#8*=Z-TR1+)Teob_*<{QVxvh5uBu z8B1PTwQIkbG|~3k@a;)J;E9@`(y|$b-Zn0}ecOM@k@0YJSMXKg8d+uFZYGrK?8<=q zdha@VCBBbph3hOo3i!HL=8$W9?P$HcPxHOl_Ju{>ca8z`LRVC{OYe?65ILRG@ljkc z@S^-{fT4EDPRN+y-wSak(Mg?$JCK>Ie60P@ubKOERFfN{)_>(WQ0V`j8THS^tA6$U zx)sV;gzy7Qz3grIai}#=soGB|oxS;+C1^)SVjnUZ#BfvaTk}Pi3`O!(NC=Six!Yn+ z&DE7<6?-cqj&if~MQvczZ@B{CWr-!DWlX)U|7`gvn$eGbTA3r}~ww*6(Ya1dp_b z>iE-HCrfwm09&>ypGiY3%e{aC@YGW(U;E>Jcv=gBS9i3m|2x{BCW#rIZoPJr;woVQ zo6I_m&FOM~0(*U%WWi^r!o}ykPxOs97-kw4L`LW|?Wmwq$_ozdqqY77t-Vk=RoaR4~*!0_azM#Mvs>OUWlsvW#03bZrWM?4RRa~TQ zAa4XY@B8aqpcFIl-SlK+15VL}uf?$0U||_|c|t@v7(0~4~1QuQNU{qU8Z>Xj9EfLacgN5+Q{R*7? zX#YY0>Dq{qorFhf0ncYIG-kSTvVrc?D@-hw+#MFEk$Rzuv0=2UNP6#Cf$kVRL+@F{ zPH#9QD=LN>7}du|FYCN)V8Ja4PTM=~3;iMcXEiY=EnJ&}op*aCUIznrB-%gXId)DG zkVq77c8>|(-f>=A7Y`+Pp!iY%^*J9-Md$0T^$3mRPjT-mwf2VU*WozVigoCzc+e}l zUD8&PMGG_bBC2`h|FL#v@ld{T8_!1$gg^2w*8#H?7%Mx6pk?B0hR-sz`WUbd&8`;3mMQOTd5f z&055&no=F0yTtEtQ|RGDq=_{4%|(Rc&g}(|kkXY^@f#4YbbK_>;wn&<7h*tMZ~q~* zXo7sH|0wEYWno1eui`--QvL%LU9A15Sj*Nta6YxgRewhMme&~~D{P8Jzdg)ur5KI$PDTINj6XEvU+F5~zQ{n? zympPQU0aq!DEAeOKW@FHX2Ebv9!jh`j{nOecVe{f=0)%Fem_h~#z54g0sHUznscDN z9Ye#2EO{CDFM57O{wN5hyk}B{@#11{>KQ3DTPD;vaq*M3D=gM`%0*VW(J@>)VOn08 zC=+nSKx9));89XO>H4~WWpRF;d-S)Y)V1LQ)|rE+S6r$IJd%xaZ_&V8>P@CZ8{}dO zP2KAf$bPW;MtY1#r=1m}t`?uu7YzuZ%jr&O&R;y9{9z%k@!DKwrsE|5&+3&}qkgrP z-(aZ;_5eY)FXIYqdEaTWVlOX?c#xJA>DR|{`gq|b-6gWI&m<$eu5e?Q-|uVBAucwgk}*DqR=Y+Nz0&P*{iIOEQbUq=)!VB}v4-{&0!i?J zI>q(Xk7+6#-kFKt7+%zE^)Uk6R?XY8I#;VMJ_7-&8) zWIvPtw&mC9Q>Vk3J&;LE;8`InNhMjAYG#roYl(wdp)L6?qbgLEcdQRFZ4Pug;wT7< z*op1{IkC5>DC}tBV?29=F2cH2u6BW==BS@uS_v^=bN4rEwW4&2KTrLJ7XyKgN*|ZM zmL)>NX#sw!`z(Yl;)lv2(9g$WoqBIbdJ%^8)^6#k9}nw8xY5?-BiwS(xqf3~MvPt% zoRk)ZYWW+ftYjOx^TSq@w5PKrjmAFZjW!QHRPHwpddr5ctlT~D(o=r@>TWd>$wlg) zbtK%~^m7s0_^NO;rj}H;HoS>&3=gtQ#XK2e8Kn&USmD@JS&E>{sf0emZ~?_G^B-a1^fQ?%h3;$S1F1) zoGrrldUc5xGsLhiH+xwIeV;#-k8im^id*E1$P~dsujQjgJpTILYMIvGn7Ox^dJEtg z9j?F@45Erlfi#IlCZs;XoW>nE#*ud62z|t1Y0g$0qw#1#4vrSlJbw`-t2prdgG@#S zqnWeKejv2IW?$&mhrC*52uszx)H5{^VZ6F>r)e$ zah9D#kxW;GUtECM$17rd^A#aJv5|DCnUIn{aisc$-$u58bIrwSks}HUJ0V07n_%_> z=I}v-UhU3Zp~v>BjY>&Q*@v5r4!VAY1QSvzU2a$$cNAh@yXvg#JU56 z2acXc{Gzn0&C4yl>l41hfW^_1gy0zXe(h1+T2z8T*7CZ)m-hy>kn(St`I8{Fg#ePp+$~R zEdpkpUx02|Dy_xW0M1`fd99aM`9Jg97zqj}sh?+5H4?s_tFpFR=KS3Zs$={mIm3eI!>nBM3b zi}0CSQfKo&*EvQipoQ%9YWK5rXE2u*hf~ya@bYMhgG#t8>iw)%`Xl?PUy^ei$9F_6 z_H=@-tts1;T;DGbk5uV1KuRe|SRETu6iXFCHA)x8V(}6)E^>R8Q6GCk((T+rY0wcl zw@PrXMz!*4j7Gx3st?aTKF&g~Ea)*5m5?3T(GiMEVb(RVSrc2`Nbf%5H{8o)AK2$R z;}cz?dN}Pp^IJY%cYa7+2BM`TaP(>}{e2RAq`Qt>5X}9)1JDCR7*kyLXob>ip4tlO z06ZwJ>aSRS0>vzKZOt(vaVG|U)@i!nZoo`ll7W{O8duuHsdeiH9gn=Tk}G1f4RsDcCF;`4tkR8j1wroVZXt{{Ss|hc)oW4~Dm%MT8GwtKn{Z(1p?%(;@c_T1vuF#`tKyuZ;Ko zHG`r3?wjw|f-l`pJ!n~%cKJ&0#4}N3ng%!O83`(y#lhocqli(9Y!>SM=MfdJLan|* ztzDl)PoO*%yG;Jw;KyaDYFH(ejYXgdYKzTZJVwU)B<+>OJeycca9!xp)cwZM%Lk9c zgPHauhj+jcu&>joBN6Q5-Qk;`$#UlPn19C3n2JDk4~$@>)sP8!rLj#6Lyr9D8NpLF zHaveeK(Q{z=EhuFP#cs_{YNUDAeIoNo(SIk;jq)DYN7C97TlCC2{!WkX?G#}r z9Y$Bp92<77qP(KZP92r;isheWdW$F)0lwe41lRd)X-UA6f6<05PSj@#>?1?_uPedi z_4NoG=rP(;V2oLk)9m4n=Q95YlK;cxxphkiIq>sK>0C2XO0weX6}1q3Wx|6b@W7hd z`fF5X3`WitYd{KM=eCZ|l`<6e`_Sihj$z)M|KHL&^I zv&KQsHY&1#HCDa`)CSjxdrN;y?rP4+Np%`r8rRCZ*0;ZUJ;JHO-smB}a&kcarLNU@ zLmlJ26R0+J+r#17w%7X=-Tq3g-r+LoLowVV;N6Hg_m}WV_DBxp3}5{v)n~*m{^b`) z!^{k7zPBOJR4*~izra-GfNxu7@GRf@O3FXE()xNOLY@I`;h7MoK{HM;alsM8MHIC${cDCz^tGtqTxCd*GeZFqle00sYD_7co|b^wh<1*XM6{qNL8FuNlVXY!5Xf=O2CEju8&w>_~La#|JldHH_NCm`OJXlHVRJWzKZONjW<{{ zA%*6qFEaG~`LIs4SsU=bq5r|&mh7_!NT9?VNq6U(F!J`!dJbTH{}s3mk)^jV2aN+J^^~ zZYK|g`rM^3RIU6@ueMa~AtF~sabvxOpVZA%Q>#FP`6uCrF}5iTm5iA2q%^76Q%SF6 zo|JWRcQ(qq&YU-HCJW-!WuUALo}*Xy8Hol&1>Y)@5uCO7OG9;8AMTl7bJtkcb4b-W z8(+fP=zsX)?y39%?Fsx!UFO^b;R#N}w*D-ye0*?Sz4khj%Iy5zQr#l0vCsRJkuF0l z8_RxeRFE&5Jxvj+-b85tc{`9N?5Yf9&w@kmOt)pW5Pi)zA>cw;-WngjwP}Yv&II?C zM*s>>{q9;)(|Cy1Bl}l=VsY>VZ$>7EfWg|%YeAb8oV+NkxyyI(r;EJUiZ(58 z7f)BiYD`jUZ#iRsQ)Ft(rS-LJqK%mB7cv9a{l1`f z!~luiBzO$R^-Q)>^mD+Oc-&cHKIP`pmv?fl$-VU7z>8Og3WEPUF9im>)yD6)qI)~4 zcYShz#V%DoqbMiQCCmc(3cjj>%HK;@$Qbz^ahxW!tS<1ZDEDr!mbr1(Wjz-?%nGn9 z+shqSCPDvfh#Ebg#H;ltF83ZnJCn)`(Hhp4kw;8CEG{~KbT`ZWSu;=9^fbGqGH1-f zit%yef2mc7)8FUTjVB6$`iLGUIneU1@4nT|-PNg47@D;ha}8hVtd(B?6;<5s(2c!< zT}!!-fy936{=7%@)37>Jfe@Yy$ib6*g19#4o{E{D=$dQNK3ITHb?vo44^y&6T-M&L z03W6@a-^f0c^UeFRqb!tR+p)HI;2PCp2I$|~Y%Oyk|Ve@s(6Rh`9Wv=$f9wHock>e&3eVz?(a&J>Q z1Kf8X@zgq?h&4gC=yGe8ZOL!1jO{3OpO1%b^SIB8;mRIY>@#?xO$7fi*z|MU*oc!3{GDb&2 zCs2O9KGqG#R4=K*heR01Z=ENz?fo$-KNQ>q%)%+wUt4CBm)E!35yJyloEf8#JPy*i ztdxAO`VrdY^Sa)=n-KigtxPb~eMyvhq9E3m)jQDRQpecj6=7B>e7s8a=X|+@4ate6 zsYqr&>i}_zWw+0nWU^7{UVXv*OJpd7+$P>HT>56jqd4NSO{7lHXSH8S*!mWX+@#Yp zT~^YRHn|;|#=YIA3-I~kHx~G9N_ioFo$U_pX}{2FZCE!FA+c`$M>Xa6bu}$u8K*88 znPtBAex~TN?%|Cj4$RJAH@$ypJjN7u6xpKnJ zX&wAo3({uhsBHR4v~;)Vj(w^}qr*Ytni;LKq)po}U=}K*zKn7Io8(f~^6vs}R)4{| zTByh!DzIDAGVi#B^N$Udme7R{^XA9hUAnrm7JTA9lXfo<1=wMHl$WL2D0wVkvtudn zm2Q`Pu^j`{8hnj1ebh#_?ZuiB9#>sYkrZ>Ie8XQ1yzR^GP0Tq$Grf-GT?xv!&dK;t zF1?}pc_Zt$Sv+l+&A;sIR!oGTF);6RD0ScC6v(4}m$adpcA`{iXLFN&Y1~y7HJ1%s z9d1-LcpnIcAmwbMCS;=;QpqpjgLzW-X;2M%`>y;|l=gtjJ<>{+&8W^+F$5 z7i@4glgC4*_3Yc6dO$I^phEsFNG#>|3e7vKQU7&6-M)=0;K=_uTW^PfRetDF>S}Lj z@A;*O{9XpvC?oy4hyZB%_s`th`IP0a5t}5oCFO|I)*o^?V)a9P+p@~DY9hxcbIJH1 z*mHeM58WmyqJT1)Y;9(O0h^gL^sBmt$^bQyEOtUD%M|+SuF0+DA~sA!2$fap{h@$4dLY%_g|f z)$&^pLrv>*I+W~Tvi8q`h1hbHBtEM3YQ`fdmGz{4eFdGc81w5}cBE z?$P3oO0V&tc=#*u9+F0b=*&NJK6Cn8)YI*AW?iV)r}l%s-rC{e$*hp$9*4h-SRvCJ zyMS)4UsMAh!(033H4n4!^dW)M(@bFwa-CRSlTT^l*VG@GFgT&Ny#?aWOOu5&5}xGF z_X^o$-}Hcn;-Q2^i#FvkVVs{m@Si}P*V}-7<>o=rx?oaj>#l-_TbeO6`#`Kd^H|PO zweY7s=?aGK?<}&Gye82j^ttqPiRC6{Io8W$0rpG611Z{HWbNR{wV9UM$V&Yd_af$y zb;zy1aSF4gs{?pQbI;M8NwAMApt0j2G*g&bi?z%)$O3DB4@Q2}Uc1N9%)4v%i013& zS`GVQfHC$~-3MY?2=DAS3CU~qV>xBLsbb$_$nT2>qV8+$t1RXutb)DMZZw@iFgGeD7HBuA;Q2|YPUKV>1UzHOe#S*kV>R02`9#%_M@!)j4FG?3qX~&vs z43&+*GtWTDBco8?QOg&`?3QO)bklt;LTq3^DRDcM`V#JM2fmHwyIZUcT)K_B&M*z6 zV?(nR{xI!{c;;T<7{x(qR6ogge~wSEToONgNLx4;P+hoHZlf{26Ge*}zW?!fu5wK- zYed=zb6o2<8t^^Vj-$_w+h-Z~rwpnPwyeQ%=Q0~z z=1(OyT{1UCJF2$)Q8yR07dR4nRnXy_v#W#8_Xk>**#7gnNU<-*zUmh$it`p)f8X$V{*M@t}~`2c%w62Mrsu^*c<+l}Rj9DNx8uWh zY^(l_@-R)TR=9VpG59;)D671yUM2+><=OF3WLZ4o7j@2b!QjHJh*cox0K|+erF=o? zC&~iA5E26-LSFrpNl@MQeOs9x~}! zE-_<7u!%TB*!zwt$C`X6mQTwCNCJ*~Mael$gMgLg9c#{j_WHJK3z#?H8)KTviLaLY z#f^N|+)p$DwblY_<+)G7!u%_7h{Z(5Lq_u@8vFi2>8+Hi+S6UD{*fZfMIldn{N~fm zcmFc>d}ghF5-fdFZZFaO57~}Kv0%o*+e=c&K|EIo*r@$Y*|6Rc>*XnN&U(6UCArC2 zn)?&CC9;!E@3-*l43r>DJetHY;+C=#9;Y5BD|`@)_O9D9O3nzLIl1NCqOX#kZI>2i z$_QA!Ed?_vcwf!?A>4IDpIQo39_JPt4%6?=6C%ty2;cesLH(ld|xvI&wuD8O=9RCYDM*)4*4 zXAk6k_Mp*#^ahnSrnUa>On>SU1^Z-wqJem(`FJt!o9+i~*_ZH>?l9wVzq>c}+3K6d zJ<3w;fJ7#5!J{0M>-Mo;p99%~ywob*9OMbK91RL&YPnMOwaj)VkP`_z_T*g01^MCl z4)NOYRQ)}xlw(f2xGno4uj|7&kAK&Lll^>4YP(`WF6qxp@>Ah~k=8DykojYfrMHKE7-DGyP?p*tk`K|Amy9 z62l&g_YVZOdz{1iHL4DGRIYOG{A7qfXD~0d?e@v*o?vIXsvCr9?WjWI?B=2sQ!rOP z8i2J?)ZT|Z`R~ffV#gu*-py?Cf7XS`4w`6h`M4sM)4$xdW4Jl+b7WPf zT}4?}DLD}kKnz$Aa!l+Nl?sj+C!?lms(q@W#M+tMmO50A+Xo|iyT5asn8WZvljJ+F z=nFemdJ|d4=Mq7fF~Y1VbsQ$bz{6Yh*<3>y6!MJ7#qI6Pq~_p?b`|?M#cxF%7leYw z3DAiTlGy!8CQR_`*v&emOonxgSMZ1C72o}V4~LiV#yYSwTKsYEJF@z<>TrF@>@#If zCcCbEP!_BN9lhgCQ*von8x^t0zA^h+swFoAS#&@1r_qhOZe1MS^KMVthM3_A=XiTuGQ|`_! zTh0=LXPE|UqRg{Qd^Jsp)`D(xtmL<@-?_9icZ@MHye&TuG;7r}!F_>x#FxI_txb1& zBeO|M-J$zdoTAd~{+iZFYPMwMMK3UyUE-!+EVIPRZKh`4hfcH-x0ZLl#go+i>_zW> zEOh^gxHTetT(7Gw=&KElMTZQ&m@)dL>}*>by*o2LXWv?N8cRaXkax-p8}{r(IVuv3 z9(hm5jYppKdLkG-Q?i*0r_R{T9L${a_48B4KGSC{czES-X{HbE1E*#Y>fdBa!Eumb z45bvef$)q|#fW;vR;alQsjjxHjLi0Y2VD>!&cjvA6OLo3=fgXWd9 z1N%?`^f0q~#5_chVScyKHb}K=^E;br?Ys)bHlDH_y$+n9qnJ7V5jQVn$UE4;Q}p4x zA;hZ$`=UA6_F3Bu#^Hryju1b-`w5_nUI9c!E`P$YOSC9;`AN((A1uO%TvX7umhkcL z_Z3@ZGEjWg==dE{0{;$pIRO2Z_n^5eG;q~cfEWMsDD%NwcU{@<%y&y8wfC>@na7w0 zPZEU9$WzUxTad1))Q#p3$D=3vowomi3NLw_tAnf_$oj?P9v!i(T~7VD>bET6w6*(R z%PYTyP0=Fup^@@3SbR)EFNgbwPeeZTp?2Wg6p}s1L03ix)L-q>T?=51xm0`s@tFY} z@+(tfJO4|IF%Z!BQao-^^EEFlT(8h@mPY-&+aZA;-2Dl0gaY3h{=G?n$qu6^xV%(V)DFIKvHy*)9v)$)cFvdiiREXL2D zgBm7EejVNeC>I~fQE`*Vn&Ut$T4;ln5KZ?8<3^9+iYlrigq z*0i^svU13eMPsRL*mZu+v?P#>{<~mm6yP8qQ1z1_U_RcRv-ofLkIX_d{@x_L@t}6{ ziQ>Qimj@41u3zzQXNdJ%3CrA0s0$+z`|P{VT<&Eklahy1(wM=*1Q23oX z{<>{HEGhW~N5Wp9TaSA+{Wp?BL|x!Fp9S25{CWCs+!xU_snem3c)k(+=aV`~jl3Gd zOa+LLz%SHj32xESnL{e4a^50cV4yrUVC

dF(+8pjq7pWJ~_z>+*mxo16^!J;)g4EZ5q6_x#qSRM*t_5;`$rP9)Ud?}Ixgw#f zdV%aHfcxG7wJq%9DWIt|3fOlg!mYk47oCz4QmW1YZg~(54*?p9`{g=_9j7}=@8SYC z46O9kA$YwTw2#!_bWV!u@qt1n#O*Ci*tcoiz73i<6$ab$=c?0ddH`6CI(PuMMyi6% zf{RG4OoC|F?yJLkt__b{TrMn`t}C<~m);hu+r{GgI^@8MGPy05F@8@`S2P3^wrnaO#vb^?NNFc$C~symbRj|2!7A0$Y$= zW<5=wY}MSYq?_-*C1)aPRycY+m(J&h+EKqv5~x%d6ntSexF{yI(jey(}x0=mZg9xQT)r>)h}fzXp-Nb!`1?|oWwzl?_4+&#J3 z(C`#&)51@+9y~)+R38yn*e-r~X;`_cn0LR&ydrELg|8xJ-sd@>T)gdi?X;)brtDb_hjVH^1llGKE=mU2`XC+*gl`3mbTL+xjxmx{ac${_Uy-aE5j6#MufNr$Z6}tgRJ+VlU{(HD zO^7mE{O8I+we_#=9B|AXQe`pWLMa>5@E%8pHSX-1!)eVJqi^82v%O}x} z4avpKN3$gw?IOq)->}Qdjm>|UPGeG5=}{u`=TJzRs=?aLULMp}oqI7$@atVYkKKaU zG~5?7uYX!=x?i^kirycf+At$C)Q6;ip?P8~zbLE2_P_t24mG=#o8GoR>)p<6zI|=G zir1&jsW*w1IBJh8X5Zc!X5zVAyXdXO{6t_?EyZ)_QPZ$^iBiEmD9tX@#(2=6=~>x- z%AM)lzk<|MzLQ`%Af%&Bt1-0<_b^XIBgw$8i?UiaS5+suoW%J$^FQ;Bz1h%ItGZhO zY0u%oT9G)6H9)f(ZCNQs8bi8YEozCQpl(~L|aPxz$IT{{65PTzX+x-(wZYE~B zO$TTaza^Jad&J-x|ATBe*j<3?iG4W*N0!EFx`*sjb;c#4L?7@hkB&n=AC|?%H|x?ybm*& z$>umKwn4o?AmHpS+jMxCTrCVJ7xlOZ9?QL$p zzX01;va&H>^;i!=t^x9bz(cKsXvJm@aT$qH-e9Y(P2P~jK=m)to}TXOlD5PpuXDta zSN`JI*`9WuGT;TupQiVg?c~8{6zOg3?BjNj?qSK<1D!>8^HVdCXrgepCYEB4?g%VT zIWZB)E9p401GWymkwzTo4xbOqYC9qinMF5v6c9ZQy%hK;H`)`!-tFghJI1C4)RcCz zY@nGI?(R{(_%~(LT+e2>48u73ramDJnl+z&huYoUnY4Im$RYC$TDy=i(V(Q1s>r!t&MVLgA zHxy3?8ni;Ei?IRv{w+?^{J`~&q55*v0yEBCVu>FqHFck%R=KGXLEXO;uvVtj-Gd#8 zk2HuZYdC*kJJ_RPUk7@7{}~2FJeQtR1Xa`~39W1@O-vzI|3NUV(l6k95ipXB>>PsdHh<|7Pj@ppqbY zMR4)$N(1QSc9xiz*Vv5rU|3Rs&}O{0}jFk}AH$Pt0Vor>ra zm=1GAR_jC5OR;cuofwj5sg*D%%p35E7OGu#-S#==YP+MWecH**=8;fjH01OQ<{RW< zh`6&zgTPidPS|%eFLae1<=)Y37J@E9x&qZPfvE3q!$nk?x-` zJR-ND{EKBjo`Z-GD%De?t4P`hHuHUW`4t~J$sa|twJ)WmHKsnIKmIMfUmL}Ha8Ywl za!GO*_jYurq^k+Iv*B*IEAk+|_IbLvd@tB#|DM-?Sf`7tb=*{qsraj`?;^&tZ7r4$ zU*M`lSr#5G{kbM^WE%dOKj+Zpflf)wY^U;%2PjVLsleb)xyZoH_=|2W&e4H;W1aAI zAQOshA@GdHa{WKMpwx1i+;>4i6gK}r>pJk6Lw`Fg?B&hMvN{0AGXaprZjZ@T7oLhc z(85?Lpnl1m$Se2c->&TV-D18Sk{o;91l995(UqEYNQ?H%J`$$JugZax?ry@KrFxC7 zDlso3N<86ubkC#6o)^j&>K1JM{_}U9Z7yxK5-RQeMl(63JJFo_#P7fxy_snT+uDC% z9Q*ROR^ApqH?LCx;QBu9MgWGTU@Zb8qg9_n_q_;4=*+1BtAmFPO)&}Y-NoaNnk#W* z)3*xn9NOhdG8tfB!2{JfCZK?uR`f~9i(Y5i5a!C1-b^-D%$a^Do5lHI+={XnUf20- zzsOM!jPKbfd;_E{JWpV1E__z^l$6FgIDeKGX=Ku6QA$gl*S?B^MMof$xmw9>56Jvr zi;RquN7vUvgwpSBylS}QfQeqX~Y`b4d= zvNf~={cKgYN5{1%yaRFF8~lD0(t;&^!ThH#OgCy8=GHv9G~06x{X4)WrW;8bN*YzE z4IN1rp;;!d!BsM2in`UtW9q>^U+N095b&wD%y$;GfB{*SK*j%4cFT;Bq?h zNk6ERo}KQTy0h3xNNJ9gZX%gjywef1xy?x{S7uFKR%LbbY~rcdq0;n=kGcwbgN6h7*#bb5UJdQzOW0f z{7=QG1xSk{UX!oiVBE-VF_y$Ci385C?{1Qd=U2tvS{WP#Z<-QpD!u%9J<{F@&BUPY zt@alf0XOLl5^*DL5g|PpY=`%+L5`RG$eJ*$>!l`Ge+%LhcY_7>$0e`;|IarC0vZW&4H~>FTcW$I%RRv4<-~l-J z0F0*^=wmOspAg=hZAlMX1@Gyjo+M9|z3y4m6HSJ{wC$9yVZ~jJF=6KY`Jdc*9Lrua z^D1;t><)@am3tr7TO`&2iQdIEKTXm%E!r845EbrSDHB|r_VLW`MKA!ax8AC59QC&V zqJN6y>Es91EqtNV0Fts$$UgI}yQ`PV3GbDUZ7K%`mZe_a)ccNeyf4zK(mJd(!H_|V zMAa&JC>+f6ZI3kt=Q5kyPXB1Q{KNu&!V7vRV}DZH^W_d$H=^6hlRHwq_PuyZqW?On zp*M7_M54~EZjKvjI{{F7u;Ki_$d0~U4yDSscUNd%WZ2@Wvwo)_E*Lm48~I} zoskb(I7yLJ_%A@@z@;^1w@dySvyp@BYbdK9`9Log9jEr(8_QBF>_*kf2Fe^1n+5C} z_iskaA?xu&so4v!I1W~mMcKey14thG>%I+QQ;lK9W8Zn-intSvgDNo2;GZT|Kg@j# z%*ec^x!d~g8kbSYSX@EOV^FE~LAhdNXUj7Qw-s<5ICSF^pb$&sg0hNVW){C9?i|1y z_~_k*J*!d9SP|$j0J3M?1m_5xI0cu}%&K{BypKN?mK%6XQ!LX(LmJ^H56_#2qQbQ0 z&D&cDS*gxFG*+0HQ}?pts*g>b{?r41R&9f&m()L4q7Gj`bj#-e?v-P`SkQAr74$@` z_I=`OC&yTD*z-k!NZ8`Awlg3-hUD^>igSFr6eN7=W15Glmf|qya&P>$;X23DMfd~( z<&xgxx{j912xkW29!}Io*;=;;I{VK=*dN=1D*y@FfR4I&4$uMJxxujqO0>DImf}`mG~@pVp;a#y3yh!NDj%ZTmBbWIlH_ z*NCU2&^LvFdNnhf~ zs%-`Jar?y^ws6t#Uy!^i?~wReVg5+W4&snT;k(2^C+Jt;zBy*F!NqD-gkx#0PQXrT zfQBav-cJzTTp6T#uZtR^&VgXx5z0oJjDgt5p|Nlapvz}WYGzjXdE)9A|J(@ilK^Tm z-1j!9Lg|8zmLuKWc|;5{{h7`)-O~n$kWh-8pn3i>MbnZR!A_7dVt+?WT&FLzf-|lU zppKQ7wL+Z^craX{Cs6ffo-kMip@KFL@0LyaD)ZaltvoEaGqE0`vT^^rgHm@W_9!wd z;h+IE3iA(rH43ZV4S@njC?dNc&>6Tcgcv*t^TfbTt9GwV1%%B^-G;a9Ub&#$$&NIn z4P#a{m2@tL9>M8*1ex~*DgWmo(Z%|X;G%p;<2pAJ?8vH_*9$bHmDUB#(Y-?+Cw7p@~tynQfZq=&8+LSq*pAl9az*rSbyb#BFQ zFR6w7%fq~0gd>%!L+pR`U~ag1fBd)C#ycCrPkGe}pv*7jZ9$$zr|P8O;}TZFSFEe~bpdJ> zBK%0!O-LV;H^1f(99ld3Lg1j*#)MowSJM>w5rql-gPV5{o>SMo*5Q+XKU|dPs8up; zTiXg`vj>MB3y6HkApxKO5;~~cY?B834qj_IyOX<+93SABis_twzwP`v@OrJe6x`i> z9NL$WH&do?jR=d;k+pRO<33~&{=lRQd!L3#b*WSMtyC>VQppS?C z@@<7)(PJc$kjnD8=`*(mJ3b;ivU?*C!`5q3Yl6G;+-as{e>?LD+~hx2ogM|4Mu~hE zg-x5jMMu$B8=5Ze6g!^2NHf$-^_-iY_|vAbrczJO;#wPVRKhz1agurK9;2EabdL*< zU)+Ra7YrE4mf^SF(1wD)jNMbM$~)B4-qG{H23X!@CcAQ_PL@KSaPgTych2*_seNFso#nX3adtfuc)eiJ}l$^Wo-2HS1_7o&i%P9=*+Z$i|WNy z{%9pzV_WW#vD3Kw950XsQ2w2}wnZ;Xz9cnYBwRi$x*U0QMS{w|QN!k_-7u0x+?FuU zGJ6i@LrZxqnaTQVvjq6av6^f9ZDkmc{@QWBJ7`hHJEg`@*%ppPH@aXXD0g%l4#6=b z5~{%*|09tr-v{0CLj$AqW>_UL*4W;3=cxav8dZ&#pR+1{wZMJ!O=a;>>E=nHB<HaNxYQ&@yt0cc zZv2E-zt5Op@s}dITVz*`_?OKojU(oz#Bb>Fw738-x3_E=d`lYIf(>IBc;xiU-9l6a z9Zsl_zo>Jd|7_7W=Z$nlXGf;$kEzGdOXeLChdQ^%Zu1H`s;=JdeXv_22m9MB3saeo zJeuL4zP3$r2hQldl?h)xZD^KxsqUlL{qQqdIMZd^&4`S1+3lvyfKPL6wl2SEe*4^N z<+KB>QR*_*lE3zts)=o!(0UQ4^4xqm8I1UZfRk55za`WjhX1MBq?)_}*`*#!P;Mac zPtY#P5b<{jG->_cUgIXd2`wQei|`$#nGwZbxRGq7vF6w^!&f~b;~ z;C7I9GA#5dZH(TAq);^x!lIb&nFw{ePDx*kx5Y{76Y@E%G-UG$eQN8;!Py?23c9ub zyE?OeXg#g4>wkDV4}U29_>YH>c}WuDNOq{CGmguyB>83}n6UW+l$b zc4uZ~mle)F``jHj-1_P|ERj)=Tt(T$%5QO7$;maphawaEP@4Ze@Wm6ibw6t4n2M#&j{9iWx!ho1iiN-55snP?iE$=($) z-btpP!FTo-7hWPc8Vu(DbJ`W&@NB6c?Kr5H+1+exeFGlsb4JG&=El-#C>&C`jA*eV z^G{AAcqMeXU2b!FO=8cW5>lOGsT(J@W9mZ>IES2$yVD_>o&txg=$_%SCVO7s#?IXR z6!x!O&AB2Nqdahc)kXLhWTuJZ+Jm{X)OR;fCv zSrt28zX<(oq5-{IzNKT)w#%7Wi_uCt5VK#20?L3V=gb+wmKld8j?MABp@`KFjIG@) zPSo~@EC1~4HszA(}&-9GR$mcs&ZuF4ReV zt-5`6o#=CYw9A8OaRAlj!Em2mx2#A=S_92|8gbw(&Asi|{Yj8vHB&&kSu$53dL|sa zyuLe76tVcmIX}J;mW(xA4A+_S!FoOKtKKoQpH||4@nfe9@7B(t z)1NCbuSj67W2eO@c{kyvsnhUxXq5}AS3FzIfb_t}Zz51_Z2#Ugu?9^9*`1W<0A9Hp zq1~rs{3ZIgWk(`>hpf^82*i_W%n6ukFsJch1aQ9$Yk>XR!MQT5JHa4{#)lQQ`D%?c zaw|j?2sA#^_$3V99NoE+g8m||)PZyx(OS+GaM3wY%h5k)iz1{JzvO@AVJE2+=cCu6 zw4$OZC1UgJsoRuUVi;Cc5pp^p@Dg3?*(Khh~QDFSw+HRKsG#niA7DVq8V( z75gO>;{3)fJf`gz3j<^|5mx4Mig=xn&$roT^;f$d@_@jzm%92uFX7{Y!%_&1LO9ZQB1gEKu8)9h>Fz;TYDR_zu`G6`oT2lcQD&=m{5SVtE{(|z4 ztUl_Ai|nXNnW@Ie)Zt%@*HUUdJku4VX0C5P@iDIdD~oxugdGUOMqgktaoS%|TQm@D zb&jx=Yvoa(*`G|8>}ve!$AVOD++zdZ^K=GXq9far{lu=8kKX-*_`{9qn8^$h?xA*` z^NSL^3_j)s5BSo{8}072tiGtpOM95J;lQIh5*^N1(pr&EvR7)rXvvLUX0(VkbOH$# z8cQ9+pHvK(4XIUM=4H3NY>ie@`P*3O0cjNMnrWJgdU-hFy#%u_sD}!bztgFyA*JJ{ zw(?(K2c-l~4Ov~BJQdrztaxeO%LG)IcM%-!5;WBRTGbcMp1gIQ1yZmxPWwVLHa{%4-~J)xgE~$5iMz3B3jPM8 z8SzK3k2Lb&Id49&R3S(@?B71J0Tdl$N7IlsinC#~^uzUluQU_BiQ>)qbec2E5z0p# zFQq#6#Y@fVSOj3q^=+|G<%{jb$Pxz27WD12ryba+~1Z2 zYAtINSniW%L$wdi4KkR<(r}eYH;GxzA&dIH55HK;ZwG&l54bB8VG6>hvZ0eAX8#J% zl`7akG43lqg`K)k=Es$g~w z<)m^qc)07fF40DhB5VX54U$tIH?HS#OfYTa3e2ikJq?&9o=VkKeU-)63wkR*1x2D~ zd1_QfHlRsS3ob{f%lrDqgk3yNBi@o2afzjM7`?0=4Z^a6O(lq%3WwDZu{pgw=q>MQFG6v|I%IJkN?OUaFH%)DtrYuP(fZpi4By+pjM z>Vl|9>5OP?APC`$#q@%c=6;1dM_u=}Xd)VQdDPn5@JuUr`Q&G} z!V3w<`w_Q_(JwtN+$L!`N^b8OD2_DNwXs*rm8kS;O6vK{r`hLLw{8DO(3^|%T1W#(kVY1RRT1D3@VnkPUom?{4XdY{}r zcogh)rd2so`sx}lLoIj3y)a2NcRRDHm{GK8|CPq+%{An|J1tLQz|`|cS{){`S>Q?A zz&H1UAHF63m~hkS!HIGGkP7*^)>V9ou;#pY4i3} zbaP>F0%647YwG2lykr0U{T%gQem|buM$hE8pK0O^13VcIpF0ZAtvl}s?AE$OB}CcO-Xm(Us&e%2_4=FQ;;^@Oko==g93WC>lpNdRU-R^9F z{H|?PnBGuKgC!VP8jKl-xjsD2Oc2??xnGbe1AC%Gb35odxI^k4nqJ47T@B?jVU zJJ15@F_D5j$be!WyMYYN<&~p)nR>6=IKJRp(QWIF+g_(D5q7V2F3+uQbeAVhH`nNl z40(6k#Y!J-vw8Q<{^Y2Cr^NL6c%1x7%;G)y8OOiN07?w@zc%!lQ9Y5n7?pLrz;myo z(-R;;SmljpxA0CmaX8UNP0tj3{dOz}ai^1!TN`ekVFCYWb!=h9Oz(TuK$TKDlAX^l zpsm)*1JXgEmPX&(XyG>Hgf*Mh5ZAsS)}RD}%Hx6)_pi{0%8n2@PpIp1kY19+5lm~nNyqY&;e6r+7a&P!C zU?s43)xtB39m}^Lsw&>%KKb+ycBTe&H|!wLyRn!IS@S#&epffNH3OIIXWko1YlG{^ zj?t@ETrtA;(WWO*ysryiLoMO@qU&-vJ&tu}k$A?!XS`6B-jS)B<82WmOapw|{7ykh zsAC8V=A+Elsg!5PDq;G%I_8u~mW}3W>MFek1m92+uNqNnZ3`D^W2I~ z;g{!OW;@Pa@4ho2Xmc4jC|p06LnOG$x81E{blp)kQuTMc#zEE$^;1XdQ$$#sAq0O( z3-QgqF3(R}?vq^JIB|ll2Iq*f?{^ae zh@M6a3P1V-GF&%sNhz7`U18i){PaBltf!~zCbjN$gSe29f>`x-Xx``A8u)(HY*mlG z@Af>EnnsjL*e!9U=jQ;CN>k2R!ftKNaOu4q-<|tSU#l`*#rxK)WVc&yc2dHm=m)R2 zRb9VZg27+i;61?4adiK-q~VKqQXH3n=gvV+m0QUN&YhfLSeDj7w^%{B)barMI`@xO z{E{}gYPIuG@%uhvcD=;xKJW4bJ$JOVax2{5Q|OrSDu@p&vgo-Rv8n4gBRr7fwZINf zQH%W8ol@puxM)W#quVR*SefXI?qr@#Ew2>uw~H4(7&@MGBrBhshbeN=SgP^U|H@=ATxnb*$j3u^}UFButI!DG= zmmFROz_YGk=Hj{X*H9g@JmBXu=aD2<d+xHI8iXWrWX|?SVMP=&c!isC3iS z659KVsG!@qgM7tZUm6ic$NeX9G06RI$m`1t9rv3;p-vsH^O=fX-pCyHTOBZoeMer$ zYx|2rP26ombH!t=Z;OuL(}}U=OCOSs1V{8wjN9~)v&cISKUyb1uCZa3n@J4ouUH4n z#qFG4z^{N={%q_rDZwViTrOYT_OFFJXdxcQp&h_OZqql$Kk51Sq@Ml1_qVYI29-`< z5seue$}bSE`AxW|U1kd3)vOP5WOB1CzJxP=l!vpAWELir;C$z7L>m=$CXWjqJ$n17 zd3E|~k5f(bB4MMQtK5h8a(hCoJkYM5qxvAEyTCEL26B2X!uv{>P;<8`e$vOd(Bns66 zcCPO`HvW@M-T7`fQ>q7X(`)i`$rQ<_r&69yVR7JaczY`JkAbAWLf%jg4sS zsz?`0^O=hUIV{CcZac2Z6V330BC%MP`cvr9`9gsMsiqX(rWf6Hx+2DnC zmCl{7jA~T{Hx>uv7fsC_DABuR$zOK)9lzs=!kQKo|6T2KYYf3H7+-NjN)^Ej0fZmgSmlSN@DPRLLKzKMgYpo(&MKx~=mO_gQZ3$Q{)g zpsm(b(5S$AQt#xYbAJ6LM{rd}7-N=b)rCya33d(cD0?-=HV2A_^4;Ikv0;KYrknM6 z4@R37ujK|U&DGfzJ9r5HJ^sEJcDQrMPafQLRY6L}{Z_e&wr%BG_O;H@BY5K<&&3zn zTL5pAs!!>#_a@l=M@oIMHG%c8Q9h`y@zAa3Pg_Tu{!j$dZjVNRU7iHNbPEn%CCf_a zqtv76?+XSW$#y|W|8;5l0K+f&kU>Qx-BcOf`beRUp%oU!&4Rv!GF`uDf^ zsLA?oVnNmVdeB!F?F6FvKMiM?X%k3XE|ealsQ z@EbUNZO#E40FK8D7TxH zHoxb0C|6Q84*qtT1JgRVNUakP4r0~4fPLy<_j=TTrOuW}y{Ny+E*2!J+TRer5?Xvk z6wAmREjY3?T`J>Fav4VMU$qdW^w~Ubvev zbYG?Rn5Iw#2YGQrH!tC2aLT@9Nf`S%BR67T$6D})^Y=)6`zcU1^g31lzrgq^(2PFX z`B%QF({#XZgPDN4r#;Omq&|(Mf{YX!H`rZIgB`&^h_&ey)7BjIea?J5dn$1vj3wyF zL#;{V%DtUy1tZ9+%iz8o)hIuil6U1kg?gu_P)+$RwTf@gTZOTvCc3Lo*(hV4aX5BFK+M6f9ax_hH)4zT60H_1 z*X2yC|KbObXip#w=!j|r?i#2pKfvsDkluOA@*c%z+H{)sc{Ez-!#v(N=Y0%%Jr!NT zPd;vPx;Vvba$LM7vNFq`+ggiNp2IL6={D~_SUTnF0nD`%dbYb6b{Qp9SzPvNoK*Kr zaJXOqZZ8>TQ7I2C*chk(JJWWAUmb-{T{}_fmh{&B@vEI^1?NtU$B3)xr zZbB8T*VCauc;jbCN7@2RO82IaUf=r7acN}k}|?O6ee@_uTFyPo6sImFqYmvENI zD6Erpc4|b})#+2{t=;|0#*~XC*(eE4u#O&skD58O>r6Y^IicLWg|qj{{|&k){yWBZ zA>y-~u;Z=>e^}Bzm%?&}*|d<2bzCuhho=NlN-(q1dIkYae@-RXbd8nT>Z#isg73<{)Bp}H>UJXyKB>JYei?wATm0%PjZ}k+Kwpn| zlWm_GftB!Ay1X7$od(3E!IJSMuaj|YX~*w~Zu0q)NUe`*v8fJ_^R$|EEJj$=OG(;i zv1&I2m#}Lx5r#4bzU>ZP&u|hrx7WO^l3TZYtZVe&`c*Yf@UyObo7jJDC}+0axs)Q3 z>146LEbK?65rDinI*z! znW?ord%~YE-={dI2Bp@aitp)n1iw)gN{lCT72>MRuRar5j+OKAlwMYxsw<wHbhM-l~gM;2m-C7p7}x{cs`VSJadT)UnWy2OpUKhj~XU^UoNN zFgLFe=Y4KoaWrQC9;SKbU-@T%v!=8ax(`_otGZ+@PK367!QPCMsH`gi&6`o)FBFo6 zDo!v;Zon$=s?55xIx;h^Uh^irihQ4N$0xuwudq;)>^Ml*b;xr=)egP6Sd+kMyBaje z2Ic**jPxj_h}SKXM+En?qBHgTJszNO-zF2VcYLBY3Q}&3F;rs8xW>fd&!TL)Fa37$ zB?vD4U4E(NmdC_UGa0!fvkKb&=Vd@4h8V;)fP-+$zQge+1=LnxAsl-_{m3)X}7he_p*(tH2auq z=EHe80%*%eP`<;=*Y~I%LbV`!MU=9+z&r1u&Y6N=!>mzZ!!PD$%2npU#@H-S%BHsD zkp?;Vbnjl`*rfT7$cPu$HrRtJyt6^Br6$3G$`R2|RUh|uANlEe^*O`zgZ&~mY7FAX zgZ^_hm>d0j-;1kc+LC=Y`=~s?I!k)_C{(m6{_t}Y;of}dH8Fa#|CbOU+q3i$v8>79 z>sF^!z7;l^Q!nJd93urH*_Q8=r)jc8YstnM>isMg0X~5F8j~kFTqRo58F-wSW;Z02K-c=4h(IME_f4mvZtD4 zcUZj_d`^)eAw$%|`PZ5sM+7Y0Z-d`v=x>G9c1rv%_H{;^`NPX9h@9#qRemO#SL6We?3moo#|Uh?bW@$|LLt`Fq52KLw{9 zhTeSefG?>lpjT=>bUDjGWst`%2AZ4`wyGVSW5r&DsP>T3aq)Y702BH^P}_p}fAO<^ z`7aS+eCq@G)qKuV^!Xq=9>;M!6G7^}17Lxaq#b`Ceo%8pp*`!4fe)5D?(QdQM8#4)y^Ar7~jb>Uh&zVQ-TAusB3{`kC-d&|Zr`$jz4>%^Po2 zuc;2uK~E+k-2aKM-}-W^+QlO};I#F_oM4$}<`XoEIb~^1s~-N%8uVk@x8luB=BxKg zf_pdCVJlJnu1!z03i9q3e_qk+yotEkHGJUEzmxN1sn4mr_(nehqv&iOH2Z0OG#K=gtuNSI#g zb8we&OugM4cgROZoy!;hLPy1!h86=;SiU_IB#!5AOp4`kpme-u7E|zt!o#F&>K~z< zx|QL2uPX|HGTUx{I*=?xC(*t5{MvVmJhL$edWu)(h6ipV_n+xLO4#}qA4;JkmX3$r zvidP%;>U~#tq)U5_??y9bvTIe>B;xf|C`0Y%1mQL68sdkWZX0gR%o&!nE!IM$*bVs z;$d3T>F2DkhA`G$=$@x=x7S}eB&LB?{S?_Smgzj&*8Pj4p-IW?BR}OiT<*>>K>>>| zU&OoipIXu3cDODS`W52s+kB+i74tK@Jh@H8B{jnfA>wNFjwEVL<2VH}-e#Wq9ugBy1Hj*gybhItW$h##z5BuC==&h%YdBU_S1 zZXBH1eU;1Ms7fW1ug;+rW%7Tg+bAvdRitHB2QA+^7-`;d(GuR80|qzUuX)bFQ^_#Ui^8Po|->( z2JN(r?=&=O++C*v!}Z^edqoN_|2@VC!l3>Cbvg0kdZ{u0+S|==hJuT&m{s>H3tRKwGcdPj zYX0~}!z;m&I~{gNDP-cyN0F$G_K7If(Fxrc7t;h7j_YXmQ6gw;zr$vxhIw#_KD#jQ z@Sc_dM`lbko4z>j-9C8Ocw+)|=LER{yK}Z3lB!UGn-)X#Hk*0Qm5BPUI`yl8zNgDs z73e_2P90CS$EM~z36t4XYKZKMZhcKO3KJe)=r?hA0EVgm5|#p3`!V$$m9@!*D2~=d z)O=H~Up-HMMAR{h9ap@XGBnPm+??D1p`wvD4r)SL2^}d*QEHv09c&Jfh`#(%L1yr7 z5lZQUR~3+l=2WF!#L-Jp5y!1-15&GQhb2$1l^Df2@9^nw5EgQ`y3OYWa(-f%`!;XOg*~*HH3{f89n| zpPl5b1(K9$fnxz(7OD(hd*`Z0vpV`GJ)8{*jM~?nD~L0_)s?>s8ahhPrN1ltKwr<7 z*K4H$k;}(*6&(vg+%|$L(J)`N!(#3H1MoUqqK&O)l}oH8Eaky@NjQgxuq5gTb&mPz zO=Th{Sg#T4%`krtt)}J4%ATI?Hjv(A}#I@_|@nRc@eEo*v&sTTrIB@;Qx!F zC0}O9hiqvkL0$<^pxm&(HzM5XEp>mHfmw7~Ju6O9xQDv2L4uV4T@~x>6dVV2Z0h!R zSO^n#);#6LpxruPc~i0YN&)Atvkgtcmht>pr|f3APv*0)oLj4rBq@2>0Pgtq@GiPd zmDriEQPn7OTlptOO*c^osbZkhh_fKD$*9BLlh{nViap&PYQ&;O5A_!4n?CMSGD--y zu3&QiTLNUA=3c%hxeZ>ET@ETeWJiB1yjUUZAP{!FWl2yNZ}<9BJ+>MR@cCyh*;eAa z_iv1Oauh9zcvJU!rk{dX$$@Q?N-OKT=gq)*RDzhnGQU zU*cP?J=^8>YK=G7fOwU?O-g?k-I21vpmGU!qd?1XO`hzY*Mt6Mvuoejdwyqf=u6T0 z2?y;j?Gtl}roGrnG4P)@3ZFp>FdMK5fH3H|509?mi!br!S}lj{d>Kn_VT0sM zyL5=HaH!tCNin64o)pCdIBDdgcVBKAY<`P=V;SLz=56{gUp2_GHc;vX=-CSwB;V2> zFzJLq7E4S>@it<}(47%bS6kG@F zF*yQIF%3QcIy`pQ`|BdW3qh@W9R`9^^Rl{0yVUmHvgo#|+&R*o{9j;DYdXhC;YQRm zfmUa|QFOY>C~OE)nYDy=LUW#VeD(B~P!F)l+835YDDE&@2Im$#{I2UB?%L)}b@?PMep~a5#cS0GZ3#S3Gg+DYCZF-oW5;1pF zhJ})YF%B2{{V-dH@B=^UMQE4FFxC*QF8=FHTKyHI9NIm$80&twN$;o23Te0^j~ull zP8BSOF!4Hw#a*yDGg=YXyd4(E<6Y29xwhg%jwczUQCa289`Z{|6heEk2a(>@yP#9k zZyG&rhj}k7ox#hVYxG-6;gSI1R?Vrj0GR)E%_6cbjy7fn041_2N2d= z-@rXq@4mQ09`ViN)mYws%^tgK+L!o?<%OGzmfum(jiI&IL5EO?u>=t?s#09?UiT_RYZRH+*7k354Fh+!U4K5Lk-Ov<0>1)mCQP9>8cn3Q&z zH_mo^S+7zBCi>tPcXlpUEyBek9lgLf%HMgD;73uUC}C@&_-xu?L@e{-459cUkQ6q? z*-}8@8Hph|AwUeMP}F}Ip=(-F zUGw$As*`}7aP{rxU8el@kFhhOkPC3s5Hm5nE_OM#Rg91UWA2+=dxzO?=?Pn#i6>`Y zdfhqQgZE7!?GK1|N&nD_+xV#tU_+(qzz)t61*KunX`HlG(d?y&m%ukNm%aFiY^o_@ z1beb=rR;KqHJ)ANa_d~D_}+Sp#j^;a<4Yb&3;%{yR*}0-4bLb0gb+?^jX1J?zOoeU zPRNywPKqQ?& z28FFx(iS@!G2+segx+>nWSv{g&2&(R!Kz=F!vV$HPO~!ERmcDAP7M}absHoi2Czj< z$*)bze5`7%Z;%XggWnF)TD!UqL3nEN|5u?+{uX>k`yd8)mhX3_Z+E~UV=U;E%#^bi z=2g=ARc%@0!;cYptn)9+(&LNU!#I}bTN_XB>kMH}=~`b{O+kwfC3Ln#dbhxG&;xSG zTl$2i(SYvW;J9=M&qMR;`N49N^(rSia7fMbwx2D}7EX#UR!%R}IlK4l_%Jl^LiP&h zC;%-}EG6($&O_BJxa%tfWuM6Xe=!@T9@&=>^V>T?J+?Dd7x0ANalsd#?{}nNQWVES zxxEa7OJ4`+98T7<>7bujXLBulxv24bp1}>n%)b^nIBfpmat2Rw>*HH%{i=eqFW>Ss z$^{VxA-5-x_r{WiTP7o#jl-=)JUY$!-CuH^^5@0pGlJ)B5`-rLH$&I@emOsFGHjcdjyy100I*`R#HMf0 z&wJanJuY}*?HG3~Cns9WG|90F|IvO8HG0pNO|q^*5EcDPgf=qMCr1z{r)>k%Q+s7x znU}w7(v(zE5wy=fYm_NF6 zX3!ykE46(gNMx>2TaU)uX?hJY5@UC0NEdbJR2x=O-H!^r_0Q%@`%ynqKFHQ^M{C6B zGgg%uX0s?0VNmJ)4G-PITXyAHRVBSimypJRLolfgpdD60m zA&2!B3qezljkUKTUW|pSty4L1i}JLh|uv*qkd->!z~o;82tyDFse-dshDT~}z) zm30Fcr(QN7KZ-0}320|UzOQA<4Ysyf_F{#N+BWbL`64B$<6ryf+BNy)I7g1YRo&qG zTc?=|lbt*L$Tu<5xeC}ezRXvus3&nNwpZJcrRz}vhD7DE(?|ck=rR8~6B2{R@wYX- zK%q4Ln9fGxvc1E?rd^ZD>lBeFOPmwjFiSUej+tO}G_Cuj2yR^~MoK;@&OSRdYk$Ao z?Tjs=6ENaXzZtX&o-fj;e8}YZcAV*$`T_pCoaSXOY{7Cu^<^dhn6Wj87+`!vPc-R| zd$c@G9rD~yORTNgWuH?(L!$ED^3?N(4tzf7g_?;f{)HffAMBh}pB``9j{o#`T(^-E zS0QG(sJfB0#5>26JUt zL=-EXgWl5#MJXLe$0K%`N2hwlgc68&z=?}R+PiKjU+$#Es<%FWbT|R^S-dCN>W)Js z4q4cAn6jOj|KCyLL)ieP?nP(a_v^1to1Vm3t3_~7u|B>fp@jIb-OCdHrEd4sO%r>J z_$ekVco%2GV50TxQXYm6Z+w}5m15=NFiLp9ffo~eK#{-f=(Zjzir!A)K!T^gby^^f zdD!X^_F`=U_F+7@&M656dRrR&)kQtZyi@?Z$>mX(0%>OKS{o~lTj5tv{FhC@qG2H2 z@BD5#pLAH6uz6Kh5X$u!v{MD`D;E zS6qXB!ja|~L(ykY?e8^lp9g?v{=jU-lH?MIkn>k|qu)v+?|+eG9d-Uh5TfSKyq9?= z`X5dU+ef+J0H-{5o;>)Kt-#0{P`&EbBA=p4p&`yGxy3^jYd zZA1q+-ZVZbgci~d=UKU{nBc&MVk0)c-@O}dc#PfBHVAs5{l}cCk#~$$XV$@z)|__Zzf1Zd6C*Ssq)xcW^u4P0gb zc}MYo=x6_HXp1S}9s~d)0y3VT$6dGuy$Alim_)BG_mkuy?u;N?3Bj1>*1cZU5`aY|ro~CeCaoZ~EL{0XG=g>Ta`8jccB|3RY2>;Wc%s3mh8Uh>gF z2EJn^`zyNhSbm{Ecm^^QlR2jcAj;$;0A@A&zkS88?Jq00PdyA-^cbKjpae{gCms$? zYwZ@CO|QF#bsPbzi5;B6|7s@m?))h1zx!i!MGlt!1MRP~HyI#$hZ@*k-|=r)Cw^R` zJQspiS1UZJAO1+|)gYJJQ}h%e>;K>vIlj$rs;sA`>7Mu(6x$OTuYTbmT5!c-a1MhN zVh_>&G zS_y%VYt`EU?kGvvkL{nCUx3pcukC|0V@U!-w(mkL8-g&B12oz_bF^_=<30EfXRd*| zKuI{a*Gl{3)(bw=&eId4785P^ktWSI?XX>M6h5+Aqna;vag0{8k9#kVa5qHDsLwf` z-~(r{^^o1!hbvAe`V=0>oGUo5-;#uO)I0^wZJQ{&G7cpMBn!}9Jr-P*_H2tMQ+eG* zJ0R@~eLXw7<8E{D1(wtc`0|_Etf&dyrRE`gMKtKG4j&8ljMCfe_`p$#J;PSv@tf$v zuQ=Xykx<)b+RI&;>}iQ0CA|wf&gd05i6Z#Z()9mt(U_msQby0BlifB?EhRSRYOv;B z6P8|ho3sSifljanKR5d5EHz0#llj1HTAb|k&1TV>T)%0m<0Z=G@~5lBzPvDTfz>rL z%(>C%-y$08^M`6U$xM5eMY*9@6wbklKV@yNssoDr=Cf^_+ES_l-Uz|M{&01kuE^uK7#zXDQ&yH-35+|lv zFg6d51-zz4i4Xy(u#)}DRB%(uWf;$N@B#3ED4vjth>+=O-kqSUZaUb1mrmV(*OKPx zUbfWo;_nGNYaYCKufE&&KI;{*Eumt|Jj?9dVC~&!w zg(@H%JrCtQG_+d*y(TovQs6xRM)032FgH?7Oj_RqSUTdtkpfgbepfFf!>mJ7_?#mv z%2B@da$EnOt6iPeJ#o0C9s;vzWHIkDjcijD>#lO*Wdg6`ch6i0ESla+D|nfdFM2Zj z&cA>Qa`)=RMz`nb(bi{!5)eltQ}5HfKG-ZBFJ$!uWwk+74B)efE+;QOSkV0%KwIP0 zzm@#Q?;&iEuZ8w3Fo=|q9N*q~dVO!GJ%)98acaRVygw1$(Jgbn_5Ou_KF&b+xGpGM zc0l!^1Ukf9tey~ZhiT(PN`z{^2I1UW`E!%nn&v+iqi@3xt`j1II4wpkxxf*NOV}?7 zE-v6@&`Xi@dmE!l(ZK;=s9Eg(WTo7$I_jMAuK@#gFd}#}xGT$ZuHXw?&ZMg~C`Yd? zzG_zaAzCr%;GHt_w2GFO9S`lGEhUn~19Q) zPmaFZUqI=-ZOe|Ai^@c)W&0naK4pFXBNn1}y6=av-7W>FPFlO2154+u;QBm*% z#e82Pug7c2qas8xef5@y5j?hMXZnSZt7??XJ&mzJdDVg75A>bHkhA9ldv<0mXXK|= z9}IDPaljYA{nA^1CXiDYwu>h!L+B4g+>Yu?yUx^=585AaCFSbU@NP%bV=5rP(c?@o zPjIQ(lEcc8?mK~@5M}DZGkdTrddIupQ5NOQM8jZk&uEO2Qp4b;}^9`|d zH0)IV)#YKw1N%=E&{e@;pqn-8$Eqg?o$$wv6J@6 zr)Njyu^?j5U3$gqk9aum-ZuR)dprKwfkO4fKzlD^Mq8~-b;fkBSZKgxmXHv9EyLob z?#E1(5lQiIh0BoG@8Mrc+W)Y9`C8tjFbfQ`zlZwQ1M%y*>{%@Uer7+)4z5KJu}b7M z_7`hs@t8i>iQB?Ce>F}cuY zE6nysUxn8R+Oo2bz!ap@otbl@(ea6m&F0}g_^qXBq4Y-__cpKvbB)-Bv$$E?NT}(Z zMecc5y=AD`pe|`DjC=NVwj7Q7-)9rwU9kPMeU50A6a$KIy?Q*L+fW^y4}5)P&RH`% zE6sxI19@|INM;^TmcEdgNUYC}2Bk){{xtv5H^C}Yq%wbI5Q7p#p#2XX`k{Y!qduxi zRoUs_K0F*7HIaRR{;nDUdOU~KcU(wn?~-ag2M9HB?h*zlDG22FPO65;dsRQclX_z$ zTtDV=NpS5ye8@{B3ad)1{&NT_gnc44B(23zIj5r6fV3MhImXHFccN1JPJy%#pmj%o zHG8eEr{I-Wy)bTO<84Y+8XdH?JU0C+30GV6@a(N>jAKvov0vNp2q=pFvMe?SJ6D-F z^RCt2mI_QH32O~~zmFbmUA#ulf|j>zoeU{(sVfft=85=ysGtIMd;|gJGu~@F;-%r;b z!sBnpo+1HXFEi4ys^M3UGIh=|em=K*Uc{^NzNZ4iBKSS6-t7$||6gv*)mK)+#5K_5 z*n?*OpU+`zt6Yt`-cELFYN6L~!zHcCG;wB#E1%hnJG@ssgx~!^c#+ew&Xv7VB#U`` zVFFxUHZ3S=GCuD?e4@#3=bnH;ze~S{e^fuMew-@vR_rZIzd^JZe1$h$4*YcI$p@#P z_n<5t-0hqTqZ#xOI=LLD{psvz3>z*M*HHQDb^|3k#Bl#lJk9M{koa^Cs4HBQ_H}zO4#fA&!RdtZ+GP z^(ajp16IP^JT58(4%4l7zO-Ze-1<$|6WxudKkB7%0pvhAiL?tgiNYl>r&-dhE+FCy z@U}~x=hGi0nwKtft_a_<<;wTipOC;>?T5b!erLaZ)c`fJdXf|WapeNI^Qyc5gG2ab zCS+$cFULTYyOVZ_bPvo6Z=-b}`u0>LZtHpoM`xx99ft9WOpAl7?tjZ}9KM)9(U)2% zs^TRMQwJGrj2b(~sb~3de;RN_I>d;9KnoWyA*&lpeb0XvaN&&P#?W<-4kP|+daX5B zN4#{K`nP6b37gr6==TcBhAZt&ap2lezWReu>!wD~ao8up3sM#%9$}FM+5a9poZs^y z9m)!%=>3NF~Q79hAP>8JWOV-N(`JLEbtsF)yc486TwBk}0D`0unN)mdK_ z|2T?FO+r|{S`;&%PkKy6PMnstJ9anQgbpI~?LV0ezwZkU4jP0&KtA?1#xr*}P}Wko za4WTnM2(0&oWqdakIVU_4$4yAYLw&B>dGEwlJ+PJ5uZNFlQrfb)@YnNm3R4zow~%^ zU?{AE#;WZSi-kMFN!&A_!=G^rPf504frr`T^nVZ33`73OdZa<@05qs?&b>+>2h3fL z!i{lp#W2sOf9@m^M*U7wmAyPfR$4isJ@jb|Z(`(p~a3IKxDR3Ge$- z2arMoAcWWfOUT#j1Ml!p?_imMq%AsDU1%p|{?UWct!jyWZGc~MA_LM^7;@Y;+kA!+GH|AbdFrZL{^%uBAfo(UPz8yBzav2M$_mrn}aF!5|#*KZoK7WW4mlwA`GabJW&KyeM9bou z7*4|EAEzk~o{%2?4{K)?*7O^=eHD;WLP|kOL>hhwh}0$}DiWfINK8QlL>SGe4e5{) z5G6%GRD>ZRH8wh>rDJptHU^CKfB(bxJ$tX~J>1z2w(I+RpZmT)pP{V1LKnU5m_z9T z^}>8X{-_52Ur*V!b*O*BBiOG!@V zg@@A=R8!}JxN)zElh?(R@R!4;y=y99Qrs$cFX$r(Xju0C!DZY})(ijcz$C+eFLoQ& zwy_S`Rs1#tRz#A&h^PM8^D5As7)c#;v zm4oW z#%0iM&n5oPIQ4mtgwF^gQV{(||JADHzdA#{xFc!^OQv@=8u5Vb@lzKtd8@IlNIx}-^0S?5D_MwOPfz2+LC?UkrtD+c zzctk>pUN2T1MOv>p8%lYbSUI*nwQiJ?B}}qy)Nay#aO{bn3esUc(LP3jKS{&OZ$Vg zJx$W4aPfyOL{;k9i=8LGn%?)fe1}))5vAxhzq<{$ zLXD!IP=&ZU6>P&)Y~S`Ad>Q}rDi=N$4}XQ^O4xQfoUUswnTi%ijCH*tV1zl zkcAyh!p+B{%2j9>Ha2@5?0pWUdD?^1OBtbw9l7sh==z@qyMD z`zI2n?3$9Oon$ixk@jlOz@o9K(tppOfAeG{g}+1?JKox>-)!6Z}I%Nd=SjT>6gw(b-i5>@UFVdf&Gv*TuwM11@58 z!m9b;_`twgkm~iU4e`hC2VdBX0!3AMTFxP2=nrIfJnfPDkI9A8p>h0SfzJvYHN=ge;bg&4LyI<*1!T` zn)tZ&*%Q28n@0X9y(p|ylQUDmg(kg z5p)J3MC5t)XpSmd;GAfnL2xsa=^9j~5J)a|SpSbwxn9qFQlL_LfcPpWTFTfKLPo+W zhd&PW#(B&ok2si9(h>=U=!1%Bkc6z%O_%~w#`?mS&HOfiT4mN3{_-mErX#)mh0J|$ z&BbYxj*e_k{TA$x4offfbryf71zc}Z5Q+JXQ0DtU%*MZz*v>h&W*9(A&q5~sFJcRx72qCg^kO8^Qo)#H!YDbF?Shpze}UgIU}9DcK~QT;(;R% zWlX)4SaTX{W5gf?`&m}Emrmpd+aRCAMHBJN2D9#an*y2E zzX3ywdfgP&Pz`4COw2!3SdqQY$*+fR!Ipe@Mf)Iv(r+=%T}@W24IcT8beBBEyL8t# zW6*@7#g{jygTz>1AVg_^K+Ll2nhyqNvL)j|{ro<0&6I}WD7kqkb|?YT$~^kKT2yxW zG)}b3@~!nNk1I z2bhA;cLC>`!z1_W`N^sc@Ub(<oee+8$;?pf|(RbdPgo$RuF2vfv74^9N&5KC9sg zVsFa8@y%-{NquZc-FTcSs~PxLKeR)q=Jq;4pLsp#3h6#TAMF}svZBl8I=u5m)B_-f zIVvnMm=e`~^ghZ#&xCwB4qOgR^VHpVNN`>WsI9+MLP&54lv&%3SxEO@!#iH=WlET` z1j-0+{uli(Ctnt2hqY&rdGtof=MKpwuHb*LkyPY>pZEy=uyNJr=<&bTa(n%QgImyx zCE*y2*JDsjzf2VghRf($+O;5+?&1-A)Sy;cw@d0~Oz-vtrGv=&$E+>t z8`?i!s@*GlL)3-|U2smdE1EM+PO7X3eIQi@%V|mOpt&!ia=feCjC!*d0rVRYeUii0BF?HEc*xU^TA9)T zK)bzE8z77$@F@Q`Dr;BwyFLTiupTsesWa%)t1?dnSPPoi7ivDf(bW@Nb@xI} zs@iA1rUF-+Tnx4LayP}&6X9V{JJLASyDE;Zo;9IZmuPw*&v*OzUzl8i%sBW3{)s@UZJLDIi`@1zqx^8+8xlexX ze7ZAr;f)0jLu6ZctH@Ygcj#4vQDP?pDBzGY-Fk+)9p_8*+vAfbi~afV9%WA+dG!XE zIP|zrsXNY4{5Cu7Q&YoNSOzP1SBT=KXhpW@XsoCgACZmroV%NJovbZ(!1pbzD5QX~ zQ;hT#m;?pqdt4?Q?no^WAr;h-1VY#3sXzCOvf&+Ht27vje`EF`(VZr*8AWxTxhQX6@*J~{Z z)WpCC&7>*?6;BZ}jC%oyrtxmixHA4@6R59eRTk7%3k1r&QrZz9oO02_-(NM#*DP$j zdt~@*a!+)}X+yamRLP2;?hve zQGw6C!9fi~MHtSnYrP(HsJsI^v`WK|0j z?xGh{u?TwQWK+06Lv>bH7^RPUHTbSMHr z)%RRkuV%IZCkS_<#Ex`ix7`vEE-BxLdPJjNaoH_kX~O2y7kb`>{V;8Anc+Eef`=%z zu-|kzL#&RCCakS!h&=XkUU)YJF{R5`zs-{qpPTQaUG>NcM`#Yru0|ba(@Mh2?;r23 zwhUq-RcT9qno>JYV_XNfDQ{j*Kk3Zh*Asy%cmj%bmClgCEXHDktW!J4tARh2yU6DE zFeWJHuKT1R3*bo%iL<-W-s?|tcUd*BpEpRJI3B#9(&)cWuoZnyPu;~a1*gL>ro_~% zX&lEb4RCeNg^G8oy^rSWp+~Q<`Aeb^4AI>?(LKAm?hR~I_YOU&)CLxXCN4^?AEq0TN3#@uTU6wQ_q@ol@EIw>VUlb; zA354bl9fw5JxmBDu7q~Wo3D=fQ|h3p2XPx(c8l#$*rIO? z?|nMY(bSkAJxKR}2sOfaNWyY_#6)Y%P4|kOkv6$=0o1O^T0sjceUJvnx{3u>oA!r3+jrjMWO z*~o{|#~Mr;^G+n228;0UN^pn-EjE``Kc``JzJez^HN4ZH?W}g066mo=Fay^aF7hMS zdNsx^gu4U=HlQ812H)1F@!me?f>yh2<8Y$uU`n*zG{Fh0ltHf0;Ll7DuloxKC!8b7 zffP_0ktNtERE*zn^JV0Qw4};Vd6+jUN6-msISf7L);}s ze@vJl1s`Inh273O(JxtWFd~*~h+-bob>qTh&FdpG=>hTk!$y0A*M;OIa)f|N$>zN% zvriUF-TR(A2cN@_T5^6@sI0pLu&>Kq-gKLp3mohuDTY?5kW7(kSAs30A@@n*BnZ=9 z+}-)O{pIKYk$vQ1{t8Rr_pJSIXt`qeEG#1Q z0C2W>QKPgc33pMvD7@`hmf@bW6QRbH{8#HYT5=$=S)_jOd?J!&p}`m+dS+Y|od@>t zZTCjm>E-3FS7vP4XHQD&b>j3sL*ee5E^A7Fr9N3pF87fGb#p#rY_bD z=2y0%KC&Ks*u%3B@os_lwMily|-v&S>d@ zs9JBY53B`K?^-G=4}4lYFj);^Pa46uv*7K=&s*4pN_Gw(V^u7ZChM7o1g-&7?=I6H z_i}dWBGYL6X#L1)z5Lt<ld+1;Nd_(8=n1E=M3aqn_K5jB_;^S~bV?=qfhP{1AD zQwCCHHz7~zY$2PLwEj9=J5ICM6}gL@dc#tIE}ObBFY40K;wA$&8|GVQd(Le!_1Tp6 z8Tw9{&TDZ}>;|xhRtjtp;BON;6PHztDcx-Po)J>>Mt4%KecGZX!>wa6lGCfED zaiMl9TW?2BH2_42CvV3@$DA?No#@6ag_Ui^j?5=|74k+(Ybg>Zw`JLR%7$@GPnk>aPx&s?<(i37s~l~4<`e%gs7vOaj2p)hKrH{ zdQaV6?>2nEz(wRB)h-0;hPk0j$>w`=FMia;tk{ke9fAP!lQ#q5h_q4{8(^oTYV6HyWWHrJYIAg zJ$U?c>{LILEO$ypo?T8uOj_mJTzSj!x$$>S32L1}FKHKDI3F?%s_EGzf8yAUy7-i|R**@{0Jz?23O?jWSgM~3sK z;-slbI+-!MEJ=iWAA6!-0Q1t&OuKpXg;Tr#gZ}-0!NC8YJ`z#c^Viq7arSJQ{lpZ! z+|AUtxL!8!6PG(NL#Vt28A^P1Dm(BI@}FJo;gwrX){><+ho~Hhj`c;T?*S~Ewuve$ zVKa0e%3s)b{E+QZ!cx9UcA^i~EC1=8gAF&%1z()Zy`;)kht<07Mc&m7Yr@i10rK>D zN{1o}##&om#~-|A4Ugo`)gkejmm4lrj$qI(UqQ{gJtO-Aua?48jYA?H_5(qlO9h95 z8I|!Ag@=mpc{eWREg#@Zqh*ecD1SNX;2~#Oof}`%?2habn6jh7 zg9G@Wu$h}r-)GAyNI%%nS*YV!v3kx>24>c%2el73;aHbV8-jTkGk2dZ6=74lpQpW) zw)4^3lf#L}h&HgpUKJ+*k)xTYqTNMSB;S-68^!76f#1>zyH7VJ>75z!CgMGVJDJMuQ4VfrVbM?b#X*F*jS*rs?1k`&+oajH+^>{byj&_X zR917u9t~_D!JkYIBX9JTX|llOe@^%NY=dY#j(}u3nY;xe_vL^JkIsN znSZeHbO^v(=71%Bsz@6bFfGk9Y+U}$f4{{=Fh7+rE;(xDA`pq{8 z51IOPIzag)Hlg64;w)x_Ut?o9kuYf^7;K~A>4YI z<*x)HBJ)o=qw3x#?__bW7Q&`uT)$gPqjpD=vvgXZF|+hs?SX+%$&-$P67VHBzCVjC zd%K6N-GlAtA7kev5g&=c6D&U{>2t((PCdA=ufhn0@3MG71-IH>ps44?!q^ z&w@Gl0^jRXk8C|V=zKJaVScFC8SaaOU!0CP^oH=}iB4y)Ik;6VM6c01;uE+2D9i1| zbsX60Nm$s~&K{wE?1-Md;(mG`lFUazj@yW5W>Mkc=jW{|aiyt{ci}rq zeV}f~3g$}T=IcENX45r|fLB8ou*ucg@CbVEkQWnR8kkZKy^QT|)ZhP&?h|T8UOCM) zc)q6gIWrvY*Q&bi`0cpec*e5l%-AUpHZHj5ee!h`Uh~E-R&0_FKDSjtXh>P2pgMbo z_+4lzUB+>f;litNk=|^+2DAla7|R&}rIC@QNEOK;~;CXZj{0s~S zMu3OQkBqHoRr3nOrQeF`lg)BU-y9+a@zxvKFeIg+HSO`}gah%NJ$%^GVb#j!CmWt` zdRLqp~OCq>8o(#^Nm5B{4yc_<}l^c5I{fmTd^&YVz1MeA|C}fFU+$R|m+e1O8Ed~Tf0oVlZx7AYxplrkXzKd> zjT7RP(`%5{#Xnn`UwR%MZH9XRNO-S%6#Lkgci@5JMdN|A)Ya2PzD&;lK*!=RSc5pr z{?(wVsYvm6dT%6BTAwR@(Ge>pM0KdI6rHr(0#z#>m3rPO^E`jfEy;Rhm*TE2A_ z@^5VzGR`L(*@91hFSa6HKFDy;tTeYL{0z77Tj-p{VfQG*+#G(=W zDSMh5?Bk_Cg8kG#7(moV%j{3Qk}uhO-Z)(lj^bW?c~U8dD=fXW#RL=3>29sW#inje z^Fz2Z}x)661wIuOy-d64j~)9!8!3zQnDh zU}t@;8}$Z6g(<-2l}DA;*|l`=4x+4EvsbL|Q_zy0UeZ?6iPIL>pNZmhcn~{pFUSvD z;@kZ5)8^W1RlhF-e_{=Slv|t52kpQ2kqLU$y0FGoCuCXRdS>(ez-$EC@SfP&MPB`7 z!Ly5+%fSf~8nK-iKX?Ir+U(>d;ZE9my@)E9b?BQf_n+FncV$C&Cr z1x5>{eJyb66?O`Tl(l`R=ka4O#C|FF;gs^B z%0KQz83gi6Omv1D>BGj9@ZW;O-HD!YM#6-=*!x)fMSuqL@`ckih?3n>FYadxyZE^4 zjJO*b!MtiF7V_!T*nn&nDSph-pZn6{ePOUb#m0z+F5N)PEHQ%h@2<+Z!Z`0n4%{u| z^W4iy0`%mJXinmDb41DgjT@P03CDDDo2S};m7BLrR4X@Wnh7#puxgfmyQ8b;wx!Ov z6|fHad_go43;~PG&SDu0Z%j|~=~yV0o-bDDBDrBITYI5DO?LCS$70g@9=STDLD}YQ z(cy7)nOj%^CR)rU_!vRjlj>9*v zh79i4a@_#ReaZKIdGW`|-d(>HRZ|b@^S3HSKJAP&-h6dSxGbWlUjcP}e)P!9#?qqC z&cu}1u^UmCU!&EQR#C|iKVMb56MHD$nzc#ERN5i`JFmh425_zNOIA)l{w2eIH6$_& zA=mAfvLNU9U2*~x5yv%4Mx8BCImkqxrTRA=pNGc1t&y5ZpH$5&8$U&Cn>pJDDKZ$x z9a2~)pW$zvb_c%;3Rv4FFw5W(mtPFR(CgOlO-c5Y5v3sII4_*ga*Q^&He1VfYt!OP4;6ohAr?`i=IR<@T#)2ZW~63SLJzy*inn+@d0u~^dO)p z49=<|1;;dSht$#f8h{mlY;Mf3ul@xA;0SY!$yLYhfEQ(bOjk&L^OoP=H8^BT!hF0` zuH*4z;ru)K-}Q&p?7A*Y*EK%Sy%+G)7~y>l#tX?`c3q~oyu z9sNpf(i3vb+|CKN&p(l~hMMY12v7cS3O%Xh+~A%bNa*ylQKkd;`|okH%TS*%Z!fVb zlc|M+65)@GSLCu$Di-`(pzX8B7mgFV>LnXk8v%EfUi1XxxHJ-KLz9a*MB#X{`(0bg zUDL925;<`2kNEnvx??6dP%7VjTDzNb~hgJDl(VV4E}m*)L*7gii_W)7KOG&em^ za@coFdmsC6bgN6Ug>ATb$cv;r{`u*}^#IRvBaV&_cKztj>11ofpO;4kzf~9bsXD}; zM-`RdYrxcv2c!eq2T1Jv+?6&^9BxT-lmQEJQ?IT&P2rM8YK7{vMid|!{oZN=c~9kI2#t@NCJnz-W+ct6X;ACibCK07V>q#41*Yk|D&G^M=k%H0^ z>c`Zvo`hiD!`R1S3Nv#_fiu~r*~O(R#}?yv_2|}1!%Mfo3Gnfzx6D)>9Q85PeNAnP z*!_thu$JEjQj(?T$W8#kpYKynl%`rD(HpQ4fTWu1FCpJ#rD@GJfLAebyq2l9^6S44 zS@+>RKabk%g(4zH63bS0ZV<;v+99EF&}>@ijr8E~s;~UJ5+6?cR5(qTDwx-E`w$Hk zYn+QhXEaybfDRW9Ul3~D7UY6Q0JWTRvuCJrX6?G_K|ffL8vD9Gw09JaPMJ1;42>umB|-DrweA#oF%k5<6WobUT?K1JZn)Up`bPb<5cu=tiUli3mN2%< zy5P5?)Nkq%Qoxc=7xB?KDE9f`hdFjT*gWN!3ZEJS{2CEk8eJ}`i?2t-{ysOQP%q;c z`=+dwsZ*gv@lwDyU4I^8|9{yiYMM7;7g@;iDx?Aozf`st8eiP2Z6)TUeS zdG3&v5Ukot0EZ)Ufs7yVqfwY$M8FW`)QI{@E3YouSOhJ7RJCv6o9r+mDuA- zXkCimi~6xJ>?drKPJB=GU0vMsraY+v5uwK_S5_|PUe9?UxBMYYjgF(M098ni_yxvE zzVTl<(?amIZk@deeQZbdz-E<2bbh->-CuLTNtc=5KwPun&AA1kRh~-~4xJQsiun{la4`ZfcL^L^QP%ko@T7dbRYc=I_dE95}1Lgtb*EC zqDl zK7GA87=*lCdx6jq%+kW0yD=Kfl@Yw8v3_jUIIR(+r@_4gdOJxI2X+>+G|P4t($xNH-25( z8<$5Fh>k$0$5|&Nb%_F^V}ktvWKO#4mULhIR2H3ob>i<#7CUtyZZ}z6QK>?ciQ|US0=&#?>tUF@aLqi_! zD*KjgH^BSb21ii#(6s&G9il&K^84vq*BQ%Tp%vg`T0lzwlrzQZDHlyvAMlH5LfnE} zwwBB7awqkZ1-111DU;18;9sprXHDs^QATQdQbw-xQQX$j`;OA+kz5Z_$e^M^)1l5h z+oo-~(z?g}#?4`70)=khcY<&C=k8tkv2j3hrlr`VG90L&egdr*@#`&KkBNX;@t;=Pdn;iL zy0;BDM^(6M!9(4c<#TNvo=uJit7)C3L`HsPI*kY}rmDlxY0k8Q{AbV4gnoYg3B+S{ zmk(a=bgiW)iu?k7gM0GN2mLq7kr%Z6*r8fiMjI|b=)`VowJ|wt0EYkAi z(M#hio||JK&UW0-!FylxSwi#iua}w#8rs9lo)b({6^JV2fRci9*su~E8h5G~Vs8=( ze%bI7dZC}G{?b9v3zM}t)|geDRMu@O54>h?sLTh}?S0ypdsIy1H6gpk*N^6Xc0*Ua zOMiH?plr!QAalS+oSA4Cf|kps3OE#nDN2aFT(8w#vj7ALZf7Kb7T2WmgUV4m8Pl0r zBqzO?7PNE1;dzxUEq7gHX)SdxA@e|EDZpj!pzDk7KntVBCSGn#WzjT3Y}ov_zw|n3 zwG$dM{cBEErOG~)VyzX#L33L}8tLh%1=ZHbjYR`172?6;>kG<9d~-`|lwOqiZcxIp zx0jJ@(|c;zyiz12!~yiuAtn5@B$b>V#Il>xUOaZ;^t0yTyF+{)gMg|aO$hQXUi*n1 zenAPG&*t-6F2mmRmOeW28+w8gxP@dp91G5y9VZk}LY@0fu4DX&T7@{**0~$}lb!q>xO z9IEgrZ1+Q>ziyp1?(I9^q4koIV5Zt{cm`(AY&BbP+`WPJMU9%`cc68D5iaDe4z3(I zt0F#iiOYL!TNB5)j^^_8Y2@p2% z@bPm{Rv}H`P=@-*`X|~;jbX@)J#|Q)6&F0nNOQt7LFH**=yON1E4EL4_r&?fxTYV| zpUa~FZ`;D%5&xweYQ&r*$jN}eo`#G!W&2)8=6<+a5TmYjroi{3YbuUC^iv|0WRTc_ z##*SdZQdI|g2f&&pm-mM3fUIR(z9~eze>aUG}BS#QnCd-F|Xiy$wFg9=`oCVL8OR7 z5AA{1$nJ~S5~}!*pJ8$7H0sBnh;QF(qIFnDKz~oltuQkKlf5E3KA#|^837*p^1{pE z?Y_mhmQJw--on}`rsqI{FY-NkU45Lf+{&#basdNfU*;*Uy_a4bfAD!){4a85lqi!V z7BxCF-_Jtp<#dn(?qbO=!5Z!@D!X!%7W2G(OluIPGLfRh2iyg{vBn^ws*o63GK&M7t(f;F94+ z9mjU~BeOp|O@!r3raUPRV1D)sfnGydI9vsN$PXAdcJ;*(g zJ1RCc$K4U62}Y+a4k&SKQSK(0-$u1v1dk(Cs5CF^V?h2%mqOWvh{D4l3t4dyv5o>i zF-%ave!P!fv(N(+{?*g$eG{8JQ@+gN7Oy`?2-kE;GCKIUEYc) zI2K}U92)cWZ2x0(r?4Bcf+els=F79(UddV{sv-zX)xbz zjXhp?3rKZPXo4+p6}PPZ4T+yCx=312{snp?LEEzZ>JYeg9jO-mx9HP| z>hGz$SOxZL=RB!!bwYGh#|G#JXAb+F4sy+=|B9oU>}{N(pxA!6x+6Y~E$fnO-aj{@ zT5MTR&9oCv=PFBxfB(Gu84fUYr`su@Q{Ct*Y~dF2@}Lq(<^NV{R zDmb;jhVNqVT_^L+1mUg0O4wvtZ()`3fN)5P7^eKK%m}hLaCJAH>Z5j%Wc~*6L+LQb zDK1!Yc}QKGKAU%%8;qBD`*&5T-EDDkbDn!`6~l~0)$G+|_o06R{DC2J1{OPPV$MYk zn#s*;6SqdF+j=55*U#l!SSlv!H`i*gGid6?OzT9lQSIaFqeRXr^5soGo6SXR=!-KI z^%vhh*!83-xAHCN%7{+c{c(sP^H8Wa96%3un-DPq{e!FS3mtFcRCkUmgU*M*=Pge& z{zG$9g^&l)z5^x`X{<@~u3*HU)mEm#x##1^X0iOdQ48)kvMjhjJMvJNhqHy2+_W`Z zML0Ws?DrL&bP$q5Piek?TNBsZ{7M3r0{DlP_$M@0U*6qZi@STTJeb=mT{x2bSt|jl z!VQEb2f9l={6P^tk>ohkKh5Xp_wg?zroeCZDqj}&t67-N{_Emg<#@d$T;l4vQr>lA z0GX{)q0Gr%z62a^fEA_u?C)4h$Aw-dafIs+{vi zg#ic=`{Q)seo_8`kwu#PBD}rj?(~7&+AW#9q=?jow898O|H_5n5>euBA+pkR9q&({ z$&UPn!XI@fU+8wOIMF^0f@ACPuuNeG`i3UXeltbEM=Z4kU@a0@2@`!tC|^@s_hYIU z9|%J0J7)SZc>h#UT)aX$t(uNHQAaz@^N}$z(;2l~4wgxa3M%ue;A{Lqu_T77VhrIw zK6;zpe^DjC#GaI&g_Xf?*iX+8vbsHeEH1o2y~q$hw8USofIscKP)fF2Ga&@Eh-NpT z4pr3T3hw232w4p~hbhYLj|DC36*s$O?VP;s1#2$uEa@}Ibh*W8lSM0}pc;{CQd;jvY9zmzv?hQ=l;s?;SuT&nKKa;w7r+ZJrKA941*Dk$F ze|B%v<7?RU;VH^04Rs0p@#cr2F4|9MzoWKh`KLI)I|wSY9p-_yd#t!w;c+?M3{tM( znI@Ffu{<(Zrp`Ms(|ieQQDq}@vGew`-(&`B-E=HRW(V=$MbMhH^QF_94R770YQg^e zkPgK;F@%@F<*m2s(XL77I||$H--&!Z({!6#`91qt==u5+>BWHZoaoS3zuBoic*&_^ z1s)a6hh?{qWyE`^5R&L=tO0U&K5;EuM0mW>uH`YI>)P^%`yQ(1%M;i0I-I~t%R&RU zEWbE3RSWLPHjimdf~H;NxY^-Le^_xWJRY2i&` zqdWCVZ(N@o(=?h`rLec@4~e2>{NYjY!sRjb9!w>*vbsp$Tw++ofBQRD8h_of54q>k z`&!22%e=jEl)BCZN9U(2EcS0c&a_{+8KRsYYF7Uw;7=6dJ6E8`X9;Nd&EQrS6`NWJg( zPmNU0^C%CgQ25p~IF{q8Q`H^E=^jl81#ed7b+^1+=g*I=mgvhZH4N{tpk#FYD@RmQ zrrtikw?Ob)EA9rxhr~;p3AWwc;8CX*zvAtAvVs{_KGOr_vGo$C4R5kF$J~mDv%8JA z`cT+pPyXo#E^gVd&C7lbo;sWT-UY>Ker?Kn`Ntcw(Su{qPyxPL)d_{zHf?{mPEIh% zAb3UJcCdEf zHD97T*1h2J_v4}_(E)Ayqg%}cpx!Uf0*;5Q-P91 zxxds#S(4AssBA~Y&+_2xPPmrnHkL!p5xQHSR`fa;1qb?tsRd5to65oNIC^aO{-hMo zi9KAjB+N?&kaa`qQko_=%kue9f0=o+;^ye`H~&RIvLYSU+=PxUHFU32(Wg->g~?&w z^$Y%}g*VrW!doE_8U_);eLrWU?u`%*YbHj44l50i^=87ueg z?!(qf4XsI#ECvo;R3j&YW^RovG9c2d5n6)f%k*0#)=yti7TK(>Xhl$ncM&@My%`@c z<0*}nRL0t^nm$0YV2ZP}RL)!zaY>Y9m3W+UcDO(wulqEuD{G&Ydc+9g<_88I{}m$4 zH^rs@nhB{|FCx|r<& zGj`SoEWVUmv*H{bmvQvY`xie~E9dLJioeF8zqW{%wi1+5@2zJq0E+LR`jP+HF@Dg(7v(JCUyPwQmO`tbh1ME^GjMR7iy z?X<6PZgn7jbB@JhZPin1=?<3W5Ru(W);tT4s#lZ@lj1ykdbhn88O@hIb#lE@Q}n{T z)Bc+FlN~5!_0)5c^cA#=&0*N64_$uJv#%teGSJnVX4MZsrIOYK+OJs-zuh)n^|Ip* zL;2)B5VEuYKy*mfDN{y>AF)a4LS2D{ZtS6N52!y!)Cvy_nlqcC$>j_e?5o$0TB%Fb zKz7#7H@8kJ8(o?^81PZrVX&=k9&+;o?HW=8qfT;!JKQ^s8l8C8p@2BK%n8$>Hb!1& zg$ru-w$lZsa`ox10r?TET^<*nMW6KKI)$kqYH#Q^7LqnM#9Lf?J1XR>Tto7(<|4J{ zxrZ3oUgo@QrqHv7@|`e3Dkc=7YY?_?XWw=0+q1{-b-y95J6adqIduq2P#4do@IY8t z*26wO37ZeqT}It9JrCjvWpK6E%CpNYEefbtgP&B|%DK~BLq#uBQw&Y9^DAvWtM`L7_``*tHB3EPgnbUH_2M34ZyJDa>A3r;$HU-L)bbR!EmXbid|&hw5wL*!?;$ zRe0*Gr+vx%g=cW+bUA}&mU!65Dl49`d7t!H8D?TlvB%@(`B9s%u_?Y5W>|ecdXCpt zA&8oBNRe5N4$(UYzDdYAusFs?IQLhS4MotOD$U&?RM6Rd{(M>x_aW){#|(|Pp?Z~m zUJ{SA)m?VHqJcW=K)(W6Xdtt-n*}B@707{|UPkP4b=i&>9<`?S&n-$q(Hr92X?r$8 zCp#YFK_zWPS|b&Ouk`C@AENQw)CY1vJeU zx|Cagt|mZcPp~&^83{Rv_&GXpglxk`|uO;b^VazCF1YNgmL{^nz2f)Km9Am?N~6 z^&c_7+`inWqtn~c9U3&1wZi7ONb&sUd`aj@Y#Tu$d7Vj`Y%wl%6=K|U9i1Q%q{Yug zwP=sY%8s-s`*rnnn*N8ronqQsur6Sq3PcD}`JeWL36q^HR^N90big`4UY7nh@S_pW zSb%av36^R3f4ybimI59t>;xBWR954WfOG&q4xTI7E{j>$G{wdf>+z7V@; z9waI8g-S=M#`MLql;KhCpy_borT}ifOgmeoAiiJe)~6(>AO2m}_f1_PiZsIgE%V+E zbT^qayZhS)$Po>D7WMe2tw|y{gGg{z1CmdF6Kst}@V}J1axg`ApEAMdiV$c$c z@2zwAgn1P%1Q#Mn5*HJo42=w{|LYmMt5pB~j{W(wo$%7!rt?%F{Esyww+=qb`s`le z1&W#ewsF{ctZ00;u}U`N`SY0{r7JYO*q(>wD?23g3iIc)U|3!NceYGiOvo1|4 z^^Q(46J~U%wGgt%m0XGoH~0PYit^()e$)JS)`nC8@vl+v%gf%%EW~p;pr_^oCX4Hv zC2CX@94Ved_Yn%cT{(btx(h-^DhS{0>LQRxH%+3FTV zga}A4M5OP9NE0B5TLct@D1DoV2uK@xq>T*_rAcUnNSDwiK!89(5<@PUEFDV|ezVez&t0rkB<>_5Be8b8RuWVIt080G8bNN&_kVam2r zhOENfF|w3+=aF-`qmirajsYs$#D3b|xzP%S*luhxiCke=p8{K)+|&^S&{YcB@aH=L zSy^3K#OJZZcp~B^K+l!z_hFat(ES0~iG60cZsTb0q6jyeH6AvXkXdyW?(@BPYj+Rz z18W|AWIrc$k(JQgruJ`B`p1))yhL>C3zj3l;L6#yaA3;*g7cp*sZu38f zwCb!B$0!S*b@yO~H)9@wHUrWhAq1?*8Pk+r@C?*^f!0_q$2-`&b&CPK*G;g>RaNS^ z#XL4OoJzt`5;;#`q|me5qmkyZ`_7~a5K6)mo(t}_BCm9jstlrU@ug(NBa7`CM(`Ht zfl1Fjiqg-0biKmQ0_oqc$zccTY8ZZH{5mZc!*>Pywgk@1v)cuc8NcMLyfLOP2*^9$ z=JSDMbRym4T!c>5$j6|=e*qJHqPsF=_IxwH8FGwy>VC-KZPKN%w|teM&DzVUfeTXA8%QH2FL!OM~Q!#bR|n^^=6Uz^D;9p_-!!^A{KXe4R2P0yP^|L#q6d3kpx!n zK>Q_KbUfG%+U8;#5WR2bT<(&ojNuA(gmjW^i@9t5K@XhQD|4@#G;~Q0WpSYw+276Gf%5fl6D+00&Y>**pA!jz<%7nTD{gpqVVFNovuMT_6wV0)PyC#Bz_=;) z*9Zqf8xN61iaUhZwkK#=$!g2_Bs8tB-j;vOKQmRB(W#X2&iw3R@x?O_727X*8f7zFN+{ZTh6BbFbT8=kIRCkO$o&Ek!=C zeL`Ul{3-ngxE!$#$zbo{I; z;nVuD?OVaN@T-`X-7JJHvi_e zjR-C65=gNz0d4`Fd^wa6m z!yEHZ=CSPNE5YP_?Q$;|gh#{f$KRM1HFr4QqSuW${E%t1w~=Sq=%;e4`Wz$5 zHeN<)lB8h9R-&8IDrcrsl*QPX)P>XKNGY>B^DFHT!g9Y`zj(RfuPQUzlMz+L8}4f+ zsY2bcbm^QjrYhmA``8q^SU=Dl9ii6o#+V+nRXz(D;K-&++ZF{6ko#aj-8U&x1O|b1wqVYyzoIIgrhLT4=VVrJ9-&H0_F1JFnTmE ze9Xu|GF}uNhUaey1J~K#yYDK(u7{ji(@8>Wujh?S`jYSU&rVfr_@c7P9glZ_`*L@y zr1Mxw^YqIs*)D-tZ$O<*4nG-7UH+UjDW0N)-lW-);;U^4&Qrmq%Mr;FlL|p$zkcjE z@GhonW;aH(f>^l`s`Qf;3O|@*qBg_8Sc~=WK3y#&n>LeDrFhf`$V%Er5T7;2Fs&UTw zi!$D)3e@QGTG4&XJ-RfTxZaYmC8$;On%*?9A^47I>IjR9{T_uqRBOUY;~Hbze6|GQ zN*o)Mo*58p$Rakj_HYPE+vRLZl+bmt?Lrj7C7RWLVTI!bzcGNA_Ev4gvXrrjx|iF} zR@nr9XCB-Q=<~p^g?Y{b9kzt)8i^F6GN~or{<)_qo`N&fQb9$+X^OX{?6T2)iuSqJ zD=ZnCPCqZJk(2C2?`Kt z+xG|h7U&u1771G9^)knDj%}eR!L-3Rif_GJUPY~-z4ayD+lSm`MFOw6Bsl)ktY1Es zi$#f!$dm@<6&{4?0PQ#UPZbm26?`0kKQ9b3YM!IRd|eI>Zxd*PyqO7qqex?%UIf(m zqaj<-r{fG!O%tPR^pYw$DF`~0Aw1-v>7!`KYzJjIc??l8DTB;bI~?<~AImB|0%;r2 zgszSq2QQG_0w+TezImg3*!udZNFgVvRFxoIZwPp?Gd_yF8`_;BdJjJUbS{yZL?cEW z;~a!jK6c5gXL>9_7ok!=G3eyB%Z(M@P~#pa6~iH_PQ39)ZW3~Vs($$L9Np7?r%|b( zr+_^0fY{y&$!BwhZ{gn|4VXM4#B|5iA9dNl_mlrog9pZD0~J>dQ`;O;sN$_|jyY`F zy*^ZYNF&w63iWWUFDV_DqqEb+9M%QEUyKD}EB9+gHy08D$=mN-n>vDXnROROo!6Yb zKKV!RU0(Dc3^K6x<>r!4iv>A3X@r==gtTHL1-g$OwipgCk?a6hSk%u>-6G$3yHg4a zFh$dNfiq!5c)QE*ULH-8xw(^3Vx2V{yETlQr``*CIK#~&D@5U_h}1MtxD)|hJoydn z&N>mmjY?nwP&rAQqq>BGx#qeij5jlv{30dr)aWH0ycmO z?dUgzVEHp~o1&Cxz- zE5mSu8DMdg(Hr>XBwVNc&b-ky5C1zVv=l!5emOxNjQfgKxj%vR6 z3q*%p0`B;a99>w@gLrH~CrY2hw8QxkrEg^mm?IvJgV1Bi!ecOz_Oh1q;LgY1sVgVl z`z4ru)j=aek;HJ7;q6x2bb@OI66^cS$T!JiJL*hTtd3(?dQamYGth@gm*j7=_S$a? zsvQp^g3Fh0_DcWAt(s%%NzBm2Z?u1e0Q=ppEv}6LvimsH(;}ClbzwTQvk--)kCiJT zQUai#4Xe^ORzu^~v4I-=E_w2b22ewZqlVpdyj>z3& zI&a-8<;oH%(Eaql8LIAe9ONi}#=^35Gm#HV7SlitwMW_D#lsN#47M3YV&0boDq{XC zH$n3s;Fl+7=yZ7h)fCF6?m9Ksa{cZ;Bt`Bf_PsV4TREw}6AJviKL6Mi-8}Fc?k6Js zWaf2Ne`k{H(0>ukD*fb9r6Zdvh$~@J_qgarY5!0lq2jJEA0@Sd$2A}03Q@D+d2og; zq-f`l-Gx!`$2ws+Y-xapj51v;vzGM9myR~Ef)ZK#$l%$MT9*I%OGj(oxV8b|%i&+= zv5gcO<7p8O8gU(n%k?#7w^4`|cvItvA)ZJEX4H!I8D81kzMyv?aMz-ZpRsK0pY&sCm{bu{hfZL8yqivFPlz*nf188i%to4)>~yMT=QZF5KpQjCkMvUPL8; zv6=FVVO)6OO+e2n>5 z2`9B7hY$&$coM6M)YQ0+pGqZBQEZF*cGH;X4(omY{Junz!hqHM#QoV%3@J_d;9eQpz3yQ4y}3IH2?j z)l^m5Z(B^(SWA1n1NU_u zT_99Zi5uh-EsKYokPVe;qwS*y~{{PMFxTx5>#~k)0mZMf3C%zbN(}b>tCJd zYXAbZ|NH`I%-HxYm*_ZaVb)-LLcT!Uqt0mamU0y@Y2xx>2Ba$aO0*S_XC>_e=Q(XD zT=S1AQCc4NxKhyUkx|Oz6Hn#+I;SsIx)y^LXHW;cAlohDB|+&JXNW+7>SC`vM6R%F zE;1$~yP_I`rg8b4J(LhUZi?IT#4e7Ch7C@o?#N3jx0&bZ?tZSr%nAh!ME;|HNIBG& zQJ1h8majz_dfge%6zmno1p8=n3D{;DpW{T1Ww8CS(o5PqCscGY(@1tiTewkXUZ~N% zO)8Ga<3dYc2k~R3=MRV-2^$DKA$096+L7=<9A1?TbSR}vR_Q(>qX41`_#5$L|F&5C z_iK~o2|gl!fld~sYWCaO63x>fb;{XU_^7Btv3D^c4Qw0jZ4A`Q-ps>FXX*CmjulJG zgbK)-kVW2PN*|am*T+e~>-nxnZt_;g(Obr~6t-&=egvg>4}NQ)TZQ;ZU^fVI0+-&- z$A&X_x5Carff-|GC?7%Ny-M6@jCB~elzJzoe4V`~5Ky%KQ|SjYBaB|qyJPDO3dCUYmnci9iVz6{>t ze1xVoW%jg;A$bSZ8yDzzyiykE%o2&8Gd%YJLSu>NbtiNuJ!+-7^-qox!0eA=ny>4u zYDQzqCet9SZ-Y!Uh;B+FRcSo643w=+XES+};fABI18~=!#CRaNvok8Adc;M7>YZcJ zGu*0Egnls2R`1|+O=NtCJoZL@k(0!`W*R9HbVFgMn!T?hnVkE>q^H0X67vM1wq3~vm#7<%R2hdU1-YtF<7FuH?LS{TE@ zsG~lgMYE145oFfQvz%s6IEDVtRBIO@!u#PaLr_6Zf*Jh{+N&KFCQowBMy2I^-;QoT zAHCc+7$y_`VpT^s;2HwdF@I8l@KLFVnb=S2d$}`7eESJ88ND^tH_-z6rT<+a@Ub$(sEY^i?#*n_#+93Yz1NU@VwA{TLV%b`sV(uK#WUEtT{^prNppJ?7$b z8Aiz7NJlki4`#5F^_wZw+h}v=btOK-B58k2>ouNPY!Uo+mHvBe&AaMcOGz?yBvOhW0fqn<4XZd^FDA9YYG$|B z?wIcHkr|ita(s=qsi7d3@(U@O6;biz%t@38OZv%Z=~$X2Iu&e(r3jP3Uu8b z(LAHYGBif)8%2`~c^|z9!{b}fR`F(fbaaDrF4tW|oc%Tm``|4kT1#eO!=6_y+=W zF(GM$wx{bRgqbjD!;PX1ex8_g>moFq>EzuNX$VXn2*PACM8P=nj*U=Fl#b{HE}|JA zZYlr2wM#c2yZQ>(7W_pu=$OB53Odh!BCw>Ec@2u=_)O;GiA#A8@^7v!?*rh!_qBQp zgOf}9)I-yWVzNebhR9cdH-5L0a|ha)-+43L{yA%n-SyNszU2z(d*ACrl=$JoD~ruu zYnW0SZ2b4@+d`e9&%Y{TzL&*^IF8q*V_%I%n}$4en2t>{>r8y~(ijtYZS(<=4=|^G z&{nLBet<1czzjxa@Q~p;b*^@z@50MLJ}jOQ=^#(F zy@f|S}D`sQ1jqlUJ_y(9S$!@lKTm~Vgf zO5=NB;nxYc?G_H_PP)dZH+`Phws?h%KE%)Wb!1VjdcYl9uxq0UkA};TwcWTZq z-PT;YsFRpA%VJC3MYu=-#W0}RkcwxH`cy@c3Vgdnj=T9tRH?DtZamPnv|DUl9I|Cb zP7(UI%W)wwSZmc_i*OhM&;J>N2o)aPQX}pDpE%YD+`;qZgxo4VfLmce>7jTB`t1zD ze|Lj*N`Un@Y;$^h>J{2#{DX($sB}NqIGhC6zKzli>5VAU56cjk%AU$zGBY3#^4K^VP>09he;H+jARpe*ArRF zr{AkZo6h&rBIP{PU>jEIh6;Ky)fUU0$vx40jf}0)#(@?@B$J23Qf+pN{5KyOqKNIh zl8!BCM3%iadfvV_qFYXnv8^MOoNI+Op+gl?R}2zOyUR`XTOkTH2}~c@TPkdIFq?7W zdO{oIQ^%T{K}7$A?&O27?7lfZxfghPh)g#3En8L6IJMENht)#7E(`wji z%KQ-nY$bFjJQOb+f(lnz*6rqY)mI4|hq^T>^?~LMW=|t9>-w7tZkU&*A}$d(G9=i^ zuUE7UWvggVcRnt>5ovhyPo8i^yd6Pl@)9!4K5my*Zo_wYgY6MpMJ%A49{^l_g@)$e zNgGaXMAPR@SoYob_Cgbzb6iSqsOKv7Ed$yqupxW>HLPek7=>g}Td}J!NDi%PBZk$h z&>P*G?gWr5hnWclJ`sOIer@k8@yY}$=&CCkBl$$COaVCS4s>rlt(H4ZpQ09kHg71O z$xwq|tH=q@A9FOypF8Ad*^&4`7{QX#CcGZrY*?qFlY7wKEF<6PO4N;)JJV(#V_YZR z5Mtj{ftYSG-9^6u@Q`PNakEZIb^m+-45sMY>=g--S;1VsXQ zyArCCg{%L3qgJ7+!ijo5p5VA>+IPgpx4N4Nu(C%#yIulf^ZP<6)DTI=1juEKmoF4` z(Fi}uIZRG!79Y!@+VV&T^#>00FmpZ0qDRo^548fm2)oDi!<1(-;PM~yTswz`mlPeFfKTf!p{LgJs7DYh_QCV=JMBR? z2s{Rz)!P>J0MTNwcx*UE9Yp&Dh$b+DNf@(`#)h0SLnOt$qw?u9BXx@=wuRmpI3jjV z&6hRudAg`?E+nyT4Yup886yZwOCt?$k%%i;`3_5$)Mo%l%c$!B)ZM7(h8gx^#wBdM zYJdWRkgHuyf$@)i2kc4$`!|sOIR^;xWuZ=T(rlsQnG=0S%luAfWn^1!-gTJvN+@$R zCCtm0y8L)eBqh%^*4MGrP-irT=nBi^1^@x%Rw%CA@eHGO6k`WWK&3UqKsIJ}YdeeIcJ0gRT3RF9cjMTNmi()T06G(CSTlMhuWG_!MWWx@N)5 zaQ4r&L}Nch-tUK-DJL`EUlF+wVzQYW+EX-5D-q{81}g-}ItlnU8xWVCNd2s*Agnt4 zw5mbH*w&9Wq9S38(TNCZW%IpDU`6CUA)OWe^L=|~W#2u2r(iN0fHWoNnlSr(IbNyQ zyS!Zoy1Jvg^V9r9U8#cvqSyaxdBzO%N?o-zKxKfM2>|73FC4D22e{p49i5%kMkIJ` zJ;M8?%nPemY|*F5A{WmVod`7m`1v{x$mK)|?<{(IPMCT| zYL6NkJ~bTK6eqZo;dQro)16h)too{_uY2v@0Xji~IQdWDj(5+DDG02j-NtVp%G-pif}&ue^#y&`j75d{G!_Ux zI;qb>_4Md5IA+}M^|X3Mz42Pv&2-#N-rQd`**YC%cdnhr)4!V_q_9u2JXm zxI!QWi?p~NDW{cm+e2DQ_d6k#G$c6$3P!e&r?t^`iwb-$Pd#u&v#>4?D( zPWSBlLbHlB!^{N~F=}_qV?$@LTa3k+v4S_ud&KRR@Yz3`{2WPA9)qi4uU8&C5tLX_ zJsJ^ncV2JGwV?OlHG&WM?`GG7Q006Ime#V>k@J;RKq8JVZFhbz`=#-ulkLoD+XDvO zGs*=uL(YK_PcHo=2fMsx>p-Tju0$aE)z!5knA>Ph)JD5ej{6UA^=R@eG@tdAki3pv zf1Co;&S9W^gFddmXZIo2&Ud)vJ*}Q~%7Gk3ZudV^7aWycaGb=S`V>%~!Qfx(+dh7Q z_(7~Y+QTBVQVE)5wIJy=7q|ZA-aE#J+7F6qlDZndv)4^?O*QjI_?saBy#LUC1>Ep6 zkfak`;0dS>r_}xhhuu%vq-oXF4$+wJL2kpE%<0FSiWbk>r(>xssS<19LoY#XMawm= z`8?D(!Jepwsb@zr&dAWY5}?~8|A!xc2q!kyvKJ1${%t zoO)%$JpFZQNR2!!-U=Jvwk`N{^U^d@TW`lI=Kfknor*-c-^k7e^;U=H{$zL8kPFGq zw9i?E1z{xA-}BGdH~u0L*rOUUgeGZhPzLO?V)c__iOy9}lx0Y~4vw=yr5e83F4Ucu z=}sOcEfdyqkGPys$29xg5|F};EqL3+3Q|L7^qxSUcCcd9pfN)3a}t~OxN7W|FhGHN zp;@5L5Xjzv>N{q{E@--C>@Wb2S4X^@G@WtGNZ;d7z>lWj-3HZBV1`7+K|9|egsdayXl5V+r6bA6R0_9wtogu+Jm2%63<)1{#&M$ecExpC8Eni38@l zD}olV6|Fky(zhx=Gf-T0hAM~=%--BaPUPR1BFJv?24dG~WeAFMZ~c$lslxUH{ZClp zE2T+ty+mm|)56J54X)yUZSk}VMz3DgvWQZiIj37^UHfnMDQNcL^M2wR&^cl)*e0)= zy~Ho&mkR--xta=HY1$ZS`wR_%Xa2F|jV#^isI~ai|K_Zyo-!ws$Sd#AX;Wco@quX~ z7N<`})BpCo9%B~jvOb`cQaT`q)8DE+-7EbGW}L*xtUa3SpJseC0_yt1l?p}uaILT# zqUx&s+-k|qxXDu@$(f^*!k;M)#gy-)Zbh>5c;i8YfRa3$`{J0V1Dz4|vPL#yw`ZvFg;T%DgHuCQEPL{V+y)7v3xY~X>gNkCb&uNk$#5hp? z>|?s?|487X$1l+2b$iPg?g4;iY4z6G z)Dg*9VUHLO`UnCWlGH|Y9GJd~ZbgmyAdr>wo2h7Nn`AoT3_gr?8`|mOa&WP9bcJfo zk6v4x@X{9fM;k(l7?6TUQEj^S-;gI_)4>g#QtQsKRThp(Ynw6DQWv>O#ti_YjZ#vtTnnVY7VkKxnib-Pr1 z!M-Nckt)kYUfzS5Pql1Wh}b*VU_`O(C>0!Lx1fpgF8X4hn1=7QHSl=reKBD(#v&Td zp4+Xuh?3z5l`fBJVZwD+H8dt;w=ZiPRdeZ&=GM!Vz=l-MG~nr=iT{!Q~cx%FafO1WfA_ICc!60Bg(vAnY?r?90gJ(!C>P`t=>k1Bi?NtoKb2(J~Bf!s3F`p``+} zKxWKpl;CsBtQ zfE?(x74cG-;03xY{k>1Z150wk@PR zAw3nGS5M7f_qG(KAHcm?2Ul}DDGT!jSQJq&6j%-C@0X!=9$0i6^r~LqDk|RR{$z2X zdF(dq=!<9SNlClY<+->Zd+*Eu4J+VA*{ISp*#C%(jY*{=J!7~PL`l0?CFxKr*{`~4 z`xf(&(X9Vc`8XpVcMP%gmoUPv!pk?cqBCz!s8zc3N4X)Z;xF3gQ>9AW2t{u6T^-;c zC*2m!$ldaZ=`>mkE;``B@djc~&C<*i0zUb7W>C1Hq>dRZFZD74VfM&1nWA|k2d<)n z{Q%o$ea=k-KbAq(W1<p7=dHB8Q$qfF^z#?H*Gyxo-rvl(C+?O5gptRvBR6tDDs@Yh8sYSV-JTG-6RyGuf ze}AbJSYr~XhF0=-7>?VT`12=I$0)yF&`@Qqs<_AB^BZ$V>df76Esd)e$7_rSxTIZT zALD-L26ikCh7B(chaK>;2sYTMe$yGL5movJ1=a zpr4dSZF-mh7i9gxK`ICL4rra%LN3@+!!8^B%%a_;&-=3T56{p}FPNbt)^CObX#u_H zedTs@&=vK-Sp+d6@7D*G_n3<4wOunn1?wiqNdjyv@Ku<%ElF%ul!}QWp84krTxUig zy%B?Hjo3~8UzrAKgLQO#U4q+=Q^x>Dl@J)^>cJy^*x`KKEOsc7Dq1_y!yIERcQb!G zj&7E)nj?#bsb0r^KFsv}h1ya(c~N$(=%)-rZ$LB?j4HJQM;ZLIjX7mGpRNc-tt4Bf zcJ#{N(?5w8L3}|y(fL({&lUM%K*)si9rZlf7F2)FOH%BUl|Oou%Ag~2`Wt%X<#y>lpJo)}GLbHgJwzom?#b2BQ zUPkEk=1SH-YQIPme4{lQ<|Y6%l;E!8)1fD(@SaO*2}NwgegIs7Q;fh)h_-uE=zjc- z;m84-C4H0*a{<1fjeE!6(V6^7#KvQBCBX!y9ZeTuQM$7qU(C}kYFDTPor}^;*QZ6g z?x70!M&*b#G^IZRm9>oT8++!G541*|q{RHpTrj6E(%+qmzQcv+I8H<1X&}R8PI~Ry zZpGX+Wa$NB{V@)N^_iK!;6L&Dp7&qeWp$^G!Aa>pA6N+Gtp>QjrBOhiN?g zFSyaVd|^z*ME`35og6zr^IBdq_qE;Jx6Qf{^>R$-2a*?fP#=Cy zu*;7jT*0S!`gT;V%Q>OFj21EOy<_AHn1}3{DESK;-PxMsij@(JhvggvQZ~CA(0Fpx zpFGR89%uuf<4z>XS22I@M`^ig;vS@mPHgtq~#{IH4Q_UXgEz5lMxt zm+2MKV=2qz1;Ve@d!wh;ntO$UIp`3p{s+lxSjI@xoKwnbGOPV4sPCJj zUj+Vs+=tWj_)0wSm1(l_9lk*`Od(BZ zhcYrQQNn*EmjUR!$>6R+9a->3d!b}(3$}1H?MnOVHw1x)3I3ZU+?udvlU?qRNDJo{ z#XV9=JzP!Rd?Z9)o~N5}4kIkk&ASq^j~jD-v{bE|pV*Zhn)XE)xKglU@;Doz+1S$- z$u;|ZWV;5;$My^ris*MNqbr!|yCL6y~vQfv<10*){9LHK!S>@r1wr;q3}m6k)~IP?tdJXxsN3 zK!aq==NJmk@S`a$`l7F(YSPNs)r*%;ZERfY{IbO2MF>oSh4AS~UOH%C!}zf!?@dw9 z4z07f2rg<@j6z(bVsmi%qK=N|lY%qzcBgwr^PPUs(>Udu{2S!Mu=fP=^hYdcpp)BW z)UZrZcR?R_IXKADkh@L4UH6T;9X+j#?a4mvOb{po(2*2%6nGncJ3?K{zP%KR$(o^? zwg;NQ-;0_FX#Rio?L#C|v$%gaCpY_~cFmDka?gy`r5pj+?L^vMtvYiXQjqo8w(c3^ zmDyRNo)NttlLS50HoKGyk>)oQfn*W4)cGkMD1N}3L*PcdyM}U)kCs6lMtDm;%0&iQ z&maaEz=|K-{y`*V+dJGh@@0#C*B?L#LXR^Pq-2zr7kxmCH|gYf=jCT^Yjg{@@ej#b zxn=p)Q`e`4CkefSqluD%xfxmy-{lu3vLNDH;j-&Y!dzmUX#YRbq3!2cHW9RQ1IhncqShjI@bOlXOVYJIbD=upHaJ1m5Gl%G{6YDrg! zQNuzgSD$IMZ(GgyV4v_0>2fZregSH1(PtCA!7HmSM>n^<|B`v7pUwlye{x_;F9LhG zn8rL|z2U5guQUhDMAzSmi&)gQ`_pN>!O!iohX~!$7@*-e>EtZyU-ys23!R|Ur)i0K zPG6O+_FH^tX?&jd*7f|Dc~{hH2hC%&i%&ZKuFQJLO097{K4$(c%FIFY5bdH{$A!wQ zH>}iJ*Xv{EJyAa$G|$j3x_5X~X1!op*SH=YGyfW;=Ae0iR{Xf*WMx(&%evN8eayT& zs?0(26s`D4$HU4jiLt(eG|yO8-Pfq`#~lGRuDTAIvX%Dc{{z#gwEr*cQ`Tb%)^+VY z9Y-ww!mKKP%ql#zP+r)*KvynntNz*YZ7}VW%oAe?GFh4<2UKgnvQdiqi=s< z$3Oo+VW5j0|7uO**re?FCcVD{f?w_4U~R{_C(*b6k01EPj(@o(acENZc$40RfZ)5o zNpE+j)-C$>e?4$6`gVX@^46S%3G3g-2j%&wP35Bh=de2QOMKkwJmv5I*nbfCUyHzT zHo^QiP}5D+{!+mFe|5$!mN-dz=Q;-I(mFT)-3H%^DkN+Az4&)~h)2D+iq5J*xPB8t z|I_&o2LD_6fiOY{jZC@yje6rk%zxv_qyP2)C#%bQE8o5Qe)A*cgYqZox}wMv!@FVs z*M8Qm@bowO@BU-|LEwKa0xzJ6{~dNO{6wAJ|Lxqe|8{Qn!QGYOTy$*id)FVN2UkH> z|FQod@IL_oVFcg+s?BPnMfL#tzc`(Ood5sRKCCKxm~JY6+>P^}4z0wks*+xA-3mXs z`|9*ozW9md$N$)W5cqFJz#|r#C_z!v%`W}@81>|T++l(N-5=kUy?*U$7Y=Dz6&+r9 zc3JM^s?_Ox0g^nP>{&-^yZ=R${e7rSXUwnUDp>T&RaE`krZ-vsUGo+#eAR6`rOHO~jtrS#DU49@CP)yP3Z0{^}e!9YxuVnFWJ z^)&AE>%P{hC1u(TUgjMnK9HGikA66101Joc{_6F&89c9{`>fAYIw_QsGZ^LYeY)Cy z_X=0dzQfbQi4xI63#7pTb4R)~T+-4R{CI$6m=yHtDZ!?b`TFbuWdsvdLNmZji z{XAa9N>i_&v6dklWZkQ)G3n^DtC#;0Rls))`i=hxSZuR9gB4UXYKRA2AM999IU*GR zbpO%o?dcGaR+V6{3?|r+tehL4FINm*nt70{U9W<3_)*&q^YVCC z&^(1udHZ25J=si?k)9>zei)e(@lK-EM-W5#Fj5)uZ4U-iAYDh1w$RIa)r@txcbEWN+P((`pcwe+COw0lW#gnr@5bou)Zx&8H0^@M|%m5a^!-Bawz0|F!HRpuiRD`lXOQRzNe zge;ewK$W(4czRM*E=JYt88Jy%`-A*F9`;EvO9_XJsSi?_Z7m55SHz;c9iuwxQq12H zA~p9ZtE{U zo(C-E>2?+vc$&b*N<*p)#o(1*)xHp|+#qQGYO_GK6n|#-r)K$uxKF~yzwBMj3@UJ~ zJTG3`Fi;uhB}r@Uue_btKLc2l*T~1ims0=hHC@p8#}aRo|8 z3tlJ0eS4BrbIb-U`8x8(>*QybPc}K9`6j2gZonRO`Dp`x>sU`LMcI0~>#?S#t>9;6 zBRmtDqsh|!tT#3N?fxX5-gY_EM8jM~N~_s^g|?$K?tty8W=`f^Cwf*BGxG!mrTn*b zXBO|J82{)IR5EABNr{)53W$XR1^2Tj-}C6wEJ03byUpL@7Znr|90motZSvx_Zs%TC zP=Z$?->}+jS87cw)}g%|$1v{pg8m7|yXcX*_oID|Km6#)o1Ey{PTSIiZWU?=BG%A2 zidh?SN4LqlaF3herSZ?BT7Avhn;t>3d6%)jhYUg7PJcY8Hkg>xjmmY2a+8gV%lFmA zcMJqltnX^sXS?WwxYaiUrA!`G_3#m^)sdUonQ?gD)9}dApn#>(9EI;|4547Pri1&u zLr|4N%zt%MzC_NO1g6E0L8s$cs}1gb6XQ@3eCxIAZ_k#+%ThH9ThkN8_v&XXHrp;A z$7(ePO3**r*X`o^3heh+ea9V#hgomda-$?1x<&=jdCvmzJ9gNGRfi|uC`PV2y)*1m z!wU&nKKzyh#vownlP}m+=Tp}NOtW=$S4bV&E2+Nnpay}KxKuv=@|D3J=I`G|c9+Ez z86Mw}#J?+1n3%<7-pmpn>G&|$P9adRH8@sJv^`C3)Gw2D* z*9Zv_eYnY1iW=R35wOW=Om)~Q`YF(qkNWyyC0`@I$smQLRaJl67YhVI6TA(Z6rL@A z;g{d1kDBiEz9?w_cG$$$T|ivIt%e$9mGW!8lkXE&N@`xcj-WV<4S4Kfv1Ci$$bZlG z{yU+Qm&*~95{49#CWS`v2jVkV>#lq_ARZG^DL?6&EfMhU*^obc4X`+E8cC>8t@0i! z((LbOZc|HYox-o&t~%fE{T-0tx@nDK2rk*nZ~INWJK#7C;W>q!6xU7C2;qMZ(Cu0r z)?@BcIixEJeXY{YX&`HUFZqaQlDL}Rl{B~8?%29xB+UMn7!teLx&FAT#PEoNM+Pcv zeKfE4!(P99?(mG7Y^UQAzh$Z&uxNBEsiCsX!yw5*^>J&3&*3Ci<+~=vZ&ON61I}!W zBH$4V?+fheGn*fyG|-V98*&3Nu3Ti==oysVahwpU*)Q?iMueW!DwfMjYMJ@I;r! z@S@0Y{cVq$n@pfi(1UFqS%c3+r%9E`9Kq=4_g75I7uCqiU&D|noZ{7H5HZ$1%EkNp zs8QLPu>6aG-aG$5@X$37lwd8H*Fe6S(S6jJHMsncO((y|DA;P{1}yXntouq&G1DUw zNlx^K+YXe`BAgHXN_c-?=-_NvaniNY;kfu|r}Sn)FR3Bm^KJPbk6iW0cIAOLARu)J zDyPGHx|e==_?PG=iV@hB62PmwV>2c)lh;Eg-EqL6Y`qlG$A3D7hedEZJf5K#aDS8Z z*3deYBqSH!;gN*7B&4Fyo3{R1bbWBu1Svniw4M6pV~&oDlt&2dS>HMq={XN3y#nQv zQ3r(iTdV%R`G7^(j-4;utLuO+X>5UIhz<>Cr}AmMfJ-^SmA@D9t=FM_h!eVBd%ic=UDl!m2P-gH_Jx2&LB;s5H>iTkh##y> z7S1@}+n;44g}F`?5oh}HF))2WO)>veW2gHbb1BRX$2hrm!UxcO3z&82Rc789Z2x&i zG>QQevtM?lmMAiFu+6t~A+nT+n94G=NL%+4p<4H*4U>e0>v@NPH&*3jN7ff-$w0lD zYn{o?IYHBe_%Xy)RnKiMU{S16!hmI@{VLfHO7)rTNUO(!G)m+qfN0j|-SSDV$0P!} z+R@DZ0@?Rc%;XXWF;4QBHJne2H?eeEH|~rz#5?4b@_oEZd%@@?x6P4TmiS8DtYosB z(fZ8F1qxHmJ(PM6wHvJDny}j$^3vIu1V{4Ru{8$=nhy5zukrrrDXjH;wn}aRSR7En z*xbf0Y8&dwBa@7y@{`|O@z+~k-z#-4IWZ+t{@blxC7m{lfUfvx4iK6nDAv#DT(%a) zweVGQ1)6y9?~&E>vJd=sDc8~Y*<=chB{QYtx#!Fzb|*i-H$MMJo^!`n{eezhaT9sS z=eOoU{F{}Ztw>t7sGz&#s5`0dHwIGO8dT6bx3ZjNV3h3swQ7=Mpy$&R zx$D>yq|Hgs+72;0PuV?vKM7=96VZlFZFHwRGj2&{P(tt{dCe5pqenad~-}Qk89gt5MLIW}%J5y>V&x~6)4=K&dDqO{zSC`VJ|bhV$FksR)%%VneR=>nGqc5Vk)5>wn~i~ z!emcA;9QSrmUvRgl#FP*22m4lI$W^a^j=gJJ%#^hw?iOjc;Dk_hIW0RYbod(^u9t|*0rC3OV*Wa4EVkvyv;wg8^ zNo)RERbtrq+rpv*v=-=bEO;5UrZ61Knvx?cRV{}N6ii#7$8uPUWJcxt;N?0cJE_P2 zxMjBGg|&V^?lOL7to)Su)c@7qc?UJM{`-2n-Bv_4A|N$erASA5&$b{cO?oFnq&Mk3 zQ4vuPkd9R8z4sELA|N%ikU)S)OMnmp1PCDs-2Bd*duPtfojL!UGjs0T{nwhzBx}9z z=UwZ~T5F!?{mSZIR#iwlcQDjW-5Go^%Dqc}{r(=@Z!lvLXm(-R1T+jstORy}Ws8h*VO$tE$F(`I?>!~zVe7ox~BQNOFxuG@!tnFmfQCCC4 zT8TzdIYiCem%+rlB&B8KXiSC!C60-QLrRAU9jn9n4Ql(xE0H+((bE1kuCm7bY)~3s z8;E&ZXn$vARZj``Et)LT-#w`Tt(LgE6#9Z*MqXhRWU$uWAa z|4>wb{C=;x6&Kruvr(*K&(2>BOL)7cg=eYC%#sitqmTp&A?Ev`fT z^SSfNnjo)HF>}WsqS+fX|Ji%h+l9XRD1o6D-y%Ko>58|K^ewpwJCp}3N=tQiG6(Ri z`Y$$Fv9EO}tv>%CMICtfF%lY&&nk24S?zv`J|~#ze%vLcYc0U7WLi6zJOnVf%+s2E zj-aF7#VIu~Lf19RwpBo30UkmT6`jGTn_Q6agE-XzY~$(&X-;|1jK*Sj6A^RL+{ftj z99Yff;aK$~$xJhjm1RWOrzO~EpvFVPa=-1IRQ9G;!=N%Z+EfFcE-V~?J!%>^#f5i2 zLYwSPa3d%pE1yG81=i=fC5AI5%G`?ssLM3*gt?IwBB#;Ht ze>7euUf9oUEVPuSmRgj(@H}OZ|+YeY23kDi(8fD)>q=%b{qZYqo6qt)K{0g z5|Q$yd)osPzdC6D2HBriy(tOamUGyHjXjrpr>V7`*EJ#9?xXMt#SrBx#K)OI`mA9>Y-}ee~615 zDc*=wI9vD(S%_+#d?R{M8du68||&{vXBTy-0MYuwo-6XDzN^8(k%P#`Pt z<*Kc8!uPk>53os?vE}pKDj73CXY9e`jP=1y-j!Zy`rM zHFd0JONu>jp#0EM8d?M6)kUMwZ{=I{Bds+YFM;{E-8>>cGiCko%@hw!%jh+ufu_`X zicdp0VHk{Q2A{+y!fjw{94rzqNRC0$G}Xx$mZNXQX;$qU19GENWsTy7zd4MiY?mf=g*iB07fEw_3j)6T}`#iG8FSZHzN-suc534+CQ>>oI#2f@k8w?BAc`EWj!R{a~fvNWB zuKHO0&gbT>j~{9(`6g9aU@d5t55GmbRQ|AcjE661)VKOe1ON0O$_J3pnc|XRgyMl+ za`&uIixI7aMY-{VW)HH~!bOY)h~szMz`R!67I5y_?QOQ*s}Wx?2)H=n$le4?8~00) z6#G#H$BXEshrBFA*$?0)o11ihVtR4a1)+fhoi%f7Gw`jvIiEtq#`n{|gRADNdy~(* zVZEf}J_tX($(X?shkpl%X>rmNz^p9I!MUj9EA@ZaYm}YVrdC!?V4XSn1Y5r7jUx zA(rpFCYog=!-gv=21ucD=A(=O5?e1nX`L4#h);!L>PJU5tW*N9-Ztt!4JjQZK@zi=MatIJ_wK}NGFidX+v%?{aJ6&2S z@taCwnyoY5=4}x%ioGnK*Ye=r^c;dZwy_*394Fvzk|umXTMtv;ct&^5`Z&DZRuz+1 zXRC40CEqmX=!+U?@R6n-mKh`jqwU_t!yIW5u_+SSax+fuRs#X)ba(WJN~;9P>ENS^ zM|InBOH;3i1_*yl;-QPX1$?UhcNP!G+Ww3`ANuHW?&932^+2*q>Y}G6B11SJ&!QC( zePyQ9sdqU#&clCDy*7V!{soy&sWu7I3uaH7Ju;Xw4qk+fEUPIfGoF#8Vum7$v{IP=5#7W$Gmv?ZiGIm2!qepeP3>++~5rxOckDOo}?46e|sa}tjxi!_q?Vp zZAYe6iCgD+we8B;IZ;8${VM!GqZzhgH@Yy`24>xN?f0{9JO>WJ-|jV4+VvF5c}xYl z0F=8@b$eDEs%F#J1f3f8qK;on$)QtQkr|P*n(y?zn>5$oeo&2*zMev55TBKHH)i@) zf}|4$)r5L9Cr`c^DAlIXs>;1+=obiO5k(ugGY1@E9kdrA&n2h6zG{*yl`<@vsoIYH zDU5Y04#g&vokV%zpFcpvxid` z^V+b|P7|8j()nmzhY$JomKt}^f6-Kjw(8vA67m-0J7QH|rOhKlrK&<@{9roYvuwQ- z>&VwkxX|^4F7zmirDw#Cv=zo1OV5eW-m^axaL}>r_(iictC`h892)CSkNczc#i?&=YDtuD%9nrYs$Pr=4&H8+(0!;2g4)z&Y>g3A>8BU7S zH?X3#I>^hvWv^Q>o}d$M&q8%F!bK(HoRXTj;lNp{Qq#f=x>PS^o9`+~Y=I0J3^vvSM|4*mx(O7ei)yF2c^}%{0a&2v6jDH zZaAs104v<&%23z2wAzPU9g4np`$%ncKrI|*R`GXr26)*!R*4c&UaPz1H_1GpcFHU< z+j6>wiR}e}99Eo1wz_>Q^0f72OhYsd84Vt{MmZYk zWa2<-%}iHmf)?jTqndCb@muQ~_cAhbv4f=|GX5Bl013L6&(AUHn5E6yTt4+dKVWw@ z#~gl9S4$qh)gF{>Rg8GoR}~xRP{Rhh5msnMv)!{3<^Ftl@-vc)JbtTu<*Gc_>5I@| zUQtNHlfEET4Vn2j+Av#r^4=zo-lFY%54CI_3KR&M2W`!EUyM_e_p`!oZ%cN}qdcVj zI~y-~1ciE-s5QLG;IP-q#rJzMA6Vo;pJ>Nb`tL@7FJP}jg=Y;JZYSyIvd&RS)qAhb z74O^fwR-(dj_@s_=lU;IhpOWZ`T8}7g|U0DO-g#k0xh4jS8cww^Qdoth)VrFgmhS9 z<@JJR2IW#8+S)l97picS*;{vbJlv+Sh37ehE~Bk*O()Y0n|(@6OZ1fwME=>re)?BY1RDbu|<%o{j;rCW=f+QGTF`Qx+A%Mh%8k4>1J(x7inlo>q)E} zEIiAs74I!DGN<7y7~xoNC`~mmGuZAlF1Qh==H;VQoyx7NrzaNSIjE5yLVoaUSvy+0 zTD<2VFcIEJn)=`iHpK0n-le@VJ8NU_^);gA+OcS?93Ms>id-g2b73a2tEhQd9A}fP zyY|YQ-i_-8*%qckI>c01`KMTvLqR*$PW1Q#ryd)>C#V&+MK&8V;@q#v&d6-We zK26e!P`nzJosZuG%hLqTQMQKl938|uqo-n6!7CiR0J!66ZajBiD$6d$(lu$sSu5(= zXCjf5Ql#6tnoJ65b@KIkD9mL?iAAm^)>!%-5$ixY5zhym5b?W~-LJF{4 zn#v~G#B9EmIi&M0w|9g$uV%XNNbcdm)X+1o)cJXPplXz&TzIvBnJjnAbN5U5!-E%m zT+1B5cE;#ENrw@x1xVnTI3T=hCf3)`@|lZ6X?^GokI3cuRlX0_d^MuBH5o2x@tQ6$6 zUBQlZo?4*p;yW}e@v{9@@0tL9j@Z7xHT%;VGH4Bn;^q&o|LBsksGK_yB$ zp5_S0@fCGKC$B2jDfrGo6j zWh8z)@**Q#(zDsH&U;%kGh;NzYkQ$peqwMX=*HS?TCjq5~dH%}bV z%Q(XJ8V+?!Cx3AN69NPcF~LKfP8R=3oBBqo9UHKp#K;^->w6oblz;lA!mZ7Q6JU$$6XO z&Qp(HzxOtAmj4}xcX|yS9T&PI^zv`1p2Bh_OclZ)apL%96$Aa&B6$8KW#5RC5ynH zy!ITXoCbV>M)I6^5KB+D432=O?~fAK@SaA8!MpIWzb+otzk9{z@tJYk3#Z~Df2%#f&XBQ{D%+!C?x;*G5?P`LjNcv|M)5YB=Dan@L%DN zFeQ|K6q0{5ng0O^{G*WkBdYv=l)!(zLc(0e9R<9Fe0F?&ZWL$;3%!1cQ5KPysw>33 zUn~>Pflm8jIj}}CCg1*-DH4#?M!AEb}FxnSiGiQUJ=w?=`}Lva~4TAjR43l8cd z1|{m;K6|3$M4A&8W$5Lewb;*Wz8o{uhmxawM}GXssLN>|OAy?7A4U@+;)c?7Se>w) z2X2cHT9g}OCj4C)PG@oHrF=4rbji&Qrr)tawiktF;dOdE(smV~FH>F%0X%_GL)#)Y ziOg>r*`y7<`rP(j2aBc2frRk=)dINoV%La!;L^4 z=Mo2=@$i_vnE@a-EGi55(ILJ)I1(o<6~{)d(jgxsAP)&IEB$^d0{6TGVSk0TF(Mdw z1o)(yTB~MO9w0P)c<5ay`juPJ69_s+Z9lZ?>s{)fh<_Ok3ecnXyg~p$g*W{KEZDVY zhAA-!h!3znb$KVJcSCzGQu;kJDz_C(#WdWvCg8zFmQu!3nip_{d5)D>^Vg_<^%jfg zaGcH3BDIZtT+>->_|9YPQy%&!^0p*qA|%phlA>Z5O5ws_k5rN za4%})h=fAxN3t?z+a=Up`BC!s-65+NK#HQ&%nq2b8$bNvqrG9x82llh%G3fT>6+@qpD21{A$PLv*W{^f`sC4C9N6@#XA-mVU5US- zq=}-Ag=>Kwxg7=jv$Bb6Iz9Po;=LM@KR5HL3a%){6)`U|dM?}U7HPIjTLI*$urch| zRBNL8oo3d93-&O7gNv`8OzHn{x%?i1r^o7NMz@YD`y;Z*^)F%7qR@mLy}6Yv0QIWV zW=c1HNVNHCzBoPfE7fT@Vw7axE?yIEyA+TNK+!G(NNYM|`cF3dz?>OA6&T+jjeE{; z?*W*^&ulxBiLc;SIOV7TuRlLgcZQ}xP~=q7{x7vr!r=!{+tQ|BGHL$d80uJ4SF<=2 z98+^k(~-Nn_#n~tN!Y3w={hWJ6&AMtB{0P5s@l{1j8bfo#@cLlx)5ovQ+2RIG_9b~ zh6-UyD6jMOSeNT&m+ zOqe`rJ~K!r(Rc%sx%q$qd^ws(f7NnNNV!sYL8g((jXSbBC3+lynMcn`OZC3f+eUq+ z8R4Qa*hM?Sd7Mm)MPQf9qQ~hg%4F=Bd_x{;7W7v=!}K^TlLrTOs6iPoEX-qNYn}0^ z-!~qu{tE*y3w`t`!|9#eeO~Q@aUHXA{_O>9z2IoYzP?WUAPMT5H>3V###x-91QON! zT`p*x{=nc}3GXq{qvz#Bkt~jqNhb@B?3EEqA`7$mFe+Z+RDnLW@cY zUTB5WCOeBpfku(j-d6E23n#w^i-==}nI=#0U@XfrS7&VU2tpJ4; zuvhf2Le$=$)OBbvhGU{>6y%hZ-_*Wg+e|fu92yxg=&e1p2FvyP-{!^k8i8n9wGG?8Fhz zZ6w{Brp2V)=7udT6k8$Yt!_dG0N9dn20$)ZD{-Uo&0%l&ZR$-0V6a*#Uy95kCFULw zM-BKZ?dF06-*LlNo^!6YiFXWpI~B2&Rvo-4b(&?WqkIu=ii5(ohoxcF1KPX@pvU!i z6YmlwWM;%DlKYADy6mYse?BBd7@I;s7~d&7~;hz0GH5x0|`mJ00Kzy=}U zk_-fJxwE9;Q0@aZz7~G+b=36TIl=desZXjp01_2+2l1!_I%#kOp2}P){Ly!AULaiw z1q>}@L8esd-=vNwH@VrRLF(i>Ayu$ASJ(uW>zOK5L?-20XBqEP?22%?{obSUe~m_D z`F+OyZjGZ(?j3yI?ts>~8hv28_#lHYp)ivf0joOucr19pGE4MF5((rv9mp%X^X7Iu zsDSZX5y2-c@bZSh;d^qa5PTI($3qQgNxLUHG#>Fyxz0H9$CK>=g>X)SyI#-Gc%x~;knGKl z%oTdrKxp-CRqTfIwEf+0h;=#>wKalfd{rxk{*sd#)SkgSAk+9oPbDN!iuCfkp-aKH z1}|{IpZeX4JYu+R-P&fmRImQ`fpu2HM*qJtv<8G=>SKmTPD4r9cXa=>7H;0#+JcG9 zKEiW%wUvf4_{jKy`um3wnj-W00Po`@($o}lA?ekc(#-Lrn;$ryV0V!z6(8A}ZiO;g z*b4jIw>j>5dAV1L0~5)M2IK)f^bg&ZE0Kb8^-5_>=Jf^=i~DXNemn8Xt&ZX_iHeV! zJ4rK&m8-IoWg`c-AN|nJ3|(=W_IXI1nU-<=0|fo~%vy$TD&Wk95q{X9=$NIJesazB z=BL#{yncZk-89g@M`ocMlu}#T(7)<6dgSlEANyMt)R-zLlo5c)n&E^Lh_@*7K7c27 ztftjCPs^y4-W}BM{0gt*;O>|VVL!*69I@i_NL7sqqNXC?X?Yw>0+szXRS@giy#pRo zfUGP!Ji_~!Z78+qjNmAY;y-1wlz0E~mFJq9jh^GnvT%8HATz8Ae&~K?GehD1DMRS# zO(DS1P? zq63{~;^Tvz`YV+>KC0S*=A*sk5llj~B64T$4{Q8I6iop%{#{rIpx}PD#U{NaRI8$-Ch(B>cDtEhsVznf3~csq^1C?Z69xJ$*0dk#I*Mw@#Q?Z0 zevTo8W#-ZM2z=z%rqr2%3p##VJ~%RRNLOK&K_s-EV9NY^vuxWulrz{i{U8w1{SJ7N`KS zA`wvN%cL_)1DR;14r8v_)Aix}Th-e9hsOyXtB?Fv)b($7v|k;q&{SH!+S1nJ_>MeKhk#1YGX*5a?`K^BZ=#%& zATy=JkDJ)tdd?bUbI9L}(&iG10D4sk^F-@kr2y~LNgBrw20xC_CC7WL84z-|sPDA$ zkJ4z^2hJCax@@(+&1XhrB;ksE-jbhJ4xEk>d)nI~fbvqn6DN*|9! z6X&#@Cgo1}Z$MJ9F{!Hg@nhI;IhYF*nm-MDuK|4%vUe6g;sO=%L6J-d|KpHy$6V~{ z?|ebR4DibB5UT(|(5Wf})Ktyk5Wu*)cE22&y7@O*SbsmEBv3>AsZ&V9C4~gPP0Px= z)C4Vhu(xM#i^AAL_@=4I1v`B<`9!5X{A#ifE%2`cHp{{yYOg!%?Z|8IB+C#F z(rL!PVZr^J&$>NG>ftnW|M1VAtNte^j{{o7OaTkcvIibJD)Y=qm+?tV2q^vrQ?n#W zB{>}Z5?4r|NI?Led*sZC1B}JVLqq_bk@4@d>(klVu~PLH+fe;` zk&a8O>o7JPhi_UxdzrnQ8ZdmUqXltnG7VIiOdMizeQt~s`J?cceudc+R7LpNIagf+Y(#{IS)IrWx`>Wqc{5`BJV8KKVlNgY1B+%QCap))oP;@`jWQbL^Ps zQ>9<>3}4_}-m$RA9>w*V59EvQZF5dhhE)f%w#nY%nW`hTnj_LF+B+-@*jfT?3Gb6E z_I-Pg{SgX#at(@*pmW2qdg$JKtY|>xJ;EgkSjN!IlR?}gJl5#b3?Myug<|*%F1n(f zv{|5i6gho(7+gdkg`@+6bx^STjO1QwxDXSfn+Ur_oAhS`i>$?uAz~MAGHwm~F;Z*< zR#yJ-gBlc{g98@L}qrYG$^-( zkA&azW0G*jJo0U78KlUJW3ed@UL-s;^D$#U!6)1M&I2&pcvx@IPkSdO?)C*y6E{in z^JWBd7RbH$n|ZeeU;PcaLd#BysMo$T*k=7~sQiQ|U}DVbw2JDVmKh|T9R+@4uo89u z_Bs(v98H{K-g99zmmrNydQHKA9-VD!m^n;^K9i#$6y(A^0~qd?T-@1qKa_=D>-Q`O z{E?3*8T}DhNCI94r~Yt+$fqM&WX7Hvy|^9NG6N>#3c*j{d&>6H}b?~Zs+|W1oB$&-f8#y z?O$A5RKt>IL48tqtac~0BQzvz2g&nJdLJ<^>=$-DfbGgLo0IK3S{S{qGoJ*ViQ@}e z1_JL8a02Vswp9DE^5aq}LOc0L#Y>kj@h{=FHOb|@d}?(VL_XNz1M@uedMESB?RiksQgrn-6EAlRT?JXt z$Iqb~!%izPI!3E0pV#=jZlO>3)16yZGjL@1%r@-!RD8VpL&|A81vvc2kLi!)w!tQY zNKSS193;3kPA^o$n=Ve^K}wX+XC?thglP_2t< zlEAbVTK%0%)wS!_C+2&14ha`c7r!r*&^p(gGfpN}?J>gMUKXjSSiv9;ABP>4QXZG7 zKREB*kQ3tZOLF)^5w|n|+J@+^h=XA~L9McWhh;id35K)w#Qhy(!Enq`_vfBq#@npk zNj{484$>W!_%Qd$(_D@-Ttv)u*k@B$vpUW2Q|TjzzyYfoP_E~A1*I5oH%FNJn6=*M z@th-Ov+Z_zsI`K3hGILU;zu@dC{3cVl`<9L&I{z z{?nH*rRuLka&d_O4i>h#)+%ePF7_#>j~Sxa0rgg<2g_$rLvDKd*>tq})>#Q^OXPGn z^@+sPYzjmJZ4`m1xv;jJFt53F66lh0Lg9~5@Cq#IC%k|=D^ACrjlHntZ3A7iO{9>3 zwo)Y7jgaiZ0(MbACgw8gLG2h7GPid>W`y-YdRpX6>%^;`R?Km(>wMYZ$FMV$YKHOX zK%O_P6j3skai9;amQ-J#pK@8qlF-LlhRy=Q=0we`_**?mH042w{v5u82qM`jSX!WF z-K9aPw`ul6Zkf7aptRzb0PBZI*`k*Koaoq8y zj|2}ZLORU_&1qJT_j*TJDA`Xm=_Z0O_>KrGjmStM1?!9rs=6`R8DdOQZ&L#8@h;8! z+v{VZoJ)FfIXA{3yU1`S(XgW&XwxBK$R3_|o^gcsKmLZ{SW$j-6&rx*w6~lo5bW(# zxj^4*JGCq^+8m#hxa#ILFQa2lP^ZuKwaT2g?S?KPQyIXn9Q!@3z12^a8JCb+wH_ui zp~qi%TaC8!3_P~$_MS+?LJj_2?OcSzkx#iH>YyEZYI7{3cH8e263bXzWS|??DE#q;cGqSE zizM9rndNc4C{kKMP5!S1xj+M$<6WTSQ?t2el`igpu0eYbY<{<_h6yWl?d4Mc=ot^) zS#<3T=0%W~*2Z{kD62$z)-V5VLZeu%xfNSs^qFC4!ZvrE%iYt3PVJgaz0m1EdV%Iz zaI7{I`@)k_Yv*xaMnxn)FYL>LJjO5O%~RMDF-esSl3h`EAPsH|(&Ci)!#dZ0!J=Vz zcWMA&bCjprT4CYSw~a<0zHXtNIN3czDz@)O1`b;v-wNjThAV=r$+7uGdRNCbbr%jO{`dD zh#0Zik6MF^k2AcQ*WCWAI&4xEb!*9~OmEY!?|@u7lele~(=Dy_Vk(+?Tm3Zk_Q|5J zYJ{uv1DcYkGW61oahUbePit;~rwvMLX}k%|J(l%Udcel5Dhs5R8(N+V4J->vFcXZV z*l#MrdMCX{H?8Pf%IM9=4FaqFh>Of+NMo0K14m32e+UPb;diOvd$x$7@)&izo?y1? z@{XWJFki@$tn*l`t2T?kTWQ+2Tc9Z-hciB1y5S3Fv%_-t3~x+y-*Yv|NEbxtb0v_b zcK!1ESg(FI2P)&uyYB5`!)>+H8rMwJBU4s+6lwHYi|~*a4Y9&Lsf~HE5x&c@khKN( z%MH5N>hkun-uQcj2q@FRfC$f7s=4-mR@C?BBY%&<)TqFjO;giMFmC zQ>zH+PmM)-vZ=DwvS%)PCT|#lW1|e?+s=l~s?VO^5?jX}fwj9j43*8Vc&i^AdBzxT zn9RJ>uJf&p2&I3%C(+D_vkaixeo3vNtUeIbReNtU+MBT5Irq5L9kVs^lvxE4yDd8E z8d5x%J?n&10q9w&RDD}@#$gjtuzD^3mz|E*)b<_MyuQEMq_Ts`f;6U=DGe01>Fb1C zP5}!><;&;T<0a{+YLOo!t_`k7mXweBc2eRkM9A&uW{_j+wS)l{z^ahVKEp$oHs4JCrnGqKPv+Zg9a=_QT3Iiv%2mOW7k*s z(Rci)8R9lJ>TxvS)h=iS35ihbt(Gy!h0zu>`uqb$J{tzJr68ug(^VF$`?8PjvLrsa zaG{#54QP&?mcIj8!K*G*a#o|nTVmp8lf%#P3RYOWsIjY#8czOvGfneNph>K1E4}Jz z$B+~udz!>!jdy$AWK>#)*djxBJM|P#!5O+?$gKS)#x}2h90ay5cYA+z__j+OV;dr| zqF-cGgHh0%wb>v2V|XN0bE-75GBe_t@~`n^ml{S_$cHtUQjN`=huJ_Gu}ZUhdk52o zrTs8=D+}bzAJNb#4O`PD@<+vJ2TFCfB-#>r75&KO97h)7SsxTyCs<Y9x;Z(53SGx>h+$E)@!c?y1YZ$Jm&Y-ExxC Date: Thu, 27 Sep 2018 19:28:38 +0800 Subject: [PATCH 12/43] bug fixed in getBiasFactor bug fixed in getBiasFactor --- .Rproj.user/7DCFFB88/sdb/per/t/B4594EC | 8 ++++---- .Rproj.user/7DCFFB88/sdb/prop/INDEX | 6 ++++++ .Rproj.user/shared/notebooks/paths | 1 + .gitignore | 1 + DESCRIPTION | 6 +++--- NEWS | 8 ++++++++ R/biasCorrect(generic).R | 3 +++ R/multi-biasCorrect(generic).R | 7 +++++-- man/applyBiasFactor.Rd | 6 ++++-- man/biasCorrect.Rd | 15 ++++++++------- man/collectData.Rd | 3 ++- man/extractPeriod.Rd | 4 ++-- man/getAnnual.Rd | 7 ++++--- man/getMeanPreci.Rd | 5 +++-- man/getPreciBar.Rd | 9 +++++---- man/getSpatialMap_mat.Rd | 6 +++--- man/plotTS.Rd | 5 +++-- 17 files changed, 65 insertions(+), 35 deletions(-) diff --git a/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC b/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC index 01b1306..d4292c9 100644 --- a/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC +++ b/.Rproj.user/7DCFFB88/sdb/per/t/B4594EC @@ -1,14 +1,14 @@ { "collab_server" : "", - "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#' \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 0 (assuming mm). If you want \n#' to use precipitation biascorrect, you should consider carefully how to set this threshold, usually is 1. But you \n#' can try with different numbers to see the results.\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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 https://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 }\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\n# Since in new version of roxygen2, describeIn was changed, https://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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", + "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#' \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 0 (assuming mm). If you want \n#' to use precipitation biascorrect, you should consider carefully how to set this threshold, usually is 1. But you \n#' can try with different numbers to see the results.\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#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\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#' # Since the example data, has some NA values, the process will include some warning #message, \n#' # which can be ignored in this case.\n#' \n#' \n#' \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 https://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 }\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\n# Since in new version of roxygen2, describeIn was changed, https://stackoverflow.com/questions/24246594/automatically-document-all-methods-of-an-s4-generic-using-roxygen2\n# so use rdname instead\n#' @rdname biasCorrect\n#' \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#' @rdname 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 # for some forcasts, they have results from different models or scenarios, if so\n # there will be a dimension called member\n \n memberIndex <- grepAndMatch('member', attributes(frcData)$dimensions)\n \n # For dataset that has a member part \n if (length(memberIndex) != 0) {\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" : 1490325226249.000, "dirty" : false, "encoding" : "ASCII", "folds" : "", - "hash" : "1881778702", + "hash" : "3235762164", "id" : "B4594EC", - "lastKnownWriteTime" : 1490325381, - "last_content_update" : 1490325381151, + "lastKnownWriteTime" : 1538045340, + "last_content_update" : 1538045340407, "path" : "~/GitHub/hyfo/R/biasCorrect(generic).R", "project_path" : "R/biasCorrect(generic).R", "properties" : { diff --git a/.Rproj.user/7DCFFB88/sdb/prop/INDEX b/.Rproj.user/7DCFFB88/sdb/prop/INDEX index 41aae6b..0f4d65f 100644 --- a/.Rproj.user/7DCFFB88/sdb/prop/INDEX +++ b/.Rproj.user/7DCFFB88/sdb/prop/INDEX @@ -1 +1,7 @@ +~%2FGitHub%2Fhyfo%2FDESCRIPTION="9E7FEC5D" +~%2FGitHub%2Fhyfo%2FNEWS="F6FD6B5D" ~%2FGitHub%2Fhyfo%2FR%2FbiasCorrect(generic).R="284FBADF" +~%2FGitHub%2Fhyfo%2FR%2Fmulti-biasCorrect(generic).R="8D6FC6B0" +~%2FGitHub%2Fhyfo%2FR%2Fncdf.R="3AC0369" +~%2FGitHub%2Fhyfo%2FREADME.md="F3D2C6B8" +~%2FGitHub%2Fhyfo%2Fvignettes%2Fhyfo.Rmd="7142D528" diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index 5130502..d0fc7c0 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1,2 +1,3 @@ +C:/Users/User/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="BE89A8F" C:/Users/user/Documents/GitHub/hyfo/R/extractPeriod(generic).R="35D21910" C:/Users/user/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="E84A6BF8" diff --git a/.gitignore b/.gitignore index f421bc6..36e034b 100644 --- a/.gitignore +++ b/.gitignore @@ -31,3 +31,4 @@ Network Trash Folder Temporary Items .apdisk inst/doc +.Rproj.user diff --git a/DESCRIPTION b/DESCRIPTION index 7695ac0..5879a08 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.3.9 -Date: 2017-2-20 +Version: 1.4.0 +Date: 2018-9-27 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and @@ -39,4 +39,4 @@ LazyData: true URL: https://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN -RoxygenNote: 6.0.1 +RoxygenNote: 6.1.0 diff --git a/NEWS b/NEWS index eee2381..5c9bfd6 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.4.0 +========== +Date: 2018-9-27 + +- "memberIndex" length zero bug fixed in getBiasFactor + + + hyfo 1.3.9 ========== Date: 2017-2-20 diff --git a/R/biasCorrect(generic).R b/R/biasCorrect(generic).R index 72c1c22..576051b 100644 --- a/R/biasCorrect(generic).R +++ b/R/biasCorrect(generic).R @@ -286,6 +286,9 @@ biasCorrect.list <- function(frc, hindcast, obs, method, scaleType, preci, prThr # Now real bias correction is executed. + # for some forcasts, they have results from different models or scenarios, if so + # there will be a dimension called member + memberIndex <- grepAndMatch('member', attributes(frcData)$dimensions) # For dataset that has a member part diff --git a/R/multi-biasCorrect(generic).R b/R/multi-biasCorrect(generic).R index 348d953..d740f94 100644 --- a/R/multi-biasCorrect(generic).R +++ b/R/multi-biasCorrect(generic).R @@ -437,11 +437,14 @@ getBiasFactor.list <- function(hindcast, obs, method, scaleType, preci, prThresh # Now real bias correction is executed. + # for some forcasts, they have results from different models or scenarios, if so + # there will be a dimension called member + memberIndex <- grepAndMatch('member', attributes(hindcastData)$dimensions) # For dataset that has a member part - if (!is.na(memberIndex)) { + if (length(memberIndex) != 0) { hindcastData <- adjustDim(hindcastData, ref = c('lon', 'lat', 'time', 'member')) @@ -573,7 +576,7 @@ applyBiasFactor.list <- function(frc, biasFactor, obs) { memberIndex <- grepAndMatch('member', attributes(frcData)$dimensions) # For dataset that has a member part - if (!is.na(memberIndex)) { + if (length(memberIndex) != 0) { # 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.') diff --git a/man/applyBiasFactor.Rd b/man/applyBiasFactor.Rd index dfba56d..ad863c1 100644 --- a/man/applyBiasFactor.Rd +++ b/man/applyBiasFactor.Rd @@ -9,9 +9,11 @@ \usage{ applyBiasFactor(frc, biasFactor, obs = NULL) -\S4method{applyBiasFactor}{data.frame,biasFactor}(frc, biasFactor, obs = NULL) +\S4method{applyBiasFactor}{data.frame,biasFactor}(frc, biasFactor, + obs = NULL) -\S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, obs = NULL) +\S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, + obs = NULL) } \arguments{ \item{frc}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 0f608fc..9db0438 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -7,16 +7,17 @@ \alias{biasCorrect,list,list,list-method} \title{Biascorrect the input timeseries or hyfo dataset} \usage{ -biasCorrect(frc, hindcast, obs, method = "scaling", scaleType = "multi", - preci = FALSE, prThreshold = 0, extrapolate = "no") +biasCorrect(frc, hindcast, obs, method = "scaling", + scaleType = "multi", preci = FALSE, prThreshold = 0, + extrapolate = "no") -\S4method{biasCorrect}{data.frame,data.frame,data.frame}(frc, hindcast, obs, - method = "scaling", scaleType = "multi", preci = FALSE, +\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") +\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, diff --git a/man/collectData.Rd b/man/collectData.Rd index 5369824..e254811 100644 --- a/man/collectData.Rd +++ b/man/collectData.Rd @@ -4,7 +4,8 @@ \alias{collectData} \title{Collect data from different csv files.} \usage{ -collectData(folderName, fileType = NULL, range = NULL, sheetIndex = 1) +collectData(folderName, fileType = NULL, range = NULL, + sheetIndex = 1) } \arguments{ \item{folderName}{A string showing the path of the folder holding different csv files.} diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index d8c5bd2..d61ae0c 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -10,8 +10,8 @@ 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}{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) diff --git a/man/getAnnual.Rd b/man/getAnnual.Rd index b5e013e..76fa55a 100644 --- a/man/getAnnual.Rd +++ b/man/getAnnual.Rd @@ -9,10 +9,11 @@ \usage{ getAnnual(data, output = "series", minRecords = 355, ...) -\S4method{getAnnual}{data.frame}(data, output = "series", minRecords = 355, - ...) +\S4method{getAnnual}{data.frame}(data, output = "series", + minRecords = 355, ...) -\S4method{getAnnual}{list}(data, output = "series", minRecords = 355, ...) +\S4method{getAnnual}{list}(data, output = "series", minRecords = 355, + ...) } \arguments{ \item{data}{A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different diff --git a/man/getMeanPreci.Rd b/man/getMeanPreci.Rd index bb53b46..77b4f07 100644 --- a/man/getMeanPreci.Rd +++ b/man/getMeanPreci.Rd @@ -4,8 +4,9 @@ \alias{getMeanPreci} \title{Get mean rainfall data.} \usage{ -getMeanPreci(inputTS, method = NULL, yearIndex = NULL, monthIndex = NULL, - fullResults = FALSE, omitNA = TRUE, plot = FALSE, ...) +getMeanPreci(inputTS, method = NULL, yearIndex = NULL, + monthIndex = NULL, fullResults = FALSE, omitNA = TRUE, + plot = FALSE, ...) } \arguments{ \item{inputTS}{A time series with only data column (1 column).} diff --git a/man/getPreciBar.Rd b/man/getPreciBar.Rd index a5a1a11..7126699 100644 --- a/man/getPreciBar.Rd +++ b/man/getPreciBar.Rd @@ -7,13 +7,14 @@ \alias{getPreciBar,data.frame-method} \title{get mean rainfall bar plot of the input dataset or time series.} \usage{ -getPreciBar(data, method, cell = "mean", output = "data", name = NULL, - plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE, ...) - -\S4method{getPreciBar}{list}(data, method, cell = "mean", output = "data", +getPreciBar(data, method, cell = "mean", output = "data", name = NULL, plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE, ...) +\S4method{getPreciBar}{list}(data, method, cell = "mean", + output = "data", name = NULL, plotRange = TRUE, member = NULL, + omitNA = TRUE, info = FALSE, ...) + \S4method{getPreciBar}{data.frame}(data, method, cell = "mean", output = "data", name = NULL, plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE, ...) diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index e783753..49ca1d9 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -4,9 +4,9 @@ \alias{getSpatialMap_mat} \title{Replot raster matrix} \usage{ -getSpatialMap_mat(matrix, title_d = NULL, catchment = NULL, point = NULL, - output = "data", name = NULL, info = FALSE, scale = "identity", - color = NULL, ...) +getSpatialMap_mat(matrix, title_d = NULL, catchment = NULL, + point = NULL, output = "data", name = NULL, info = FALSE, + scale = "identity", color = NULL, ...) } \arguments{ \item{matrix}{A matrix raster, should be the result of \code{getSpatialMap()}, output should be default diff --git a/man/plotTS.Rd b/man/plotTS.Rd index b77530f..909a842 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -4,8 +4,9 @@ \alias{plotTS} \title{plot time series, with marks on missing value.} \usage{ -plotTS(..., type = "line", output = "data", plot = "norm", name = NULL, - showNA = TRUE, x = NULL, y = NULL, title = NULL, list = NULL) +plotTS(..., type = "line", output = "data", plot = "norm", + name = NULL, showNA = TRUE, x = NULL, y = NULL, title = NULL, + list = NULL) } \arguments{ \item{...}{input time series.} From 02f75a918be033cf6853e7b7d4725cefd5ce4abf Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 2 Oct 2019 11:17:01 +0800 Subject: [PATCH 13/43] changes to loadNcdf --- .Rhistory | 10 +++++----- DESCRIPTION | 6 +++--- NEWS | 8 ++++++++ R/ncdf.R | 1 + 4 files changed, 17 insertions(+), 8 deletions(-) diff --git a/.Rhistory b/.Rhistory index d93e539..d522918 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,8 +1,3 @@ -# 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. @@ -510,3 +505,8 @@ rm(name) rm(nc) rm(varname) rm(writePath) +devtools::check(as.cran= T) +?devtools::check +devtools::check(cran= T) +?devtools::build() +devtools::build() diff --git a/DESCRIPTION b/DESCRIPTION index 5879a08..abea9e9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.0 -Date: 2018-9-27 +Version: 1.4.1 +Date: 2019-10-2 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and @@ -39,4 +39,4 @@ LazyData: true URL: https://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN -RoxygenNote: 6.1.0 +RoxygenNote: 6.1.1 diff --git a/NEWS b/NEWS index 5c9bfd6..8049d52 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.4.1 +========== +Date: 2019-10-2 + +- changes made to loadNcdf for different types of NCDF files with different dimension names + + + hyfo 1.4.0 ========== Date: 2018-9-27 diff --git a/R/ncdf.R b/R/ncdf.R index 0fb5e93..0df8f14 100644 --- a/R/ncdf.R +++ b/R/ncdf.R @@ -94,6 +94,7 @@ loadNcdf <- function(filePath, varname, tz = 'GMT', ...) { # Only deals with the most common dimensions, futher dimensions will be added in future. dimIndex <- grepAndMatch(c('lon', 'lat', 'time', 'member'), dimNames) + if (length(dimIndex) < 3) dimIndex <- grepAndMatch(c('x', 'y', 'time', 'member'), dimNames) if (length(dimIndex) < 3) stop('Your file has less than 3 dimensions.') # First needs to identify the variable name, load the right data From d1d3728e6540028fde8a948298f3de562ed956ab Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 2 Oct 2019 11:30:34 +0800 Subject: [PATCH 14/43] remove travis check since package rgdal cannot pass it --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 5f92802..aa6ebb1 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ # hyfo -[![Travis-CI Build Status](https://travis-ci.org/Yuanchao-Xu/hyfo.svg?branch=master)](https://travis-ci.org/Yuanchao-Xu/hyfo) + [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/hyfo)](https://cran.r-project.org/package=hyfo) ## Installation From a65b9056588c5e0d2202256060f734fce87ef020 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Fri, 25 Oct 2019 16:34:47 +0800 Subject: [PATCH 15/43] updated for travis --- .RData | Bin 2586 -> 2595 bytes .Rhistory | 10 +++++----- .travis.yml | 6 ++++-- 3 files changed, 9 insertions(+), 7 deletions(-) diff --git a/.RData b/.RData index 57e33ec8b9c139ae68107823c9b37f80b2b6b193..5bc9d9d7b5a0d2c8a241183405dc6d41e813aba8 100644 GIT binary patch delta 66 zcmbOwvRFi0zMF#q4A>ZXxITXka)~hJir@l@Ff%Z-F)}c-f+Sg;11ycrCMsz&I&Jhj O!pU)ZiPT{ppdtW=oeX;b delta 57 zcmZ21GD}2BzMF#q4A>Z%x&C|&a)~hFir@l@FflMQGchnRGfdRhX5`u!euR_5p)qj= HGf)lyFDeRf diff --git a/.Rhistory b/.Rhistory index d522918..21009d2 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,8 +1,3 @@ -# 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 @@ -510,3 +505,8 @@ devtools::check(as.cran= T) devtools::check(cran= T) ?devtools::build() devtools::build() +dvetools:check(cran = T) +devtools:check(cran = T) +library(devtools) +devtools::check(cran = T) +devtools::build() diff --git a/.travis.yml b/.travis.yml index e4b1735..b07e912 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,7 +17,7 @@ apt_packages: - udunits-bin - libudunits2-dev - netcdf-bin -# - libproj-dev + - libproj-dev # - libcurl4-gnutls-dev # - libdap-dev # - libgdal-dev @@ -26,7 +26,9 @@ apt_packages: # - libhdf5-dev # - libhdf5-serial-dev # - libgdal-dev -# - libgdal1-dev + - libgdal1-dev + - libgeos-dev + r_binary_packages: - rgdal - rgeos From aebf4c3aa64e6abfffbd55836956b2a32cd643e5 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Fri, 25 Oct 2019 18:16:54 +0800 Subject: [PATCH 16/43] Update .travis.yml --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index b07e912..8990489 100644 --- a/.travis.yml +++ b/.travis.yml @@ -28,6 +28,7 @@ apt_packages: # - libgdal-dev - libgdal1-dev - libgeos-dev + - libproj0 r_binary_packages: - rgdal From 4b1b7f7b3792d6e60fa7f659818729e9c96b56af Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 11:45:50 +0800 Subject: [PATCH 17/43] Update .travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 8990489..3551369 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,7 +17,7 @@ apt_packages: - udunits-bin - libudunits2-dev - netcdf-bin - - libproj-dev +# - libproj-dev # - libcurl4-gnutls-dev # - libdap-dev # - libgdal-dev From 90fc32314e72340fe27a3e68ae0067f7e0388c4d Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 12:30:32 +0800 Subject: [PATCH 18/43] Update .travis.yml --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3551369..c402791 100644 --- a/.travis.yml +++ b/.travis.yml @@ -30,6 +30,6 @@ apt_packages: - libgeos-dev - libproj0 -r_binary_packages: - - rgdal - - rgeos +#r_binary_packages: +# - rgdal +# - rgeos From 7fe7d4336892779b4773d06eee2e0680fc63fddd Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 12:36:19 +0800 Subject: [PATCH 19/43] Update .travis.yml --- .travis.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index c402791..b22ba1e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -30,6 +30,7 @@ apt_packages: - libgeos-dev - libproj0 -#r_binary_packages: +r_binary_packages: # - rgdal # - rgeos + - data.table \ No newline at end of file From 867d7d50496bea4a7f5d48c014d3fad15131ff8c Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:22:53 +0800 Subject: [PATCH 20/43] Update .travis.yml --- .travis.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index b22ba1e..ca82e26 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,8 +29,9 @@ apt_packages: - libgdal1-dev - libgeos-dev - libproj0 + - r-caran-data.table -r_binary_packages: +#r_binary_packages: # - rgdal # - rgeos - - data.table \ No newline at end of file +# - data.table \ No newline at end of file From 91db66dda00e964451484638228632c2100426c5 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:25:47 +0800 Subject: [PATCH 21/43] Update .travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ca82e26..e329ad4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,7 +29,7 @@ apt_packages: - libgdal1-dev - libgeos-dev - libproj0 - - r-caran-data.table + - r-cran-data.table #r_binary_packages: # - rgdal From 41cbbce215e6f0706296f0d18e07feee9dc7d1cc Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:29:39 +0800 Subject: [PATCH 22/43] Update .travis.yml --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index e329ad4..12f236d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,6 +10,10 @@ env: - NOT_CRAN = true before_install: echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && + export PATH="/usr/local/opt/llvm/bin:$PATH" && + export LDFLAGS="-L/usr/local/opt/llvm/lib" && + export CFLAGS="-I/usr/local/opt/llvm/include"; fi # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: From d6378932f3782e7b32f0b0ccb398069338374051 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:34:02 +0800 Subject: [PATCH 23/43] Update .travis.yml --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 12f236d..4e1cf2d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,10 +10,10 @@ env: - NOT_CRAN = true before_install: echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && - export PATH="/usr/local/opt/llvm/bin:$PATH" && - export LDFLAGS="-L/usr/local/opt/llvm/lib" && - export CFLAGS="-I/usr/local/opt/llvm/include"; fi + if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && + export PATH="/usr/local/opt/llvm/bin:$PATH" && + export LDFLAGS="-L/usr/local/opt/llvm/lib" && + export CFLAGS="-I/usr/local/opt/llvm/include"; fi # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: From cfd8f3e051db7b31ea5e1a7d1d29911bf6d03933 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:38:02 +0800 Subject: [PATCH 24/43] Update .travis.yml --- .travis.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4e1cf2d..95a98f2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,11 +9,11 @@ env: global: - NOT_CRAN = true before_install: - echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && - export PATH="/usr/local/opt/llvm/bin:$PATH" && - export LDFLAGS="-L/usr/local/opt/llvm/lib" && - export CFLAGS="-I/usr/local/opt/llvm/include"; fi + #echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && + export PATH="/usr/local/opt/llvm/bin:$PATH" && + export LDFLAGS="-L/usr/local/opt/llvm/lib" && + export CFLAGS="-I/usr/local/opt/llvm/include"; fi # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: From 72e9edba994a31b2992e95aad9cb28e4f28a80b5 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 14:41:57 +0800 Subject: [PATCH 25/43] Update .travis.yml --- .travis.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 95a98f2..cb9864e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -33,7 +33,6 @@ apt_packages: - libgdal1-dev - libgeos-dev - libproj0 - - r-cran-data.table #r_binary_packages: # - rgdal From 3097deca9c01e81a8abcb20b854859dbc8ec6122 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:01:56 +0800 Subject: [PATCH 26/43] Update .travis.yml --- .travis.yml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index cb9864e..e27fafb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,11 +9,7 @@ env: global: - NOT_CRAN = true before_install: - #echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile - - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && - export PATH="/usr/local/opt/llvm/bin:$PATH" && - export LDFLAGS="-L/usr/local/opt/llvm/lib" && - export CFLAGS="-I/usr/local/opt/llvm/include"; fi + echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: From 1e0771eaeeb379df4ea7a0aadaf6c00e38f8aef7 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:07:41 +0800 Subject: [PATCH 27/43] Update .travis.yml --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index e27fafb..b22ba1e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -30,7 +30,7 @@ apt_packages: - libgeos-dev - libproj0 -#r_binary_packages: +r_binary_packages: # - rgdal # - rgeos -# - data.table \ No newline at end of file + - data.table \ No newline at end of file From b77e6d92795362b20c5a5cc49eeb093f7817086e Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:18:30 +0800 Subject: [PATCH 28/43] Update .travis.yml --- .travis.yml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index b22ba1e..80f9fcd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,8 @@ # Sample .travis.yml for R projects language: r +r: + - data.table warnings_are_errors: true sudo: required dist: precise @@ -9,7 +11,11 @@ env: global: - NOT_CRAN = true before_install: - echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile + - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && + export PATH="/usr/local/opt/llvm/bin:$PATH" && + export LDFLAGS="-L/usr/local/opt/llvm/lib" && + export CFLAGS="-I/usr/local/opt/llvm/include"; fi +# echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev apt_packages: From 48f48243b9ef1e09a5090c86385846c89a0c63b4 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:18:47 +0800 Subject: [PATCH 29/43] Update .travis.yml --- .travis.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 80f9fcd..e536d76 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,8 +1,6 @@ # Sample .travis.yml for R projects language: r -r: - - data.table warnings_are_errors: true sudo: required dist: precise From c2f1c7a2f6fc6a9a1223d0e4cee3a8d6e995d70e Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:21:47 +0800 Subject: [PATCH 30/43] Update .travis.yml --- .travis.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index e536d76..abad6da 100644 --- a/.travis.yml +++ b/.travis.yml @@ -34,7 +34,9 @@ apt_packages: - libgeos-dev - libproj0 -r_binary_packages: +#r_binary_packages: # - rgdal # - rgeos +# - data.table +r_packages: - data.table \ No newline at end of file From 314b81532e8f4d7f03ef33dc9ef61cfe0ed5b449 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:24:54 +0800 Subject: [PATCH 31/43] Update .travis.yml --- .travis.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index abad6da..b3c17c3 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,6 +13,7 @@ before_install: export PATH="/usr/local/opt/llvm/bin:$PATH" && export LDFLAGS="-L/usr/local/opt/llvm/lib" && export CFLAGS="-I/usr/local/opt/llvm/include"; fi + - R -q -e 'remotes::install_github("Rdatatable/data.table") # echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev @@ -38,5 +39,5 @@ apt_packages: # - rgdal # - rgeos # - data.table -r_packages: - - data.table \ No newline at end of file +#r_packages: +# - data.table \ No newline at end of file From 6c496a763972ee99a2d815dedfcd68fbe062391b Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Mon, 28 Oct 2019 15:28:18 +0800 Subject: [PATCH 32/43] Update .travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index b3c17c3..cda9e1c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,11 +9,11 @@ env: global: - NOT_CRAN = true before_install: + - R -q -e 'remotes::install_github("Rdatatable/data.table") - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew install llvm && export PATH="/usr/local/opt/llvm/bin:$PATH" && export LDFLAGS="-L/usr/local/opt/llvm/lib" && export CFLAGS="-I/usr/local/opt/llvm/include"; fi - - R -q -e 'remotes::install_github("Rdatatable/data.table") # echo "options(repos = c(CRAN='https://cran.rstudio.com'))" > ~/.Rprofile # - sudo apt-get autoclean # - sudo aptitude install libgdal-dev From efd0b27585cd2f1099611aa66d7eba52ed600136 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Sat, 4 Apr 2020 00:27:27 +0800 Subject: [PATCH 33/43] to work with new R version --- DESCRIPTION | 4 ++-- NEWS | 8 ++++++++ R/ncdf.R | 4 +++- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index abea9e9..de00783 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.1 -Date: 2019-10-2 +Version: 1.4.2 +Date: 2020-4-3 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and diff --git a/NEWS b/NEWS index 8049d52..d328388 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.4.2 +========== +Date: 2020-4-3 + +- change to work with new R version + + + hyfo 1.4.1 ========== Date: 2019-10-2 diff --git a/R/ncdf.R b/R/ncdf.R index 0df8f14..1282752 100644 --- a/R/ncdf.R +++ b/R/ncdf.R @@ -450,7 +450,9 @@ getTimeUnit <- function(dates) { output <- NULL for (unit in units) { time <- difftime(dates, dates[1], units = unit) - rem <- sapply(time, function(x) x%%1) + # previously it worked like below, then new version came + # rem <- sapply(time, function(x) x%%1) + rem <- as.numeric(time) %% 1 if (!any(rem != 0)) { output <- unit break From eec386ac4c973dde54836f8cbc25d8d521ba808a Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Sat, 4 Apr 2020 02:14:04 +0800 Subject: [PATCH 34/43] Update .Rhistory --- .Rhistory | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/.Rhistory b/.Rhistory index 21009d2..31f4ff2 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,25 +1,3 @@ -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. @@ -510,3 +488,25 @@ devtools:check(cran = T) library(devtools) devtools::check(cran = T) devtools::build() +devtools::build() +install.packages('knitr') +devtools::build() +library(hyfo) +?writeNcdf +filePath <- system.file("extdata", "tnc.nc", package = "hyfo") +varname <- getNcdfVar(filePath) +varname +nc <- loadNcdf(filePath, varname) +writeNcdf(nc, 'test.nc') +debug(writeNcdf) +writeNcdf(nc, 'test.nc') +writeNcdf(nc, 'test.nc') +debug(getTimeUnit) +dates +units() +units +time +dates +dates[1] +rem +devtools::build() From a6372b893053b910d0aabb6175af177b9442f02d Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 26 Aug 2020 16:05:45 +0800 Subject: [PATCH 35/43] update of sp object --- .Rhistory | 76 +++++++++++++++++++++++------------------------ data/testCat.rda | Bin 3566 -> 3326 bytes 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/.Rhistory b/.Rhistory index 31f4ff2..c477936 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,41 +1,3 @@ -# 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", lower = c(0, 0)) -# 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)) -} -biasCorrect_core_eqm_nonPreci <- function(frc, hindcast, obs, extrapolate, prThreshold) { -ecdfHindcast <- ecdf(hindcast) -if (extrapolate == 'constant') { -higherIndex <- which(frc > max(hindcast, na.rm = TRUE)) -lowerIndex <- which(frc < min(hindcast, na.rm = TRUE)) -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) { maxHindcast <- max(hindcast, na.rm = TRUE) @@ -510,3 +472,41 @@ dates dates[1] rem devtools::build() +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +library(hyfo) +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +sp::rebuild_CRS(cat) +install.packages('sp') +install.packages("sp") +install.packages('sp') +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +library(hyfo) +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +sp::rebuild_CRS(cat) +a <- sp::rebuild_CRS(cat) +a +getSpatialMap(tgridData, method = 'meanAnnual', catchment = a) +save(a) +save(a, file.choose()) +save(file.choose(), a) +file<-file.choose() +file<-choose.dir() +save(a, file) +file +save(file, a) +saveRDS(a, file) +saveRDS(a, choose.dir()) +saveRDS(a, choose.dir()) +saveRDS(a, 'testCat.shp') +saveRDS(a, file.choose(new = T)) +library(hyfo) +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +cat +a +a == cat +identical(a, cat) diff --git a/data/testCat.rda b/data/testCat.rda index 75fa18719f066eebd0c2a18e072006c177e16815..2b8ea7fc1010871dc02397123321546a437942bf 100644 GIT binary patch literal 3326 zcmVza&;Pz0snh8~b)i-Dy3i{0QdcD@`Pq)0bo$VSI$c-@{Xwq_(^aDk zGn^@_;v{kK^aTaSHy{g0R%D*PsOpZ|&`G4U?hs9=}n2#Q}$5zoY@)K76<%NRtZI#h@>o2w#}4j z5mYNu8oCY{4(W;V#aDCK$9I4#Ko98TUhtsA5xI8jgiO0lN?VVmRa;3!a``lRKWVC1 zO`~$1&_Tp?s!_?L=^TyH&hdTn73 z&INVyqxPq9F8Qhc6nCwmZdU5Bu_of$^vd0X8>bN0C(kVDcqNaxzNp%H zRnsiu+WXzPTEkxF{QAR!Ns9{9JT@)*+R-A;GedTyh8Ggo53PpnPkf)aO8$5lJ83y_ zUH^93itV4Nd2>y-$kI)m_r{$sXniPfdR~}xC4CQPu<2#Gt326w@QRPstp49!vxH`W30vDGfs0pW$5lCH;KDLy^B9SxT0qK)u{vHLx{WE&ZfI^ z?htp+xqDl0s7Ks=M~y5h2`BF4PWrGXT%0deTQxQ{nz%l z={v%j61U^!<}JH-Bkl=p_b)1l<(%p@>$bkgIrCIl&W)a8&Ut_B`IfJ!xp<m>cf2oL?)IxVQZCpu3NgxIcY2bM*8q&fU4;XLrq16Q_gc zMfqsutCb(r6Y34^146rTe?Wghze0b*IKa5TIN@=GafWdRdjR_Ydjb0aV*3L71A7EJ z1%my8J46!hD7K4D%c2JIsI31<(!96Cmge=nm)*=#ogku+9NN2SFc!pqrqh zps%32pujH1gN>UgH$Oh$`~}MK z6Z$!7QyPBg6OpK3WRG6OPWqB^YIS1#O3D>g5)L1s%*g6G(xu?j-*mbcXD}{((4pg; z5tRED#5SL+;H=-x* z17SYkd7?#_Ux+aORPz$%tB5eKWx{;-5p)3b0rUbW>j>5t6+wsId@Jp>Cn?EOuip5r z0^a#5J(X~-XlKgUOWVIhb$dCBtDbRYo}^50j6Xr!SM01k zsaw8+A8eYkE>XcB`%bT2pL1n{pJx*P=Wf` zvLw|Y3*_fewMXG(k?z;R{vKZo$~QONo|9v-IsKGQ)B4;r;a;`tM$tI;^{Aa;$0F&% zbic;hdughgFZ^zG>b$F)%YKjas=YGRz3R@Z;VpB#gkB7MgAwcoCfJP--mr+MwSmDK z84>XY5^pd?8y?ZdN3;P7bR#6%Xyc6#-Vou95ZVx7iW~?3cLxQgXd{NHwK2mRG)(O9 z33S62?8Xf{utXcSK#3h_u))KG4WAbAhEQu`h$(XTi5!2Tc0qq=QOhx?(PgFahhi^M$fpX*IW&m!(~dkSZ-UC()GVe1DM-{t(-ayT=32j{QPjy^qj zGw1I$t0&H0L);Jly>atFLOl9y{Tu7HaYnpxqp<4<;;H@D*>{}>IUj$zefs7S;%O3c z^!T+i+HC$WTlZ$aYqQMqbfzsQ)0-ILVS1AwCexi~IJMGiJEmQhrjxnE!*p^k@i3j7Mm$U( zR}v4?$3>h>C%14iyzGQHHPDd}h9CdAA1vo7&6-RwZTOgEczGTm&z$#kLIERz8@%YK3c@jLq9>k0dc=VzvFR%@xtQ>;|t>r1Umq`0DA%Z zk%{d~MQo2?r$De@Y~Nt_Fb{w*KVZJV{1MGxn1@&=KtDiFfS@y=JD^8E&?znb10BWs z3c8DR8T1=;9&{flT1W7D1nU&6Yp@Q&x(Mr~yne#E>RV@F-G%iSuh)1zhjkv-eRw~> z`_Nzy&a~cdwBBFJ7=WWFSjSJW4j&QAIfAqutf~VY(ZLRK@L~tBro&k4;0H5U2e;^; z2pt%SsCkf7*#jl5gC)^H5<0-Z2OO#cB`x9umdYMHX&ppq9UujGAhqa_`S|<;lncK; z+VU=CTAM?=TTr%`b1-G7!MO0ZoBOU8D)@N{nYvBEX`k+@f0eRd!_PN0Q1G$I+j}M% zj0-MY`uN;L%Jn@r+g4NNuG<)PT*0mp>z9X9hK^Yq*O_zvkz?yc zdV4Qrt9wO-rJVC_4PO+~Ou?PI=Y2Y;0!ohR8I-c4+DFMzU1BiKl^oS{KF*c&rZ=Ue zGvobG(w)^6P|~9loO5J75>nEq_CZk6uZ#dF>DzqH*^<8PseqEc-BM7}xfTk_dZ!{z z7c6nPK&|?TC@Kf)E9vrdgK?Im%Ucwbbommcq|5acl=Qg=rKHPt&bMS;R#DR9Zz&}m z_WGfu%drMyp`^oUl#;#{`XStx3D5b6^M!In6x0{D%SUK8^aJz{>Nn_5l|5*Tr_VmY zUa_5{dE%Q_FwgM3gn28XJilSSt8@VL0rUdt3)UZ>E@6Uh$vTGh&8K@n&_mEkSvNsP zRr(6LDBc!C2{ z5LE#UBI5TH9PoewA5;Ml@IItPQDB5tfJC4H5Td|_Km#0bAcH7?0p6E!0D~w{K@^aH zsTH6g2vkr7EMVe;Xc0vL4x)gDKo8_4y-M{%Nw->P^F2w=?pHub*ADriq;m@@prn5p zeu&eF@)y)6==M~${*TH4+oMIzafI>K2*eNuW|RxiC_DeI31{N;T3;GeG=uo?A2O)z z=fGX-K)(*oRUcRJN&ln8C`74>i}h3g5S{M}o${Z5j2dMxC<`Fag@I!eUhLpY2AB}) z4u^l`zhg0H=fHO{_2e{lbo~1weF0odKzBlOvTeRgQ-PmAjOw`#`{?*Qr}R~dzfWkS z+a^aQ{s^i^Tj@rE)o#nQnw&9h%_e7lPQpvir*w&rX=}5;YPMwL#k93pt+{#dtJ6L{ zGp|d0LTo$wS1?eaNrO`YH6_)<(J8qmXST@-gWb#IH1+1+83j4&VM7KFHA?sY2hQkc IC6+b-03p_&oHWS!ai{$8pZCY)2V6 zD|?2BLV47$p4anw{(qj&AK%yakGH;~kEY69gftuhne5X7ToHf%_y4uV@r?F{qlUMn z7QpCYNB1kmneuorS+wYL0e%GT4i8x0_}TBbu$b;RGFm>o*eb@tt9e( z^0|qF`({SK%rVO5(mb-;qLo$O({B=SR@>Up#8cm!gv(l7+S0ix_%jjSwa6$HOza4S zFeoZ^+>5d<0l&VCxtyYx0O$wE^wwX0K?Aoqp<>rH)&Xwf00paoctq0r|{~AlBc{OxTR&ox%XM!Z~2gP?A^V}oHAdSl4BX^i%Mdp#frFYyvU7tWX+(! z$UG~Vl&9}zneF_R(kjc$6mUy4J7;o_G5JDbRYdPPerdOyhF-3MyMglXP<9dD#u zs?&$2lswfYl;FKoMS5lM3424Y>b@KD6`w=RPdNJ?N;jxvTwY!$FNG#(IleX|>%l!I zG(RxXePcNA&)AJfw~|mjE;YY*nnR?Mlp910{y}T%4Z3SGNq?9*Q=u7NI+rqPH|s2n z_o0Q)C_x9`*3-wIZ{oNCf)ku~o7nGM%TTHRxbVDBywr{3V8#BveEHH*87Kt@Bo&7C zCp}^+TEV`im{I}+J=i?1%oBkTHO1)sYo4n(ek#@MWl={yc#bXLm8wP1=$BRZcJ$LS zvxjx*=h<((+PRiQwfUPHPO3x*YUba)t= zd6bFkW-6I?EVU4QOQ<_MZ5E^6*#`rUJ$wqu>P0v0KJF~EE=;v`C54@CTP*jd&A4!{ z;a*8^i;j@Ls8zV9Vq=<-LPI4M=TNZ&#w9wZMoDbH9b6^oZw%?NaoBY_Eyr=|Rf{P{ zxI%Pt+So847+o1{+rFgI@Z{@ANb^>T%>{T`*z@Aj*pG#EqT;h+SW7rA^GWUo8h7zb zlE5!^-Kv9V25oi0)4fC1!j)+Ksu7dl2huRPl4Df zXwu--=+%@z!}dxC;tn2Lsd)C6U11ukM`9Sqwh$YslB9zvLd03wA#?`pyyUI+L01>Z zHY;!yc>9n$_nF%b5Wueo)M2XpMuC~EvHS9OfQm`H3>2@td(R9(X=p&?<{Gp>FkbLyDe{kc;n6sTIVQUPR z6YzTik&-a5?3BmT(sKl~yZ#fs*ar8_kghQpQYZWk2-fg#<%6?nco~&z^?^XOzw6&w z3pX31#eaCb*gX)zciwF?Mh&X-K$F*GwXGyOGlxNoX;joGvRgpbMzz~P|p ziAngS&!P`PPEWw=Hy)uK*~+CKAz%C4%^FspI#%1q*qcl)#=C2 zNjs@Lx!mi8My3(|q3w50n6lvwcaa6+Y-{uV8S;sBdlDIYR9>oxXv`wMiRy!7J0tKr zdzH8MPf0*f+zhZDdqi%MQ>L^oFosQYadLQ zaOW1gRnPuw_1(1&A!F!Hxg>3LB~!tL|HrciShk5 z-={V!zu0{*z&&Htz<+`~;KMfGdD89+DaAXLCCZA{>`H%-<5TW+eRiMwmt%?x%(B7^ z%UOO7JAIyVM^WR3?vqW^k5Qi;iHCXIR@XXdX^389#;tyLb^fJC=E0(15bbNRTmANjh_|U9Mzsnd(>@B1UB_?p}nr)P{sZ(?PtKc$;B=P%N&u)Q^r`+m|lq*LV$#vYUJRwrR3?BUrXZrHq z;4j?Yba?g>*<=KQq}vt{QLTT%vHfeW@vhO(L+_pe)#(reRetjy)L}`>BEfOhqWIyu z#gKoP-j7pUEM_v1q(FbmOV;8o;^6EoH5%-Fi5|Cy7&`7Y5vLa-f2EG4^zaYCD29*Y z+N4%TmK{}oXoj`K+xw9@f2|?j*?zi zWeY_07HnIRPY9uK{-_%14`=A$53%;M?`m{Kq|3g^*G0Gvq+!-7BXuu{cKZ%3{S9yJ za*u%5E2TBsg=T(Zj&j@|dk}qW9B0uPgBoJ1bkKpqex*||d}YPMwp1f*aO39`{CVG` zD+$hbZo8%^C|Zw`n6 z(mL+evDJ%T(hRYF3pe|dr8{PbOh#9GSFgY}5wQtNxFt z3*NtsmukE!e>E2g&c+JKgiEq+k6pg#uQiXWt-X9KMM=d+@V=XOAlkIbjN~Qr9^OJa zVdJK!EA#lPa*fE|vY8+U*Gnouu{|#nq&pbO7sEIzx08btqF-@7L@=K5u>5?*)Dzn3 z)=|+|FVS+66;W}%Jo@NRAL4yRv}#$2kATLLiP<4xI|Rg3yV(zm_pN7ht!EY2le;8~ z(qbOx1cxW>c1;Hp#9!-jx5(9N`OQ{Jd=}7{QIFd0v@e0ut(q+%ULMUU+0IJl7MDXT z2;sF8z~c`>mA{9EI(|JQ%OM~Z6rn7&-LR?$S&BSNiEF_9Erw--9eW#MeQQpP&upg7 z{&QTNaM+wCZUt5V**_hQ`6#z-Jha7Z8QBqix;mx-dD5eaomYg1hHo;Fi1%rJ5jJWN zip^bv#wPr@sr0z`<1r`k1qbE)d#Sqe0mYfSo^T6wGfjGqN%_PEGB)ne?A2`$=i1Op zd5W`JL z=M-?1Bx4;&uN?cvFW*kc)@Kyq+-G9x$@Rfx!Tpsbv~)e_$v1&Xci5tIbr1e84^X6b zC|#hdTTSU(&x*W8a^G`J&5CARVPXM!VkJQUUY*(bSh%`@if5Zs)d z;SZCaM#r-Xy0Iv@eNZF2-(WVG^XLk~qj%avn zQTJb_Pb&j2s!oj0Wee0-5QxvIj;br2J9&@4@>MwlgH0DD3nO+niy-#&YX{TdNu4wA z(|H&|F)}!X#fSG;X5&g;cA=K%hjwfPuC}4~3#>tl)UV`q;W6x_IvwFVHDMcBIs)4X zD}g6e>Cc-_t*G_k6ddzVs1fGKGb>Rl zNYApvbP_67*jdQZvS={*@3Opn?x;> zD6hP6#m9k(-EnCCbLE_5lF5-BuZwk;nFLZfVKG$}WNx~9Ytd(iy From df01308dfcd29cf42e6cb3baacb1ec5872024f41 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 26 Aug 2020 16:08:01 +0800 Subject: [PATCH 36/43] update news and description --- .Rproj.user/shared/notebooks/paths | 1 + DESCRIPTION | 4 ++-- NEWS | 8 ++++++++ 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index d0fc7c0..bfddd77 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1,3 +1,4 @@ C:/Users/User/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="BE89A8F" C:/Users/user/Documents/GitHub/hyfo/R/extractPeriod(generic).R="35D21910" C:/Users/user/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="E84A6BF8" +C:/Users/xuyua/OneDrive/文档/hyfo/NEWS="73E17A04" diff --git a/DESCRIPTION b/DESCRIPTION index de00783..46912f4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.2 -Date: 2020-4-3 +Version: 1.4.3 +Date: 2020-8-26 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and diff --git a/NEWS b/NEWS index d328388..24eeb7c 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.4.3 +========== +Date: 2020-8-26 + +- update sp object with CRS issues + + + hyfo 1.4.2 ========== Date: 2020-4-3 From 12c72077c305486e11a3eab15dd306440a167e6f Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Thu, 27 Aug 2020 10:41:11 +0800 Subject: [PATCH 37/43] tiny changes --- .Rhistory | 38 +++++++++++++++++++------------------- R/ncdf.R | 3 +++ README.md | 2 +- data/testCat.rda | Bin 3326 -> 14587 bytes man/writeNcdf.Rd | 3 +++ 5 files changed, 26 insertions(+), 20 deletions(-) diff --git a/.Rhistory b/.Rhistory index c477936..1491e09 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,22 +1,3 @@ -# return 1:length(sim) -if (length(higherIndex) > 0) { -maxHindcast <- max(hindcast, na.rm = TRUE) -dif <- maxHindcast - max(obs, na.rm = TRUE) -frc[higherIndex] <- frc[higherIndex] - dif -} -if (length(lowerIndex) > 0) { -minHindcast <- min(hindcast, na.rm = TRUE) -dif <- minHindcast - min(obs, nna.rm = TRUE) -frc[lowerIndex] <- frc[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) -} -biasCorrect_core_eqm_preci <- function(frc, hindcast, obs, minHindcastPreci, extrapolate, prThreshold) { # Most of time this condition seems useless because minHindcastPreci comes from hindcast, so there will be # always hindcast > minHindcastPreci exists. @@ -510,3 +491,22 @@ cat a a == cat identical(a, cat) +devtools::build() +devtools::check() +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +library(hyfo) +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +file <- system.file("extdata", "testCat.rda", package = "hyfo") +cat <- shp2cat(file) +file <- system.file("extdata", "testCat.shp", package = "hyfo") +cat <- shp2cat(file) +devtools::check() +devtools::check(cran = T) +devtools::build() +devtools::document() +devtools::check(cran = T) +devtools::built() +devtools::build() +devtools::build() diff --git a/R/ncdf.R b/R/ncdf.R index 1282752..1180e52 100644 --- a/R/ncdf.R +++ b/R/ncdf.R @@ -339,7 +339,10 @@ downscaleNcdf <- function(gridData, year = NULL, month = NULL, lon = NULL, lat = #' #' # Then write to your work directory #' +#' \dontrun{ #' writeNcdf(nc, 'test.nc') +#' } +#' #' #' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' diff --git a/README.md b/README.md index aa6ebb1..7026754 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ install.packages("devtools") devtools::install_github("Yuanchao-Xu/hyfo") ``` -**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo)** +**Official Website is [https://yuanchao-xu.github.io/hyfo/](http://yuanchao-xu.github.io/hyfo/)** hyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate. diff --git a/data/testCat.rda b/data/testCat.rda index 2b8ea7fc1010871dc02397123321546a437942bf..4dffbafd814ff05c95169717937706847d59007a 100644 GIT binary patch literal 14587 zcmb`O34BvU9>>!|TFNCL0*cZtD+-j_3)+H6O8YF;($*Fbgesv4Z6QrcnsSH>D+&sh zTZ@1c4-{4qJV3>3@WKTFL14iP)+z!kitB-*dCAVayx&Xm4{u-VNBrQI$;_LXH}jw0 z%=~9wN$!}`xG`}ilPS^^&HqM5@qb1~^8ZEfaBI#Ox2@KlV{w}zqPml)Xsg9-F`1$| zi)T37arz%s7?MpZyKS1yUdvNls-*H~-YVN+aZR+LD9L4WIPa<>#avQux76ZERIAk_ zOS#+W;(2*5UUHO=logqiqLvexlj<)b8flDkjqpFA<%%a_hq)|{^2+#>=HzHObiJ&yGIhB?who!m2PESGs=r2(P_5H$HBu?~k(j=ECUTN!)UX87B+Gkcc9iqCO`QONkSV?SgXqt$N zq`AaynONiI87K|JJcq7mnpHf~EUn&IocJX-$&f;$EiM~3J0)$z&}oS$UR#vFpAAh@ z>9mUq3(MxOCjNxP$GEB-6}eTyencyXBx(zAs*kV?_F#UKr)*QTlc11gRtQQ0k@ED~JAWRDZ5&OP2E zz`D179RFz+^MH3hykbw6B<8udDm|maw)%(W5OrF{AofR{Z1DxZtnqC;eWN`kW=<2h>n5@S|Pp|*9_Z>{8eCRG| z_=H=Tyk^A7?W=EM@)LiVpK!QbpBsPfy|n#kCU5=cE_t|{$uB)xF?nuffN#{q9DRL0 zlPPIBJP*=%8g6NRs3+bB?+4<&X?vjk(5`5A^aJ_@{Y3i{{fz#HJ-|L-FR&kw+8OK* zb_qKLVZX3v)$YT_55^;i@r&_{@s070@eh4~en3w^=nQlRIs{#!x`i!yztY{Ij7IO#npk+{Mqo>>>$Ps&24n^MarQkveVabuDxW)p1qutDhEyQ1o8S0 z2L6&_mR4OzN?TOM`S!BpUWw}ok>wJ$LX6fN?=Kt`*Y0hnD z&gEalIlJJS6T><4ww|t=#@Vsc$u_*64}DVi#p8#A_~fzUnXx>q$LhhK>>tA8^*FHc zsMXHnK~uz`-&XOk9+3{D>F_%(Pp^J@zmxaG`)loic0oHC5$%e0R@tDozee;A`V0N1 z_Al*s%^qMEuoKm8s6AT&<43uyKj;sz;1# zm21@Tt`T|weSltos*XTcbO}9rVBz?CujV?$uD$c@cmIb!zgs?<@pzSM6D^Z=ay?l) z(L1>>*B6be)>J=qJr9EiGHYZX536i!b;Moqky&aS;+lSt>sO<@!>qw|L40QO?5DWi zHG*H{&+X8KhgGiY`t`gSC(V*B3-5iP={X)xY4n^?Jk77UVVbYebMxZs3m)M0Zz+xP zZEpM@Etk9}`b+Ca^e0IBy}4o74XD}^>`No;kCNJ}YR9l^jTjFYAIf+k8~P|~RkgaA z7cQs^{I4K)4vBrgaBD;g#}hX9F{)F7`r%) z%gS9bVV;E6!n@QQhel+6E>9U;y@+Ig#o~|!@pFW|Pmq&Eyl)5bTyTck8-#j6%AM8K z+?PZWi_-a`NvO;UUF)S|MxZ` zFXEMHD}Ezxn0EX(;dqHUuD@}i8xR`C#s#GDbi;x$O^4^{h6NiJN}~-7HZ<7C=n)$n z5E~s(Z^NUv@xexjZh)G*5uzI)gy}|zZiwhch-`?cBS70A5yyd{qoSqhsRIKWFc2Ft zN~4V#-JoHk24ceoHh06;(v2H7Y@ptT4I4KjVq*tlgGY%CpAqSX5MjC@)C(g$NXtXL zP+z_G!v@xfXg{bEf(C8-+8*dOBa%|Ai{~+uF_5yo?0{{*I5cUW=h5b_dCgVdJ zcNmWtryv{|AjUO_aSt5;;V^+C1&$RsTA(-3A?Oka{emM0gx-PBLFglN6#5Fnkpx}V zBh_()q5G7W7eLG#m`5nz&DofHekPMY=sNs`YD^5K##Oa^~y*CxCENhbgH?@e2FG3JffR?x$=Ex_3O&n_5r zka;_dt3U7F72xI9_b=bl#JpEU?mKY$h%tNp%W-4EPt0q?zR$GZH2xIxg35uyXUwZd z;m|qoEAxVS>F_(!fr{hjEb}T3q&Vgk4yD<$J{6t0f_e3*=u8LZ1r@#N$Go7TH}TA? z=*SJ9^&=2diQV1SA~l`^lQPs5p4(IqSMDta_FKt-3P zF|VRaQvy_U>3-&IF6r|KBmd?S&w(gk(Z{=)7gThzhItj8T+Fm1>*83t^azAb zLAOAvZ_rWbDhS=B`V3u%&O`S>%m*Om3(P|x<}b{9mthp&caQpaTaVMh7H_$H5BtM-QIp!45qT!aHf;*u0g!)?(M^J%+j*YPdtC@F3t_Zwm6>Pta)lvG(Y&$I4E|*niw9AnzBA6 zBfzD5_doW2xmjA;kg~SyVa_`rTJ_^j&g*_@Sa2@DB|qH0B0j+^X?*RCB`@8|!+I1B z?Rh+2b%1LW4(lefv{)Q0@PpRHLT_&36prZW7opG{{yvNKC>+rTdA!O+>VbzYg=4zE zSz6Rw3LTro(;HDZw3qU9D(l68&6{RPmqO=$;PIf)Ic^X2pn6bLPl@r3PH z!g}>Uy~RQMT(k6`I3U{^M4`(kcv$E%KWNe@^m!-`3w?G5xKP#QFbX~X&@3$!ddv^J z!YB>|lg-isp~vGnh3@ik7DmLYT&O;$k>-zb^{7){`d(TX?~V3A`;d04SKCvw3$#D& zAJU(&OU;g{{gZKn@uZDAIzBOO^{9^TCF*$B#y|7``T+eP`a<Jj>EM5^y<82Yaf^8)4xb>7e}I$*v5F<;SnOud*8b|C@t zC+1ra^Dv=y;egEFy1!$-2eA&I#5w__7gI<$>_P)se`xVopHSk$1BeSV^a2FdLq^2< z3B<(+Q15~SUB_XaN7sX7{it1RXzm3EdXWL^UaW($F2)5YdVxXJ??;8c1YcB8FCyT; zR=bdZiwPiI|I-6ugvmt(93*QO7I1L^#6HA`^k5tN8odh*^q^kvKwjw8Xns+EQs@_- zzt=(2FwK#SGQ{{1-I*=j82iCLYO;-Ous!aZcPm2s`}`z0IJ1 z_>T-OMdm@@Js2J6cNEVAUnz)CKY0ndqY!e^A6Cm2-BIWiR-FG*f^wZhtG{Rz@t1zP z5j}CDbB6x{fhigePAu^7rG{A@7~u`Bpi{E_1ls%>tUEg>p6-fRpt+ooDgvTZ&r(~oLNK4I19gvchm7bP%(K0f#lC{!vO2_dY zsj8`UR#`3f#MGb%vd84}rV<@j<*u{x>}{4>cc6SxhoX{PsbpMA&_m6xS!hP$u|Oka zrKF~op%s)I{Z+BJ)tWe*E_Y>U4*seH*Zza&;Pz0snh8~b)i-Dy3i{0QdcD@`Pq)0bo$VSI$c-@{Xwq_(^aDk zGn^@_;v{kK^aTaSHy{g0R%D*PsOpZ|&`G4U?hs9=}n2#Q}$5zoY@)K76<%NRtZI#h@>o2w#}4j z5mYNu8oCY{4(W;V#aDCK$9I4#Ko98TUhtsA5xI8jgiO0lN?VVmRa;3!a``lRKWVC1 zO`~$1&_Tp?s!_?L=^TyH&hdTn73 z&INVyqxPq9F8Qhc6nCwmZdU5Bu_of$^vd0X8>bN0C(kVDcqNaxzNp%H zRnsiu+WXzPTEkxF{QAR!Ns9{9JT@)*+R-A;GedTyh8Ggo53PpnPkf)aO8$5lJ83y_ zUH^93itV4Nd2>y-$kI)m_r{$sXniPfdR~}xC4CQPu<2#Gt326w@QRPstp49!vxH`W30vDGfs0pW$5lCH;KDLy^B9SxT0qK)u{vHLx{WE&ZfI^ z?htp+xqDl0s7Ks=M~y5h2`BF4PWrGXT%0deTQxQ{nz%l z={v%j61U^!<}JH-Bkl=p_b)1l<(%p@>$bkgIrCIl&W)a8&Ut_B`IfJ!xp<m>cf2oL?)IxVQZCpu3NgxIcY2bM*8q&fU4;XLrq16Q_gc zMfqsutCb(r6Y34^146rTe?Wghze0b*IKa5TIN@=GafWdRdjR_Ydjb0aV*3L71A7EJ z1%my8J46!hD7K4D%c2JIsI31<(!96Cmge=nm)*=#ogku+9NN2SFc!pqrqh zps%32pujH1gN>UgH$Oh$`~}MK z6Z$!7QyPBg6OpK3WRG6OPWqB^YIS1#O3D>g5)L1s%*g6G(xu?j-*mbcXD}{((4pg; z5tRED#5SL+;H=-x* z17SYkd7?#_Ux+aORPz$%tB5eKWx{;-5p)3b0rUbW>j>5t6+wsId@Jp>Cn?EOuip5r z0^a#5J(X~-XlKgUOWVIhb$dCBtDbRYo}^50j6Xr!SM01k zsaw8+A8eYkE>XcB`%bT2pL1n{pJx*P=Wf` zvLw|Y3*_fewMXG(k?z;R{vKZo$~QONo|9v-IsKGQ)B4;r;a;`tM$tI;^{Aa;$0F&% zbic;hdughgFZ^zG>b$F)%YKjas=YGRz3R@Z;VpB#gkB7MgAwcoCfJP--mr+MwSmDK z84>XY5^pd?8y?ZdN3;P7bR#6%Xyc6#-Vou95ZVx7iW~?3cLxQgXd{NHwK2mRG)(O9 z33S62?8Xf{utXcSK#3h_u))KG4WAbAhEQu`h$(XTi5!2Tc0qq=QOhx?(PgFahhi^M$fpX*IW&m!(~dkSZ-UC()GVe1DM-{t(-ayT=32j{QPjy^qj zGw1I$t0&H0L);Jly>atFLOl9y{Tu7HaYnpxqp<4<;;H@D*>{}>IUj$zefs7S;%O3c z^!T+i+HC$WTlZ$aYqQMqbfzsQ)0-ILVS1AwCexi~IJMGiJEmQhrjxnE!*p^k@i3j7Mm$U( zR}v4?$3>h>C%14iyzGQHHPDd}h9CdAA1vo7&6-RwZTOgEczGTm&z$#kLIERz8@%YK3c@jLq9>k0dc=VzvFR%@xtQ>;|t>r1Umq`0DA%Z zk%{d~MQo2?r$De@Y~Nt_Fb{w*KVZJV{1MGxn1@&=KtDiFfS@y=JD^8E&?znb10BWs z3c8DR8T1=;9&{flT1W7D1nU&6Yp@Q&x(Mr~yne#E>RV@F-G%iSuh)1zhjkv-eRw~> z`_Nzy&a~cdwBBFJ7=WWFSjSJW4j&QAIfAqutf~VY(ZLRK@L~tBro&k4;0H5U2e;^; z2pt%SsCkf7*#jl5gC)^H5<0-Z2OO#cB`x9umdYMHX&ppq9UujGAhqa_`S|<;lncK; z+VU=CTAM?=TTr%`b1-G7!MO0ZoBOU8D)@N{nYvBEX`k+@f0eRd!_PN0Q1G$I+j}M% zj0-MY`uN;L%Jn@r+g4NNuG<)PT*0mp>z9X9hK^Yq*O_zvkz?yc zdV4Qrt9wO-rJVC_4PO+~Ou?PI=Y2Y;0!ohR8I-c4+DFMzU1BiKl^oS{KF*c&rZ=Ue zGvobG(w)^6P|~9loO5J75>nEq_CZk6uZ#dF>DzqH*^<8PseqEc-BM7}xfTk_dZ!{z z7c6nPK&|?TC@Kf)E9vrdgK?Im%Ucwbbommcq|5acl=Qg=rKHPt&bMS;R#DR9Zz&}m z_WGfu%drMyp`^oUl#;#{`XStx3D5b6^M!In6x0{D%SUK8^aJz{>Nn_5l|5*Tr_VmY zUa_5{dE%Q_FwgM3gn28XJilSSt8@VL0rUdt3)UZ>E@6Uh$vTGh&8K@n&_mEkSvNsP zRr(6LDBc!C2{ z5LE#UBI5TH9PoewA5;Ml@IItPQDB5tfJC4H5Td|_Km#0bAcH7?0p6E!0D~w{K@^aH zsTH6g2vkr7EMVe;Xc0vL4x)gDKo8_4y-M{%Nw->P^F2w=?pHub*ADriq;m@@prn5p zeu&eF@)y)6==M~${*TH4+oMIzafI>K2*eNuW|RxiC_DeI31{N;T3;GeG=uo?A2O)z z=fGX-K)(*oRUcRJN&ln8C`74>i}h3g5S{M}o${Z5j2dMxC<`Fag@I!eUhLpY2AB}) z4u^l`zhg0H=fHO{_2e{lbo~1weF0odKzBlOvTeRgQ-PmAjOw`#`{?*Qr}R~dzfWkS z+a^aQ{s^i^Tj@rE)o#nQnw&9h%_e7lPQpvir*w&rX=}5;YPMwL#k93pt+{#dtJ6L{ zGp|d0LTo$wS1?eaNrO`YH6_)<(J8qmXST@-gWb#IH1+1+83j4&VM7KFHA?sY2hQkc IC6+b-03p_ Date: Thu, 27 Aug 2020 18:40:16 +0800 Subject: [PATCH 38/43] tiny changes --- .Rproj.user/shared/notebooks/paths | 5 +---- README.md | 2 +- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index bfddd77..fd5ec94 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1,4 +1 @@ -C:/Users/User/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="BE89A8F" -C:/Users/user/Documents/GitHub/hyfo/R/extractPeriod(generic).R="35D21910" -C:/Users/user/Documents/GitHub/hyfo/vignettes/hyfo.Rmd="E84A6BF8" -C:/Users/xuyua/OneDrive/文档/hyfo/NEWS="73E17A04" +C:/hyfo/README.md="BBF5FB5B" diff --git a/README.md b/README.md index 7026754..bd6c127 100644 --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ install.packages("devtools") devtools::install_github("Yuanchao-Xu/hyfo") ``` -**Official Website is [https://yuanchao-xu.github.io/hyfo/](http://yuanchao-xu.github.io/hyfo/)** +**Official Website is [https://yuanchao-xu.github.io/hyfo/](https://yuanchao-xu.github.io/hyfo/)** hyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate. From 37791a34a0676a9a05cb6ee87291561f702e1bc7 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Fri, 28 Aug 2020 17:15:05 +0800 Subject: [PATCH 39/43] change invalid url it's not actually invalid, but anyway it's fixed now --- .Rhistory | 20 ++++++++++---------- .Rproj.user/shared/notebooks/paths | 6 ++++++ README.md | 2 +- vignettes/hyfo.Rmd | 4 ++-- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/.Rhistory b/.Rhistory index 1491e09..7e312aa 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,13 +1,3 @@ -prThreshold) { -# 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 (length(which(hindcast > minHindcastPreci)) > 0) { -ecdfHindcast <- ecdf(hindcast[hindcast > minHindcastPreci]) -noRain <- which(frc <= minHindcastPreci & !is.na(frc)) -rain <- which(frc > 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 > minHindcastPreci & frc <= min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) & !is.na(frc)) if (length(rain) > 0) { @@ -510,3 +500,13 @@ devtools::check(cran = T) devtools::built() devtools::build() devtools::build() +devtools::build() +devtools::build() +devtools::build() +devtools::check(remote = T, cran = T) +devtools::check_win_devel() +devtools::build() +devtools::check_win_devel() +devtools::check_win_devel() +devtools::build() +devtools::build() diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index fd5ec94..4f1930a 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1 +1,7 @@ +C:/hyfo/DESCRIPTION="E115FF50" +C:/hyfo/R/getSpatialMap.R="360D9F5D" +C:/hyfo/R/ncdf.R="6981B7D0" C:/hyfo/README.md="BBF5FB5B" +C:/hyfo/man/getSpatialMap.Rd="B8BD6975" +C:/hyfo/man/writeNcdf.Rd="665DA26C" +C:/hyfo/vignettes/hyfo.Rmd="4D6D9459" diff --git a/README.md b/README.md index bd6c127..d4dea0c 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ This package mainly focuses on data process and visulization in hydrology and cl **If you feel hyfo is of a little help, please cite it as following:** -Xu, Yuanchao(2015). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/ +Xu, Yuanchao(2020). hyfo: Hydrology and Climate Forecasting R Package for Data Analysis and Visualization. Retrieved from http://yuanchao-xu.github.io/hyfo/ diff --git a/vignettes/hyfo.Rmd b/vignettes/hyfo.Rmd index ae26955..1e298af 100644 --- a/vignettes/hyfo.Rmd +++ b/vignettes/hyfo.Rmd @@ -1,6 +1,6 @@ --- title: '[hyfo Easy Start](https://yuanchao-xu.github.io/hyfo/)' -author: '[Yuanchao Xu](https://dk.linkedin.com/in/xuyuanchao37)' +author: '[Yuanchao Xu](https://www.linkedin.com/in/xuyuanchao37/)' date: '`r Sys.Date()`' output: pdf_document: @@ -16,7 +16,7 @@ vignette: > # Introduction -**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo), where manuals and more details can be found.** +**Official Website is [https://yuanchao-xu.github.io/hyfo](http://yuanchao-xu.github.io/hyfo/), where manuals and more details can be found.** hyfo is an R package, initially designed for the European Project EUPORIAS, and cooperated with DHI Denmark, which was then extended to other uses in hydrology, hydraulics and climate. From 27329d85193217a33e104c30a29bb1b154d91f0c Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Wed, 19 Jul 2023 22:25:29 +0800 Subject: [PATCH 40/43] hyfo 1.4.4 change package from rgdal to sf due to retirement of rdgal --- .Rbuildignore | 2 + .Rhistory | 126 ++++++++++++++--------------- .Rproj.user/shared/notebooks/paths | 11 +-- .travis.yml | 3 +- CRAN-SUBMISSION | 3 + DESCRIPTION | 9 +-- NAMESPACE | 4 +- NEWS | 5 ++ R/dataDocument.R | 2 +- R/getSpatialMap.R | 4 +- R/shp2cat.R | 8 +- cran-comments.md | 5 ++ man/applyBiasFactor.Rd | 9 +-- man/biasCorrect.Rd | 46 ++++++++--- man/collectData.Rd | 3 +- man/collectData_txt_anarbe.Rd | 7 +- man/downscaleNcdf.Rd | 5 +- man/extractPeriod.Rd | 35 +++++--- man/getAnnual.Rd | 7 +- man/getBiasFactor.Rd | 42 +++++++--- man/getEnsem_comb.Rd | 12 ++- man/getFrcEnsem.Rd | 14 +++- man/getHisEnsem.Rd | 13 ++- man/getMeanPreci.Rd | 13 ++- man/getNcdfVar.Rd | 2 +- man/getPreciBar.Rd | 52 +++++++++--- man/getPreciBar_comb.Rd | 13 ++- man/getSpatialMap.Rd | 2 +- man/getSpatialMap_comb.Rd | 13 ++- man/getSpatialMap_mat.Rd | 19 +++-- man/loadNcdf.Rd | 2 +- man/plotTS.Rd | 15 +++- man/plotTS_comb.Rd | 12 ++- man/resample.Rd | 1 - man/shp2cat.Rd | 4 +- man/testCat.Rd | 6 +- man/testdl.Rd | 6 +- man/tgridData.Rd | 6 +- man/writeNcdf.Rd | 12 ++- 39 files changed, 361 insertions(+), 192 deletions(-) create mode 100644 CRAN-SUBMISSION create mode 100644 cran-comments.md diff --git a/.Rbuildignore b/.Rbuildignore index 5eb8c20..02b6fed 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,3 +2,5 @@ ^\.Rproj\.user$ ^data-raw$ ^\.travis\.yml$ +^cran-comments\.md$ +^CRAN-SUBMISSION$ diff --git a/.Rhistory b/.Rhistory index 7e312aa..2cc9b0d 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,66 +1,3 @@ -drizzle <- which(frc > minHindcastPreci & frc <= min(hindcast[hindcast > minHindcastPreci], na.rm = TRUE) -& !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] > max(hindcast, na.rm = TRUE)) -lowerIndex <- which(frc[rain] < min(hindcast, na.rm = TRUE)) -extrapolateIndex <- c(higherIndex, lowerIndex) -non_extrapolateIndex <- setdiff(1:length(rain), extrapolateIndex) -if (length(higherIndex) > 0) { -maxHindcast <- max(hindcast, na.rm = TRUE) -dif <- maxHindcast - max(obs, na.rm = TRUE) -frc[rain[higherIndex]] <- frc[higherIndex] - dif -} -if (length(lowerIndex) > 0) { -minHindcast <- min(hindcast, na.rm = TRUE) -dif <- minHindcast - min(obs, nna.rm = TRUE) -frc[rain[lowerIndex]] <- frc[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 > min(hindcast[which(hindcast > minHindcastPreci)], na.rm = TRUE) & -!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 <= minHindcastPreci & !is.na(frc)) -rain <- which(frc > 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) -} -biasCorrect_core_gqm <- function(frc, hindcast, obs, prThreshold, minHindcastPreci) { -if (any(obs > prThreshold)) { -ind <- which(obs > prThreshold & !is.na(obs)) -obsGamma <- fitdistr(obs[ind],"gamma", lower = c(0, 0)) -ind <- which(hindcast > 0 & !is.na(hindcast)) -hindcastGamma <- fitdistr(hindcast[ind],"gamma", lower = c(0, 0)) -rain <- which(frc > minHindcastPreci & !is.na(frc)) -noRain <- which(frc <= minHindcastPreci & !is.na(frc)) -probF <- pgamma(frc[rain], hindcastGamma$estimate[1], rate = hindcastGamma$estimate[2]) -frc[rain] <- qgamma(probF,obsGamma$estimate[1], rate = obsGamma$estimate[2]) frc[noRain] <- 0 } else { warning('All the observations of this cell(station) are lower than the threshold, @@ -510,3 +447,66 @@ devtools::check_win_devel() devtools::check_win_devel() devtools::build() devtools::build() +devtools::check_win_devel() +install.packages("sf") +devtools::check_win_devel() +install.packages("sf") +install.packages("sf") +devtools::check_win_devel() +devtools::check_win_devel() +devtools::check_win_devel() +devtools::check_win_devel() +devtools::build() +devtools::build() +devtools::check(remote = T, cran = T) +devtools::document() +devtools::check(remote = T, cran = T) +devtools::check_win_devel() +devtools::check_win_devel() +install.packages("devtools") +install.packages("devtools") +install.packages("devtools") +install.packages("devtools") +install.packages("devtools") +install.packages("devtools") +install.packages("devtools") +devtools::document() +install.packages("cli") +install.packages("cli") +devtools::document() +devtools::check(remote = T, cran = T) +library(cli) +devtools::document() +library(devtools) +devtools::document() +library(rlang) +devtools::document() +devtools::check(remote = T, cran = T) +devtools::build() +?devtools +devtools::build(binary = T) +devtools::build() +devtools::submit_cran() +devtools::use_cran_comments() +use_cran_comments() +usethis::use_cran_comments() +devtools::submit_cran() +devtools::submit_cran() +devtools::submit_cran() +devtools::build() +devtools::submit_cran() +debug(devtools::build()) +debug(submit_cran) +debug(devtools::submit_cran) +devtools::submit_cran() +devtools::submit_cran() +r +new_url +new_url$query$submit == "1" +new_url$query$submit +new_url$query +r$url +httr::parse_url(r$url) +devtools::submit_cran() +undebug(devtools::submit_cran) +devtools::submit_cran() diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index 4f1930a..78708e6 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -1,7 +1,4 @@ -C:/hyfo/DESCRIPTION="E115FF50" -C:/hyfo/R/getSpatialMap.R="360D9F5D" -C:/hyfo/R/ncdf.R="6981B7D0" -C:/hyfo/README.md="BBF5FB5B" -C:/hyfo/man/getSpatialMap.Rd="B8BD6975" -C:/hyfo/man/writeNcdf.Rd="665DA26C" -C:/hyfo/vignettes/hyfo.Rmd="4D6D9459" +/Users/yuanchaoxu/Documents/GitHub/hyfo/.travis.yml="3AC61E6F" +/Users/yuanchaoxu/Documents/GitHub/hyfo/NAMESPACE="11200187" +/Users/yuanchaoxu/Documents/GitHub/hyfo/NEWS="40156A70" +/Users/yuanchaoxu/Documents/GitHub/hyfo/cran-comments.md="E91D33FC" diff --git a/.travis.yml b/.travis.yml index cda9e1c..8e44625 100644 --- a/.travis.yml +++ b/.travis.yml @@ -36,8 +36,7 @@ apt_packages: - libproj0 #r_binary_packages: -# - rgdal -# - rgeos +# - sf # - data.table #r_packages: # - data.table \ No newline at end of file diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION new file mode 100644 index 0000000..2afa0fb --- /dev/null +++ b/CRAN-SUBMISSION @@ -0,0 +1,3 @@ +Version: 1.4.4 +Date: 2023-07-19 14:24:10 UTC +SHA: 37791a34a0676a9a05cb6ee87291561f702e1bc7 diff --git a/DESCRIPTION b/DESCRIPTION index 46912f4..1abbc2a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.3 -Date: 2020-8-26 +Version: 1.4.4 +Date: 2023-7-12 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and @@ -19,13 +19,12 @@ Imports: ggplot2 (>= 1.0.1), reshape2 (>= 1.4.1), zoo (>= 1.7-12), - rgdal (>= 0.8-16), + sf (>= 1.0-12), plyr (>= 1.8.3), moments (>= 0.14), lmom (>= 2.5), maps(>= 2.3-9), maptools (>= 0.8-36), - rgeos (>= 0.3-8), ncdf4 (>= 1.14.1), MASS (>= 7.3-39), methods, @@ -39,4 +38,4 @@ LazyData: true URL: https://yuanchao-xu.github.io/hyfo/ BugReports: https://github.com/Yuanchao-Xu/hyfo/issues Repository: CRAN -RoxygenNote: 6.1.1 +RoxygenNote: 7.2.3 diff --git a/NAMESPACE b/NAMESPACE index 1786e35..b071cdc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,8 +36,7 @@ import(maps) import(maptools) import(ncdf4) import(plyr) -import(rgdal) -import(rgeos) +import(sf) importFrom(MASS,fitdistr) importFrom(data.table,rbindlist) importFrom(grDevices,rainbow) @@ -49,6 +48,7 @@ importFrom(methods,setMethod) importFrom(moments,kurtosis) importFrom(moments,skewness) importFrom(reshape2,melt) +importFrom(sf,st_read) importFrom(stats,aggregate) importFrom(stats,coef) importFrom(stats,cor) diff --git a/NEWS b/NEWS index 24eeb7c..00f80c3 100644 --- a/NEWS +++ b/NEWS @@ -69,6 +69,11 @@ Date: 2015-12-15 NOTE: ==== - for hyfo$Data part, when load and write using ncdf4, there will be very little differences compared to the original, which cannot be addressed. If you first load an ncdf file, then write it, then load it again. The data part may have very little difference, less than 10E-5. +hyfo 1.4.4 +========== +Date: 2023-07-12 + +- change package from rgdal to sf due to retirement of rdgal diff --git a/R/dataDocument.R b/R/dataDocument.R index 28ba822..0899028 100644 --- a/R/dataDocument.R +++ b/R/dataDocument.R @@ -53,7 +53,7 @@ #' testCat -#' @format A catchment file generated by library rgdal. +#' @format A catchment file generated by library sf. #' \describe{ #' \item{class}{Formal class 'SpatialPolygonsDataFrame' [package "sp"] with 5 slots} #' ... diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 8f39170..8a99ce2 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -223,7 +223,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export -#' @import ggplot2 plyr maps maptools rgeos +#' @import ggplot2 plyr maps maptools sf #' @importFrom stats median #' @importFrom reshape2 melt #' @references @@ -246,7 +246,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools #' #' \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R -#' package version 0.3-11. https://CRAN.R-project.org/package=rgeos +#' package version 0.3-11. https://CRAN.R-project.org/package=sf #' #' } #' diff --git a/R/shp2cat.R b/R/shp2cat.R index fc5a8bf..b86372a 100644 --- a/R/shp2cat.R +++ b/R/shp2cat.R @@ -2,7 +2,7 @@ #' @param filePath A string representing the path of the shape file. #' @return A catchment object can be used in \code{getSpatialMap()}. #' @export -#' @details This function is based on the package \code{rgdal} and \code{sp}, and the output comes from the package +#' @details This function is based on the package \code{sf} and \code{sp}, and the output comes from the package #' \code{sp} #' @examples #' #open internal file @@ -11,13 +11,13 @@ #' #' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' -#' @import rgdal +#' @importFrom sf st_read #' @importFrom utils tail #' @references #' #' \itemize{ #' \item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data -#' Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=rgdal +#' Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=sf #' #' \item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for #' Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. @@ -46,6 +46,6 @@ shp2cat <- function(filePath) { } if (length(folderName) == 0) stop('No shape file found, make sure the shp file is selected.') - catchment <- readOGR(folderName, catName1) + catchment <- st_read(folderName, catName1) return(catchment) } diff --git a/cran-comments.md b/cran-comments.md new file mode 100644 index 0000000..858617d --- /dev/null +++ b/cran-comments.md @@ -0,0 +1,5 @@ +## R CMD check results + +0 errors | 0 warnings | 1 note + +* This is a new release. diff --git a/man/applyBiasFactor.Rd b/man/applyBiasFactor.Rd index ad863c1..8183ff1 100644 --- a/man/applyBiasFactor.Rd +++ b/man/applyBiasFactor.Rd @@ -1,6 +1,5 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/multi-biasCorrect(generic).R -\docType{methods} \name{applyBiasFactor} \alias{applyBiasFactor} \alias{applyBiasFactor,data.frame,biasFactor-method} @@ -9,11 +8,9 @@ \usage{ applyBiasFactor(frc, biasFactor, obs = NULL) -\S4method{applyBiasFactor}{data.frame,biasFactor}(frc, biasFactor, - obs = NULL) +\S4method{applyBiasFactor}{data.frame,biasFactor}(frc, biasFactor, obs = NULL) -\S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, - obs = NULL) +\S4method{applyBiasFactor}{list,biasFactor.hyfo}(frc, biasFactor, obs = NULL) } \arguments{ \item{frc}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, @@ -63,7 +60,7 @@ for how to debug S4 method. ######## hyfo grid file biascorrection ######## -# If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect +# If your input is obtained by \code{loadNcdf}, you can also directly biascorrect # the file. # First load ncdf file. diff --git a/man/biasCorrect.Rd b/man/biasCorrect.Rd index 9db0438..e764fc3 100644 --- a/man/biasCorrect.Rd +++ b/man/biasCorrect.Rd @@ -1,23 +1,43 @@ % Generated by roxygen2: do not edit by hand % 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", 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") +biasCorrect( + frc, + hindcast, + obs, + method = "scaling", + scaleType = "multi", + 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, @@ -135,7 +155,7 @@ for how to debug S4 method. ######## hyfo grid file biascorrection ######## -# If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect +# If your input is obtained by \code{loadNcdf}, you can also directly biascorrect # the file. # First load ncdf file. diff --git a/man/collectData.Rd b/man/collectData.Rd index e254811..5369824 100644 --- a/man/collectData.Rd +++ b/man/collectData.Rd @@ -4,8 +4,7 @@ \alias{collectData} \title{Collect data from different csv files.} \usage{ -collectData(folderName, fileType = NULL, range = NULL, - sheetIndex = 1) +collectData(folderName, fileType = NULL, range = NULL, sheetIndex = 1) } \arguments{ \item{folderName}{A string showing the path of the folder holding different csv files.} diff --git a/man/collectData_txt_anarbe.Rd b/man/collectData_txt_anarbe.Rd index 771f563..1a72969 100644 --- a/man/collectData_txt_anarbe.Rd +++ b/man/collectData_txt_anarbe.Rd @@ -7,8 +7,11 @@ http://www4.gipuzkoa.net/oohh/web/esp/02.asp } \usage{ -collectData_txt_anarbe(folderName, output = TRUE, - rangeWord = c("Ene ", -1, "Total ", -6)) +collectData_txt_anarbe( + folderName, + output = TRUE, + rangeWord = c("Ene ", -1, "Total ", -6) +) } \arguments{ \item{folderName}{A string showing the folder path.} diff --git a/man/downscaleNcdf.Rd b/man/downscaleNcdf.Rd index 32d0031..eea1e9f 100644 --- a/man/downscaleNcdf.Rd +++ b/man/downscaleNcdf.Rd @@ -4,8 +4,7 @@ \alias{downscaleNcdf} \title{Downscale NetCDF file} \usage{ -downscaleNcdf(gridData, year = NULL, month = NULL, lon = NULL, - lat = NULL) +downscaleNcdf(gridData, year = NULL, month = NULL, lon = NULL, lat = NULL) } \arguments{ \item{gridData}{A hyfo list file from \code{\link{loadNcdf}}} @@ -31,7 +30,7 @@ Downscale NetCDF file filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -# Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name +# Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) diff --git a/man/extractPeriod.Rd b/man/extractPeriod.Rd index d61ae0c..b237b1c 100644 --- a/man/extractPeriod.Rd +++ b/man/extractPeriod.Rd @@ -1,20 +1,37 @@ % Generated by roxygen2: do not edit by hand % 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(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) +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{data}{A list of different dataframes of time series, or a dataframe with first column Date, the rest columns value.} diff --git a/man/getAnnual.Rd b/man/getAnnual.Rd index 76fa55a..47fad7d 100644 --- a/man/getAnnual.Rd +++ b/man/getAnnual.Rd @@ -1,6 +1,5 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/getAnnual(generic).R -\docType{methods} \name{getAnnual} \alias{getAnnual} \alias{getAnnual,data.frame-method} @@ -9,11 +8,9 @@ \usage{ getAnnual(data, output = "series", minRecords = 355, ...) -\S4method{getAnnual}{data.frame}(data, output = "series", - minRecords = 355, ...) +\S4method{getAnnual}{data.frame}(data, output = "series", minRecords = 355, ...) -\S4method{getAnnual}{list}(data, output = "series", minRecords = 355, - ...) +\S4method{getAnnual}{list}(data, output = "series", minRecords = 355, ...) } \arguments{ \item{data}{A list containing different time series of different rainfall gauges. Or a dataframe with first column Date and the rest columns the value of different diff --git a/man/getBiasFactor.Rd b/man/getBiasFactor.Rd index a68c835..19a53bd 100644 --- a/man/getBiasFactor.Rd +++ b/man/getBiasFactor.Rd @@ -1,22 +1,40 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/multi-biasCorrect(generic).R -\docType{methods} \name{getBiasFactor} \alias{getBiasFactor} \alias{getBiasFactor,data.frame,data.frame-method} \alias{getBiasFactor,list,list-method} \title{Get bias factor for multi/operational/real time bias correction.} \usage{ -getBiasFactor(hindcast, obs, method = "scaling", scaleType = "multi", - preci = FALSE, prThreshold = 0, extrapolate = "no") - -\S4method{getBiasFactor}{data.frame,data.frame}(hindcast, obs, - method = "scaling", scaleType = "multi", preci = FALSE, - prThreshold = 0, extrapolate = "no") - -\S4method{getBiasFactor}{list,list}(hindcast, obs, method = "scaling", - scaleType = "multi", preci = FALSE, prThreshold = 0, - extrapolate = "no") +getBiasFactor( + hindcast, + obs, + method = "scaling", + scaleType = "multi", + preci = FALSE, + prThreshold = 0, + extrapolate = "no" +) + +\S4method{getBiasFactor}{data.frame,data.frame}( + hindcast, + obs, + method = "scaling", + scaleType = "multi", + preci = FALSE, + prThreshold = 0, + extrapolate = "no" +) + +\S4method{getBiasFactor}{list,list}( + hindcast, + obs, + method = "scaling", + scaleType = "multi", + preci = FALSE, + prThreshold = 0, + extrapolate = "no" +) } \arguments{ \item{hindcast}{a hyfo grid data output or a dataframe(time series) consists of Date column and one or more value columns, @@ -78,7 +96,7 @@ for how to debug S4 method. ######## hyfo grid file biascorrection ######## -# If your input is obtained by \\code{loadNcdf}, you can also directly biascorrect +# If your input is obtained by \code{loadNcdf}, you can also directly biascorrect # the file. # First load ncdf file. diff --git a/man/getEnsem_comb.Rd b/man/getEnsem_comb.Rd index 2563858..5e2e869 100644 --- a/man/getEnsem_comb.Rd +++ b/man/getEnsem_comb.Rd @@ -4,8 +4,16 @@ \alias{getEnsem_comb} \title{Combine ensembles together} \usage{ -getEnsem_comb(..., list = NULL, nrow = 1, legend = TRUE, x = "", - y = "", title = "", output = FALSE) +getEnsem_comb( + ..., + list = NULL, + nrow = 1, + legend = TRUE, + x = "", + y = "", + title = "", + output = FALSE +) } \arguments{ \item{...}{different ensembles generated by \code{getHisEnsem(, output = 'ggplot')} diff --git a/man/getFrcEnsem.Rd b/man/getFrcEnsem.Rd index c9347ff..e97a179 100644 --- a/man/getFrcEnsem.Rd +++ b/man/getFrcEnsem.Rd @@ -4,8 +4,16 @@ \alias{getFrcEnsem} \title{Extract time series from forecasting data.} \usage{ -getFrcEnsem(dataset, cell = "mean", plot = "norm", output = "data", - name = NULL, mv = 0, coord = NULL, ...) +getFrcEnsem( + dataset, + cell = "mean", + plot = "norm", + output = "data", + name = NULL, + mv = 0, + coord = NULL, + ... +) } \arguments{ \item{dataset}{A list containing different information, should be the result of \code{\link{loadNcdf}}} @@ -54,7 +62,7 @@ the system time will be selected as name column. \examples{ filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -# Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name +# Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) a <- getFrcEnsem(nc) diff --git a/man/getHisEnsem.Rd b/man/getHisEnsem.Rd index 0a68297..9997f55 100644 --- a/man/getHisEnsem.Rd +++ b/man/getHisEnsem.Rd @@ -4,8 +4,17 @@ \alias{getHisEnsem} \title{Get ensemble forecast from historical data.} \usage{ -getHisEnsem(TS, example, interval = 365, buffer = 0, plot = "norm", - output = "data", name = NULL, mv = 0, ...) +getHisEnsem( + TS, + example, + interval = 365, + buffer = 0, + plot = "norm", + output = "data", + name = NULL, + mv = 0, + ... +) } \arguments{ \item{TS}{A time series dataframe, with first column Date, and second column value.} diff --git a/man/getMeanPreci.Rd b/man/getMeanPreci.Rd index 77b4f07..fb11eb3 100644 --- a/man/getMeanPreci.Rd +++ b/man/getMeanPreci.Rd @@ -4,9 +4,16 @@ \alias{getMeanPreci} \title{Get mean rainfall data.} \usage{ -getMeanPreci(inputTS, method = NULL, yearIndex = NULL, - monthIndex = NULL, fullResults = FALSE, omitNA = TRUE, - plot = FALSE, ...) +getMeanPreci( + inputTS, + method = NULL, + yearIndex = NULL, + monthIndex = NULL, + fullResults = FALSE, + omitNA = TRUE, + plot = FALSE, + ... +) } \arguments{ \item{inputTS}{A time series with only data column (1 column).} diff --git a/man/getNcdfVar.Rd b/man/getNcdfVar.Rd index 842cef1..916f95e 100644 --- a/man/getNcdfVar.Rd +++ b/man/getNcdfVar.Rd @@ -20,7 +20,7 @@ the target variable. # First open the test NETcDF file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -# Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name +# Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ diff --git a/man/getPreciBar.Rd b/man/getPreciBar.Rd index 7126699..d712fb4 100644 --- a/man/getPreciBar.Rd +++ b/man/getPreciBar.Rd @@ -1,23 +1,49 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/getPreciBar(generic).R -\docType{methods} \name{getPreciBar} \alias{getPreciBar} \alias{getPreciBar,list-method} \alias{getPreciBar,data.frame-method} \title{get mean rainfall bar plot of the input dataset or time series.} \usage{ -getPreciBar(data, method, cell = "mean", output = "data", - name = NULL, plotRange = TRUE, member = NULL, omitNA = TRUE, - info = FALSE, ...) - -\S4method{getPreciBar}{list}(data, method, cell = "mean", - output = "data", name = NULL, plotRange = TRUE, member = NULL, - omitNA = TRUE, info = FALSE, ...) - -\S4method{getPreciBar}{data.frame}(data, method, cell = "mean", - output = "data", name = NULL, plotRange = TRUE, member = NULL, - omitNA = TRUE, info = FALSE, ...) +getPreciBar( + data, + method, + cell = "mean", + output = "data", + name = NULL, + plotRange = TRUE, + member = NULL, + omitNA = TRUE, + info = FALSE, + ... +) + +\S4method{getPreciBar}{list}( + data, + method, + cell = "mean", + output = "data", + name = NULL, + plotRange = TRUE, + member = NULL, + omitNA = TRUE, + info = FALSE, + ... +) + +\S4method{getPreciBar}{data.frame}( + data, + method, + cell = "mean", + output = "data", + name = NULL, + plotRange = TRUE, + member = NULL, + omitNA = TRUE, + info = FALSE, + ... +) } \arguments{ \item{data}{A list containing different information, should be the result of reading netcdf file using @@ -76,7 +102,7 @@ It is a generic function, if in your case you need to debug, please see \code{?d for how to debug S4 method. } \examples{ -#gridData provided by package is the result of \\code{loadNcdf()} +#gridData provided by package is the result of \code{loadNcdf()} data(tgridData) b1 <- getPreciBar(tgridData, method = 'annual') b2 <- getPreciBar(tgridData, method = 'meanMonthly') diff --git a/man/getPreciBar_comb.Rd b/man/getPreciBar_comb.Rd index 945abe9..6f95087 100644 --- a/man/getPreciBar_comb.Rd +++ b/man/getPreciBar_comb.Rd @@ -4,8 +4,15 @@ \alias{getPreciBar_comb} \title{Combine bars together} \usage{ -getPreciBar_comb(..., list = NULL, nrow = 1, x = "", y = "", - title = "", output = FALSE) +getPreciBar_comb( + ..., + list = NULL, + nrow = 1, + x = "", + y = "", + title = "", + output = FALSE +) } \arguments{ \item{...}{different barplots generated by \code{getPreciBar(, output = 'ggplot')}, refer to details.} @@ -40,7 +47,7 @@ and short term mean monthly precipitation. They are both mean monthly precipitat } \examples{ -data(tgridData)# the result of \\code{\\link{loadNcdf}} +data(tgridData)# the result of \code{\link{loadNcdf}} #output type of getPreciBar() has to be 'ggplot'. b1 <- getPreciBar(tgridData, method = 2, output = 'ggplot', name = 'b1') b2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2') diff --git a/man/getSpatialMap.Rd b/man/getSpatialMap.Rd index f68d710..94bd55d 100644 --- a/man/getSpatialMap.Rd +++ b/man/getSpatialMap.Rd @@ -37,7 +37,7 @@ Month(number 1 to 12): MEAN month rainfall of each year is plotted, e.g. MEAN ma \dontrun{ -#gridData provided in the package is the result of \\code {loadNcdf} +#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/getSpatialMap_comb.Rd b/man/getSpatialMap_comb.Rd index 4552a51..50d8c93 100644 --- a/man/getSpatialMap_comb.Rd +++ b/man/getSpatialMap_comb.Rd @@ -4,8 +4,15 @@ \alias{getSpatialMap_comb} \title{Combine maps together} \usage{ -getSpatialMap_comb(..., list = NULL, nrow = 1, x = "", y = "", - title = "", output = FALSE) +getSpatialMap_comb( + ..., + list = NULL, + nrow = 1, + x = "", + y = "", + title = "", + output = FALSE +) } \arguments{ \item{...}{different maps generated by \code{getSpatialMap(, output = 'ggplot')}, see details.} @@ -38,7 +45,7 @@ If they have different resolutions, use \code{interpGridData{ecomsUDG.Raccess}} \dontrun{ -data(tgridData)# the result of \\code{\\link{loadNcdf}} +data(tgridData)# the result of \code{\link{loadNcdf}} #The output should be 'ggplot' a1 <- getSpatialMap(tgridData, method = 'summer', output = 'ggplot', name = 'a1') a2 <- getSpatialMap(tgridData, method = 'winter', output = 'ggplot', name = 'a2') diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index 49ca1d9..b49555f 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -4,9 +4,18 @@ \alias{getSpatialMap_mat} \title{Replot raster matrix} \usage{ -getSpatialMap_mat(matrix, title_d = NULL, catchment = NULL, - point = NULL, output = "data", name = NULL, info = FALSE, - scale = "identity", color = NULL, ...) +getSpatialMap_mat( + matrix, + title_d = NULL, + catchment = NULL, + point = NULL, + output = "data", + name = NULL, + info = FALSE, + scale = "identity", + color = NULL, + ... +) } \arguments{ \item{matrix}{A matrix raster, should be the result of \code{getSpatialMap()}, output should be default @@ -49,7 +58,7 @@ value. \examples{ \dontrun{ -data(tgridData)# the result of \\code{loadNcdf} +data(tgridData)# the result of \code{loadNcdf} #the output type of has to be default or 'data'. a1 <- getSpatialMap(tgridData, method = 'mean') a2 <- getSpatialMap(tgridData, method = 'max') @@ -89,7 +98,7 @@ by Thomas P Minka (2015). maps: Draw Geographical Map Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R -package version 0.3-11. https://CRAN.R-project.org/package=rgeos +package version 0.3-11. https://CRAN.R-project.org/package=sf } } diff --git a/man/loadNcdf.Rd b/man/loadNcdf.Rd index ad4b617..6b2fff0 100644 --- a/man/loadNcdf.Rd +++ b/man/loadNcdf.Rd @@ -30,7 +30,7 @@ Load NetCDF file # First open the test NETcDF file. filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -# Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name +# Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) diff --git a/man/plotTS.Rd b/man/plotTS.Rd index 909a842..17705e0 100644 --- a/man/plotTS.Rd +++ b/man/plotTS.Rd @@ -4,9 +4,18 @@ \alias{plotTS} \title{plot time series, with marks on missing value.} \usage{ -plotTS(..., type = "line", output = "data", plot = "norm", - name = NULL, showNA = TRUE, x = NULL, y = NULL, title = NULL, - list = NULL) +plotTS( + ..., + type = "line", + output = "data", + plot = "norm", + name = NULL, + showNA = TRUE, + x = NULL, + y = NULL, + title = NULL, + list = NULL +) } \arguments{ \item{...}{input time series.} diff --git a/man/plotTS_comb.Rd b/man/plotTS_comb.Rd index 55e84e3..88908e7 100644 --- a/man/plotTS_comb.Rd +++ b/man/plotTS_comb.Rd @@ -4,8 +4,16 @@ \alias{plotTS_comb} \title{Combine time seires plot together} \usage{ -plotTS_comb(..., nrow = 1, type = "line", list = NULL, x = "Date", - y = "", title = "", output = FALSE) +plotTS_comb( + ..., + nrow = 1, + type = "line", + list = NULL, + x = "Date", + y = "", + title = "", + output = FALSE +) } \arguments{ \item{...}{different time series plots generated by \code{plotTS(, output = 'ggplot')}, refer to details.} diff --git a/man/resample.Rd b/man/resample.Rd index e6f7edb..059f501 100644 --- a/man/resample.Rd +++ b/man/resample.Rd @@ -1,6 +1,5 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/resample(generic).R -\docType{methods} \name{resample} \alias{resample} \alias{resample,data.frame-method} diff --git a/man/shp2cat.Rd b/man/shp2cat.Rd index 1231889..5c9e044 100644 --- a/man/shp2cat.Rd +++ b/man/shp2cat.Rd @@ -16,7 +16,7 @@ A catchment object can be used in \code{getSpatialMap()}. Get a catchment object from selected shape file. } \details{ -This function is based on the package \code{rgdal} and \code{sp}, and the output comes from the package +This function is based on the package \code{sf} and \code{sp}, and the output comes from the package \code{sp} } \examples{ @@ -30,7 +30,7 @@ catchment <- shp2cat(file) \references{ \itemize{ \item Roger Bivand, Tim Keitt and Barry Rowlingson (2015). rgdal: Bindings for the Geospatial Data -Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=rgdal +Abstraction Library. R package version 1.0-4. https://CRAN.R-project.org/package=sf \item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for Statistical Computing, Vienna, Austria. URL https://www.R-project.org/. diff --git a/man/testCat.Rd b/man/testCat.Rd index 883b60b..a4a463c 100644 --- a/man/testCat.Rd +++ b/man/testCat.Rd @@ -4,11 +4,13 @@ \name{testCat} \alias{testCat} \title{testCat} -\format{A catchment file generated by library rgdal. +\format{ +A catchment file generated by library sf. \describe{ \item{class}{Formal class 'SpatialPolygonsDataFrame' [package "sp"] with 5 slots} ... -}} +} +} \usage{ testCat } diff --git a/man/testdl.Rd b/man/testdl.Rd index 010c840..20bd2e9 100644 --- a/man/testdl.Rd +++ b/man/testdl.Rd @@ -4,13 +4,15 @@ \name{testdl} \alias{testdl} \title{testdl} -\format{A list consists of 3 different lists. +\format{ +A list consists of 3 different lists. \describe{ \item{AAA}{AAA, a dataframe containing a date column and a value column. } \item{BBB}{BBB, a dataframe containing a date column and a value column.} \item{CCC}{CCC, a dataframe containing a date column and a value column.} ... -}} +} +} \source{ http://meteo.navarra.es/estaciones/mapadeestaciones.cfm http://www4.gipuzkoa.net/oohh/web/esp/02.asp diff --git a/man/tgridData.Rd b/man/tgridData.Rd index db4fb2c..ee61870 100644 --- a/man/tgridData.Rd +++ b/man/tgridData.Rd @@ -4,14 +4,16 @@ \name{tgridData} \alias{tgridData} \title{tgridData} -\format{A list containing different information. +\format{ +A list containing different information. \describe{ \item{Variables}{variable information. } \item{Data}{Data.} \item{xyCoords}{longitude and latitude of the data.} \item{Dates}{Date information.} ... -}} +} +} \source{ http://www.meteo.unican.es/datasets/spain02 } diff --git a/man/writeNcdf.Rd b/man/writeNcdf.Rd index 9197f7e..4f7d404 100644 --- a/man/writeNcdf.Rd +++ b/man/writeNcdf.Rd @@ -4,8 +4,14 @@ \alias{writeNcdf} \title{Write to NetCDF file using hyfo list file} \usage{ -writeNcdf(gridData, filePath, missingValue = 1e+20, tz = "GMT", - units = NULL, version = 3) +writeNcdf( + gridData, + filePath, + missingValue = 1e+20, + tz = "GMT", + units = NULL, + version = 3 +) } \arguments{ \item{gridData}{A hyfo list file from \code{\link{loadNcdf}}} @@ -36,7 +42,7 @@ Write to NetCDF file using hyfo list file filePath <- system.file("extdata", "tnc.nc", package = "hyfo") -# Then if you don't know the variable name, you can use \\code{getNcdfVar} to get variable name +# Then if you don't know the variable name, you can use \code{getNcdfVar} to get variable name varname <- getNcdfVar(filePath) nc <- loadNcdf(filePath, varname) From 2b490b64cc6d6237b182487fd5111dcb185682a2 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Sat, 12 Aug 2023 22:10:40 +0800 Subject: [PATCH 41/43] further updates required by CRAN change class to is --- .Rhistory | 12 ++++++------ CRAN-SUBMISSION | 6 +++--- DESCRIPTION | 4 ++-- NAMESPACE | 1 + NEWS | 9 +++++++++ R/analyzeTS.R | 3 ++- R/getSpatialMap.R | 6 ++++-- 7 files changed, 27 insertions(+), 14 deletions(-) diff --git a/.Rhistory b/.Rhistory index 2cc9b0d..0384905 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,9 +1,3 @@ -frc[noRain] <- 0 -} else { -warning('All the observations of this cell(station) are lower than the threshold, -no bias correction applied.') -} -return(frc) } frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) library(MASS) @@ -510,3 +504,9 @@ httr::parse_url(r$url) devtools::submit_cran() undebug(devtools::submit_cran) devtools::submit_cran() +devtools::check(remote = T, cran = T) +devtools::check(remote = T, cran = T) +devtools::check(remote = T, cran = T) +devtools::check(remote = T, cran = T) +devtools::check_win_devel() +devtools::submit_cran() diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION index 2afa0fb..6cc9f65 100644 --- a/CRAN-SUBMISSION +++ b/CRAN-SUBMISSION @@ -1,3 +1,3 @@ -Version: 1.4.4 -Date: 2023-07-19 14:24:10 UTC -SHA: 37791a34a0676a9a05cb6ee87291561f702e1bc7 +Version: 1.4.5 +Date: 2023-08-12 14:09:46 UTC +SHA: 27329d85193217a33e104c30a29bb1b154d91f0c diff --git a/DESCRIPTION b/DESCRIPTION index 1abbc2a..5e42f74 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.4 -Date: 2023-7-12 +Version: 1.4.5 +Date: 2023-8-11 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and diff --git a/NAMESPACE b/NAMESPACE index b071cdc..cf15912 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,6 +41,7 @@ importFrom(MASS,fitdistr) importFrom(data.table,rbindlist) importFrom(grDevices,rainbow) importFrom(lmom,samlmu) +importFrom(methods,is) importFrom(methods,new) importFrom(methods,setClass) importFrom(methods,setGeneric) diff --git a/NEWS b/NEWS index 00f80c3..5326b0f 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,12 @@ +hyfo 1.4.5 +========== +Date: 2023-8-11 + +- update Rgdal dependencies +- change class() to is() to avoid cran notes + + + hyfo 1.4.3 ========== Date: 2020-8-26 diff --git a/R/analyzeTS.R b/R/analyzeTS.R index b6f9ca1..0d70136 100644 --- a/R/analyzeTS.R +++ b/R/analyzeTS.R @@ -50,13 +50,14 @@ #' #' @import ggplot2 #' @importFrom reshape2 melt +#' @importFrom methods is #' @export plotTS <- function(..., type = 'line', output = 'data', plot = 'norm', name = NULL, showNA = TRUE, x = NULL, y = NULL, title = NULL, list = NULL) { ## arrange input TS or TS list. if (is.null(list)) { list <- list(...) - if (!class(list[[1]]) == 'data.frame') { + if (!is(list[[1]])[1] == 'data.frame') { warning('Your input is probably a list, but you forget to add "list = " before it. Try again, or check help for more information.') } diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 8a99ce2..2bcd96f 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -225,6 +225,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' @export #' @import ggplot2 plyr maps maptools sf #' @importFrom stats median +#' @importFrom methods is #' @importFrom reshape2 melt #' @references #' @@ -260,7 +261,7 @@ getSpatialMap_mat <- function(matrix, title_d = NULL, catchment = NULL, point = checkWord <- c('lon', 'lat', 'z', 'value') if (is.null(attributes(matrix)$dimnames)) { stop('Input matrix is incorrect, check help to know how to get the matrix.') - } else if (!is.null(catchment) & class(catchment) != "SpatialPolygonsDataFrame") { + } else if (!is.null(catchment) & is(catchment)[1] != "SpatialPolygonsDataFrame") { stop('Catchment format is incorrect, check help to get more details. ') } else if (!is.null(point) & any(is.na(match(checkWord, attributes(point)$names)))) { stop('point should be a dataframe with colnames "lon, lat, z, value".') @@ -416,6 +417,7 @@ getSpatialMap_mat <- function(matrix, title_d = NULL, catchment = NULL, point = #' @export #' @import ggplot2 maps #' @importFrom data.table rbindlist +#' @importFrom methods is #' @references #' #' \itemize{ @@ -433,7 +435,7 @@ getSpatialMap_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title data_ggplot <- rbindlist(maps) } - if (!class(data_ggplot) == 'data.frame') { + if (!is(data_ggplot)[1] == 'data.frame') { warning('Your input is probably a list, but you forget to add "list = " before it. Try again, or check help for more information.') } else if (is.null(data_ggplot$Name)) { From 08f04c62a795cbac04e4f851345c04dcb0dce7a3 Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 15 Aug 2023 23:17:17 +0800 Subject: [PATCH 42/43] supplementary updates for maptools dependency --- .Rproj.user/shared/notebooks/paths | 1 + DESCRIPTION | 6 +++--- NAMESPACE | 2 +- NEWS | 8 ++++++++ R/getSpatialMap.R | 5 ++--- man/getSpatialMap_mat.Rd | 3 +-- 6 files changed, 16 insertions(+), 9 deletions(-) diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths index 78708e6..7cc155f 100644 --- a/.Rproj.user/shared/notebooks/paths +++ b/.Rproj.user/shared/notebooks/paths @@ -2,3 +2,4 @@ /Users/yuanchaoxu/Documents/GitHub/hyfo/NAMESPACE="11200187" /Users/yuanchaoxu/Documents/GitHub/hyfo/NEWS="40156A70" /Users/yuanchaoxu/Documents/GitHub/hyfo/cran-comments.md="E91D33FC" +/Users/yuanchaoxu/Documents/GitHub/hyfo/man/getSpatialMap_mat.Rd="5D3771F5" diff --git a/DESCRIPTION b/DESCRIPTION index 5e42f74..a7ee95c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: hyfo Type: Package Title: Hydrology and Climate Forecasting -Version: 1.4.5 -Date: 2023-8-11 +Version: 1.4.6 +Date: 2023-8-15 Authors@R: person("Yuanchao", "Xu", email = "xuyuanchao37@gmail.com", role = c("aut", "cre")) Description: Focuses on data processing and visualization in hydrology and @@ -24,7 +24,7 @@ Imports: moments (>= 0.14), lmom (>= 2.5), maps(>= 2.3-9), - maptools (>= 0.8-36), + sp (>= 2.0-0), ncdf4 (>= 1.14.1), MASS (>= 7.3-39), methods, diff --git a/NAMESPACE b/NAMESPACE index cf15912..44d3147 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -33,10 +33,10 @@ export(writeNcdf) exportClasses(biasFactor) import(ggplot2) import(maps) -import(maptools) import(ncdf4) import(plyr) import(sf) +import(sp) importFrom(MASS,fitdistr) importFrom(data.table,rbindlist) importFrom(grDevices,rainbow) diff --git a/NEWS b/NEWS index 5326b0f..b05446b 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,11 @@ +hyfo 1.4.6 +========== +Date: 2023-8-15 + +- further update for the maptools dependency under instruction + + + hyfo 1.4.5 ========== Date: 2023-8-11 diff --git a/R/getSpatialMap.R b/R/getSpatialMap.R index 2bcd96f..c0abcf3 100644 --- a/R/getSpatialMap.R +++ b/R/getSpatialMap.R @@ -223,7 +223,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' # More examples can be found in the user manual on https://yuanchao-xu.github.io/hyfo/ #' #' @export -#' @import ggplot2 plyr maps maptools sf +#' @import ggplot2 plyr maps sp sf #' @importFrom stats median #' @importFrom methods is #' @importFrom reshape2 melt @@ -243,8 +243,7 @@ getSpatialMap <- function(dataset, method = NULL, member = 'mean', ...) { #' by Thomas P Minka (2015). maps: Draw Geographical Maps. R package version #' 2.3-11. https://CRAN.R-project.org/package=maps #' -#' \item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial -#' Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools +#' \item Pebesma, Edzer, and Roger Bivand. 2023a. Sp: Classes and Methods for Spatial Data. https://CRAN.R-project.org/package=sp. #' #' \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R #' package version 0.3-11. https://CRAN.R-project.org/package=sf diff --git a/man/getSpatialMap_mat.Rd b/man/getSpatialMap_mat.Rd index b49555f..f786dd1 100644 --- a/man/getSpatialMap_mat.Rd +++ b/man/getSpatialMap_mat.Rd @@ -94,8 +94,7 @@ Software, 40(1), 1-29. URL http://www.jstatsoft.org/v40/i01/. by Thomas P Minka (2015). maps: Draw Geographical Maps. R package version 2.3-11. https://CRAN.R-project.org/package=maps -\item Roger Bivand and Nicholas Lewin-Koh (2015). maptools: Tools for Reading and Handling Spatial -Objects. R package version 0.8-36. https://CRAN.R-project.org/package=maptools +\item Pebesma, Edzer, and Roger Bivand. 2023a. Sp: Classes and Methods for Spatial Data. https://CRAN.R-project.org/package=sp. \item Roger Bivand and Colin Rundel (2015). rgeos: Interface to Geometry Engine - Open Source (GEOS). R package version 0.3-11. https://CRAN.R-project.org/package=sf From 1895ea5dd0e8819f26f5a8b0a1bd045e2c83b41c Mon Sep 17 00:00:00 2001 From: Yuanchao Xu Date: Tue, 15 Aug 2023 23:36:14 +0800 Subject: [PATCH 43/43] minor changes --- .Rhistory | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/.Rhistory b/.Rhistory index 0384905..c8f945e 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,14 +1,3 @@ -} -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) -library(MASS) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) -trace(biasCorrect) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) -devtools::check() -trace("biasCorrect", browser, exit=browser, signature = c("data.frame", "data.frame", "data.frame")) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) -frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) debug(hindcast) debug(preprocessHindcast) frc_new4 <- biasCorrect(frc, hindcast, obs, method = 'gqm', preci = TRUE) @@ -510,3 +499,14 @@ devtools::check(remote = T, cran = T) devtools::check(remote = T, cran = T) devtools::check_win_devel() devtools::submit_cran() +devtools::check(remote = T, cran = T) +devtools::check(remote = T, cran = T) +install.packages("sp") +install.packages("sp") +install.packages("sp") +devtools::check(remote = T, cran = T) +devtools::check(remote = T, cran = T) +devtools::check_win_devel() +devtools::check_win_devel() +devtools::submit_cran() +devtools::build()