/
drc-tidiers.R
161 lines (145 loc) · 3.91 KB
/
drc-tidiers.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
#' @templateVar class drc
#' @template title_desc_tidy
#'
#' @param x A `drc` object produced by a call to [drc::drm()].
#' @template param_confint
#' @template param_unused_dots
#'
#' @evalRd return_tidy(
#' curve = "Index identifying the curve.",
#' regression = TRUE
#' )
#'
#' @details The tibble has one row for each curve and term in the regression.
#' The `curveid` column indicates the curve.
#'
#' @examplesIf rlang::is_installed("drc")
#'
#' # load libraries for models and data
#' library(drc)
#'
#' # fit model
#' mod <- drm(dead / total ~ conc, type,
#' weights = total, data = selenium, fct = LL.2(), type = "binomial"
#' )
#'
#' # summarize model fit with tidiers
#' tidy(mod)
#' tidy(mod, conf.int = TRUE)
#'
#' glance(mod)
#'
#' augment(mod, selenium)
#'
#' @export
#' @seealso [tidy()], [drc::drm()]
#' @family drc tidiers
#' @aliases drc_tidiers
tidy.drc <- function(x, conf.int = FALSE, conf.level = 0.95, ...) {
check_ellipses("exponentiate", "tidy", "drc", ...)
ret <- coef(summary(x))
ret <- as_tibble(ret, rownames = "term")
names(ret) <- c("term", "estimate", "std.error", "statistic", "p.value")
if (conf.int) {
ci <- broom_confint_terms(x, level = conf.level)
ret <- dplyr::left_join(ret, ci, by = "term")
}
tidyr::separate(ret, term, c("term", "curve"), sep = ":")
}
#' @templateVar class drc
#' @template title_desc_glance
#'
#' @inherit tidy.drc params examples
#' @template param_unused_dots
#'
#' @evalRd return_glance(
#' "logLik",
#' "AIC",
#' "AICc" = "AIC corrected for small samples",
#' "BIC",
#' "df.residual"
#' )
#' @seealso [glance()], [drc::drm()]
#' @export
#' @family drc tidiers
glance.drc <- function(x, ...) {
as_glance_tibble(
AIC = stats::AIC(x),
BIC = stats::BIC(x),
logLik = stats::logLik(x),
df.residual = x$df.residual,
na_types = "rrri"
)
}
#' @templateVar class drc
#' @template title_desc_augment
#' @inherit tidy.drc params examples
#' @template param_data
#' @template param_newdata
#' @template param_confint
#' @template param_se_fit
#' @template param_unused_dots
#'
#' @evalRd return_augment(
#' ".lower",
#' ".upper",
#' ".se.fit",
#' ".fitted",
#' ".resid",
#' ".cooksd"
#' )
#'
#' @seealso [augment()], [drc::drm()]
#' @export
#'
#' @family drc tidiers
augment.drc <- function(x, data = NULL, newdata = NULL,
se_fit = FALSE, conf.int = FALSE, conf.level = 0.95, ...) {
if (is.null(data) && is.null(newdata)) {
stop("Must specify either `data` or `newdata` argument.", call. = FALSE)
}
# drc doesn't like tibbles
if (inherits(newdata, "tbl")) {
newdata <- data.frame(newdata)
}
# drc doesn't like NA in the type
if (!missing(newdata) || is.null(newdata)) {
original <- newdata
original$.rownames <- rownames(original)
}
if (!missing(newdata) && x$curveVarNam %in% names(newdata) &&
any(is.na(newdata[[x$curveVarNam]]))) {
newdata <- newdata[!is.na(newdata[[x$curveVarNam]]), ]
}
ret <- augment_columns(x, data, newdata, se.fit = FALSE)
if (!is.null(newdata)) {
if (conf.int) {
preds <- data.frame(predict(x,
newdata = newdata, interval = "confidence",
level = conf.level
))
ret[[".lower"]] <- preds[["Lower"]]
ret[[".upper"]] <- preds[["Upper"]]
}
if (se_fit) {
preds <- data.frame(predict(x, newdata = newdata, se.fit = TRUE))
ret[[".se.fit"]] <- preds[["SE"]]
}
}
# join back removed rows
if (!".rownames" %in% names(ret)) {
ret$.rownames <- rownames(ret)
}
if (!is.null(original)) {
reto <- ret %>% select(starts_with("."))
ret <- merge(reto, original, by = ".rownames", all.y = TRUE)
}
# reorder to line up with original
ret <- ret[order(match(ret$.rownames, rownames(original))), ]
rownames(ret) <- NULL
# if rownames are just the original 1...n, they can be removed
if (all(ret$.rownames == seq_along(ret$.rownames))) {
ret$.rownames <- NULL
}
as_tibble(ret)
}