/
test-mvrsquared.R
160 lines (91 loc) · 4.21 KB
/
test-mvrsquared.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
context("mvrsquared tests")
### Test univariate rsquared ----
f <- stats::lm(mpg ~ cyl + disp + hp + wt, data = datasets::mtcars)
y <- f$model$mpg
yhat <- f$fitted.values
s <- summary(f)
test_that("We get the expected value for correct inputs to univariate rsquared",{
r2 <- calc_rsquared(y = y, yhat = yhat)
expect_equal(round(r2, 3), round(s$r.squared, 3))
ss <- calc_rsquared(y = y, yhat = yhat, ybar = mean(y), return_ss_only = TRUE)
expect_equal(length(ss), 2)
expect_equal(r2, 1 - ss[[1]] / ss[[2]])
})
test_that("Get the right r-squared for single column matrix inputs", {
y_mat <- matrix(y, ncol = 1)
x <- cbind(1, as.matrix(f$model[, -1]))
w <- matrix(s$coefficients[, 1], ncol = 1)
expect_equal(calc_rsquared(y = y_mat, yhat = list(x, w)),
calc_rsquared(y = y, yhat = yhat))
})
test_that("Multithreading works as expected",{
r2 <- calc_rsquared(y = y, yhat = yhat, threads = 2)
expect_equal(length(r2), 1)
# expect_equal(round(r2, 3), round(s$r.squared, 3))
ss <- calc_rsquared(y = y, yhat = yhat, ybar = mean(y), return_ss_only = TRUE)
expect_equal(length(ss), 2)
# expect_equal(r2, 1 - ss[[1]] / ss[[2]])
})
### fancier stuff ----
test_that("can pass named 'w' and 'x' in list for 'yhat' out-of order and still get the same calculation", {
x <- cbind(1, as.matrix(f$model[, -1]))
w <- matrix(s$coefficients[, 1], ncol = 1)
r2_1 <- calc_rsquared(y = y, yhat = list(w = w, x = x))
expect_equal(r2_1, s$r.squared)
# name only one and you should get a warning
expect_warning(calc_rsquared(y = y, yhat = list(x = x, w)))
# repeated names of 'x' or 'w' produce a warning
expect_warning(calc_rsquared(y = y, yhat = list(x = x, w = w, x = x)))
# confirm that naming nothing produces no warning
calc_rsquared(y = y, yhat = list(x, w))
})
test_that("Get the right value for dgCMatrix inputs", {
expect_type(calc_rsquared(y = Matrix::Matrix(y, ncol = 1, sparse = TRUE), yhat = yhat),
"double")
})
test_that("get errors for incompatible dimensions",{
# not enough columns for yhat
expect_error(calc_rsquared(y = cbind(y, y), yhat = yhat))
# too many columns for yhat
expect_error(calc_rsquared(y = y, yhat = cbind(yhat, yhat)))
# number of rows does not match
expect_error(calc_rsquared(y = y[1:10], yhat = yhat))
# pass a vector and matrix in list
expect_error(
calc_rsquared(y = y, yhat = list(yhat, matrix(1, nrow = 1, ncol = 3)))
)
# dimensions of matrices in list do not match
expect_error(
calc_rsquared(y = y, yhat = list(matrix(yhat, ncol = 1), matrix(1, nrow = 1, ncol = 3)))
)
})
test_that("batch (for parallel) computation behaves nicely", {
# define some batches
batches <- list(list(y = cbind(y[1:16], y[1:16]), yhat = cbind(yhat[1:16], yhat[1:16])),
list(y = cbind(y[17:32], y[17:32]), yhat = cbind(yhat[17:32], yhat[17:32])))
ybar <- c(mean(y), mean(y))
# calc sum of squares by batch with correct inputs
# Note: this uses lapply, but one could easily do this in parallel with mclapply or similar
ss <- lapply(X = batches,
FUN = function(ybatch){
calc_rsquared(y = ybatch$y, yhat = ybatch$yhat, ybar = ybar, return_ss_only = TRUE)
})
sse <- sum(sapply(ss, function(x) x["sse"]))
sst <- sum(sapply(ss, function(x) x["sst"]))
r2_batch <- 1 - sse / sst # final r-squared value here
expect_equal(round(r2_batch, 4), round(s$r.squared, 4))
# leave out ybar and get a warning
expect_warning(lapply(X = batches,
FUN = function(ybatch){
calc_rsquared(y = ybatch$y, yhat = ybatch$yhat, return_ss_only = TRUE)
}))
})
test_that("Errors are triggered for malformed inputs",{
expect_error(calc_rsquared(y = y, yhat = yhat, return_ss_only = NA))
expect_error(calc_rsquared(y = y, yhat = yhat, ybar = c(1,1)))
expect_error(calc_rsquared(y = list(y), yhat = yhat))
expect_error(calc_rsquared(y = as.character(y), yhat = yhat))
expect_error(calc_rsquared(y = as.character(y), yhat = yhat))
expect_error(calc_rsquared(y = y, yhat = data.frame(yhat)))
expect_error(calc_rsquared(y = y, yhat = 5))
})