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
|
#' Extract a model offset
#'
#' `model_offset()` extracts a numeric offset from a model frame. It is
#' inspired by [stats::model.offset()], but has nicer error messages and
#' is slightly stricter.
#'
#' @param terms A `"terms"` object corresponding to `data`, returned from a
#' call to `model_frame()`.
#'
#' @param data A data frame returned from a call to `model_frame()`.
#'
#' @return
#'
#' A numeric vector representing the offset.
#'
#' @details
#'
#' If a column that has been tagged as an offset is not numeric, a nice error
#' message is thrown telling you exactly which column was problematic.
#'
#' [stats::model.offset()] also allows for a column named `"(offset)"` to be
#' considered an offset along with any others that have been tagged by
#' [stats::offset()]. However, [stats::model.matrix()] does not recognize
#' these columns as offsets (so it doesn't remove them as it should). Because
#' of this inconsistency, columns named `"(offset)"` are _not_ treated specially
#' by `model_offset()`.
#'
#' @examples
#'
#' x <- model.frame(Species ~ offset(Sepal.Width), iris)
#'
#' model_offset(terms(x), x)
#'
#' xx <- model.frame(Species ~ offset(Sepal.Width) + offset(Sepal.Length), iris)
#'
#' model_offset(terms(xx), xx)
#'
#' # Problematic columns are caught with intuitive errors
#' tryCatch(
#' expr = {
#' x <- model.frame(~ offset(Species), iris)
#' model_offset(terms(x), x)
#' },
#' error = function(e) {
#' print(e$message)
#' }
#' )
#' @export
model_offset <- function(terms, data) {
.offset_pos <- attr(terms, "offset")
has_offset <- !is.null(.offset_pos)
if (!has_offset) {
return(NULL)
}
ans <- rep(0, times = nrow(data))
for (.pos in .offset_pos) {
.offset_val <- data[[.pos]]
if (!is.numeric(.offset_val)) {
bad_col <- colnames(data)[.pos]
glubort(
"Column, '{bad_col}', is tagged as an offset, but is not numeric. ",
"All offsets must be numeric."
)
}
ans <- ans + .offset_val
}
ans
}
extract_offset <- function(terms, data) {
.offset <- model_offset(terms, data)
if (is.null(.offset)) {
NULL
} else {
tibble::tibble(.offset = .offset)
}
}
|
