1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
#' 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)
}
|
