Using highly optimized lubridate instead of custom functions
This commit is contained in:
hollorol
parent
3188c8d2d4
commit
c63cfff17b
@ -11,6 +11,7 @@ Packaged: 2017-07-19 14:00:04 UTCs; hollorol
|
||||
Author: Roland Hollo's [aut, cre]
|
||||
Imports:
|
||||
grDevices,
|
||||
lubridate,
|
||||
limSolve,
|
||||
stats,
|
||||
utils,
|
||||
|
||||
@ -29,7 +29,7 @@ calibMuso <- function(settings=NULL, calibrationPar=NULL,
|
||||
debugging=FALSE, logfilename=NULL,
|
||||
keepEpc=FALSE, export=FALSE,
|
||||
silent=FALSE, aggressive=FALSE,
|
||||
leapYear=FALSE,keepBinary=FALSE,
|
||||
keepBinary=FALSE,
|
||||
binaryPlace="./", fileToChange="epc",
|
||||
skipSpinup = TRUE, modifyOriginal =FALSE, prettyOut = FALSE){
|
||||
########################################################################
|
||||
@ -325,15 +325,11 @@ calibMuso <- function(settings=NULL, calibrationPar=NULL,
|
||||
if(!prettyOut){
|
||||
colnames(Reva) <- unlist(settings$outputVars[[1]])
|
||||
} else{
|
||||
dates <- as.Date(musoDate(startYear = settings$startYear,
|
||||
numYears = settings$numYears,
|
||||
timestep="d",combined = TRUE,corrigated = FALSE),
|
||||
"%d.%m.%Y")
|
||||
Reva <- cbind.data.frame(dates,
|
||||
musoDate(startYear = settings$startYear,
|
||||
numYears = settings$numYears,
|
||||
timestep = "d", combined = FALSE, corrigated = FALSE),
|
||||
Reva)
|
||||
Reva <- cbind.data.frame(
|
||||
musoDate(startYear = settings$startYear,
|
||||
numYears = settings$numYears,
|
||||
combined = FALSE, prettyOut = TRUE),
|
||||
Reva)
|
||||
colnames(Reva) <- as.character(c("date","day","month","year",unlist(settings$outputVars[[1]])) )
|
||||
|
||||
}
|
||||
@ -344,19 +340,22 @@ calibMuso <- function(settings=NULL, calibrationPar=NULL,
|
||||
|
||||
|
||||
|
||||
if(leapYear){
|
||||
Reva <- corrigMuso(settings,Reva)
|
||||
if(!prettyOut){
|
||||
rownames(Reva) <- musoDate(settings$startYear,settings$numYears)
|
||||
}
|
||||
## if(leapYear){
|
||||
## Reva <- corrigMuso(settings,Reva)
|
||||
## if(!prettyOut){
|
||||
## rownames(Reva) <- musoDate(settings$startYear,settings$numYears)
|
||||
## }
|
||||
|
||||
} else {
|
||||
if(!prettyOut){
|
||||
rownames(Reva) <- musoDate(settings$startYear, settings$numYears, corrigated=FALSE)
|
||||
}
|
||||
## } else {
|
||||
## if(!prettyOut){
|
||||
## rownames(Reva) <- musoDate(settings$startYear, settings$numYears)
|
||||
## }
|
||||
|
||||
}
|
||||
|
||||
## }
|
||||
|
||||
if(!prettyOut){
|
||||
rownames(Reva) <- musoDate(settings$startYear, numYears = settings$numYears)
|
||||
}
|
||||
|
||||
|
||||
if(export!=FALSE){
|
||||
|
||||
@ -1,160 +1,76 @@
|
||||
#' isLeapyear
|
||||
#' musoDate
|
||||
#'
|
||||
#'This function tells us if its argument a leapyear or not.
|
||||
#'
|
||||
#'@param year a year
|
||||
#'@usage isLeapyear(year)
|
||||
#'@return TRUE, if leapyear, FALSE if dont.
|
||||
#' @keywords internal
|
||||
isLeapyear <- function(year){
|
||||
##This Boolean function tells us whether the given year is leapyear or not
|
||||
|
||||
if(((year%%4==0)&(year%%100!=0))|(year%%400==0)){
|
||||
return(TRUE)
|
||||
} else {
|
||||
return(FALSE)
|
||||
}
|
||||
}
|
||||
|
||||
#' dayOfMonths
|
||||
#'
|
||||
#'This function gives as a vector which contains the number of the days per each month
|
||||
#'
|
||||
#'@param year a year
|
||||
#'@param corrigated Do you want to handle the leapyears, if yes choose TRUE
|
||||
#'@usage dayOfMonths(year, corrigated=TRUE)
|
||||
#'@return vector with 12 element. First is January, the last is December. All of the vector element represents the number of the days in that specific month
|
||||
#'@keywords internal
|
||||
|
||||
|
||||
|
||||
dayOfMonths <- function(year,corrigated=TRUE){
|
||||
##This function tells us how many days are in the months in the choosen year.
|
||||
|
||||
dayMonths <- c(31,28,31,30,31,30,31,31,30,31,30,31)
|
||||
|
||||
if(corrigated){
|
||||
|
||||
if(isLeapyear(year)==TRUE){
|
||||
dayMonths[2] <-29
|
||||
}
|
||||
}
|
||||
|
||||
return(dayMonths)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' This function tells us how many days are in the given year.
|
||||
#'
|
||||
#' This function tells us how many days are in the given year.
|
||||
#' @author Roland Hollos
|
||||
#' @keywords internal
|
||||
|
||||
dayOfYears <- function(year, corrigated=TRUE){
|
||||
##This function tells us how many days are in the given year.
|
||||
|
||||
if(corrigated){
|
||||
if(isLeapyear(year)==TRUE){
|
||||
return(366)
|
||||
} else {
|
||||
return(365)
|
||||
}
|
||||
} else {
|
||||
return(365)
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#' How many days are from the given date and given period length(periodlen)?
|
||||
#'
|
||||
#'How many days are from the given date and given period length(periodlen)?
|
||||
#' @author Roland Hollos
|
||||
#' @keywords internal
|
||||
|
||||
sumDaysOfPeriod <- function(year, periodlen, corrigated=TRUE){
|
||||
##How many days are from the given date and given period length(periodlen)?
|
||||
|
||||
years <- year:(year+periodlen)
|
||||
|
||||
if(corrigated){
|
||||
years100 <-length(which(years%%100==0))
|
||||
years400 <-length(which(years%%400==0))
|
||||
years4 <- length(which(years%%4==0))
|
||||
numberOfLeapdays <- years4-years100+years400
|
||||
days <- periodlen*365+numberOfLeapdays
|
||||
return(days)
|
||||
} else {
|
||||
days <- periodlen*365
|
||||
return(days)
|
||||
}
|
||||
}
|
||||
|
||||
#' Musoleapyear
|
||||
#'
|
||||
#' How many days are from the given date and given period length(periodlen)?
|
||||
#' @author Roland Hollos
|
||||
#' @keywords internal
|
||||
|
||||
musoLeapYears <- function(settings){
|
||||
days <- 365*settings$numyears
|
||||
years <- settings$startyear:(settings$startyear+settings$numyears-1)
|
||||
Leapyears <-unlist(lapply(years,isLeapyear))
|
||||
return(Leapyears)
|
||||
}
|
||||
|
||||
#' It generates BiomeBGC-MuSo dates
|
||||
#'
|
||||
#' It generates all of the day-dates which are between the start and endyear of BiomeBGC-MuSo run.
|
||||
#' How many days are from the given date and given period length(periodlen)?
|
||||
#' @author Roland Hollos
|
||||
#' @param timestep timestep, which can be daily ("d"), monthly ("m"), yearly("y")
|
||||
#' @param settings You have to run the setupMuso function before musoDate. It is its output which contains all of the necessary system variables. It sets the whole environment.
|
||||
#' @param combined If FALSE the output is a vector of 3 string: day, month year, if true, these strings will be concatenated.
|
||||
#' @param corrigated If True it counts with leapyears, else dont.
|
||||
#' @param format This is the format of the date. It can be "en" (dd.mm.yyyy), or "hu" (yyyy.mm.dd)
|
||||
#' @return The exact date-vectors for the BioBGC-MuSo output. You can use this for labelling purpose for example.
|
||||
#' This function generates MuSo compatibla dates for the data
|
||||
#' @author Roland HOLLOS
|
||||
#' @param startYear
|
||||
#' @param numYears
|
||||
#' @param timestep
|
||||
#' @param combined
|
||||
#' @param corrigated
|
||||
#' @param format
|
||||
#' @importFrom lubridate leap_year
|
||||
#' @export
|
||||
|
||||
musoDate <- function(startYear, numYears, timestep="d", combined=TRUE, corrigated=TRUE, format="en"){
|
||||
##purpose: generate date label for muso
|
||||
|
||||
musoDate <- function(startYear, endYears = NULL, numYears, combined = TRUE, leapYearHandling = FALSE, prettyOut = FALSE){
|
||||
|
||||
if(is.null(endYears) & is.null(numYears)){
|
||||
stop("You should provide endYears or numYears")
|
||||
}
|
||||
|
||||
|
||||
if(is.null(endYears)){
|
||||
endYear <- startYear + numYears -1
|
||||
}
|
||||
|
||||
days <- sumDaysOfPeriod(startYear, numYears, corrigated=corrigated)
|
||||
dates <- matrix(rep(NA,days*3),ncol=3)
|
||||
|
||||
dates[1,] <- c(1,1,startYear)
|
||||
for(i in 2:days){
|
||||
dates[i,]<-dates[(i-1),]
|
||||
if((dates[i-1,2]==12)&(dates[i-1,1]==31)){
|
||||
dates[i,] <-c(1,1,(dates[(i-1),3]+1))
|
||||
} else {
|
||||
|
||||
if(dates[i-1,1]==(dayOfMonths(dates[(i-1),3],corrigated=corrigated)[dates[(i-1),2]] )){
|
||||
dates[i,]<-c(1,(dates[(i-1),2]+1),dates[(i-1),3])
|
||||
} else {
|
||||
dates[i,1]<-dates[(i-1),1]+1
|
||||
}
|
||||
}
|
||||
|
||||
dates <- seq(from = as.Date(paste0(startYear,"01","01"),format = "%Y%m%d"), to = as.Date(paste0(endYear,"12","31"),format = "%Y%m%d"), by = "day")
|
||||
if(leapYearHandling){
|
||||
if(prettyOut){
|
||||
return(cbind(format(dates,"%d.%m.%Y"),as.numeric(format(dates,"%d")),as.numeric(format(dates,"%m")),as.numeric(format(dates,"%Y"))) )
|
||||
}
|
||||
if(format=="en"){
|
||||
|
||||
} else {
|
||||
if(format=="hu"){
|
||||
dates<-dates[,c(3,2,1)]
|
||||
if(combined == FALSE){
|
||||
return(cbind(format(dates,"%d"),format(dates,"%m"),format(dates,"%Y")))
|
||||
} else {
|
||||
cat("format is coerced to english, because I don't know what do you mean by:",format)
|
||||
return(format(dates,"%d.%m.%Y"))
|
||||
}
|
||||
|
||||
} else {
|
||||
if(prettyOut){
|
||||
return(cbind(format(dates,"%d.%m.%Y"),as.numeric(format(dates,"%d")),as.numeric(format(dates,"%m")),as.numeric(format(dates,"%Y"))) )
|
||||
}
|
||||
dates <- dates[format(dates,"%m%d")!="0229"]
|
||||
|
||||
if(combined == FALSE){
|
||||
return(cbind(format(dates,"%d"),format(dates,"%m"),format(dates,"%Y")))
|
||||
} else {
|
||||
return(format(dates,"%d.%m.%Y"))
|
||||
}
|
||||
}
|
||||
|
||||
if(combined==TRUE){
|
||||
dates <- apply(dates,1,function(x) paste(x,collapse="."))
|
||||
return(dates)
|
||||
}
|
||||
|
||||
return(dates)
|
||||
|
||||
}
|
||||
|
||||
corrigLeapYear <- function(data, dataCol, modellSettings = NULL, startYear, fromDate = NULL,toDate = NULL,formatString = "%Y-%m-%d"){
|
||||
data <- as.data.frame(data)
|
||||
numDays <- nrow(data)
|
||||
dates <- seq(as.Date(paste0(startYear,"01","01"),format = "%Y%m%d"), by= "day", length = numDays)
|
||||
goodInd <- which(!(leap_year(dates)&
|
||||
(format(date,"%m") == "12")&
|
||||
(format(date,"%d") == "31")))
|
||||
realDate <- musoDate(startYear = startYear, numYears = numYears)
|
||||
|
||||
data <- cbind.data.frame(real,data[goodInd])
|
||||
|
||||
modellDates <- musoDate(startYear = settings$startYear,numYears = settings$numYears)
|
||||
|
||||
|
||||
|
||||
if(is.null(modellSettings)){
|
||||
modellSettings <- setupMuso()
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
alignDataWithModelIndex <- function(){
|
||||
|
||||
}
|
||||
|
||||
@ -229,7 +229,7 @@ setupMuso <- function(executable=NULL,
|
||||
## numValues will be replaced to numVar
|
||||
## numValues<-unlist(read.table(iniInput[2],skip=102,nrows = 1)[1])
|
||||
startYear <- as.numeric(unlist(strsplit(iniFiles[[2]][grep("TIME_DEFINE",iniFiles[[2]])+3],"[\ \t]"))[1])
|
||||
numData[1] <- numValues * sumDaysOfPeriod(startYear,numYears,corrigated=leapYear)
|
||||
numData[1] <- numValues * numYears*365 #LEAPYEAR CORRECTION NEEDED
|
||||
|
||||
numData[2] <- numYears * numValues*12
|
||||
numData[3] <- numYears * numValues
|
||||
@ -241,7 +241,7 @@ setupMuso <- function(executable=NULL,
|
||||
|
||||
if(!is.null(modelOutputs)){
|
||||
outVarChanges <- putOutVars(iniFile = iniInput[2],outputVars = modelOutputs, modifyOriginal = TRUE)
|
||||
numData <- round(numDate*outVarChanges[[2]])
|
||||
numData <- round(numData*outVarChanges[[2]])
|
||||
outputVars[[1]] <-outVarChanges[[1]]
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user