R/aw.R

In mkin: Kinetic Evaluation of Chemical Degradation Data

#' Calculate Akaike weights for model averaging
#'
#' Akaike weights are calculated based on the relative
#' expected Kullback-Leibler information as specified
#' by Burnham and Anderson (2004).
#'
#' @param object An [mmkin] column object, containing two or more
#'   [mkinfit] models that have been fitted to the same data,
#'   or an mkinfit object. In the latter case, further mkinfit
#'   objects fitted to the same data should be specified
#'   as dots arguments.
#' @param \dots Not used in the method for [mmkin] column objects,
#'   further [mkinfit] objects in the method for mkinfit objects.
#' @references Burnham KP and Anderson DR (2004) Multimodel
#'   Inference: Understanding AIC and BIC in Model Selection.
#'   *Sociological Methods & Research* **33**(2) 261-304
#' @md
#' @examples
#' \dontrun{
#' f_sfo <- mkinfit("SFO", FOCUS_2006_D, quiet = TRUE)
#' f_dfop <- mkinfit("DFOP", FOCUS_2006_D, quiet = TRUE)
#' aw_sfo_dfop <- aw(f_sfo, f_dfop)
#' sum(aw_sfo_dfop)
#' aw_sfo_dfop # SFO gets more weight as it has less parameters and a similar fit
#' f <- mmkin(c("SFO", "FOMC", "DFOP"), list("FOCUS D" = FOCUS_2006_D), cores = 1, quiet = TRUE)
#' aw(f)
#' sum(aw(f))
#' aw(f[c("SFO", "DFOP")])
#' }
#' @export
aw <- function(object, ...) UseMethod("aw")

.aw <- function(all_objects) {
  AIC_all <- sapply(all_objects, AIC)
  delta_i <- AIC_all - min(AIC_all)
  denom <- sum(exp(-delta_i/2))
  w_i <- exp(-delta_i/2) / denom
  return(w_i)
}

#' @export
#' @rdname aw
aw.mkinfit <- function(object, ...) {
  oo <- list(...)
  data_object <- object$data[c("time", "variable", "observed")]
  for (i in seq_along(oo)) {
    if (!inherits(oo[[i]], "mkinfit")) stop("Please supply only mkinfit objects")
    data_other_object <- oo[[i]]$data[c("time", "variable", "observed")]
    if (!identical(data_object, data_other_object)) {
      stop("It seems that the mkinfit objects have not all been fitted to the same data")
    }
  }
  all_objects <- list(object, ...)
  .aw(all_objects)
}

#' @export
#' @rdname aw
aw.mmkin <- function(object, ...) {
  if (ncol(object) > 1) stop("Please supply an mmkin column object")
  do.call(aw, object)
}

#' @export
#' @rdname aw
aw.mixed.mmkin <- function(object, ...) {
  oo <- list(...)
  data_object <- object$data[c("ds", "name", "time", "value")]
  for (i in seq_along(oo)) {
    if (!inherits(oo[[i]], "mixed.mmkin")) stop("Please supply objects inheriting from mixed.mmkin")
    data_other_object <- oo[[i]]$data[c("ds", "name", "time", "value")]
    if (!identical(data_object, data_other_object)) {
      stop("It seems that the mixed.mmkin objects have not all been fitted to the same data")
    }
  }
  all_objects <- list(object, ...)
  .aw(all_objects)
}

#' @export
#' @rdname aw
aw.multistart <- function(object, ...) {
  do.call(aw, object)
}