SeriesAggreg.data.frame.R

SeriesAggreg.data.frame <- function(x,
                                    Format,
                                    ConvertFun,
                                    TimeFormat = NULL,    # deprecated
                                    NewTimeFormat = NULL, # deprecated
                                    YearFirstMonth = 1,
                                    TimeLag = 0,
                                    ...) {
  ## Arguments checks
  if (!is.null(TimeFormat)) {
    warning("deprecated 'TimeFormat' argument", call. = FALSE)
  }
  if (missing(Format)) {
    Format <- .GetSeriesAggregFormat(NewTimeFormat)
  } else if (!is.null(NewTimeFormat)) {
    warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
            call. = FALSE)
  }
  if (is.null(Format)) {
    stop("argument 'Format' is missing")
  }

  ## check x
  if (!is.data.frame(x)) {
    stop("'x' must be a data.frame containing the dates and data to be aggregated")
  }
  if (ncol(x) < 2) {
    stop("'x' must contain at least two columns (including the column of dates)")
  }
  ## check x date column
  if (!inherits(x[[1L]], "POSIXt")) {
    stop("'x' first column must be a vector of class 'POSIXlt' or 'POSIXct'")
  }
  if (inherits(x[[1L]], "POSIXlt")) {
    x[[1L]] <- as.POSIXct(x[[1L]])
  }
  ## check x other columns (boolean converted to numeric)
  apply(x[, -1L, drop = FALSE],
        MARGIN = 2,
        FUN = function(iCol) {
          if (!is.numeric(iCol)) {
            stop("'x' columns (other than the first one) must be of numeric class")
          }
        })
  ## check Format
  listFormat <- c("%Y%m%d", "%Y%m", "%Y", "%m", "%d")
  Format <- gsub(pattern = "[[:punct:]]+", replacement = "%", Format)
  Format <- match.arg(Format, choices = listFormat)

  ## check ConvertFun
  if (length(ConvertFun) != (ncol(x) - 1)) {
    stop(sprintf("'ConvertFun' must be of length %i (ncol(x)-1)", ncol(x) - 1))
  }
  listConvertFun <- lapply(unique(ConvertFun), function(y) {
    if (!grepl("^q\\d+$", y, ignore.case = TRUE)) {
      return(match.fun(y))
    }
  })
  names(listConvertFun) <- unique(ConvertFun)
  lapply(ConvertFun, function(y) {
    if (!grepl("^q\\d+$", y, ignore.case = TRUE)) {
      TestOutput <- listConvertFun[[y]](1:10)
      if (!is.numeric(TestOutput)) {
        stop(sprintf("Returned value of '%s' function should be numeric", y))
      }
      if (length(TestOutput) != 1) {
        stop(sprintf("Returned value of '%s' function should be of length 1", y))
      }
    }
  })