Skip to content
GitLab
Commit 27f26347 authored by unknown's avatar unknown
Browse files

v1.0.5.15 function CreateInputsModel() cleaned

parent 16a9ca4f
dev 115-add-pcict-date-format-managment 118-plot-outputsmodel-remove-case-sensitivity-to-the-which-argument 136-decreased-performance-of-calibration-execution-time 161-runmodel_lag-proposal-for-a-better-transformation-and-screening-of-the-parameters 165-add-missing-isintstore-argument-in-createcaliboptions 171-check-error-direct-call-of-as-data-frame-posixct-is-deprecated-use-as-data-frame-vector-or-as 191-speed-up-runmodel_lag-when-it-is-used-alone 33-merge-airgr-and-airgrplus-functions 60-migrate-transfoparam-functions-and-createcaliboptions-to-s3-methods 96-parallelize-the-grid-screening-step-during-calibration airGRplus master rmOptions CRAN_v1.7.6 CRAN_v1.7.5 CRAN_v1.7.4 CRAN_v1.7.3 CRAN_v1.7.2 CRAN_v1.7.1 CRAN_v1.7.0 CRAN_v1.6.12 CRAN_v1.6.11 CRAN_v1.6.10.4 CRAN_v1.6.9.27 CRAN_v1.6.9.24 CRAN_v1.6.9.23 CRAN_v1.6.9.21 CRAN_v1.4.3.65 CRAN_v1.4.3.60 CRAN_v1.4.3.52 CRAN_v1.3.2.42 CRAN_v1.3.2.41 CRAN_v1.3.2.40 CRAN_v1.3.2.39 CRAN_v1.3.2.23 CRAN_v1.3.2.17 CRAN_v1.2.13.16 CRAN_v1.2.13.13 CRAN_v1.0.14.1 CRAN_v1.0.13.19 CRAN_v1.0.10.11 CRAN_v1.0.9.64
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 300 additions and 133 deletions
+300 -133
.Rbuildignore
+ 1
− 0
View file @ 27f26347
^.*\.Rproj$ ^.*\.Rproj$
^\.Rproj\.user$ ^\.Rproj\.user$
^\.Rprofile$
DESCRIPTION
+ 1
− 1
View file @ 27f26347
Package: airGR Package: airGR
Type: Package Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.0.5.14 Version: 1.0.5.15
Date: 2017-01-23 Date: 2017-01-23
Authors@R: c( Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl")), person("Laurent", "Coron", role = c("aut", "trl")),
......
R/CreateInputsModel.R
+ 298
− 132
View file @ 27f26347
CreateInputsModel <- function(FUN_MOD, DatesR, Precip, PrecipScale = TRUE, PotEvap = NULL, TempMean = NULL, TempMin = NULL, TempMax = NULL, ZInputs = NULL, HypsoData = NULL, NLayers = 5, verbose = TRUE) { CreateInputsModel <- function(FUN_MOD,
DatesR,
ObjectClass <- NULL Precip, PrecipScale = TRUE,
PotEvap = NULL,
##check_FUN_MOD TempMean = NULL, TempMin = NULL, TempMax = NULL,
ZInputs = NULL, HypsoData = NULL, NLayers = 5,
verbose = TRUE) {
ObjectClass <- NULL
##check_FUN_MOD
BOOL <- FALSE BOOL <- FALSE
if(identical(FUN_MOD,RunModel_GR4H)) { if (identical(FUN_MOD, RunModel_GR4H)) {
ObjectClass <- c(ObjectClass,"hourly","GR"); ObjectClass <- c(ObjectClass, "hourly", "GR")
TimeStep <- as.integer(60*60);
TimeStep <- as.integer(60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(identical(FUN_MOD,RunModel_GR4J) | identical(FUN_MOD,RunModel_GR5J) | identical(FUN_MOD,RunModel_GR6J)) { if (identical(FUN_MOD, RunModel_GR4J) |
ObjectClass <- c(ObjectClass,"daily","GR"); identical(FUN_MOD, RunModel_GR5J) |
TimeStep <- as.integer(24*60*60); identical(FUN_MOD, RunModel_GR6J)) {
ObjectClass <- c(ObjectClass, "daily", "GR")
TimeStep <- as.integer(24 * 60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(identical(FUN_MOD,RunModel_GR2M)) { if (identical(FUN_MOD, RunModel_GR2M)) {
ObjectClass <- c(ObjectClass,"GR","monthly"); ObjectClass <- c(ObjectClass, "GR", "monthly")
TimeStep <- as.integer(c(28,29,30,31)*24*60*60);
TimeStep <- as.integer(c(28, 29, 30, 31) * 24 * 60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(identical(FUN_MOD,RunModel_GR1A)) { if (identical(FUN_MOD, RunModel_GR1A)) {
ObjectClass <- c(ObjectClass,"GR","yearly"); ObjectClass <- c(ObjectClass, "GR", "yearly")
TimeStep <- as.integer(c(365,366)*24*60*60);
TimeStep <- as.integer(c(365, 366) * 24 * 60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(identical(FUN_MOD,RunModel_CemaNeige)) { if (identical(FUN_MOD, RunModel_CemaNeige)) {
ObjectClass <- c(ObjectClass,"daily","CemaNeige"); ObjectClass <- c(ObjectClass, "daily", "CemaNeige")
TimeStep <- as.integer(24*60*60);
TimeStep <- as.integer(24 * 60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(identical(FUN_MOD,RunModel_CemaNeigeGR4J) | identical(FUN_MOD,RunModel_CemaNeigeGR5J) | identical(FUN_MOD,RunModel_CemaNeigeGR6J)) { if (identical(FUN_MOD, RunModel_CemaNeigeGR4J) |
ObjectClass <- c(ObjectClass,"daily","GR","CemaNeige"); identical(FUN_MOD, RunModel_CemaNeigeGR5J) |
TimeStep <- as.integer(24*60*60); identical(FUN_MOD, RunModel_CemaNeigeGR6J)) {
ObjectClass <- c(ObjectClass, "daily", "GR", "CemaNeige")
TimeStep <- as.integer(24 * 60 * 60)
BOOL <- TRUE BOOL <- TRUE
} }
if(!BOOL) { if (!BOOL) {
stop("Incorrect FUN_MOD for use in CreateInputsModel \n") stop("Incorrect FUN_MOD for use in CreateInputsModel \n")
return(NULL) return(NULL)
} }
##check_arguments ##check_arguments
if("GR" %in% ObjectClass | "CemaNeige" %in% ObjectClass) { if ("GR" %in% ObjectClass | "CemaNeige" %in% ObjectClass) {
if(is.null(DatesR)) { stop("DatesR is missing \n"); return(NULL); } if (is.null(DatesR)) {
if("POSIXlt" %in% class(DatesR) == FALSE & "POSIXct" %in% class(DatesR) == FALSE) { stop("DatesR must be defined as POSIXlt or POSIXct \n"); return(NULL); } stop("DatesR is missing \n")
if("POSIXlt" %in% class(DatesR) == FALSE) { DatesR <- as.POSIXlt(DatesR); } return(NULL)
if(difftime(tail(DatesR,1),tail(DatesR,2),units="secs")[[1]] %in% TimeStep==FALSE) { stop(paste("the time step of the model inputs must be ",TimeStep," seconds \n",sep="")); return(NULL); } }
LLL <- length(DatesR); if ("POSIXlt" %in% class(DatesR) == FALSE & "POSIXct" %in% class(DatesR) == FALSE) {
} stop("DatesR must be defined as POSIXlt or POSIXct \n")
if("GR" %in% ObjectClass) { return(NULL)
if(is.null(Precip )) { stop("Precip is missing \n" ); return(NULL); } }
if(is.null(PotEvap )) { stop("PotEvap is missing \n" ); return(NULL); } if ("POSIXlt" %in% class(DatesR) == FALSE) {
if(!is.vector( Precip) | !is.vector( PotEvap)) { stop("Precip and PotEvap must be vectors of numeric values \n"); return(NULL); } DatesR <- as.POSIXlt(DatesR)
if(!is.numeric(Precip) | !is.numeric(PotEvap)) { stop("Precip and PotEvap must be vectors of numeric values \n"); return(NULL); } }
if(length(Precip)!=LLL | length(PotEvap)!=LLL) { stop("Precip, PotEvap and DatesR must have the same length \n"); return(NULL); } if (difftime(tail(DatesR, 1), tail(DatesR, 2), units = "secs")[[1]] %in% TimeStep == FALSE) {
} stop(paste( "the time step of the model inputs must be ", TimeStep, " seconds \n", sep = ""))
if("CemaNeige" %in% ObjectClass) { return(NULL)
if(is.null(Precip )) { stop("Precip is missing \n" ); return(NULL); } }
if(is.null(TempMean)) { stop("TempMean is missing \n"); return(NULL); } LLL <- length(DatesR)
if(!is.vector( Precip) | !is.vector( TempMean)) { stop("Precip and TempMean must be vectors of numeric values \n"); return(NULL); } }
if(!is.numeric(Precip) | !is.numeric(TempMean)) { stop("Precip and TempMean must be vectors of numeric values \n"); return(NULL); } if ("GR" %in% ObjectClass) {
if(length(Precip)!=LLL | length(TempMean)!=LLL) { stop("Precip, TempMean and DatesR must have the same length \n"); return(NULL); } if (is.null(Precip)) {
if(is.null(TempMin)!=is.null(TempMax)) { stop("TempMin and TempMax must be both defined if not null \n"); return(NULL); } stop("Precip is missing \n")
if(!is.null(TempMin) & !is.null(TempMax)) { return(NULL)
if(!is.vector( TempMin) | !is.vector( TempMax)) { stop("TempMin and TempMax must be vectors of numeric values \n"); return(NULL); } }
if(!is.numeric(TempMin) | !is.numeric(TempMax)) { stop("TempMin and TempMax must be vectors of numeric values \n"); return(NULL); } if (is.null(PotEvap)) {
if(length(TempMin)!=LLL | length(TempMax)!=LLL) { stop("TempMin, TempMax and DatesR must have the same length \n"); return(NULL); } stop("PotEvap is missing \n")
} return(NULL)
if(!is.null(HypsoData)) { }
if(!is.vector( HypsoData)) { stop("HypsoData must be a vector of numeric values if not null \n"); return(NULL); } if (!is.vector(Precip) | !is.vector(PotEvap)) {
if(!is.numeric(HypsoData)) { stop("HypsoData must be a vector of numeric values if not null \n"); return(NULL); } stop("Precip and PotEvap must be vectors of numeric values \n")
if(length(HypsoData)!=101) { stop("HypsoData must be of length 101 if not null \n"); return(NULL); } return(NULL)
if(sum(is.na(HypsoData))!=0 & sum(is.na(HypsoData))!=101) { stop("HypsoData must not contain any NA if not null \n"); return(NULL); } }
} if (!is.numeric(Precip) | !is.numeric(PotEvap)) {
if(!is.null(ZInputs)) { stop("Precip and PotEvap must be vectors of numeric values \n")
if(length(ZInputs)!=1 ) { stop("\t ZInputs must be a single numeric value if not null \n"); return(NULL); } return(NULL)
if(is.na(ZInputs) | !is.numeric(ZInputs)) { stop("\t ZInputs must be a single numeric value if not null \n"); return(NULL); } }
} if (length(Precip) != LLL | length(PotEvap) != LLL) {
if(is.null(HypsoData)) { stop("Precip, PotEvap and DatesR must have the same length \n")
if(verbose) { warning("\t HypsoData is missing => a single layer is used and no extrapolation is made \n"); } return(NULL)
HypsoData <- as.numeric(rep(NA,101)); ZInputs <- as.numeric(NA); NLayers <- as.integer(1); }
} }
if(is.null(ZInputs)) { if ("CemaNeige" %in% ObjectClass) {
if(verbose & !identical(HypsoData,as.numeric(rep(NA,101)))) { warning("\t ZInputs is missing => HypsoData[51] is used \n"); } if (is.null(Precip)) {
ZInputs <- HypsoData[51L]; stop("Precip is missing \n")
} return(NULL)
if(NLayers <= 0) { }
if (is.null(TempMean)) {
stop("TempMean is missing \n")
return(NULL)
}
if (!is.vector(Precip) | !is.vector(TempMean)) {
stop("Precip and TempMean must be vectors of numeric values \n")
return(NULL)
}
if (!is.numeric(Precip) | !is.numeric(TempMean)) {
stop("Precip and TempMean must be vectors of numeric values \n")
return(NULL)
}
if (length(Precip) != LLL | length(TempMean) != LLL) {
stop("Precip, TempMean and DatesR must have the same length \n")
return(NULL)
}
if (is.null(TempMin) != is.null(TempMax)) {
stop("TempMin and TempMax must be both defined if not null \n")
return(NULL)
}
if (!is.null(TempMin) & !is.null(TempMax)) {
if (!is.vector(TempMin) | !is.vector(TempMax)) {
stop("TempMin and TempMax must be vectors of numeric values \n")
return(NULL)
}
if (!is.numeric(TempMin) | !is.numeric(TempMax)) {
stop("TempMin and TempMax must be vectors of numeric values \n")
return(NULL)
}
if (length(TempMin) != LLL | length(TempMax) != LLL) {
stop("TempMin, TempMax and DatesR must have the same length \n")
return(NULL)
}
}
if (!is.null(HypsoData)) {
if (!is.vector(HypsoData)) {
stop("HypsoData must be a vector of numeric values if not null \n")
return(NULL)
}
if (!is.numeric(HypsoData)) {
stop("HypsoData must be a vector of numeric values if not null \n")
return(NULL)
}
if (length(HypsoData) != 101) {
stop("HypsoData must be of length 101 if not null \n")
return(NULL)
}
if (sum(is.na(HypsoData)) != 0 & sum(is.na(HypsoData)) != 101) {
stop("HypsoData must not contain any NA if not null \n")
return(NULL)
}
}
if (!is.null(ZInputs)) {
if (length(ZInputs) != 1) {
stop("\t ZInputs must be a single numeric value if not null \n")
return(NULL)
}
if (is.na(ZInputs) | !is.numeric(ZInputs)) {
stop("\t ZInputs must be a single numeric value if not null \n")
return(NULL)
}
}
if (is.null(HypsoData)) {
if (verbose) {
warning("\t HypsoData is missing => a single layer is used and no extrapolation is made \n")
}
HypsoData <- as.numeric(rep(NA, 101))
ZInputs <- as.numeric(NA)
NLayers <- as.integer(1)
}
if (is.null(ZInputs)) {
if (verbose & !identical(HypsoData, as.numeric(rep(NA, 101)))) {
warning("\t ZInputs is missing => HypsoData[51] is used \n")
}
ZInputs <- HypsoData[51L]
}
if (NLayers <= 0) {
stop("NLayers must be a positive integer value \n") stop("NLayers must be a positive integer value \n")
return(NULL) return(NULL)
} }
if(NLayers != as.integer(NLayers)) { if (NLayers != as.integer(NLayers)) {
warning("Coerce NLayers to be of integer type (", NLayers, " => ", as.integer(NLayers), ")") warning("Coerce NLayers to be of integer type (", NLayers, " => ", as.integer(NLayers), ")")
NLayers <- as.integer(NLayers) NLayers <- as.integer(NLayers)
} }
} }
##check_NA_values ##check_NA_values
BOOL_NA <- rep(FALSE,length(DatesR)); BOOL_NA <- rep(FALSE, length(DatesR))
if("GR" %in% ObjectClass) {
BOOL_NA_TMP <- (Precip < 0) | is.na(Precip ); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < 0 or NA values detected in Precip series \n"); } } if ("GR" %in% ObjectClass) {
BOOL_NA_TMP <- (PotEvap < 0) | is.na(PotEvap); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < 0 or NA values detected in PotEvap series \n"); } } BOOL_NA_TMP <- (Precip < 0) | is.na(Precip)
} if (sum(BOOL_NA_TMP) != 0) {
if("CemaNeige" %in% ObjectClass) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP
BOOL_NA_TMP <- (Precip < 0 ) | is.na(Precip ); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < 0 or NA values detected in Precip series \n"); } } if (verbose) {
BOOL_NA_TMP <- (TempMean<(-150)) | is.na(TempMean); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < -150) or NA values detected in TempMean series \n"); } } warning("\t Values < 0 or NA values detected in Precip series \n")
if(!is.null(TempMin) & !is.null(TempMax)) { }
BOOL_NA_TMP <- (TempMin<(-150)) | is.na(TempMin); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < -150) or NA values detected in TempMin series \n"); } } }
BOOL_NA_TMP <- (TempMax<(-150)) | is.na(TempMax); if(sum(BOOL_NA_TMP)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP; if(verbose) { warning("\t Values < -150) or NA values detected in TempMax series \n"); } } } BOOL_NA_TMP <- (PotEvap < 0) | is.na(PotEvap)
} if (sum(BOOL_NA_TMP) != 0) {
if(sum(BOOL_NA)!=0) { BOOL_NA <- BOOL_NA | BOOL_NA_TMP
WTxt <- NULL; if (verbose) {
WTxt <- paste(WTxt,"\t Missing values are not allowed in InputsModel \n",sep=""); warning("\t Values < 0 or NA values detected in PotEvap series \n")
Select <- (max(which(BOOL_NA))+1):length(BOOL_NA); }
if(Select[1L]>Select[2L]) { stop("Time series could not be trunced since missing values were detected at the list time-step"); return(NULL); } }
if("GR" %in% ObjectClass) { }
Precip <- Precip[Select]; PotEvap <- PotEvap[Select]; } if ("CemaNeige" %in% ObjectClass) {
if("CemaNeige" %in% ObjectClass) { BOOL_NA_TMP <- (Precip < 0) | is.na(Precip)
Precip <- Precip[Select]; TempMean <- TempMean[Select]; if(!is.null(TempMin) & !is.null(TempMax)) { TempMin <- TempMin[Select]; TempMax <- TempMax[Select]; } } if (sum(BOOL_NA_TMP) != 0) {
DatesR <- DatesR[Select]; BOOL_NA <- BOOL_NA | BOOL_NA_TMP
WTxt <- paste(WTxt,"\t -> Data were trunced to keep the most recent available time-steps \n",sep=""); if (verbose) {
WTxt <- paste(WTxt,"\t -> ", length(Select), " time-steps were kept \n",sep=""); warning("\t Values < 0 or NA values detected in Precip series \n")
if(!is.null(WTxt) & verbose) { warning(WTxt); } }
} }
BOOL_NA_TMP <- (TempMean < (-150)) | is.na(TempMean)
if (sum(BOOL_NA_TMP) != 0) {
##DataAltiExtrapolation_Valery BOOL_NA <- BOOL_NA | BOOL_NA_TMP
if("CemaNeige" %in% ObjectClass) { if (verbose) {
RESULT <- DataAltiExtrapolation_Valery(DatesR = DatesR, Precip = Precip, PrecipScale = PrecipScale, TempMean = TempMean, TempMin = TempMin, TempMax = TempMax, ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers, verbose = verbose) warning("\t Values < -150) or NA values detected in TempMean series \n")
if(verbose) { }
if(NLayers == 1) { }
if (!is.null(TempMin) & !is.null(TempMax)) {
BOOL_NA_TMP <- (TempMin < (-150)) | is.na(TempMin)
if (sum(BOOL_NA_TMP) != 0) {
BOOL_NA <- BOOL_NA | BOOL_NA_TMP
if (verbose) {
warning("\t Values < -150) or NA values detected in TempMin series \n")
}
}
BOOL_NA_TMP <- (TempMax < (-150)) | is.na(TempMax)
if (sum(BOOL_NA_TMP) != 0) {
BOOL_NA <- BOOL_NA | BOOL_NA_TMP
if (verbose) {
warning("\t Values < -150) or NA values detected in TempMax series \n")
}
}
}
}
if (sum(BOOL_NA) != 0) {
WTxt <- NULL
WTxt <- paste(WTxt, "\t Missing values are not allowed in InputsModel \n", sep = "")
Select <- (max(which(BOOL_NA)) + 1):length(BOOL_NA)
if (Select[1L] > Select[2L]) {
stop("Time series could not be trunced since missing values were detected at the list time-step")
return(NULL)
}
if ("GR" %in% ObjectClass) {
Precip <- Precip[Select]
PotEvap <- PotEvap[Select]
}
if ("CemaNeige" %in% ObjectClass) {
Precip <- Precip[Select]
TempMean <- TempMean[Select]
if (!is.null(TempMin) & !is.null(TempMax)) {
TempMin <- TempMin[Select]
TempMax <- TempMax[Select]
}
}
DatesR <- DatesR[Select]
WTxt <- paste(WTxt, "\t -> Data were trunced to keep the most recent available time-steps \n", sep = "")
WTxt <- paste(WTxt, "\t -> ", length(Select), " time-steps were kept \n", sep = "")
if (!is.null(WTxt) & verbose) {
warning(WTxt)
}
}
##DataAltiExtrapolation_Valery
if ("CemaNeige" %in% ObjectClass) {
RESULT <- DataAltiExtrapolation_Valery(DatesR = DatesR,
Precip = Precip, PrecipScale = PrecipScale,
TempMean = TempMean, TempMin = TempMin, TempMax = TempMax,
ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers,
verbose = verbose)
if (verbose) {
if (NLayers == 1) {
message("\t Input series were successfully created on 1 elevation layer for use by CemaNeige") message("\t Input series were successfully created on 1 elevation layer for use by CemaNeige")
} else { } else {
message("\t Input series were successfully created on ", NLayers, " elevation layers for use by CemaNeige") message( "\t Input series were successfully created on ", NLayers, " elevation layers for use by CemaNeige")
} }
} }
} }
##Create_InputsModel ##Create_InputsModel
InputsModel <- list(DatesR=DatesR) InputsModel <- list(DatesR = DatesR)
if("GR" %in% ObjectClass) { if ("GR" %in% ObjectClass) {
InputsModel <- c(InputsModel,list(Precip=as.double(Precip),PotEvap=as.double(PotEvap))); } InputsModel <- c(InputsModel, list(Precip = as.double(Precip), PotEvap = as.double(PotEvap)))
if("CemaNeige" %in% ObjectClass) { }
InputsModel <- c(InputsModel,list(LayerPrecip=RESULT$LayerPrecip,LayerTempMean=RESULT$LayerTempMean, if ("CemaNeige" %in% ObjectClass) {
LayerFracSolidPrecip=RESULT$LayerFracSolidPrecip,ZLayers=RESULT$ZLayers)); } InputsModel <- c(InputsModel, list(LayerPrecip = RESULT$LayerPrecip,
LayerTempMean = RESULT$LayerTempMean,
class(InputsModel) <- c("InputsModel",ObjectClass); LayerFracSolidPrecip = RESULT$LayerFracSolidPrecip,
return(InputsModel); ZLayers = RESULT$ZLayers))
}
} class(InputsModel) <- c("InputsModel", ObjectClass)
return(InputsModel)
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment