Merge branch 'master' into mxkin

1 files changed, 58 insertions, 0 deletions

diff --git a/R/aw.R b/R/aw.R
new file mode 100644
index 00000000..f46b20ec
--- /dev/null
+++ b/R/aw.R
@@ -0,0 +1,58 @@
+#' 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")
+
+#' @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, ...)
+  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.mmkin <- function(object, ...) {
+  if (ncol(object) > 1) stop("Please supply an mmkin column object")
+  do.call(aw, object)
+}