-
Notifications
You must be signed in to change notification settings - Fork 28
/
Copy pathdistribution-helpers.R
109 lines (102 loc) · 2.72 KB
/
distribution-helpers.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
## helpers for working with mgcv's families
#' Negative binomial parameter theta
#'
#' @param model a fitted model.
#'
#' @return A numeric vector of length 1 containing the estimated value of
#' theta.
#'
#' @export
#'
#' @examples
#' load_mgcv()
#' df <- data_sim("eg1", n = 500, dist = "poisson", scale = 0.1, seed = 6)
#'
#' m <- gam(y ~ s(x0, bs = "cr") + s(x1, bs = "cr") + s(x2, bs = "cr") +
#' s(x3, bs = "cr"), family = nb, data = df, method = "REML")
#' ## IGNORE_RDIFF_BEGIN
#' nb_theta(m)
#' ## IGNORE_RDIFF_END
`nb_theta` <- function(model) {
UseMethod("nb_theta")
}
#' @export
#' @importFrom stringr str_detect
#' @describeIn nb_theta Method for class `"gam"`
`nb_theta.gam` <- function(model) {
supported <- str_detect(
family_name(model),
c("Negative Binomial", "negative binomial")
)
if (!any(supported)) {
stop("Only negative binomial models are supported.")
}
## how mgcv stores theta depends on which family was used, and this also
## affects the actual function stored in the family. Need theta on natural
## scale so we transform this if family is nb()
fam <- family(model)
theta <- if (inherits(fam, "extended.family")) {
fam$getTheta(trans = TRUE)
} else {
fam$getTheta()
}
## return
theta
}
#' General extractor for additional parameters in mgcv models
#'
#' @param object a fitted model
#' @param transform logical; transform to the natural scale of the parameter
#' @param ... arguments passed to other methods.
#'
#' @export
#'
#' @return Returns a numeric vector of additional parameters
#'
#' @examples
#' load_mgcv()
#' df <- data_sim("eg1", dist = "poisson", seed = 42, scale = 1 / 5)
#' m <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3),
#' data = df, method = "REML",
#' family = nb()
#' )
#' p <- theta(m)
`theta` <- function(object, ...) {
UseMethod("theta")
}
#' @export
#' @rdname theta
`theta.gam` <- function(object, transform = TRUE, ...) {
theta_fun <- family(object)$getTheta
if (is.null(theta_fun)) {
stop("No additional parameters available for this model")
}
theta_fun(trans = transform)
}
#' Are additional parameters available for a GAM?
#'
#' @param object an R object, either a [family()] object or an object whose
#' class has a [family()] method.
#'
#' @return A logical; `TRUE` if additional parameters available, `FALSE`
#' otherwise.
#'
#' @export
#'
#' @examples
#' load_mgcv()
#' df <- data_sim("eg1", dist = "poisson", seed = 42, scale = 1 / 5)
#' m <- gam(y ~ s(x0) + s(x1) + s(x2) + s(x3),
#' data = df, method = "REML",
#' family = nb()
#' )
#' has_theta(m)
#' p <- theta(m)
`has_theta` <- function(object) {
theta_fun <- if (inherits(object, "family")) {
object$getTheta
} else {
family(object)$getTheta
}
!is.null(theta_fun)
}