v1.1.3.0 NEW: CreatInputsCrit can now process with SCA, SWE and SD observations

DESCRIPTION

 Package: airGR
 Type: Package
 Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.1.2.43
+Version: 1.1.3.0
 Date: 2019-02-21
 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.1.2.43 Release Notes (2019-02-21)
+### 1.1.3.0 Release Notes (2019-02-21)
 
 
 

R/CreateInputsCrit.R

@@ -3,7 +3,7 @@ CreateInputsCrit <- function(FUN_CRIT,
                              RunOptions,
                              Qobs,
                              obs,
-                             varObs = "Qobs",
+                             varObs = "Q",
                              BoolCrit = NULL,
                              transfo = "",
                              # groupLayer,
@@ -37,6 +37,29 @@ CreateInputsCrit <- function(FUN_CRIT,
   }
   
   
+  ## check 'InputsModel'
+  if (!inherits(InputsModel, "InputsModel")) {
+    stop("'InputsModel' must be of class 'InputsModel' \n")
+    return(NULL)
+  }
+  
+  
+  ## length of index of period to be used for the model run
+  LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
+  
+  
+  ## check 'obs'
+  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 \n", LLL), call. = FALSE)
+  }
+  if (!is.list(obs)) {
+    obs <- list(obs)
+  } else {
+    obs <- lapply(obs, function(x) rowMeans(as.data.frame(x)))
+  }
+  
+  
   ## create list of arguments
   listArgs <- list(FUN_CRIT   = FUN_CRIT,
                    obs        = obs,
@@ -62,18 +85,18 @@ CreateInputsCrit <- function(FUN_CRIT,
   
   ## check 'varObs'
   if (missing(varObs)) {
-    listArgs$varObs <- as.list(rep("Qobs", times = length(listArgs$obs)))
-    if (warnings) {
-      warning("'varObs' automatically set to \"Qobs\"")
-    }
+    listArgs$varObs <- as.list(rep("Q", times = length(listArgs$obs)))
+    # if (warnings) {
+    #   warning("'varObs' automatically set to \"Q\"")
+    # }
   }
   
   ## check 'transfo'
   if (missing(transfo)) {
     listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
-    if (warnings) {
-      warning("'transfo' automatically set to \"\"")
-    }
+    # if (warnings) {
+    #   warning("'transfo' automatically set to \"\"")
+    # }
   }  
   
   ## check length of each args
@@ -83,19 +106,13 @@ CreateInputsCrit <- function(FUN_CRIT,
   }
   
   
-  ## check "InputsModel"
-  if (!inherits(InputsModel, "InputsModel")) {
-    stop("'InputsModel' must be of class 'InputsModel' \n")
-    return(NULL)
-  }
-  
-  
   ## check 'RunOptions'
   if (!inherits(RunOptions , "RunOptions")) {
     stop("'RunOptions' must be of class 'RunOptions' \n")
     return(NULL)
   }
   
+  
   ## check 'weights'
   if (length(listArgs$weights) > 1 & sum(unlist(listArgs$weights)) == 0 & !any(sapply(listArgs$weights, is.null))) {
     stop("sum of 'weights' cannot be equal to zero \n")
@@ -106,17 +123,13 @@ CreateInputsCrit <- function(FUN_CRIT,
   listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
   
   
-  ## length of index of period to be used for the model run
-  LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
-  
-  
   ## preparation of warning messages
-  inVarObs  <- c("Qobs") ##, "SCAobs")
+  inVarObs  <- c("Q", "SCA", "SWE", "SD")
   msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s \n"
-  msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ","))
+  msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", "))
   inTransfo  <- c("", "sqrt", "log", "inv", "sort")
   msgTransfo <- "'transfo' must be a (list of) character vector(s) and one of %s \n"
-  msgTransfo <- sprintf(msgTransfo, paste(sapply(inTransfo, shQuote), collapse = ","))
+  msgTransfo <- sprintf(msgTransfo, paste(sapply(inTransfo, shQuote), collapse = ", "))
   
   
   ## ---------- loop on the list of inputs
@@ -135,6 +148,12 @@ CreateInputsCrit <- function(FUN_CRIT,
     }
     
     ## check 'obs'
+    # lapply(iListArgs2$obs, function(iObs) {
+    #   if (!is.vector(iObs) | length(iObs) != LLL | !is.numeric(iObs)) {
+    #     stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
+    #     return(NULL)
+    #   }
+    # })
     if (!is.vector(iListArgs2$obs) | length(iListArgs2$obs) != LLL | !is.numeric(iListArgs2$obs)) {
       stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
       return(NULL)
@@ -159,6 +178,24 @@ CreateInputsCrit <- function(FUN_CRIT,
       return(NULL)
     }
     
+    ## check 'varObs' + 'obs'
+    if (any(iListArgs2$varObs %in% "SCA")) {
+      idSCA <- which(iListArgs2$varObs == "SCA")
+      vecSCA <- unlist(iListArgs2$obs[idSCA])
+      if (min(vecSCA, na.rm = TRUE) < 0 | max(vecSCA, na.rm = TRUE) > 1) {
+        stop("'obs' outside [0,1] for \"SCA\" for 'varObs'", call. = FALSE)
+      }
+    } 
+    inPosVarObs <- c("Q", "SWE", "SD")
+    if (any(iListArgs2$varObs %in% inPosVarObs)) {
+      idQSS <- which(iListArgs2$varObs %in% inPosVarObs)
+      vecQSS <- unlist(iListArgs2$obs[idQSS])
+      if (min(vecQSS, na.rm = TRUE) < 0) {
+        stop(sprintf("'obs' outside [0,Inf[ for \"%s\" for 'varObs'", iListArgs2$varObs), call. = FALSE)
+      }
+    }
+    
+    
     ## check 'transfo'
     if (is.null(iListArgs2$transfo) | !is.vector(iListArgs2$transfo) | length(iListArgs2$transfo) != 1 | !is.character(iListArgs2$transfo) | !all(iListArgs2$transfo %in% inTransfo)) {
       stop(msgTransfo, call. = FALSE)