v1.6.8.18 feat: handle matrix and data.frame in SeriesAggreg.list for SD model

Refs #41

DESCRIPTION

 Package: airGR
 Type: Package
 Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.6.8.17
+Version: 1.6.8.18
 Date: 2020-12-01
 Authors@R: c(
   person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),

R/SeriesAggreg.InputsModel.R

 SeriesAggreg.InputsModel <- function(TabSeries, ...) {
-
   if (!inherits(TabSeries, "InputsModel")) {
     stop("to be used with 'InputsModel' object")
   }
-  res <- SeriesAggreg.list(TabSeries, except = "ZLayers", ...)
+  res <-
+    SeriesAggreg.list(TabSeries,
+                      except = c("ZLayers", "LengthHydro", "BasinAreas"),
+                      ...)
 
   return(res)
 
-}
\ No newline at end of file
+}

R/SeriesAggreg.list.R

@@ -9,14 +9,14 @@ SeriesAggreg.list <- function(TabSeries,
   if (!is.list(TabSeries)) {
     stop("to be used with a list")
   }
-  
+
   if (missing(Format)) {
     Format <- getSeriesAggregFormat(NewTimeFormat)
   } else if (!is.null(NewTimeFormat)) {
     warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
             call. = FALSE)
   }
-  
+
   # Determination of DatesR
   if (!is.null(TabSeries$DatesR)) {
     if (!inherits(TabSeries$DatesR, "POSIXt")) {
@@ -30,8 +30,7 @@ SeriesAggreg.list <- function(TabSeries,
         inherits(x, "POSIXt")
       }, simplify = TRUE))[1]
     if (is.na(itemPOSIXt)) {
-      stop(
-        "At least one item of argument 'TabSeries' should be of class 'POSIXt'")
+      stop("At least one item of argument 'TabSeries' should be of class 'POSIXt'")
     }
     warning(
       "Item 'DatesR' not found in 'TabSeries' argument: the item ",
@@ -40,18 +39,19 @@ SeriesAggreg.list <- function(TabSeries,
     )
     DatesR <- TabSeries[[names(TabSeries)[itemPOSIXt]]]
   }
-  
+
   # Selection of numeric items for aggregation
-  cols <- sapply(TabSeries, inherits, "numeric")
-  cols <- names(cols[which(cols)])
+  numericCols <- names(which(sapply(TabSeries, inherits, "numeric")))
+  arrayCols <- names(which(sapply(TabSeries, inherits, "array")))
+  numericCols <- setdiff(numericCols, arrayCols)
   if (!is.null(except)) {
     if (!inherits(except, "character")) {
       stop("Argument 'except' should be a 'character'")
     }
-    cols <- setdiff(cols, except)
+    numericCols <- setdiff(numericCols, except)
   }
-  
-  cols <- TabSeries[cols]
+
+  cols <- TabSeries[numericCols]
   lengthCols <- sapply(cols, length, simplify = TRUE)
   if (any(lengthCols != length(DatesR))) {
     sErr <- paste0(names(lengthCols)[lengthCols != length(DatesR)],
@@ -61,7 +61,7 @@ SeriesAggreg.list <- function(TabSeries,
       "The length of the following `numeric` items in 'TabSeries' ",
       "is different than the length of 'DatesR (",
       length(DatesR),
-      ")': ",
+      ")': they will be ignored in the aggregation: ",
       sErr
     )
     cols <- cols[lengthCols == length(DatesR)]
@@ -81,11 +81,11 @@ SeriesAggreg.list <- function(TabSeries,
                           ...,
                           ConvertFun = ConvertFun2)
   }
-  
+
   if (simplify) {
     # Returns data.frame of numeric found in the first level of the list
     return(dfOut)
-    
+
   } else {
     res <- list()
     # Convert aggregated data.frame into list
@@ -94,16 +94,17 @@ SeriesAggreg.list <- function(TabSeries,
       ## to be consistent with InputsModel class and because plot.OutputsModel use the POSIXlt class
       res$DatesR <- as.POSIXlt(res$DatesR)
     }
-    
+
     # Exploration of embedded lists and data.frames
     if (is.null(recursive) || recursive) {
       listCols <- TabSeries[sapply(TabSeries, inherits, "list")]
       dfCols <- TabSeries[sapply(TabSeries, inherits, "data.frame")]
+      dfCols <-
+        c(dfCols, TabSeries[sapply(TabSeries, inherits, "matrix")])
       listCols <- listCols[setdiff(names(listCols), names(dfCols))]
       if (length(listCols) > 0) {
         # Check for predefined ConvertFun for all sub-elements
-        ConvertFun <-
-          unlist(lapply(names(listCols), .AggregConvertFun))
+        ConvertFun <- .AggregConvertFun(names(listCols))
         # Run SeriesAggreg for each embedded list
         listRes <-
           lapply(names(listCols),
@@ -119,28 +120,50 @@ SeriesAggreg.list <- function(TabSeries,
                    )
                  })
         names(listRes) <- names(listCols)
-        if(is.null(res$DatesR)) {
+        if (is.null(res$DatesR)) {
           # Copy DatesR in top level list
           res$DatesR <- listRes[[1]]$DatesR
         }
         # Remove DatesR in embedded lists
-        lapply(names(listRes), function(x) {listRes[[x]]$DatesR <<- NULL})
+        lapply(names(listRes), function(x) {
+          listRes[[x]]$DatesR <<- NULL
+        })
         res <- c(res, listRes)
       }
+      if (length(dfCols) > 0) {
+        # Processing matrix and dataframes
+        for (i in length(dfCols)) {
+          key <- names(dfCols)[i]
+          m <- dfCols[[i]]
+          if (nrow(m) != length(DatesR)) {
+            warning(
+              "The number of rows of the 'matrix' item ",
+              key, " (", nrow(m),
+              ") is different than the length of 'DatesR ('", length(DatesR),
+              "), it will be ignored in the aggregation"
+            )
+          } else {
+            ConvertFun <- rep(.AggregConvertFun(key), ncol(m))
+            res[[key]] <- SeriesAggreg(data.frame(DatesR, m),
+                                           Format = Format,
+                                           ConvertFun = ConvertFun)
+          }
+        }
+      }
     }
-    
+
     # Store elements that are not aggregated
     res <- c(res, TabSeries[setdiff(names(TabSeries), names(res))])
-    
+
     class(res) <-
       gsub(
         "hourly|daily|monthly|yearly",
         getSeriesAggregClass(Format),
         class(TabSeries)
       )
-    
+
     return(res)
-    
+
   }
-  
-}
\ No newline at end of file
+
+}

