#' Extract percent-change contributions
#'
#' Extract a matrix or data frame of percent-change contributions from a price
#' index.
#'
#' @param x A price index, as made by, e.g., [elementary_index()].
#' @param level,levels The level of an index for which percent-change
#'   contributions
#'   are desired, defaulting to the first level (usually the top-level for an
#'   aggregate index). `contrib2DF()` can accept multiple levels.
#' @param period The time periods for which percent-change contributions are
#'   desired, defaulting to all time periods.
#' @param pad A numeric value to pad contributions so that they fit into a
#'   rectangular array when products differ over time. The default is 0.
#' @param value A numeric matrix of replacement contributions with a row for
#'   each product and a column for each time period. Recycling occurs along time
#'   periods.
#'
#' @returns
#' `contrib()` returns a matrix of percent-change contributions with a column
#' for each `period` and a row for each product (sorted) for which there are
#' contributions in `level`. Contributions are padded with `pad` to fit into a
#' rectangular array when products differ over time. The replacement methods
#' returns a copy of `x` with contributions given by the matrix `value`.
#' (`set_contrib()` is an alias that's easier to use with pipes.)
#' `set_contrib_from_index()` is a helper to return a copy of `x` with all
#' contributions set to the corresponding index value minus 1.
#'
#' `contrib2DF()` returns a data frame of contributions with four
#' columns: `period`, `level`, `product`, and `value`.
#'
#' @examples
#' prices <- data.frame(
#'   rel = 1:8,
#'   period = rep(1:2, each = 4),
#'   ea = rep(letters[1:2], 4)
#' )
#'
#' index <- elementary_index(prices, rel ~ period + ea, contrib = TRUE)
#'
#' pias <- aggregation_structure(
#'   list(c("top", "top", "top"), c("a", "b", "c")),
#'   weights = 1:3
#' )
#'
#' index <- aggregate(index, pias, na.rm = TRUE)
#'
#' # Percent-change contributions for the top-level index
#'
#' contrib(index)
#'
#' contrib2DF(index)
#'
#' # Calculate EA contributions for the chained index
#'
#' library(gpindex)
#'
#' arithmetic_contributions(
#'   as.matrix(chain(index))[c("a", "b", "c"), 2],
#'   weights(pias)
#' )
#'
#' @export contrib
#' @family index methods
contrib <- function(x, level = NULL, period = NULL, pad = 0) {
  level <- if (!is.null(level)) match_levels(as.character(level), x) else 1L
  period <- if (!is.null(period)) {
    match_time(as.character(period), x, several = TRUE)
  } else {
    seq_along(x$time)
  }
  pad <- as.numeric(pad)
  if (length(pad) != 1L) {
    stop("'pad' must be a length 1 numeric value")
  }
  if (is.null(x$contrib)) {
    return(
      matrix(
        numeric(0L),
        nrow = 0L,
        ncol = length(period),
        dimnames = list(product = character(0L), time = period)
      )
    )
  }
  con <- x$contrib[level, period]

  con_names <- lapply(con, names)
  products <- sort.int(unique(unlist(con_names, use.names = FALSE)))

  out <- vector("list", length(con))
  names(out) <- x$time[period]

  # Initialize `pad` contributions for all products in all time periods, then
  # replace with the actual values so products that didn't sell have `pad` and
  # not NA contributions.
  out[] <- list(structure(rep.int(pad, length(products)), names = products))
  res <- do.call(cbind, Map(replace, out, con_names, con))
  names(dimnames(res)) <- c("product", "time")
  res
}

#' @rdname contrib
#' @export
contrib2DF <- function(x, levels = NULL, period = NULL) {
  level <- if (!is.null(levels)) {
    match_levels(as.character(levels), x, several = TRUE)
  } else {
    1L
  }
  period <- if (!is.null(period)) {
    match_time(as.character(period), x, several = TRUE)
  } else {
    seq_along(x$time)
  }
  if (is.null(x$contrib)) {
    return(
      data.frame(
        period = character(0L),
        level = character(0L),
        product = character(0L),
        value = numeric(0L)
      )
    )
  }

  con <- x$contrib[level, period, drop = FALSE]

  products <- apply(con, 2L, lengths, simplify = FALSE)

  levels <- x$levels[level]
  levels <- unlist(
    lapply(products, \(z) rep.int(levels, z)),
    use.names = FALSE
  )

  periods <- rep.int(x$time[period], vapply(products, sum, numeric(1L)))

  contributions <- unlist(con)
  data.frame(
    period = periods,
    level = levels,
    # NULL if there are no contributions.
    product = as.character(names(contributions)),
    value = unname(contributions)
  )
}

#' @rdname contrib
#' @export
`contrib<-` <- function(x, level = NULL, period = NULL, value) {
  level <- if (!is.null(level)) match_levels(as.character(level), x) else 1L
  period <- if (!is.null(period)) {
    match_time(as.character(period), x, several = TRUE)
  } else {
    seq_along(x$time)
  }

  if (is.null(x$contrib)) {
    x$contrib <- contrib_skeleton(x$levels, x$time)
  }

  value <- as.matrix(value)
  if (ncol(value) == 0L) {
    stop("replacement has length zero")
  } else if (length(period) %% ncol(value) != 0) {
    warning(
      "number of items to replace is not a multiple of replacement length"
    )
  }
  value <- matrix(
    as.numeric(value),
    nrow = nrow(value),
    ncol = ncol(value),
    dimnames = dimnames(value)
  )

  products <- if (nrow(value) > 0L) {
    if (is.null(rownames(value))) {
      as.character(seq_len(nrow(value)))
    } else {
      valid_product_names(rownames(value))
    }
  }

  j <- 0
  for (t in period) {
    j <- j %% ncol(value) + 1
    con <- value[, j]
    names(con) <- products
    x$contrib[level, t] <- list(con)
  }
  validate_contrib(x)
}

#' @rdname contrib
#' @export
set_contrib <- `contrib<-`

#' @rdname contrib
#' @export
set_contrib_from_index <- function(x) {
  x$contrib <- index2contrib(x$index, x$levels, x$time)
  validate_contrib(x)
}
