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
|
get_comparisons_data_numeric <- function(
model,
newdata,
variable,
modeldata,
...) {
h <- variable[["eps"]]
s <- m <- NA
if (is.numeric(modeldata[[variable$name]])) {
s <- stats::sd(modeldata[[variable$name]], na.rm = TRUE)
m <- mean(modeldata[[variable$name]], na.rm = TRUE)
}
x <- newdata[[variable$name]]
xmd <- modeldata[[variable$name]]
make_label <- function(lab, val) {
if (identical(lab, "custom")) {
return(lab)
}
args <- append(list(lab), as.list(val))
out <- tryCatch(
do.call("sprintf", args),
error = function(e) lab
)
return(out)
}
# slope
# by default variable$value, so we need to check this first
slopes <- c(
"dY/dX",
"eY/eX",
"eY/dX",
"dY/eX",
"mean(dY/dX)",
"mean(eY/eX)",
"mean(eY/dX)",
"mean(dY/eX)"
)
# manual high
if (isTRUE(checkmate::check_data_frame(variable$value))) {
if (all(c("low", "high") %in% colnames(variable$value))) {
low <- variable$value$low
high <- variable$value$high
} else {
low <- variable$value[[1]]
high <- variable$value[[2]]
}
lab <- "manual"
} else if (isTRUE(variable$label %in% slopes)) {
low <- x - h / 2
high <- x + h / 2
lab <- variable$label
} else if (identical(variable$label, "exp(dY/dX)")) {
low <- x - h / 2
high <- x + h / 2
lab <- "exp(dY/dX)"
# contrast_label is designed for categorical predictors
# numeric contrasts first
} else if (isTRUE(checkmate::check_numeric(variable$value, len = 1))) {
direction <- getOption(
"marginaleffects_contrast_direction",
default = "forward"
)
if (isTRUE(direction == "center")) {
low <- x - variable$value / 2
high <- x + variable$value / 2
} else if (isTRUE(direction == "backward")) {
low <- x - variable$value
high <- x
} else {
low <- x
high <- x + variable$value
}
# wrap in parentheses, unless mean() because there are already parentheses
# important to display ratios of x+1, etc.
# label should not be `(mpg+1) - mpg` because that is misleading for centered contrast
if (!isTRUE(grepl("mean", variable$label))) {
lab <- sprintf("+%s", variable$value)
} else {
lab <- sprintf("mean(+%s)", variable$value)
}
} else if (isTRUE(checkmate::check_numeric(variable$value, len = 2))) {
variable$value <- sort(variable$value)
low <- variable$value[1]
high <- variable$value[2]
lab <- make_label(variable$label, rev(variable$value))
# character contrasts
} else if (identical(variable$value, "sd")) {
low <- m - s / 2
high <- m + s / 2
lab <- c("x + sd/2", "x - sd/2")
if (!isTRUE(grepl("mean", variable$label))) {
lab <- sprintf("(%s)", lab)
}
lab <- make_label(variable$label, lab)
} else if (identical(variable$value, "2sd")) {
low <- m - s
high <- m + s
lab <- c("x + sd", "x - sd")
if (!isTRUE(grepl("mean", variable$label))) {
lab <- sprintf("(%s)", lab)
}
lab <- make_label(variable$label, lab)
} else if (identical(variable$value, "iqr")) {
low <- stats::quantile(xmd, probs = 0.25, na.rm = TRUE)
high <- stats::quantile(xmd, probs = 0.75, na.rm = TRUE)
lab <- make_label(variable$label, c("Q3", "Q1"))
} else if (identical(variable$value, "minmax")) {
low <- min(xmd, na.rm = TRUE)
high <- max(xmd, na.rm = TRUE)
lab <- make_label(variable$label, c("Max", "Min"))
} else if (isTRUE(checkmate::check_function(variable$value))) {
tmp <- variable$value(x)
low <- tmp[, 1]
high <- tmp[, 2]
lab <- "custom"
}
lo <- hi <- newdata
lo[[variable$name]] <- low
hi[[variable$name]] <- high
out <- list(
rowid = seq_len(nrow(newdata)),
lo = lo,
hi = hi,
original = newdata,
ter = rep(variable$name, nrow(newdata)),
lab = rep(lab, nrow(newdata))
)
return(out)
}
|
