R/SeriesAggreg.list.R

In airGR: Suite of GR Hydrological Models for Precipitation-Runoff Modelling

SeriesAggreg.list <- function(x,
                              Format,
                              ConvertFun,
                              NewTimeFormat = NULL,
                              simplify = FALSE,
                              except = NULL,
                              recursive = TRUE,
                              ...) {

  classIni <- class(x)
  class(x) <- "list" # in order to avoid the use of '['.InputsModel' or '['.OutputsModel' when x[i] is used

  if (missing(Format)) {
    Format <- .GetSeriesAggregFormat(NewTimeFormat)
  } else if (!is.null(NewTimeFormat)) {
    warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
            call. = FALSE)
  }
  # Check ConvertFun
  if (any(classIni %in% c("InputsModel", "OutputsModel"))) {
    if (!all(is.na(ConvertFun))) {
      warning("Argument 'ConvertFun' is ignored on 'InputsModel' and 'OutputsModel' objects")
    }
  } else if (length(ConvertFun) != 1) {
    stop("Argument 'ConvertFun' must be of length 1 with 'list' object")
  } else if (!is.character(ConvertFun)) {
    stop("Argument 'ConvertFun' must be a character")
  }

  # Determination of DatesR
  if (!is.null(x$DatesR)) {
    if (!inherits(x$DatesR, "POSIXt")) {
      stop("'x$DatesR' should be of class 'POSIXt'")
    }
    DatesR <- x$DatesR
  } else {
    # Auto-detection of POSIXt item in Tabseries
    itemPOSIXt <- which(sapply(x, function(x) {
      inherits(x, "POSIXt")
    }, simplify = TRUE))[1]
    if (is.na(itemPOSIXt)) {
      stop("At least one item of argument 'x' should be of class 'POSIXt'")
    }
    warning("Item 'DatesR' not found in 'x' argument: the item ",
            names(x)[itemPOSIXt],
            " has been automatically chosen")
    DatesR <- x[[names(x)[itemPOSIXt]]]
  }

  # Selection of numeric items for aggregation
  numericCols <- names(which(sapply(x, inherits, "numeric")))
  arrayCols <- names(which(sapply(x, inherits, "array")))
  numericCols <- setdiff(numericCols, arrayCols)
  if (!is.null(except)) {
    if (!inherits(except, "character")) {
      stop("Argument 'except' should be a 'character'")
    }
    numericCols <- setdiff(numericCols, except)
  }

  cols <- x[numericCols]
  lengthCols <- sapply(cols, length, simplify = TRUE)
  if (any(lengthCols != length(DatesR))) {
    sErr <- paste0(names(lengthCols)[lengthCols != length(DatesR)],
                   " (", lengthCols[lengthCols != length(DatesR)], ")",
                   collapse = ", ")
    warning("The length of the following `numeric` items in 'x' ",
            "is different than the length of 'DatesR (",
            length(DatesR),
            ")': they will be ignored in the aggregation: ",
            sErr)
    cols <- cols[lengthCols == length(DatesR)]
  }
  dfOut <- NULL
  if (length(cols)) {
    # Treating aggregation at root level
    if (is.na(ConvertFun)) {
      ConvertFun2 <- .GetAggregConvertFun(names(cols), Format)
    } else {
      ConvertFun2 <- rep(ConvertFun, length(cols))
    }
    dfOut <- SeriesAggreg(cbind(DatesR, as.data.frame(cols)),
                          Format,
                          ...,
                          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
    if (!is.null(dfOut)) {
      res <- as.list(dfOut)
      ## 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 <- x[!names(x) %in% except]
      listCols <- listCols[sapply(listCols, inherits, "list")]
      dfCols <- x[sapply(x, inherits, "data.frame")]
      dfCols <- c(dfCols, x[sapply(x, inherits, "matrix")])
      listCols <- listCols[setdiff(names(listCols), names(dfCols))]
      if (length(listCols) > 0) {
        if (is.na(ConvertFun)) {
          # Check for predefined ConvertFun for all sub-elements
          listConvertFun <- .GetAggregConvertFun(names(listCols), Format)
        }
        # Run SeriesAggreg for each embedded list
        listRes <- lapply(names(listCols), function(y) {
          listCols[[y]]$DatesR <- DatesR
          if (is.na(ConvertFun)) {
            SeriesAggreg.list(listCols[[y]],
                       Format = Format,
                       recursive = NULL,
                       ...,
                       ConvertFun = listConvertFun[y])
          } else {
            SeriesAggreg.list(listCols[[y]],
                              Format = Format,
                              recursive = NULL,
                              ...)
          }
        })
        names(listRes) <- names(listCols)
        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
        })
        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 {
            if (is.na(ConvertFun)) {
              ConvertFun2 <- rep(.GetAggregConvertFun(key, Format), ncol(m))
            } else {
              ConvertFun2 <- rep(ConvertFun, ncol(m))
            }
            res[[key]] <- SeriesAggreg.data.frame(data.frame(DatesR, m),
                                       Format = Format,
                                       ConvertFun = ConvertFun2)
          }
        }
      }
    }

    # Store elements that are not aggregated
    res <- c(res, x[setdiff(names(x), names(res))])

    class(res) <- gsub("hourly|daily|monthly|yearly",
                       .GetSeriesAggregClass(Format),
                       classIni)

    return(res)

  }

}