Skip to content

Commit

Permalink
update names for fitted_values
Browse files Browse the repository at this point in the history
  • Loading branch information
@gavinsimpson
gavinsimpson committed Oct 17, 2023
1 parent ad8599b commit dfd1345
Show file tree
Hide file tree
Showing 2 changed files with 41 additions and 32 deletions.
38 changes: 22 additions & 16 deletions R/fitted_values.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -113,8 +113,10 @@
se.fit = TRUE) |>
as.data.frame() |>
rlang::set_names(c(".fitted", ".se")) |>
as_tibble()
fit <- bind_cols(data, fit)
as_tibble() |>
mutate(.row = row_number())
fit <- bind_cols(data, fit) |>
relocate(".row", .before = 1L)

# create the confidence interval
crit <- coverage_normal(ci_level)
Expand Down Expand Up @@ -147,19 +149,23 @@
# convert fv to tibble then long format
fv <- fv |>
as_tibble() |>
tidyr::pivot_longer(everything(), values_to = ".fitted",
names_to = "parameter")
mutate(.row = row_number()) |>
relocate(".row", .before = 1L) |>
tidyr::pivot_longer(!matches("\\.row"), values_to = ".fitted",
names_to = ".parameter")
# convert fv to tibble then long format
std_err <- std_err |>
as_tibble() |>
tidyr::pivot_longer(everything(), values_to = ".std_err",
names_to = "parameter")
mutate(.row = row_number()) |>
relocate(".row", .before = 1L) |>
tidyr::pivot_longer(!matches("\\.row"), values_to = ".std_err",
names_to = ".parameter")
# bind .std_err to fv...
fit <- fv |>
add_column(.std_err = pull(std_err, ".std_err")) |>
add_column(.se = pull(std_err, ".std_err")) |>
# ...and compute interval
mutate(.lower_ci = .data$.fitted + (crit * .data$.std_err),
.upper_ci = .data$.fitted - (crit * .data$.std_err))
mutate(.lower_ci = .data$.fitted + (crit * .data$.se),
.upper_ci = .data$.fitted - (crit * .data$.se))

