Skip to content

Commit fd3c2a4

Browse files
strengejackestrengejacke
authored
Fix selection models (#1140)
* Fix `selection` models * fix
1 parent aebe77b commit fd3c2a4

File tree

4 files changed

+128
-13
lines changed

4 files changed

+128
-13
lines changed

‎DESCRIPTION‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
Type: Package
22
Package: parameters
33
Title: Processing of Model Parameters
4-
Version: 0.27.0
4+
Version: 0.27.0.1
55
Authors@R:
66
c(person(given = "Daniel",
77
family = "Lüdecke",
@@ -202,6 +202,7 @@ Suggests:
202202
rms,
203203
rstan,
204204
rstanarm,
205+
sampleSelection,
205206
sandwich,
206207
see (>= 0.8.1),
207208
serp,
@@ -230,3 +231,4 @@ Config/testthat/parallel: true
230231
Config/Needs/website: easystats/easystatstemplate
231232
Config/Needs/check: stan-dev/cmdstanr
232233
Config/rcmdcheck/ignore-inconsequential-notes: true
234+
Remotes: easystats/insight

‎R/methods_selection.R‎

Lines changed: 21 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -39,20 +39,23 @@ model_parameters.selection <- function(model,
3939

4040

4141
#' @export
42-
p_value.selection <- function(model, component = c("all", "selection", "outcome", "auxiliary"), ...) {
43-
component <- match.arg(component)
42+
p_value.selection <- function(model, component = "all", ...) {
43+
component <- insight::validate_argument(
44+
component,
45+
c("all", "selection", "outcome", "auxiliary")
46+
)
4447
s <- summary(model)
4548
rn <- row.names(s$estimate)
4649
estimates <- as.data.frame(s$estimate, row.names = FALSE)
4750
params <- data.frame(
4851
Parameter = rn,
4952
p = estimates[[4]],
50-
Component = "auxiliary",
53+
Component = "selection",
5154
stringsAsFactors = FALSE,
5255
row.names = NULL
5356
)
54-
params$Component[s$param$index$betaS] <- "selection"
55-
params$Component[s$param$index$betaO] <- "outcome"
57+
params$Component[s$param$index$errTerms] <- "auxiliary"
58+
params$Component[s$param$index$outcome] <- "outcome"
5659

5760
if (component != "all") {
5861
params <- params[params$Component == component, , drop = FALSE]
@@ -63,20 +66,23 @@ p_value.selection <- function(model, component = c("all", "selection", "outcome"
6366

6467

6568
#' @export
66-
standard_error.selection <- function(model, component = c("all", "selection", "outcome", "auxiliary"), ...) {
67-
component <- match.arg(component)
69+
standard_error.selection <- function(model, component = "all", ...) {
70+
component <- insight::validate_argument(
71+
component,
72+
c("all", "selection", "outcome", "auxiliary")
73+
)
6874
s <- summary(model)
6975
rn <- row.names(s$estimate)
7076
estimates <- as.data.frame(s$estimate, row.names = FALSE)
7177
params <- data.frame(
7278
Parameter = rn,
7379
SE = estimates[[2]],
74-
Component = "auxiliary",
80+
Component = "selection",
7581
stringsAsFactors = FALSE,
7682
row.names = NULL
7783
)
78-
params$Component[s$param$index$betaS] <- "selection"
79-
params$Component[s$param$index$betaO] <- "outcome"
84+
params$Component[s$param$index$errTerms] <- "auxiliary"
85+
params$Component[s$param$index$outcome] <- "outcome"
8086

8187
if (component != "all") {
8288
params <- params[params$Component == component, , drop = FALSE]
@@ -89,9 +95,12 @@ standard_error.selection <- function(model, component = c("all", "selection", "o
8995
#' @export
9096
simulate_model.selection <- function(model,
9197
iterations = 1000,
92-
component = c("all", "selection", "outcome", "auxiliary"),
98+
component = "all",
9399
...) {
94-
component <- match.arg(component)
100+
component <- insight::validate_argument(
101+
component,
102+
c("all", "selection", "outcome", "auxiliary")
103+
)
95104
out <- .simulate_model(model, iterations, component = component, effects = "fixed", ...)
96105

97106
class(out) <- c("parameters_simulate_model", class(out))

‎tests/testthat/_snaps/sampleSelection.md‎

Lines changed: 71 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,71 @@
1+
# model_parameters
2+
3+
Code
4+
print(model_parameters(m1), zap_small = TRUE, table_width = Inf)
5+
Output
6+
# selection
7+
8+
Parameter | Coefficient | SE | 95% CI | t(490) | p
9+
------------------------------------------------------------------
10+
(Intercept) | -0.15 | 0.11 | [-0.36, 0.05] | -1.47 | 0.141
11+
xs | 1.14 | 0.18 | [ 0.79, 1.49] | 6.39 | < .001
12+
13+
# outcome
14+
15+
Parameter | Coefficient | SE | 95% CI | t(490) | p
16+
------------------------------------------------------------------
17+
(Intercept) | 0.03 | 0.16 | [-0.30, 0.35] | 0.17 | 0.869
18+
xo1 | 0.84 | 0.15 | [ 0.55, 1.13] | 5.61 | < .001
19+
(Intercept) | 0.16 | 0.16 | [-0.30, 0.35] | 0.17 | 0.869
20+
xo2 | 0.84 | 0.17 | [ 0.50, 1.17] | 4.91 | < .001
21+
22+
# Auxiliary
23+
24+
Parameter | Coefficient | SE | 95% CI | t(490) | p
25+
----------------------------------------------------------------
26+
sigma1 | 0.93 | 0.09 | [ 0.75, 1.11] | 10.12 | < .001
27+
rho1 | 0.89 | 0.05 | [ 0.78, 1.00] | 16.62 | < .001
28+
sigma2 | 0.91 | 0.04 | [ 0.82, 0.99] | 20.45 | < .001
29+
rho2 | 0.18 | 0.33 | [-0.47, 0.83] | 0.53 | 0.594
30+
Message
31+
32+
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
33+
using a Wald t-distribution approximation.
34+
35+
---
36+
37+
Code
38+
print(model_parameters(m2), zap_small = TRUE, table_width = Inf)
39+
Output
40+
# selection
41+
42+
Parameter | Coefficient | SE | 95% CI | t(740) | p
43+
-------------------------------------------------------------------
44+
(Intercept) | -4.12 | 1.40 | [-6.87, -1.37] | -2.94 | 0.003
45+
age | 0.18 | 0.07 | [ 0.05, 0.31] | 2.79 | 0.005
46+
age^2 | 0.00 | 0.00 | [ 0.00, 0.00] | -3.12 | 0.002
47+
faminc | 0.00 | 0.00 | [ 0.00, 0.00] | 1.29 | 0.199
48+
kidsTRUE | -0.45 | 0.13 | [-0.71, -0.20] | -3.46 | < .001
49+
educ | 0.10 | 0.02 | [ 0.05, 0.14] | 4.12 | < .001
50+
51+
# outcome
52+
53+
Parameter | Coefficient | SE | 95% CI | t(740) | p
54+
------------------------------------------------------------------
55+
(Intercept) | -1.96 | 1.20 | [-4.32, 0.39] | -1.64 | 0.102
56+
exper | 0.03 | 0.06 | [-0.09, 0.15] | 0.45 | 0.651
57+
exper^2 | 0.00 | 0.00 | [ 0.00, 0.00] | -0.06 | 0.955
58+
educ | 0.46 | 0.07 | [ 0.31, 0.60] | 6.24 | < .001
59+
city | 0.45 | 0.32 | [-0.17, 1.07] | 1.41 | 0.158
60+
61+
# Auxiliary
62+
63+
Parameter | Coefficient | SE | 95% CI | t(740) | p
64+
----------------------------------------------------------------
65+
sigma | 3.11 | 0.11 | [ 2.88, 3.33] | 27.31 | < .001
66+
rho | -0.13 | 0.17 | [-0.46, 0.19] | -0.80 | 0.424
67+
Message
68+
69+
Uncertainty intervals (equal-tailed) and p-values (two-tailed) computed
70+
using a Wald t-distribution approximation.
71+

‎tests/testthat/test-sampleSelection.R‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
skip_on_os("mac")
2+
skip_on_cran()
3+
skip_if_not_installed("sampleSelection")
4+
skip_if_not_installed("mvtnorm")
5+
6+
test_that("model_parameters", {
7+
set.seed(0)
8+
vc <- diag(3)
9+
vc[lower.tri(vc)] <- c(0.9, 0.5, 0.1)
10+
vc[upper.tri(vc)] <- vc[lower.tri(vc)]
11+
eps <- mvtnorm::rmvnorm(500, c(0, 0, 0), vc)
12+
xs <- runif(500)
13+
ys <- xs + eps[, 1] > 0
14+
xo1 <- runif(500)
15+
yo1 <- xo1 + eps[, 2]
16+
xo2 <- runif(500)
17+
yo2 <- xo2 + eps[, 3]
18+
yo <- ifelse(ys, yo2, yo1)
19+
ys <- as.numeric(ys) + 1
20+
dat_sel <<- data.frame(ys, yo, yo1, yo2, xs, xo1, xo2)
21+
m1 <- sampleSelection::selection(ys ~ xs, list(yo1 ~ xo1, yo2 ~ xo2), data = dat_sel)
22+
23+
data(Mroz87, package = "sampleSelection")
24+
Mroz87$kids <- (Mroz87$kids5 + Mroz87$kids618 > 0)
25+
m2 <- sampleSelection::selection(
26+
lfp ~ age + I(age^2) + faminc + kids + educ,
27+
wage ~ exper + I(exper^2) + educ + city,
28+
data = Mroz87
29+
)
30+
31+
expect_snapshot(print(model_parameters(m1), zap_small = TRUE, table_width = Inf))
32+
expect_snapshot(print(model_parameters(m2), zap_small = TRUE, table_width = Inf))
33+
})

0 commit comments

Comments
 (0)