Skip to content

GitLab

Commit c8027afe authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

v0.2.10.92 style(R): trim horizontal whitespaces in R functions

parent 511eaeb4
Pipeline #18274 passed with stages
in 1 minute and 29 seconds
Expand all Hide whitespace changes
Inline Side-by-side
DESCRIPTION
View file @ c8027afe
Package: airGRteaching
Type: Package
Title: Teaching Hydrological Modelling with the GR Rainfall-Runoff Models ('Shiny' Interface Included)
Version: 0.2.10.91
Version: 0.2.10.92
Date: 2020-12-09
Authors@R: c(
person("Olivier", "Delaigue", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
......
NEWS.md
View file @ c8027afe
......@@ -4,7 +4,7 @@
### 0.2.10.91 Release Notes (2020-12-09)
### 0.2.10.92 Release Notes (2020-12-09)
#### New features
......
R/CalGR.R
View file @ c8027afe
CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
WupPer = NULL, CalPer, transfo = c("", "sqrt", "log", "inv", "sort"), verbose = TRUE) {
CalCrit <- match.arg(arg = CalCrit)
CalCrit <- sprintf("ErrorCrit_%s", CalCrit)
FUN_CRIT <- get(CalCrit)
if (! any(transfo %in% c("", "sqrt", "log", "inv", "sort"))) {
stop("Non convenient transformation \"transfo\"")
} else {
transfo <- transfo[1L]
}
if (! any(class(PrepGR) %in% "PrepGR")) {
stop("Non convenient data for argument \"PrepGR\". Must be of class \"PrepGR\"")
}
isQobs <- !all(is.na(PrepGR$Qobs))
if (!isQobs) {
stop("\"PrepGR\" does not contain any Qobs values. It is not possible to calibrate the model")
}
WupInd <- NULL
if (!is.null(WupPer)) {
WupPer <- as.POSIXct(WupPer, tz = "UTC")
......@@ -37,7 +37,7 @@ CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
}
}
}
CalPer <- as.POSIXct(CalPer, tz = "UTC")
if (length(CalPer) != 2) {
stop("Calibration period \"CalPer\" must be of length 2")
......@@ -51,36 +51,36 @@ CalGR <- function(PrepGR, CalCrit = c("NSE", "KGE", "KGE2", "RMSE"),
CalInd <- which(PrepGR$InputsModel$DatesR == CalPer[1]):which(PrepGR$InputsModel$DatesR == CalPer[2])
}
}
MOD_opt <- CreateRunOptions(FUN_MOD = get(PrepGR$TypeModel), InputsModel = PrepGR$InputsModel,
IndPeriod_WarmUp = WupInd, IndPeriod_Run = CalInd, verbose = FALSE)
MOD_crt <- CreateInputsCrit(FUN_CRIT = FUN_CRIT, InputsModel = PrepGR$InputsModel,
MOD_opt <- CreateRunOptions(FUN_MOD = get(PrepGR$TypeModel), InputsModel = PrepGR$InputsModel,
IndPeriod_WarmUp = WupInd, IndPeriod_Run = CalInd, verbose = FALSE)
MOD_crt <- CreateInputsCrit(FUN_CRIT = FUN_CRIT, InputsModel = PrepGR$InputsModel,
RunOptions = MOD_opt, Obs = PrepGR$Qobs[CalInd], transfo = transfo)
CAL_opt <- CreateCalibOptions(FUN_MOD = get(PrepGR$TypeModel), FUN_CALIB = Calibration_Michel)
CAL <- Calibration(InputsModel = PrepGR$InputsModel, RunOptions = MOD_opt,
InputsCrit = MOD_crt, CalibOptions = CAL_opt,
FUN_MOD = get(PrepGR$TypeModel), FUN_CRIT = FUN_CRIT,
FUN_CALIB = Calibration_Michel, verbose = verbose)
SIM <- RunModel(InputsModel = PrepGR$InputsModel, RunOptions = MOD_opt,
Param = CAL$ParamFinalR, FUN_MOD = get(PrepGR$TypeModel))
CalGR <- list(OptionsCalib = MOD_opt, Qobs = PrepGR$Qobs[CalInd],
OutputsCalib = CAL, OutputsModel = SIM,
TypeModel = PrepGR$TypeModel, CalCrit = CalCrit,
PeriodModel = list(WarmUp = as.POSIXct(PrepGR$InputsModel$DatesR[range(MOD_opt$IndPeriod_WarmUp)], tz = "UTC"),
Run = CalPer))
class(CalGR) <- c("CalGR", "GR", "airGRt")
return(CalGR)
}
\ No newline at end of file
return(CalGR)
}
R/PrepGR.R
View file @ c8027afe
PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Qobs = NULL, TempMean = NULL,
PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Qobs = NULL, TempMean = NULL,
ZInputs = NULL, HypsoData = NULL, NLayers = 5,
HydroModel, CemaNeige = FALSE) {
SuiteGR <- paste0("GR", c("1A", "2M", "4J", "5J", "6J", "4H", "5H"))
HydroModel <- match.arg(arg = HydroModel, choices = SuiteGR)
if (is.null(ObsDF) && (is.null(DatesR) | is.null(Precip) | is.null(PotEvap))) {
stop("Missing input data")
}
......@@ -15,19 +15,19 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
TempMean <- ObsDF[, 5L]
}
}
if (!is.null(Qobs)) {
Qobs <- Qobs
} else {
Qobs <- NA
}
if (!is.null(TempMean)) {
TempMean <- TempMean
} else {
TempMean <- NA
}
if (is.null(ObsDF)) {
ObsDF <- data.frame(DatesR = DatesR,
Precip = Precip,
......@@ -35,7 +35,7 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
Qobs = Qobs,
TempMean = TempMean)
}
if (!is.null(ObsDF)) {
ObsDF <- data.frame(DatesR = ObsDF[, 1L],
Precip = ObsDF[, 2L],
......@@ -43,11 +43,11 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
Qobs = ObsDF[, 4L],
TempMean = TempMean)
}
if (! any(attributes(ObsDF$DatesR[1])$tzone %in% "UTC")) {
stop("Non convenient date format. Time zone must be defined as \"UTC\"")
}
if (! CemaNeige) {
TypeModel <- sprintf("RunModel_%s", HydroModel)
}
......@@ -61,13 +61,13 @@ PrepGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Q
FUN_MOD <- get(TypeModel)
MOD_obs <- CreateInputsModel(FUN_MOD = FUN_MOD, DatesR = ObsDF$DatesR,
Precip = ObsDF$Precip, PotEvap = ObsDF$PotEvap, TempMean = ObsDF$TempMean,
MOD_obs <- CreateInputsModel(FUN_MOD = FUN_MOD, DatesR = ObsDF$DatesR,
Precip = ObsDF$Precip, PotEvap = ObsDF$PotEvap, TempMean = ObsDF$TempMean,
ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers, verbose = FALSE)
PrepGR <- list(InputsModel = MOD_obs, Qobs = ObsDF$Qobs, TypeModel = TypeModel)
class(PrepGR) <- c("PrepGR", "GR", "airGRt")
return(PrepGR)
}
R/ShinyGR.R
View file @ c8027afe
ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Qobs = NULL, TempMean = NULL,
ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL, Qobs = NULL, TempMean = NULL,
ZInputs = NULL, HypsoData = NULL, NLayers = 5, SimPer, NamesObsBV = NULL,
theme = "RStudio") {
......@@ -14,7 +14,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if (is.null(SimPer) | any(sapply(SimPer, is.null))) {
stop("Null values non suitable for 'SimPer'.")
}
if (!is.null(ObsDF)) {
if (!is.list(ObsDF) | inherits(ObsDF, "PrepGR")) {
stop("'ObsDF' must be a (list of) 'data.frame'.")
......@@ -23,21 +23,21 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if (is.data.frame(ObsDF)) {
ObsDF <- list(ObsDF)
}
if (!is.list(HypsoData)) {
HypsoData <- list(HypsoData)
}
if (!is.list(SimPer)) {
SimPer <- list(SimPer)
}
if (is.null(ObsDF)) {
lenObsDF <- 1L
} else {
lenObsDF <- length(ObsDF)
}
if (is.null(names(ObsDF)) & !is.null(ObsDF)) {
if (is.null(NamesObsBV)) {
NamesObsBV <- paste0("%s %0", nchar(lenObsDF), "d")
......@@ -60,8 +60,8 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
if (any(nchar(NamesObsBV) == 0)) {
stop("NamesObsBV must be a string vector of at least one character.")
}
}
}
if (is.null(ObsDF)) {
if (length(ZInputs) > 1) {
warning("Too long 'ZInputs'. Only the first element(s) of 'ZInputs' argument used.")
......@@ -80,7 +80,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
SimPer <- SimPer[[1L]]
}
}
if (is.null(ZInputs)) {
ZInputs <- vector(mode = "list", length = lenObsDF)
} else {
......@@ -98,7 +98,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
}
names(ZInputs) <- NamesObsBV
if (is.null(HypsoData)) {
HypsoData <- vector(mode = "list", length = lenObsDF)
} else {
......@@ -135,7 +135,7 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
}
names(NLayers) <- NamesObsBV
if (length(SimPer) > lenObsDF) {
SimPer <- as.list(SimPer)[seq_along(ObsDF)]
warning("Too long 'SimPer'. Only the first element(s) of 'SimPer' argument used.")
......@@ -147,20 +147,20 @@ ShinyGR <- function(ObsDF = NULL, DatesR = NULL, Precip = NULL, PotEvap = NULL,
}
names(SimPer) <- NamesObsBV
.GlobalEnv$.ShinyGR.hist <- list(list())#list(Param = list(), TypeModel = lsit(), Crit = list(), Qsim = list())
.GlobalEnv$.ShinyGR.args <- list(ObsDF = ObsDF, NamesObsBV = NamesObsBV,
DatesR = DatesR, Precip = Precip, PotEvap = PotEvap, Qobs = Qobs, TempMean = TempMean,
DatesR = DatesR, Precip = Precip, PotEvap = PotEvap, Qobs = Qobs, TempMean = TempMean,
ZInputs = ZInputs, HypsoData = HypsoData, NLayers = NLayers, SimPer = SimPer,
theme = theme)
## timezone used
# oTZ <- Sys.timezone()
Sys.setenv(TZ = "UTC")
on.exit({rm(.ShinyGR.args, .ShinyGR.hist, envir = .GlobalEnv) ; Sys.unsetenv("TZ")})
shiny::runApp(system.file("ShinyGR", package = "airGRteaching"), launch.browser = TRUE)
return(NULL)
}
R/SimGR.R
View file @ c8027afe
SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2", "RMSE"),
WupPer = NULL, SimPer, transfo = c("", "sqrt", "log", "inv", "sort"), verbose = TRUE) {
EffCrit <- match.arg(arg = EffCrit)
EffCrit <- sprintf("ErrorCrit_%s", EffCrit)
FUN_CRIT <- get(EffCrit)
if (! any(transfo %in% c("", "sqrt", "log", "inv", "sort"))) {
stop("Non convenient transformation \"transfo\"")
} else {
transfo <- transfo[1L]
}
if (! any(class(PrepGR) %in% "PrepGR")) {
stop("Non convenient data for argument \"PrepGR\". Must be of class \"PrepGR\"")
}
isQobs <- !all(is.na(PrepGR$Qobs))
if (!isQobs) {
warning("\"PrepGR\" does not contain any Qobs values. The efficiency criterion is not computed")
}
if (!missing(CalGR)) {
warning("Deprecated \"CalGR\" argument. Use \"Param\" instead")
}
......@@ -41,7 +41,7 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
if (inherits(Param, "CalGR")) {
Param <- Param$OutputsCalib$ParamFinalR
}
WupInd <- NULL
if (!is.null(WupPer)) {
WupPer <- as.POSIXct(WupPer, tz = "UTC")
......@@ -58,7 +58,7 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
}
}
}
SimPer <- as.POSIXct(SimPer, tz = "UTC")
if (length(SimPer) != 2) {
stop("Simulation period \"SimPer\" must be of length 2")
......@@ -73,37 +73,37 @@ SimGR <- function(PrepGR, CalGR = NULL, Param, EffCrit = c("NSE", "KGE", "KGE2",
}
}
MOD_opt <- CreateRunOptions(FUN_MOD = get(PrepGR$TypeModel), InputsModel = PrepGR$InputsModel,
MOD_opt <- CreateRunOptions(FUN_MOD = get(PrepGR$TypeModel), InputsModel = PrepGR$InputsModel,
IndPeriod_WarmUp = WupInd, IndPeriod_Run = SimInd, verbose = verbose)
if (isQobs) {
MOD_crt <- CreateInputsCrit(FUN_CRIT = FUN_CRIT, InputsModel = PrepGR$InputsModel,
MOD_crt <- CreateInputsCrit(FUN_CRIT = FUN_CRIT, InputsModel = PrepGR$InputsModel,
RunOptions = MOD_opt, Obs = PrepGR$Qobs[SimInd], transfo = transfo)
} else {
MOD_crt <- NULL
}
SIM <- RunModel(InputsModel = PrepGR$InputsModel, RunOptions = MOD_opt,
SIM <- RunModel(InputsModel = PrepGR$InputsModel, RunOptions = MOD_opt,
Param = Param, FUN_MOD = get(PrepGR$TypeModel))
if (isQobs) {
CRT <- ErrorCrit(InputsCrit = MOD_crt, OutputsModel = SIM, verbose = verbose)
} else {
CRT <- NULL
}
SimGR <- list(OptionsSimul = MOD_opt, OptionsCrit = MOD_crt, OutputsModel = SIM, Qobs = PrepGR$Qobs[SimInd],
TypeModel = PrepGR$TypeModel,
CalCrit = CalGR$CalCrit, EffCrit = CRT,
PeriodModel = list(WarmUp = as.POSIXct(PrepGR$InputsModel$DatesR[range(MOD_opt$IndPeriod_WarmUp)], tz = "UTC"),
Run = SimPer))
class(SimGR) <- c("SimGR", "GR", "airGRt")
return(SimGR)
}
\ No newline at end of file
return(SimGR)
}
R/Utils.R
View file @ c8027afe
This diff is collapsed.
R/as.data.frame.airGRt.R
View file @ c8027afe
as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
if (!(inherits(x, "PrepGR") | inherits(x, "CalGR") | inherits(x, "SimGR"))) {
stop("'InputsCrit' must be of class 'PrepGR', 'CalGR', 'SimGR'")
}
TMGR <- .TypeModelGR(x)
myGR <- list()
myGR$FracSolid <- NA
myGR$TempMean <- NA
if (inherits(x, "PrepGR")) {
if (TMGR$CemaNeige) {
PrecipSol <- rowMeans(as.data.frame(x$InputsModel$LayerPrecip) * as.data.frame(x$InputsModel$LayerFracSolidPrecip), na.rm = TRUE)
......@@ -41,7 +41,7 @@ as.data.frame.airGRt <- function(x, row.names = NULL, ...) {
myGR$Precip <- x$OutputsModel$Precip
myGR$Qobs <- x$Qobs
myGR$Qsim <- x$OutputsModel$Qsim
}
}
TabSim <- data.frame(Dates = myGR$DatesR,
PotEvap = myGR$PotEvap,
PrecipObs = myGR$Precip,
......
R/dyplot.CalGR.R
View file @ c8027afe
......@@ -3,7 +3,7 @@ dyplot.CalGR <- function(x, ...) {
if (! any(class(x) %in% "CalGR")) {
stop("Non convenient data for x argument. Must be of class \"CalGR\"")
}
dyplot.default(x, ...)
}
R/dyplot.PrepGR.R
View file @ c8027afe
......@@ -3,7 +3,7 @@ dyplot.PrepGR <- function(x, ...) {
if (! any(class(x) %in% "PrepGR")) {
stop("Non convenient data for x argument. Must be of class \"PrepGR\"")
}
dyplot.default(x, ...)
}
R/dyplot.SimGR.R
View file @ c8027afe
......@@ -3,7 +3,7 @@ dyplot.SimGR <- function(x, ...) {
if (! any(class(x) %in% "SimGR")) {
stop("Non convenient data for x argument. Must be of class \"SimGR\"")
}
dyplot.default(x, ...)
}
R/dyplot.default.R
View file @ c8027afe
......@@ -3,14 +3,14 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
ylab = NULL, main = NULL,
plot.na = TRUE, RangeSelector = TRUE, Roller = FALSE,
LegendShow = c("follow", "auto", "always", "onmouseover", "never"), ...) {
# barChartPrecip <- scan(file = system.file("plugins/barChartPrecip.js", package = "airGRteaching"),
# what = "character", quiet = TRUE)
if (! any(class(x) %in% c("PrepGR", "CalGR", "SimGR"))) {
stop("Non convenient data for x argument. Must be of class \"PrepGR\", \"CalGR\" or \"SimGR\"")
}
if (is.null(ylab)) {
yunit <- .TypeModelGR(x)$TimeUnit
ylab <- paste0(c("flow [mm/", "precip. [mm/"), yunit, "]")
......@@ -18,11 +18,11 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if (length(ylab) < 2) {
ylab <- c(ylab, "")
}
}
}
if (is.null(Qsup)) {
Qsup <- as.numeric(rep(NA, length.out = length(x$Qobs)))
}
}
if (!is.numeric(Qsup)) {
stop("'Qsup' must be numeric")
}
......@@ -32,8 +32,8 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if (!is.character(Qsup.name)) {
Qsup.name <- as.character(Qsup.name)
}
if (any(class(x) %in% "PrepGR")) {
data <- data.frame(DatesR = x$InputsModel$DatesR,
Precip = x$InputsModel$Precip,
......@@ -44,7 +44,7 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
data$Psol <- rowMeans(as.data.frame(x$InputsModel$LayerPrecip) * as.data.frame(x$InputsModel$LayerFracSolidPrecip), na.rm = TRUE)
data$Pliq <- data$Precip - data$Psol
data$Precip <- NULL
}
}
} else {
data <- data.frame(DatesR = x$OutputsModel$DatesR,
Precip = x$OutputsModel$Precip,
......@@ -58,8 +58,8 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
}
}
data.xts <- xts::xts(data[, -1L], order.by = data$DatesR, tz = "UTC")
rgba <- function(x, alpha = 1) {
sprintf("rgba(%s, %f)", paste0(col2rgb(x), collapse = ", "), alpha)
}
......@@ -72,16 +72,16 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
if (length(col.Precip) < 2) {
col.Precip <- c(rgba(col.Precip), rgba(col.Precip, alpha = 0.5))
}
if (grepl("CemaNeige", x$TypeModel)) {
Plim <- c(-1e-3, max(data$Psol+data$Pliq, na.rm = TRUE))
} else {
Plim <- c(-1e-3, max(data$Precip, na.rm = TRUE))
col.Precip <- col.Precip[1L]
}
dg <- dygraphs::dygraph(data.xts, main = main, ...)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qobs", axis = "y", color = col.Q[1L], drawPoints = TRUE)
dg <- dygraphs::dySeries(dygraph = dg, name = "Qsim", axis = "y", color = col.Q[2L])
......@@ -109,7 +109,7 @@ dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
dg <- dygraphs::dyLegend(dygraph = dg, show = LegendShow[1L])
}
dg <- dygraphs::dyOptions(dygraph = dg, useDataTimezone = TRUE)
return(dg)
}
R/plot.CalGR.R
View file @ c8027afe
plot.CalGR <- function(x, xlab = NULL, ylab = NULL, main = NULL, which = c("perf", "iter", "ts"), ...) {
if (! any(class(x) %in% "CalGR")) {
stop("Non convenient data for x argument. Must be of class \"CalGR\"")
}
if (! any(which %in% c("perf", "iter", "ts"))) {
stop("Non convenient data for which argument. Must be of class \"perf\", \"iter\" or \"ts\"")
}
nbParamX <- .TypeModelGR(x)$NbParam #as.numeric(gsub("\\D", "", x$TypeModel))
nbParamC <- ifelse(.TypeModelGR(x)$CemaNeige, 2, 0)
nbParam <- nbParamX + nbParamC
nmParam <- c(sprintf("X%i", 1:nbParamX), sprintf("C%i", seq_len(nbParamC)))
opar <- par(no.readonly = TRUE)
on.exit(par(opar))
if (any(which[1L] %in% c("perf"))) {
plot(x$OutputsModel, Qobs = x$Qobs, ...)
}
if (any(which[1L] %in% c("iter"))) {
layout.list <- list(matrix(c(1:2), ncol = 2),
matrix(c(1:3, 3), ncol = 2),
......@@ -40,7 +40,7 @@ plot.CalGR <- function(x, xlab = NULL, ylab = NULL, main = NULL, which = c("per
if (which[1L] %in% c("ts")) {
layout(mat = matrix(1:2), widths = c(1, 2), heights = c(1, 2))
}
if (any(which[1L] %in% c("iter"))) {
ParamLab <- data.frame(Name = c(sprintf("X%i", 1:6), sprintf("C%i", 1:2)),
Label = c("prod. store capacity [mm]",
......@@ -52,8 +52,8 @@ plot.CalGR <- function(x, xlab = NULL, ylab = NULL, main = NULL, which = c("per
"weight for snowpack thermal state [-]",
"degree-day melt coef. [mm/degC/TimeUnit]"))
ParamLab$Label <- gsub("TimeUnit", substr(.TypeModelGR(x)$TimeUnit, 1, 1), ParamLab$Label)