# convert to the response scale if requested
if (identical(scale, "response")) {
Expand All @@ -168,7 +174,7 @@

fit <- fit |>
mutate(across(all_of(c(".fitted", ".lower_ci", ".upper_ci")),
.fns = ~ case_match(.data$parameter,
.fns = ~ case_match(.data$.parameter,
"location" ~ extra_fns[["location"]](ilink_loc(.x)),
"scale" ~ extra_fns[["scale"]](ilink_scl(.x)),
"shape" ~ extra_fns[["shape"]](ilink_scl(.x)),
Expand Down Expand Up @@ -236,18 +242,18 @@ identity_fun <- function(eta) {
mutate(.row = row_number()) |>
relocate(".row", .before = 1L) |>
tidyr::pivot_longer(!matches("\\.row"), values_to = ".fitted",
names_to = "parameter")
names_to = ".parameter")
# convert fv to tibble then long format
std_err <- std_err |>
as_tibble() |>
tidyr::pivot_longer(everything(), values_to = ".std_err",
names_to = "parameter")
names_to = ".parameter")
# bind .std_err to fv...
fit <- fv |>
add_column(.std_err = pull(std_err, ".std_err")) |>
add_column(.se = pull(std_err, ".std_err")) |>
# ...and compute interval
mutate(.lower_ci = .data$.fitted + (crit * .data$.std_err),
.upper_ci = .data$.fitted - (crit * .data$.std_err))
mutate(.lower_ci = .data$.fitted + (crit * .data$.se),
.upper_ci = .data$.fitted - (crit * .data$.se))

# convert to the response scale if requested
if (identical(scale, "response")) {
Expand All @@ -256,7 +262,7 @@ identity_fun <- function(eta) {

fit <- fit |>
mutate(across(all_of(c(".fitted", ".lower_ci", ".upper_ci")),
.fns = ~ case_match(.data$parameter,
.fns = ~ case_match(.data$.parameter,
"location" ~ extra_fns[["location"]](ilink_loc(.x)),
"pi" ~ extra_fns[["pi"]](ilink_scl(.x)))))
}
Expand Down
35 changes: 19 additions & 16 deletions tests/testthat/test-fitted-values.R
View file
Original file line number Diff line number Diff line change
@@ -1,10 +1,11 @@
## Test fitted-values()
# Test fitted_values()

fv_nms <- c(".fitted", ".se", ".lower_ci", ".upper_ci")

test_that("fitted_values() works for a GAM", {
expect_silent(fv <- fitted_values(m_gam))

expect_named(fv, expected = c("x0", "x1", "x2", "x3", ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", "x0", "x1", "x2", "x3", fv_nms))

expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))

Expand All @@ -15,8 +16,7 @@ test_that("fitted_values() scale='response' works for a GAM", {
expect_silent(fv <- fitted_values(m_gam, scale = "response"))
expect_silent(fv2 <- fitted_values(m_gam, scale = "linear predictor"))

expect_named(fv, expected = c("x0", "x1", "x2", "x3", ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", "x0", "x1", "x2", "x3", fv_nms))

expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))

Expand All @@ -28,8 +28,7 @@ test_that("fitted_values() scale='response' works for a GAM", {
test_that("fitted_values() scale='link' works for a GAM", {
expect_silent(fv <- fitted_values(m_gam, scale = "link"))

expect_named(fv, expected = c("x0", "x1", "x2", "x3", ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", "x0", "x1", "x2", "x3", fv_nms))

expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))

Expand All @@ -40,8 +39,7 @@ test_that("fitted_values() works for a GAM", {
new_df <- data_sim("eg1", n = 100, dist = "normal", scale = 2, seed = 1)
expect_silent(fv <- fitted_values(m_gam, data = new_df))

expect_named(fv, expected = c(names(new_df), ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", names(new_df), fv_nms))

expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))

Expand All @@ -53,40 +51,45 @@ test_that("fitted_values() works for an ocat GAM", {
expect_silent(fv <- fitted_values(m_ocat))

expect_named(fv, expected = c(".row", "x0", "x1", "x2", "x3", ".category",
".fitted", ".se", ".lower_ci", ".upper_ci"))
fv_nms))
expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))
expect_identical(nrow(su_eg1_ocat) * 4L, nrow(fv))

new_df <- data_sim("eg1", n = 50, dist = "ocat", seed = 1)
expect_silent(fv <- fitted_values(m_ocat, data = new_df))
expect_named(fv, expected = c(".row", names(new_df), ".category",
".fitted", ".se", ".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", names(new_df), ".category", fv_nms))
expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))
expect_identical(nrow(new_df) * 4L, nrow(fv))

# link scale
expect_silent(fv <- fitted_values(m_ocat, scale = "link"))
expect_named(fv, expected = c("x0", "x1", "x2", "x3", ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", "x0", "x1", "x2", "x3", fv_nms))
expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))
expect_identical(nrow(su_eg1_ocat), nrow(fv))

new_df <- data_sim("eg1", n = 50, dist = "ocat", seed = 1)
expect_silent(fv <- fitted_values(m_ocat, data = new_df, scale = "link"))
expect_named(fv, expected = c(names(new_df), ".fitted", ".se",
".lower_ci", ".upper_ci"))
expect_named(fv, expected = c(".row", names(new_df), fv_nms))
expect_s3_class(fv, c("tbl_df", "tbl", "data.frame"))
expect_identical(nrow(new_df), nrow(fv))
})

test_that("fitted values works for a univariate scam model", {
expect_silent(fv <- fitted_values(m_scam))
expect_named(fv, expected = c(".row", "x1", "x2", fv_nms))
})

test_that("fitted values works for a ziplss model", {
expect_silent(fv <- fitted_values(m_ziplss))
expect_named(fv, expected = c(".row", ".parameter", fv_nms))
})

test_that("fitted values works for a gaulss model", {
expect_silent(fv <- fitted_values(m_gaulss))
expect_named(fv, expected = c(".row", ".parameter", fv_nms))
})

test_that("fitted values works for a gamm model", {
expect_silent(fv <- fitted_values(m_gamm))
expect_named(fv, expected = c(".row","x0", "x1", "x2", "x3", fv_nms))
})

0 comments on commit dfd1345

Please sign in to comment.