/
broom.R
166 lines (157 loc) · 4.66 KB
/
broom.R
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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
# Methods for logitr objects in broom package
#' @importFrom generics tidy
#' @export
generics::tidy
#' @importFrom generics glance
#' @export
generics::glance
#' @importFrom generics augment
#' @export
generics::augment
#' Tidy a `logitr` class object
#'
#' @param x is an object of class `logitr`.
#' @param conf.int Logical indicating whether or not to include
#' a confidence interval in the tidied output. Defaults to FALSE.
#' @param conf.level The confidence level to use for the confidence
#' interval if conf.int = TRUE. Must be strictly greater than 0
#' and less than 1. Defaults to 0.95, which corresponds to a
#' 95 percent confidence interval.
#' @param ... Unused, included for generic consistency only.
#' @return A tidy [tibble::tibble()] summarizing component-level
#' information about the model
#' @export
#' @examples
#' library(logitr)
#'
#' # Estimate a preference space model
#' mnl_pref <- logitr(
#' data = yogurt,
#' outcome = "choice",
#' obsID = "obsID",
#' pars = c("price", "feat", "brand")
#' )
#'
#' # Extract a tibble of the model coefficients
#' tidy(mnl_pref)
#'
#' # Extract a tibble of the model coefficients with confidence intervals
#' tidy(mnl_pref, conf.int = TRUE)
#'
#' @export
tidy.logitr <- function(
x,
conf.int = FALSE,
conf.level = 0.95,
...
) {
result <- stats::coef(summary(x))
result <- tibble::as_tibble(result, rownames = 'term')
names(result) <- c('term', 'estimate', 'std.error', 'statistic', 'p.value')
if (x$modelType == 'mxl') {
result$effect <- ifelse(grepl('sd_', result$term), 'ran_pars', 'fixed')
}
if (conf.int) {
ci <- NULL
tryCatch(
{
ci <- stats::confint(x, level = conf.level)
},
error = function(e) {
warning(
"Confidence interval could not be computed due to an error: ",
e
)
}
)
if (!is.null(ci)) {
names(ci) <- c('conf.low', 'conf.high')
ci <- tibble::as_tibble(ci, rownames = "term")
result <- tibble::as_tibble(merge(result, ci, by = "term"))
}
}
return(result)
}
#' Glance a `logitr` class object
#'
#' @param x is an object of class `logitr`.
#' @param ... further arguments.
#'
#' @return A tibble of the model summary statistics.
#' @export
#' @examples
#' library(logitr)
#'
#' # Estimate a preference space model
#' mnl_pref <- logitr(
#' data = yogurt,
#' outcome = "choice",
#' obsID = "obsID",
#' pars = c("price", "feat", "brand")
#' )
#'
#' # Extract a tibble of the model summary statistics
#' glance(mnl_pref)
#'
#' @export
glance.logitr <- function(x, ...) {
result <- tibble::as_tibble(t(summary(x)$statTable))
names(result) <- c(
'logLik', 'null.logLik', 'AIC', 'BIC',
'r.squared', 'adj.r.squared', 'nobs'
)
return(result)
}
#' Glance a `logitr` class object
#'
#' @param x is an object of class `logitr`.
#' @param newdata a `data.frame`. Each row is an alternative and each column an
#' attribute corresponding to parameter names in the estimated model. Defaults
#' to `NULL`, in which case predictions are made on the original data used to
#' estimate the model.
#' @param obsID The name of the column that identifies each set of
#' alternatives in the data. Required if newdata != NULL. Defaults to `NULL`,
#' in which case the value for `obsID` from the data in `object` is used.
#' @param type A character vector defining what to predict: `prob` for
#' probabilities, `outcomes` for outcomes. If you want both outputs, use
#' `c("prob", "outcome")`. Outcomes are predicted randomly according to the
#' predicted probabilities. Defaults to `"prob"`.
#' @param ... further arguments.
#'
#' @return A tibble of ...
#' @export
#' @examples
#' library(logitr)
#'
#' # Estimate a preference space model
#' mnl_pref <- logitr(
#' data = yogurt,
#' outcome = "choice",
#' obsID = "obsID",
#' pars = c("price", "feat", "brand")
#' )
#'
#' # Extract a tibble of the model summary statistics
#' augment(mnl_pref)
#'
#' @export
augment.logitr <- function(
x,
newdata = NULL,
obsID = NULL,
type = "prob",
...
) {
if (is.null(obsID)) {
obsIDName <- x$inputs$obsID
}
if (is.null(newdata)) {
result <- stats::predict(x, newdata = newdata, obsID = obsID, type = type)
result <- merge(result, x$fitted.values, by = obsIDName)
names(result)[which(names(result) == 'fitted_value')] <- '.fitted'
result <- cbind(result, .resid = x$residuals$residual)
} else {
result <- stats::predict(x, newdata = newdata, obsID = obsID, type = type)
}
return(result)
}