v1.2.8.0 UPDATE: CreateInputsCrit now returns a idLayer to indicate which...

v1.2.8.0 UPDATE: CreateInputsCrit now returns a idLayer to indicate which layer to use for SCA or SWE

DESCRIPTION

 Package: airGR
 Type: Package
 Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.2.7.12
+Version: 1.2.8.0
 Date: 2019-03-06
 Authors@R: c(
   person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),

NEWS.rmd

@@ -13,7 +13,7 @@ output:
 
 
 
-### 1.2.7.12 Release Notes (2019-03-06) 
+### 1.2.8.0 Release Notes (2019-03-06) 
 
 
 
@@ -36,6 +36,8 @@ output:
 
 - <code>CreateInputsCrit()</code> now presents a <code>warnings</code> argument to replace the verbose action (the <code>verbose</code> argument is keep to print messages).
 
+- <code>CreateInputsCrit()</code> now  returns a <code>idLayer</code> element to indicate which layer to use for SCA or SWE aggregation.
+
 - <code>CreateRunOptions()</code> now presents a <code>warnings</code> argument to replace the verbose action (the <code>verbose</code> argument is keep to print messages).
 
 - <code>Calibration()</code> function now returns an error message if <code>FUN_CALIB</code> is not a function

R/CreateInputsCrit.R

 CreateInputsCrit <- function(FUN_CRIT,
                              InputsModel,
                              RunOptions,
-                             Qobs,
+                             Qobs,              # deprecated
                              obs,
                              varObs = "Q",
                              BoolCrit = NULL,
                              transfo = "",
-                             # groupLayer,
                              weights = NULL,
-                             Ind_zeroes = NULL,
+                             Ind_zeroes = NULL, # deprecated
                              epsilon = NULL,
                              warnings = TRUE,
                              verbose = TRUE) {
@@ -47,25 +46,33 @@ CreateInputsCrit <- function(FUN_CRIT,
   LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
   
   
-  ## check 'obs'
+  ## check 'obs' and definition of idLayer
   vecObs <- unlist(obs)
   if (length(vecObs) %% LLL != 0 | !is.numeric(vecObs)) {
     stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE)
   }
   if (!is.list(obs)) {
+    idLayer <- list(1L)
     obs <- list(obs)
   } else {
+    idLayer <- lapply(obs, function(i) {
+        if (is.list(i)) {
+          length(i)
+        } else {
+          1L
+        }
+      })
     obs <- lapply(obs, function(x) rowMeans(as.data.frame(x)))
   }
-  
+
   
   ## create list of arguments
   listArgs <- list(FUN_CRIT   = FUN_CRIT,
                    obs        = obs,
                    varObs     = varObs,
                    BoolCrit   = BoolCrit,
+                   idLayer    = idLayer,
                    transfo    = transfo,
-                   # groupLayer = groupLayer,
                    weights    = weights,
                    epsilon    = epsilon)
   
@@ -90,6 +97,21 @@ CreateInputsCrit <- function(FUN_CRIT,
     # }
   }
   
+  ## check 'varObs' + 'RunOptions'
+  if ("Q" %in% varObs & !inherits(RunOptions, "GR")) {
+    stop("'varObs' cannot contain Q if a GR rainfall-runoff model is not used")
+  }
+  if (any(c("SCA", "SWE") %in% varObs) & !inherits(RunOptions, "CemaNeige")) {
+    stop("'varObs' cannot contain SCA or SWE if CemaNeige is not used")
+  }
+  if ("SCA" %in% varObs & inherits(RunOptions, "CemaNeige") & !"Gratio"   %in% RunOptions$Outputs_Sim) {
+    stop("'Gratio' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SCA with CemaNeige")
+  }
+  if ("SWE" %in% varObs & inherits(RunOptions, "CemaNeige") & !"SnowPack" %in% RunOptions$Outputs_Sim) {
+    stop("'SnowPack' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SWE with CemaNeige")
+  }
+
+  
   ## check 'transfo'
   if (missing(transfo)) {
     listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
@@ -117,10 +139,11 @@ CreateInputsCrit <- function(FUN_CRIT,
   }
 
   
+  ## ---------- reformat
+  
   ## reformat list of arguments
   listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
   
-  
   ## preparation of warning messages
   inVarObs  <- c("Q", "SCA", "SWE")
   msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s"
@@ -219,7 +242,7 @@ CreateInputsCrit <- function(FUN_CRIT,
                         obs        = iListArgs2$obs,
                         varObs     = iListArgs2$varObs,
                         BoolCrit   = iListArgs2$BoolCrit,
-                        # groupLayer = iListArgs2$groupLayer,
+                        idLayer = iListArgs2$idLayer,
                         transfo    = iListArgs2$transfo,
                         epsilon    = iListArgs2$epsilon,
                         weights    = iListArgs2$weights)
@@ -229,7 +252,51 @@ CreateInputsCrit <- function(FUN_CRIT,
   })
   names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
   
-  # if only one criterion --> not a list of InputsCrit but directly an InputsCrit
+  
+  listVarObs <- sapply(InputsCrit, FUN = "[[", "varObs")
+  inCnVarObs <- c("SCA", "SWE")
+  if (!"ZLayers" %in% names(InputsModel)) {
+    if(any(listVarObs %in% inCnVarObs)) {
+      stop(sprintf("'varOBS' can not be equal to %i if CemaNeige is not used",
+                   paste(sapply(inCnVarObs, shQuote), collapse = " or ")))
+    }
+  } else {
+    listGroupLayer0 <- sapply(InputsCrit, FUN = "[[", "idLayer")
+    listGroupLayer <- rep(listVarObs, times = listGroupLayer0)
+    tabGroupLayer  <- as.data.frame(table(listGroupLayer))
+    colnames(tabGroupLayer) <- c("varObs", "freq")
+    nLayers <- length(InputsModel$ZLayers)
+    for (iInCnVarObs in inCnVarObs) {
+      if (any(listVarObs %in% iInCnVarObs)) {
+        if (tabGroupLayer[tabGroupLayer$varObs %in% iInCnVarObs, "freq"] != nLayers) {
+          stop(sprintf("'obs' must contains %i vector(s) about %s", nLayers, iInCnVarObs))
+        }
+      }
+    }
+  }
+  
+  ## define idLayer as an index of the layer to use
+  for (iInCnVarObs in unique(listVarObs)) {
+    if (iInCnVarObs == "Q") {
+      k <- 1
+      for (i in which(listVarObs == iInCnVarObs)) {
+        InputsCrit[[i]]$idLayer <- NA
+        k <- k + 1
+      }
+    } else {
+      aa <- listGroupLayer0[listVarObs == iInCnVarObs]
+      bb <- c(0, aa[-length(aa)])
+      cc <- lapply(seq_along(aa), function(x) seq_len(aa[x]) + bb[x])
+      k <- 1
+      for (i in which(listVarObs == iInCnVarObs)) {
+        InputsCrit[[i]]$idLayer <- cc[[k]]
+        k <- k + 1
+      }
+    }
+  }
+
+  
+  ## if only one criterion --> not a list of InputsCrit but directly an InputsCrit
   if (length(InputsCrit) < 2) {
     InputsCrit <- InputsCrit[[1L]]
     InputsCrit["weights"] <- list(weights = NULL)