R/Utils.R

@@ -26,7 +26,7 @@
                Outputs = c("zzz","PotEvap","Precip","Pn","Ps","AE","Perc","PR","Q9",
                        "Q1","Exch","AExch1","AExch2","AExch","QR","QRExp",
                        "QD","Qsim","Pliq","Psol","PotMelt","Melt","PliqAndMelt",
-                       "LayerPrecip","LayerFracSolidPrecip", "Qmm", "Qls", "E", "P"))
+                       "LayerPrecip","LayerFracSolidPrecip", "Qmm", "Qls", "E", "P", "Qupstream"))
   )
   res <- sapply(Outputs, function(iOutputs) {
     iRes <- Table$ConvertFun[Table$Outputs == iOutputs]

tests/testthat/test-SeriesAggreg.R

@@ -141,10 +141,14 @@ test_that("Check SeriesAggreg.outputsModel", {
         which(format(BasinObs$DatesR, format = "%Y-%m-%d") == "1999-12-31"))
 
   ## preparation of the RunOptions object
-  RunOptions <-
-    CreateRunOptions(FUN_MOD = RunModel_CemaNeigeGR4J,
-                     InputsModel = InputsModel,
-                     IndPeriod_Run = Ind_Run)
+  suppressWarnings(
+    RunOptions <-
+      CreateRunOptions(
+        FUN_MOD = RunModel_CemaNeigeGR4J,
+        InputsModel = InputsModel,
+        IndPeriod_Run = Ind_Run
+      )
+  )
 
   ## simulation
   Param <- c(
@@ -164,3 +168,25 @@ test_that("Check SeriesAggreg.outputsModel", {
   expect_equal(length(O2$DatesR),
                length(O2$CemaNeigeLayers$Layer01$Pliq))
 })
+
+test_that("Check data.frame handling in SeriesAggreg.list", {
+  QObsUp <- imputeTS::na_interpolation(BasinObs$Qmm)
+  InputsModelDown1 <- CreateInputsModel(
+    FUN_MOD = RunModel_GR4J,
+    DatesR = BasinObs$DatesR,
+    Precip = BasinObs$P,
+    PotEvap = BasinObs$E,
+    Qupstream = matrix(QObsUp, ncol = 1),
+    # Upstream observed flow
+    LengthHydro = 100 * 1000,
+    # Distance between upstream catchment outlet and the downstream one in m
+    BasinAreas = c(180, 180) # Upstream and downstream areas in km²
+  )
+  expect_warning(SeriesAggreg(InputsModelDown1, "%Y%m"),
+                 regexp = NA)
+  I2 <- SeriesAggreg(InputsModelDown1, "%Y%m")
+  expect_equal(length(I2$DatesR), nrow(I2$Qupstream))
+  InputsModelDown1$Qupstream <- InputsModelDown1$Qupstream[-1, , drop=FALSE] # https://stackoverflow.com/a/7352287/5300212
+  expect_warning(SeriesAggreg(InputsModelDown1, "%Y%m"),
+               regexp = "it will be ignored in the aggregation")
+})