Nothing
tests/testthat/test-fn.R
In matrixset: Creating, Manipulating and Annotating Matrix Ensemble
test_that("matrixset general loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
expect_identical(apply_row(matrixset(NULL), mean), NULL)
expect_identical(apply_column(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
mn <- apply_row(student_results2, mean)
M <- matrix_elm(student_results2,1)
mn_ref <- list(failure=apply(M, 1, function(u) list(mean=mean(u)),simplify = FALSE))
mn_ref <- c(mn_ref, list(remedial = NULL))
# mn_ref <- c(mn_ref, list(remedial=lapply(mn_ref$failure, function(u) lapply(u, function(v) NULL))))
expect_equal(mn, mn_ref)
create_expected <- function(midx, margin, ...)
{
fns <- rlang::enquos(..., .named = TRUE)
if (margin == "row") {
extract_info <- column_info
extract_info_compl <- row_info
tag_name <- ".colname"
tag_name_compl <- ".rowname"
pronoun <- ".i"
N <- nrow
mrgnames <- rownames
} else {
extract_info <- row_info
extract_info_compl <- column_info
tag_name <- ".rowname"
tag_name_compl <- ".colname"
pronoun <- ".j"
N <- ncol
mrgnames <- colnames
}
meta <- extract_info(student_results)
meta <- tibble::column_to_rownames(meta, tag_name)
meta_compl <- extract_info_compl(student_results)
meta_compl <- tibble::column_to_rownames(meta_compl, tag_name_compl)
meta_env <- list2env(meta)
meta_mask <- rlang::new_data_mask(meta_env)
expected <- lapply(midx, function(m) {
M <- matrix_elm(student_results, m)
ans <- lapply(1:N(student_results),
function(i) {
meta_env[[pronoun]] <- if (margin == "row") M[i,] else M[,i]
meta_env <- list2env(meta_compl[i, ], envir = meta_env)
lapply(fns, function(f) rlang::eval_tidy(f, data = meta_mask))
})
names(ans) <- mrgnames(student_results)
ans
})
names(expected) <- matrixnames(student_results)[midx]
expected
}
testcase <- list(# single function, not named, no params, all matrices
quote(apply_row(student_results, mean)),
# single function, named, no params, all matrices
quote(apply_row(student_results, mn=mean)),
# two functions, named, mix params/no params, all matrices
quote(apply_row(student_results, mn=mean, md=~median(.i))),
quote(apply_row(student_results, mn=mean,
reg = ~lm(.i ~ national_average + program))),
quote(apply_row(student_results, mn=mean,
reg = ~lm(.i ~ national_average + program),
.matrix = 2)),
quote(apply_row(student_results,
mn = ~{
ii <- .i
mean(ii)
})),
quote(apply_row(student_results,
s=~{
.i + school_average + previous_year_score
})),
quote(apply_column(student_results, mean)),
quote(apply_column(student_results, mn=mean)),
quote(apply_column(student_results, mn=mean, md=~median(.j))),
quote(apply_column(student_results, mn=mean,
reg = ~lm(.j ~ teacher + class))),
quote(apply_column(student_results, mn=mean,
reg = ~lm(.j ~ teacher + class),
.matrix = 2)),
quote(apply_column(student_results,
mn = ~{
jj <- .j
mean(jj)
})),
quote(apply_column(student_results,
s=~{
.j + school_average + previous_year_score
}))
)
expected_expr <- list(quote(create_expected(seq(nmatrix(student_results)),
"row", mean = mean(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i), md=median(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i),
reg = lm(.i ~ national_average + program))),
quote(create_expected(2, "row", mn=mean(.i),
reg = lm(.i ~ national_average + program))),
quote(create_expected(seq(nmatrix(student_results)),
"row",
mn = {
ii <- .i
mean(ii)
})),
quote(create_expected(seq(nmatrix(student_results)),
"row",
s={
.i + school_average + previous_year_score
})),
quote(create_expected(seq(nmatrix(student_results)),
"col", mean = mean(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j), md=median(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j),
reg = lm(.j ~ teacher + class))),
quote(create_expected(2, "col", mn=mean(.j),
reg = lm(.j ~ teacher + class))),
quote(create_expected(seq(nmatrix(student_results)),
"col",
mn = {
jj <- .j
mean(jj)
})),
quote(create_expected(seq(nmatrix(student_results)),
"col",
s={
.j + school_average + previous_year_score
}))
)
for (case in seq_along(testcase))
{
testthis <- eval(testcase[[case]])
expected <- eval(expected_expr[[case]])
expect_equal(testthis, expected, ignore_attr = TRUE)
}
# mn <- apply_row(student_results, mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mean=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# mn <- apply_row(student_results, mn=mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# ct <- apply_row(student_results, mn=mean, md=~median(.i))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u),
# md=median(u)),
# simplify = FALSE)
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref)
#
#
#
# ct <- apply_row(student_results, mn=mean, reg = ~lm(.i ~ national_average + program))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- column_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".colname")
# ans <- lapply(1:nrow(student_results),
# function(i) {
# meta$.i <- M[i,]
# list(mn=mean(M[i,]),
# reg=eval(quote(lm(.i ~ national_average + program)), envir = meta))
# })
# names(ans) <- rownames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
# ct <- apply_row(student_results, mn=mean, reg = ~ lm(.i ~ national_average + program),
# .matrix = 2)
# ct_ref <- lapply(2,
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- column_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".colname")
# ans <- lapply(1:nrow(student_results),
# function(i) {
# meta$.i <- M[i,]
# list(mn=mean(M[i,]),
# reg=eval(quote(lm(.i ~ national_average + program)), envir = meta))
# })
# names(ans) <- rownames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)[2]
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# mn <- apply_column(student_results, mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mean=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# mn <- apply_column(student_results, mn=mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
#
# ct <- apply_column(student_results, mn=mean, md=~median(.j))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u),
# md=median(u)),
# simplify = FALSE)
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref)
#
#
#
#
# ct <- apply_column(student_results, mn=mean, reg = ~lm(.j ~ teacher + class))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- row_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".rowname")
# ans <- lapply(1:ncol(student_results),
# function(j) {
# meta$.j <- M[,j]
# list(mn=mean(M[,j]),
# reg=eval(quote(lm(.j ~ teacher + class)), envir = meta))
# })
# names(ans) <- colnames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# ct <- apply_column(student_results, mn=mean, reg = ~lm(.j ~ teacher + class),
# .matrix = 2)
# ct_ref <- lapply(2,
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- row_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".rowname")
# ans <- lapply(1:ncol(student_results),
# function(j) {
# meta$.j <- M[,j]
# list(mn=mean(M[,j]),
# reg=eval(quote(lm(.j ~ teacher + class)), envir = meta))
# })
# names(ans) <- colnames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)[2]
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_row(student_results,
# mn = ~ {
# ii <- .i
# mean(ii)
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_column(student_results,
# mn = ~ {
# jj <- .j
# mean(jj)
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
#
# e <- apply_row(student_results,
# s=~{
# .i + school_average + previous_year_score
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# row_meta <- row_info(student_results)
# col_meta <- column_info(student_results)
# s <- lapply(1:nrow(M), function(i) list(s=M[i,] + row_meta$previous_year_score[i] + col_meta$school_average))
# names(s) <- rownames(student_results)
# s
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_column(student_results,
# s=~{
# .j + school_average + previous_year_score
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# row_meta <- row_info(student_results)
# col_meta <- column_info(student_results)
# s <- lapply(1:ncol(M), function(j) list(s=M[,j] + row_meta$previous_year_score + col_meta$school_average[j]))
# names(s) <- colnames(student_results)
# s
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
# .data
rg <- apply_row(student_results, reg = ~unname(coef(lm(.i ~ .data[["national_average"]] + program))))
rg_ref <- apply_row(student_results, reg = ~unname(coef(lm(.i ~ national_average + program))))
expect_identical(rg, rg_ref)
rg <- apply_column(student_results, reg = ~ unname(coef(lm(.j ~ .data[["teacher"]] + class))))
rg_ref <- apply_column(student_results, reg = ~ unname(coef(lm(.j ~ teacher + class))))
expect_identical(rg, rg_ref)
previous_year_score <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], row_meta$previous_year_score[i]))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
col_meta <- column_info(student_results)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], col_meta$school_average[j]))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_average <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, previous_year_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], previous_year_average))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
prior_school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, prior_school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
col_meta <- column_info(student_results)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], prior_school_average))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_score <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, .env$previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], previous_year_score))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, .env$school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], school_average))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
# 1-row/1 column
avr <- apply_column(student_results[,1,], avr = ~mean(.j))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[,1,drop=FALSE], 2, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_column(student_results[1,1,], avr = ~ mean(.j))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,1,drop=FALSE], 2, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_row(student_results[1,,], avr = ~ mean(.i))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,,drop=FALSE], 1, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_row(student_results[1,1,], avr = ~ mean(.i))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,1,drop=FALSE], 1, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
# grouped
#
grmn <- apply_row(column_group_by(student_results, program), mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(row_group_by(student_results, teacher, class), mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(row_group_by(student_results, teacher, class), mn=mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row(row_group_by(column_group_by(student_results, program),
class, teacher), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(column_group_by(row_group_by(student_results, teacher, class),
program), mn=mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
})
test_that("matrixset 'long' loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
# with null
expect_identical(apply_row_dfl(matrixset(NULL), mean), NULL)
expect_identical(apply_column_dfl(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_row_dfl(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 1, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".rowname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.rowname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_column_dfl(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 2, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".colname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.colname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
ct <- apply_row_dfl(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
md = unname(apply(m,1,median))))
expect_equal(ct, ct_ref)
ct <- apply_column_dfl(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
md = unname(apply(m,2,median))))
expect_equal(ct, ct_ref)
# showcase > 1 length answer
summ <- apply_row_dfl(student_results, mn=~c(mean(.i), median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,1, function(x) c(one=mean(x), two=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("one", "two")))), rownames = ".rowname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.rowname...4` <- NULL
a <- dplyr::rename(a, `.rowname` = `.rowname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "..1", "..2")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfl(student_results, mn=~c(mean(.j), median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,2, function(x) c(one=mean(x), two=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("one", "two")))), rownames = ".colname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.colname...4` <- NULL
a <- dplyr::rename(a, `.colname` = `.colname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "..1", "..2")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_row_dfl(student_results, mn=~c(mn=mean(.i), md=median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,1, function(x) c(one=mean(x), two=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("one", "two")))), rownames = ".rowname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.rowname...4` <- NULL
a <- dplyr::rename(a, `.rowname` = `.rowname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "mn", "md")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfl(student_results, mn=~c(mn=mean(.j), md=median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,2, function(x) c(one=mean(x), two=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("one", "two")))), rownames = ".colname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.colname...4` <- NULL
a <- dplyr::rename(a, `.colname` = `.colname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "mn", "md")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
# error
expect_error(apply_row_dfl(student_results,
mn=mean,
reg = ~lm(.i ~ national_average + program)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results,
mn=mean,
reg = ~lm(.j ~ teacher + previous_year_score)),
"vectors must be of the same length")
# the trick
summ <- apply_row_dfl(student_results, mn=mean, reg = ~list(lm(.i ~ national_average + program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
reg = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average + program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfl(student_results, mn=mean, reg = ~list(lm(.j ~ teacher + previous_year_score)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
reg = unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher + previous_year_score)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_row_dfl(student_results, reg = ~list(lm(.i ~ national_average), lm(.i ~ program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
u <- tibble::tibble(
.rowname = rownames(student_results),
a=unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average)), envir = meta)
})),
b=unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ program)), envir = meta)
})))
u <- tidyr::pivot_longer(u, names_to = "reg.name",
values_to = "reg",
cols = c("a", "b"))
u$reg.name <- ifelse(u$reg.name == "a", "..1", "..2")
u
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfl(student_results, reg = ~ list(lm(.j ~ class), lm(.j ~ teacher)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
u <- tibble::tibble(
.colname = colnames(student_results),
a=unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ class)), envir = meta)
})),
b=unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher)), envir = meta)
})))
u <- tidyr::pivot_longer(u, names_to = "reg.name",
values_to = "reg",
cols = c("a", "b"))
u$reg.name <- ifelse(u$reg.name == "a", "..1", "..2")
u
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
# this should fail
expect_error(apply_row_dfl(student_results, mn=~mean(.i), rg=~range(.i)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results, mn=~mean(.j), rg=~range(.j)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results, .colname = mean))
expect_error(apply_column_dfw(student_results, .colname = mean))
expect_error(apply_row_dfl(student_results, .rowname = mean))
expect_error(apply_row_dfw(student_results, .rowname = mean))
# grouped
grmn <- apply_row_dfl(column_group_by(student_results, program), mean, median)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), mean, median)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfl(column_group_by(student_results, program), mn=mean, md=~median(.i))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), mn=mean, md=~median(.j))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfl(column_group_by(student_results, program), ct=~c(mean(.i), median(.i)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) tibble::tibble(ct.name = c("..1", "..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), ct=~c(mean(.j), median(.j)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) tibble::tibble(ct.name = c("..1", "..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
})
test_that("matrixset 'wide' loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
# with null
expect_identical(apply_row_dfw(matrixset(NULL), mean), NULL)
expect_identical(apply_column_dfw(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_row_dfw(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 1, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".rowname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.rowname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_column_dfw(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 2, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".colname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.colname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
ct <- apply_row_dfw(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
md = unname(apply(m,1,median))))
expect_equal(ct, ct_ref)
ct <- apply_column_dfw(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
md = unname(apply(m,2,median))))
expect_equal(ct, ct_ref)
# showcase > 1 length answer
summ <- apply_row_dfw(student_results, mn=~c(mean(.i), median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,1, function(x) c(`mn ..1`=mean(x), `mn ..2`=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfw(student_results, mn=~c(mean(.j), median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,2, function(x) c(`mn ..1`=mean(x), `mn ..2`=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_row_dfw(student_results, mn=~c(mn=mean(.i), md=median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,1, function(x) c(`mn mn`=mean(x), `mn md`=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfw(student_results, mn=~c(mn=mean(.j), md=median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,2, function(x) c(`mn mn`=mean(x), `mn md`=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
# error
expect_error(apply_row_dfw(student_results,
mn=mean,
reg = ~lm(.i ~ national_average + program)),
"vectors must be of the same length")
expect_error(apply_column_dfw(student_results,
mn=mean,
reg = ~lm(.j ~ teacher + previous_year_score)),
"vectors must be of the same length")
# the trick
summ <- apply_row_dfw(student_results, mn=mean, reg = ~list(lm(.i ~ national_average + program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
reg = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average + program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfw(student_results, mn=mean, reg = ~list(lm(.j ~ teacher + previous_year_score)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
reg = unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher + previous_year_score)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_row_dfw(student_results, reg = ~list(national = lm(.i ~ national_average), program = lm(.i ~ program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
`reg national` = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average)), envir = meta)
})),
`reg program` = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
# summ <- apply_column_dfw(student_results, reg = list(teacher = lm(.j ~ teacher), score = lm(.j ~ previous_year_score)))
# M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
# meta <- column_info(student_results)
# summ_ref <- lapply(M,
# function(m) {
# tibble::tibble(.rowname = rownames(m),
# `reg national` = unname(apply(m,1,function(x) {
# meta$.i <- x
# eval(quote(lm(.i ~ national_average)), envir = meta)
# })),
# `reg program` = unname(apply(m,1,function(x) {
# meta$.i <- x
# eval(quote(lm(.i ~ program)), envir = meta)
# })))
# })
# expect_equal(summ, summ_ref, ignore_attr = TRUE)
#
# # this should fail
expect_error(apply_row_dfw(student_results, mn=~mean(.i), rg=~range(.i)),
"vectors must be of the same length")
expect_error(apply_column_dfw(student_results, mn=~mean(.j), rg=~range(.j)),
"vectors must be of the same length")
# grouped
grmn <- apply_row_dfw(column_group_by(student_results, program), mean, median)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), mean, median)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program), mn=mean, md=~median(.i))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), mn=mean, md=~median(.j))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program), ct=~c(mean(.i), median(.i)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) tibble::tibble(ct.name = c("ct ..1", "ct ..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = "ct.name", values_from = "ct"))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), ct=~c(mean(.j), median(.j)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) tibble::tibble(ct.name = c("d..1", "d..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::pivot_wider(u, names_from = "ct.name", values_from = "ct"))
grmn_ref <- lapply(grmn_ref, function(u) {
colnames(u)[3:5] <- c(".colname", "ct ..1", "ct ..2")
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program),
ct=~c(mn=mean(.i), md=median(.i)),
rg=range,
fit=~list(lm(.i ~ 1), lm(.i ~ school_average)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
meta <- column_info(student_results)
rows <- lapply(seq(nrow(M)), function(i) {
u <- M[i, gr]
info <- meta[gr, ]
info$.i <- u
tibble::tibble(ct.name = c("ct mn", "ct md"),
ct=c(mean(u), median(u)),
rg.name=c("rg ..1", "rg ..2"),
rg=range(u),
fit.name = c("fit ..1", "fit ..2"),
fit=list(eval(quote(lm(.i ~ 1)), info),
eval(quote(lm(.i ~ school_average)), info)))
})
names(rows) <- rownames(student_results)
dplyr::bind_rows(rows, .id = ".rowname")
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = c("ct.name", "rg.name", "fit.name"), values_from = c("ct", "rg", "fit")))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[3:8] <- c("ct mn", "ct md", "rg ..1", "rg ..2", "fit ..1", "fit ..2")
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref, ignore_attr = TRUE)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class),
ct=~c(mn=mean(.j), md=median(.j)),
rg=range,
fit=~list(lm(.j ~ 1), lm(.j ~ previous_year_score)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
meta <- row_info(student_results)
cols <- lapply(seq(ncol(M)), function(j) {
u <- M[gr, j]
info <- meta[gr, ]
info$.j <- u
tibble::tibble(ct.name = c("ct mn", "ct md"),
ct=c(mean(u), median(u)),
rg.name=c("rg ..1", "rg ..2"),
rg=range(u),
fit.name = c("fit ..1", "fit ..2"),
fit=list(eval(quote(lm(.j ~ 1)), info),
eval(quote(lm(.j ~ previous_year_score)), info)))
})
names(cols) <- colnames(student_results)
dplyr::bind_rows(cols, .id = ".colname")
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = c("ct.name", "rg.name", "fit.name"), values_from = c("ct", "rg", "fit")))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[3:8] <- c("ct mn", "ct md", "rg ..1", "rg ..2", "fit ..1", "fit ..2")
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref, ignore_attr = TRUE)
})
test_that("matrixset matrix loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
expect_identical(apply_matrix(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
mn <- apply_matrix(student_results2, mean)
M <- matrix_elm(student_results2,1)
# mn_ref <- list(failure=list(mean=mean(M)), remedial=list(mean=NULL))
mn_ref <- list(failure=list(mean=mean(M)), remedial=NULL)
expect_equal(mn, mn_ref)
mn <- apply_matrix(student_results, mean)
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mean=mean(M))
})
names(mn_ref) <- matrixnames(student_results)
expect_equal(mn, mn_ref)
mn <- apply_matrix(student_results, mn=mean)
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M))
})
names(mn_ref) <- matrixnames(student_results)
expect_equal(mn, mn_ref)
ct <- apply_matrix(student_results, mn=mean, md=~median(.m))
ct_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M), md=median(M))
})
names(ct_ref) <- matrixnames(student_results)
expect_equal(ct, ct_ref)
ct <- apply_matrix(student_results, mn=mean, reg = ~lm(.m ~ teacher + class))
ct_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
meta <- row_info(student_results)
meta <- tibble::column_to_rownames(meta, ".rowname")
ans <- list(mn=mean(.m),
reg=eval(quote(lm(.m ~ teacher + class)), envir = meta))
ans
})
names(ct_ref) <- matrixnames(student_results)
expect_equal(ct, ct_ref, ignore_attr = TRUE)
ct <- apply_matrix(student_results, mn=mean, reg = ~lm(.m ~ teacher + class),
.matrix = 2)
ct_ref <- lapply(2,
function(m) {
.m <- matrix_elm(student_results,m)
meta <- row_info(student_results)
meta <- tibble::column_to_rownames(meta, ".rowname")
ans <- list(mn=mean(.m),
reg=eval(quote(lm(.m ~ teacher + class)), envir = meta))
ans
})
names(ct_ref) <- matrixnames(student_results)[2]
expect_equal(ct, ct_ref, ignore_attr = TRUE)
e <- apply_matrix(student_results,
mn = ~{
mm <- .m
mean(mm)
})
e_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M))
})
names(e_ref) <- matrixnames(student_results)
expect_equal(e, e_ref, ignore_attr = TRUE)
e <- apply_matrix(student_results,
s=~{
.m + school_average + previous_year_score
})
e_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
col_meta <- column_info(student_results)
s <- list(s=.m + row_meta$previous_year_score + col_meta$school_average)
s
})
names(e_ref) <- matrixnames(student_results)
expect_equal(e, e_ref, ignore_attr = TRUE)
fc <- apply_matrix_dfl(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, median))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
.fc <- do.call(cbind,
list(FC = rowMeans(.m), FC_rob = apply(.m, 1, median)))
.fc <- tibble::as_tibble(.fc, rownames = "FC.name")
.fc <- dplyr::mutate(.fc, FC_rob.name = FC.name)
.fc[, c("FC.name", "FC", "FC_rob.name", "FC_rob")]
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(fc, fc_ref)
expect_error(apply_matrix_dfl(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 2, median)),
"vectors must be of the same length")
fc <- apply_matrix_dfw(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, median))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
.fc <- do.call(cbind,
list(FC = rowMeans(.m), FC_rob = apply(.m, 1, median)))
.fc <- tibble::as_tibble(.fc, rownames = "FC.name")
.fc <- dplyr::mutate(.fc, FC_rob.name = FC.name)
.fc <- tidyr::pivot_wider(.fc,
names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
# .fc[, c("FC.name", "FC", "FC_rob.name", "FC_rob")]
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(fc, fc_ref)
# .data
rg <- apply_matrix(student_results, reg = ~unname(coef(lm(.m ~ .data[["teacher"]] + class))))
rg_ref <- apply_matrix(student_results, reg = ~unname(coef(lm(.m ~ teacher + class))))
expect_identical(rg, rg_ref)
previous_year_score <- 0.5
avr <- apply_matrix(student_results, av=~mean(c(.m, previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- list(av=mean(c(M, row_meta$previous_year_score)))
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_score <- 0.5
avr <- apply_matrix(student_results, av=~mean(c(.m, .env$previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- list(av=mean(c(M, previous_year_score)))
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
# grouped
grmn <- apply_matrix(column_group_by(student_results, program), mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mean=mean(M[, gr]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mn=mean(M[, gr]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(row_group_by(student_results, teacher, class), mean, rg=range)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mean=mean(M[gr, ]), rg=range(M[gr, ]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(column_group_by(row_group_by(student_results, teacher, class), program), mean, rg=range)
grs_row <- row_group_meta(row_group_by(student_results, teacher, class))
grs_col <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
M <- matrix_elm(student_results,m)
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
list(mean=mean(M[grr, grc]), rg=range(M[grr, grc]))
})
})
unlist(grmn_ref, recursive = FALSE)
# grmn_ref
# ans$.rows <- NULL
# ans$.mats <- grmn_ref
# ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn$failure$.vals, mn_ref$failure)
expect_identical(grmn$remedial$.vals, mn_ref$remedial)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
mean(M[, gr])
})
ans$.rows <- NULL
ans$mn <- grmn_ref
ans %>% tidyr::unnest(mn)
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
Mgr <- M[, gr, drop = FALSE]
colMeans(Mgr)
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
Mgr <- M[, gr, drop = FALSE]
apply(Mgr, 2, median)
})
ans$FC_rob <- grmn_ref
ans$.rows <- NULL
ans %>% tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::select(program, FC.name = FC_id, FC,
FC_rob.name = FC_rob_id, FC_rob) %>%
dplyr::mutate(FC = unname(FC), FC_rob = unname(FC_rob))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~rowMeans(.m))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
rowMeans(M[, gr, drop = FALSE])
})
ans$.rows <- NULL
ans$FC <- grmn_ref
ans %>% tidyr::unnest_longer(FC) %>%
dplyr::select(program, FC.name=FC_id, FC) %>%
dplyr::mutate(FC=unname(FC))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~colMeans(.m))
grs <- row_group_meta(row_group_by(student_results, class, teacher))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
colMeans(M[gr, , drop = FALSE])
})
ans$.rows <- NULL
ans$FC <- grmn_ref
ans %>% tidyr::unnest_longer(FC) %>%
dplyr::select(class, teacher, FC.name=FC_id, FC) %>%
dplyr::mutate(FC=unname(FC))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, mean))
grs <- row_group_meta(row_group_by(student_results, class, teacher))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
rowMeans(M[gr, , drop = FALSE])
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 1, mean)
})
ans$.rows <- NULL
ans$FC_rob <- grmn_ref
ans %>% tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::select(class, teacher, FC.name=FC_id, FC,
FC_rob.name=FC_rob_id, FC_rob) %>%
dplyr::mutate(FC=unname(FC), FC_rob=unname(FC_rob))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
grs <- column_group_by(row_group_by(student_results, teacher), program)
grs_row <- row_group_meta(grs)
grs_col <- column_group_meta(grs)
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs_row
M <- matrix_elm(student_results,m)
ans$.rows <- NULL
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
colMeans(M[grr, grc, drop = FALSE])
})
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
apply(M[grr, grc, drop = FALSE], 2, median)
})
})
ans$FC_rob <- grmn_ref
ans %>%
tidyr::unnest(c(FC, FC_rob)) %>%
tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::left_join(column_info(student_results) %>%
dplyr::select(FC_id=.colname, program),
by = "FC_id") %>%
dplyr::select(teacher, program, FC.name=FC_id, FC,
FC_rob.name=FC_rob_id, FC_rob) %>%
dplyr::mutate(FC=unname(FC), FC_rob=unname(FC_rob))
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(grfc, fc_ref)
#dfw
grmn <- apply_matrix_dfw(column_group_by(student_results, program), mn=mean)
mn_ref <- apply_matrix_dfl(column_group_by(student_results, program), mn=mean)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfw(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
mn_ref <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(grmn, names)))
nms_ref <- unlist(unique(lapply(mn_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
mn_ref <- purrr::map2(mn_ref, grmn, ~ .x[, names(.y)])
expect_identical(grmn, mn_ref)
fc <- apply_matrix_dfw(column_group_by(student_results, program), FC = ~rowMeans(.m))
fc_ref <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~rowMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = FC.name, values_from = FC,
names_glue = "{.value} {FC.name}")
})
expect_identical(fc, fc_ref)
fc <- apply_matrix_dfw(row_group_by(student_results, class, teacher),
FC = ~colMeans(.m))
fc_ref <- apply_matrix_dfl(row_group_by(student_results, class, teacher),
FC = ~colMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = FC.name, values_from = FC,
names_glue = "{.value} {FC.name}")
})
expect_identical(fc, fc_ref)
mn <- apply_matrix_dfw(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~rowMeans(.m))
mn_ref <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~rowMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(mn, names)))
nms_ref <- unlist(unique(lapply(mn_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
mn_ref <- purrr::map2(mn_ref, mn, ~ .x[, names(.y)])
expect_identical(mn, mn_ref)
ct <- apply_matrix_dfw(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
ct_ref <- apply_matrix_dfl(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(ct, names)))
nms_ref <- unlist(unique(lapply(ct_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
ct_ref <- purrr::map2(ct_ref, ct, ~ .x[, names(.y)])
expect_identical(ct, ct_ref)
})
Try the matrixset package in your browser
Any scripts or data that you put into this service are public.
matrixset documentation built on April 3, 2025, 6:32 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
test_that("matrixset general loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
expect_identical(apply_row(matrixset(NULL), mean), NULL)
expect_identical(apply_column(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
mn <- apply_row(student_results2, mean)
M <- matrix_elm(student_results2,1)
mn_ref <- list(failure=apply(M, 1, function(u) list(mean=mean(u)),simplify = FALSE))
mn_ref <- c(mn_ref, list(remedial = NULL))
# mn_ref <- c(mn_ref, list(remedial=lapply(mn_ref$failure, function(u) lapply(u, function(v) NULL))))
expect_equal(mn, mn_ref)
create_expected <- function(midx, margin, ...)
{
fns <- rlang::enquos(..., .named = TRUE)
if (margin == "row") {
extract_info <- column_info
extract_info_compl <- row_info
tag_name <- ".colname"
tag_name_compl <- ".rowname"
pronoun <- ".i"
N <- nrow
mrgnames <- rownames
} else {
extract_info <- row_info
extract_info_compl <- column_info
tag_name <- ".rowname"
tag_name_compl <- ".colname"
pronoun <- ".j"
N <- ncol
mrgnames <- colnames
}
meta <- extract_info(student_results)
meta <- tibble::column_to_rownames(meta, tag_name)
meta_compl <- extract_info_compl(student_results)
meta_compl <- tibble::column_to_rownames(meta_compl, tag_name_compl)
meta_env <- list2env(meta)
meta_mask <- rlang::new_data_mask(meta_env)
expected <- lapply(midx, function(m) {
M <- matrix_elm(student_results, m)
ans <- lapply(1:N(student_results),
function(i) {
meta_env[[pronoun]] <- if (margin == "row") M[i,] else M[,i]
meta_env <- list2env(meta_compl[i, ], envir = meta_env)
lapply(fns, function(f) rlang::eval_tidy(f, data = meta_mask))
})
names(ans) <- mrgnames(student_results)
ans
})
names(expected) <- matrixnames(student_results)[midx]
expected
}
testcase <- list(# single function, not named, no params, all matrices
quote(apply_row(student_results, mean)),
# single function, named, no params, all matrices
quote(apply_row(student_results, mn=mean)),
# two functions, named, mix params/no params, all matrices
quote(apply_row(student_results, mn=mean, md=~median(.i))),
quote(apply_row(student_results, mn=mean,
reg = ~lm(.i ~ national_average + program))),
quote(apply_row(student_results, mn=mean,
reg = ~lm(.i ~ national_average + program),
.matrix = 2)),
quote(apply_row(student_results,
mn = ~{
ii <- .i
mean(ii)
})),
quote(apply_row(student_results,
s=~{
.i + school_average + previous_year_score
})),
quote(apply_column(student_results, mean)),
quote(apply_column(student_results, mn=mean)),
quote(apply_column(student_results, mn=mean, md=~median(.j))),
quote(apply_column(student_results, mn=mean,
reg = ~lm(.j ~ teacher + class))),
quote(apply_column(student_results, mn=mean,
reg = ~lm(.j ~ teacher + class),
.matrix = 2)),
quote(apply_column(student_results,
mn = ~{
jj <- .j
mean(jj)
})),
quote(apply_column(student_results,
s=~{
.j + school_average + previous_year_score
}))
)
expected_expr <- list(quote(create_expected(seq(nmatrix(student_results)),
"row", mean = mean(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i), md=median(.i))),
quote(create_expected(seq(nmatrix(student_results)),
"row", mn=mean(.i),
reg = lm(.i ~ national_average + program))),
quote(create_expected(2, "row", mn=mean(.i),
reg = lm(.i ~ national_average + program))),
quote(create_expected(seq(nmatrix(student_results)),
"row",
mn = {
ii <- .i
mean(ii)
})),
quote(create_expected(seq(nmatrix(student_results)),
"row",
s={
.i + school_average + previous_year_score
})),
quote(create_expected(seq(nmatrix(student_results)),
"col", mean = mean(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j), md=median(.j))),
quote(create_expected(seq(nmatrix(student_results)),
"col", mn=mean(.j),
reg = lm(.j ~ teacher + class))),
quote(create_expected(2, "col", mn=mean(.j),
reg = lm(.j ~ teacher + class))),
quote(create_expected(seq(nmatrix(student_results)),
"col",
mn = {
jj <- .j
mean(jj)
})),
quote(create_expected(seq(nmatrix(student_results)),
"col",
s={
.j + school_average + previous_year_score
}))
)
for (case in seq_along(testcase))
{
testthis <- eval(testcase[[case]])
expected <- eval(expected_expr[[case]])
expect_equal(testthis, expected, ignore_attr = TRUE)
}
# mn <- apply_row(student_results, mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mean=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# mn <- apply_row(student_results, mn=mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# ct <- apply_row(student_results, mn=mean, md=~median(.i))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u),
# md=median(u)),
# simplify = FALSE)
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref)
#
#
#
# ct <- apply_row(student_results, mn=mean, reg = ~lm(.i ~ national_average + program))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- column_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".colname")
# ans <- lapply(1:nrow(student_results),
# function(i) {
# meta$.i <- M[i,]
# list(mn=mean(M[i,]),
# reg=eval(quote(lm(.i ~ national_average + program)), envir = meta))
# })
# names(ans) <- rownames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
# ct <- apply_row(student_results, mn=mean, reg = ~ lm(.i ~ national_average + program),
# .matrix = 2)
# ct_ref <- lapply(2,
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- column_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".colname")
# ans <- lapply(1:nrow(student_results),
# function(i) {
# meta$.i <- M[i,]
# list(mn=mean(M[i,]),
# reg=eval(quote(lm(.i ~ national_average + program)), envir = meta))
# })
# names(ans) <- rownames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)[2]
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# mn <- apply_column(student_results, mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mean=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
# mn <- apply_column(student_results, mn=mean)
# mn_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(mn_ref) <- matrixnames(student_results)
#
# expect_equal(mn, mn_ref)
#
#
#
#
# ct <- apply_column(student_results, mn=mean, md=~median(.j))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u),
# md=median(u)),
# simplify = FALSE)
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref)
#
#
#
#
# ct <- apply_column(student_results, mn=mean, reg = ~lm(.j ~ teacher + class))
# ct_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- row_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".rowname")
# ans <- lapply(1:ncol(student_results),
# function(j) {
# meta$.j <- M[,j]
# list(mn=mean(M[,j]),
# reg=eval(quote(lm(.j ~ teacher + class)), envir = meta))
# })
# names(ans) <- colnames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# ct <- apply_column(student_results, mn=mean, reg = ~lm(.j ~ teacher + class),
# .matrix = 2)
# ct_ref <- lapply(2,
# function(m) {
# M <- matrix_elm(student_results,m)
# meta <- row_info(student_results)
# meta <- tibble::column_to_rownames(meta, ".rowname")
# ans <- lapply(1:ncol(student_results),
# function(j) {
# meta$.j <- M[,j]
# list(mn=mean(M[,j]),
# reg=eval(quote(lm(.j ~ teacher + class)), envir = meta))
# })
# names(ans) <- colnames(student_results)
# ans
# })
# names(ct_ref) <- matrixnames(student_results)[2]
#
# expect_equal(ct, ct_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_row(student_results,
# mn = ~ {
# ii <- .i
# mean(ii)
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 1, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_column(student_results,
# mn = ~ {
# jj <- .j
# mean(jj)
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# apply(M, 2, function(u) list(mn=mean(u)),simplify = FALSE)
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
#
# e <- apply_row(student_results,
# s=~{
# .i + school_average + previous_year_score
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# row_meta <- row_info(student_results)
# col_meta <- column_info(student_results)
# s <- lapply(1:nrow(M), function(i) list(s=M[i,] + row_meta$previous_year_score[i] + col_meta$school_average))
# names(s) <- rownames(student_results)
# s
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
#
#
#
#
#
# e <- apply_column(student_results,
# s=~{
# .j + school_average + previous_year_score
# })
#
# e_ref <- lapply(seq(nmatrix(student_results)),
# function(m) {
# M <- matrix_elm(student_results,m)
# row_meta <- row_info(student_results)
# col_meta <- column_info(student_results)
# s <- lapply(1:ncol(M), function(j) list(s=M[,j] + row_meta$previous_year_score + col_meta$school_average[j]))
# names(s) <- colnames(student_results)
# s
# })
# names(e_ref) <- matrixnames(student_results)
#
# expect_equal(e, e_ref, ignore_attr = TRUE)
# .data
rg <- apply_row(student_results, reg = ~unname(coef(lm(.i ~ .data[["national_average"]] + program))))
rg_ref <- apply_row(student_results, reg = ~unname(coef(lm(.i ~ national_average + program))))
expect_identical(rg, rg_ref)
rg <- apply_column(student_results, reg = ~ unname(coef(lm(.j ~ .data[["teacher"]] + class))))
rg_ref <- apply_column(student_results, reg = ~ unname(coef(lm(.j ~ teacher + class))))
expect_identical(rg, rg_ref)
previous_year_score <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], row_meta$previous_year_score[i]))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
col_meta <- column_info(student_results)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], col_meta$school_average[j]))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_average <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, previous_year_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], previous_year_average))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
prior_school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, prior_school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
col_meta <- column_info(student_results)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], prior_school_average))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_score <- 0.5
avr <- apply_row(student_results, av=~mean(c(.i, .env$previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- lapply(1:nrow(M), function(i) list(av=mean(c(M[i,], previous_year_score))))
names(s) <- rownames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
school_average <- 0.5
avr <- apply_column(student_results, av=~mean(c(.j, .env$school_average)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- lapply(1:ncol(M), function(j) list(av=mean(c(M[,j], school_average))))
names(s) <- colnames(student_results)
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
# 1-row/1 column
avr <- apply_column(student_results[,1,], avr = ~mean(.j))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[,1,drop=FALSE], 2, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_column(student_results[1,1,], avr = ~ mean(.j))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,1,drop=FALSE], 2, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_row(student_results[1,,], avr = ~ mean(.i))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,,drop=FALSE], 1, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
avr <- apply_row(student_results[1,1,], avr = ~ mean(.i))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
apply(M[1,1,drop=FALSE], 1, function(u) list(avr=mean(u)),simplify = FALSE)
})
names(avr_ref) <- matrixnames(student_results)
expect_equal(avr, avr_ref)
# grouped
#
grmn <- apply_row(column_group_by(student_results, program), mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(row_group_by(student_results, teacher, class), mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(row_group_by(student_results, teacher, class), mn=mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row(row_group_by(column_group_by(student_results, program),
class, teacher), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
ans$.rows <- NULL
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column(column_group_by(row_group_by(student_results, teacher, class),
program), mn=mean)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u)),simplify = FALSE)
})
ans$.vals <- mn_ref
ans
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
})
test_that("matrixset 'long' loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
# with null
expect_identical(apply_row_dfl(matrixset(NULL), mean), NULL)
expect_identical(apply_column_dfl(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_row_dfl(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 1, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".rowname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.rowname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_column_dfl(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 2, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".colname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.colname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
ct <- apply_row_dfl(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
md = unname(apply(m,1,median))))
expect_equal(ct, ct_ref)
ct <- apply_column_dfl(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
md = unname(apply(m,2,median))))
expect_equal(ct, ct_ref)
# showcase > 1 length answer
summ <- apply_row_dfl(student_results, mn=~c(mean(.i), median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,1, function(x) c(one=mean(x), two=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("one", "two")))), rownames = ".rowname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.rowname...4` <- NULL
a <- dplyr::rename(a, `.rowname` = `.rowname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "..1", "..2")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfl(student_results, mn=~c(mean(.j), median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,2, function(x) c(one=mean(x), two=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("one", "two")))), rownames = ".colname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.colname...4` <- NULL
a <- dplyr::rename(a, `.colname` = `.colname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "..1", "..2")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_row_dfl(student_results, mn=~c(mn=mean(.i), md=median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,1, function(x) c(one=mean(x), two=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("one", "two")))), rownames = ".rowname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.rowname...4` <- NULL
a <- dplyr::rename(a, `.rowname` = `.rowname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "mn", "md")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfl(student_results, mn=~c(mn=mean(.j), md=median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
a <- list(tibble::as_tibble(t(apply(m,2, function(x) c(one=mean(x), two=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("one", "two")))), rownames = ".colname"))
a <- lapply(a,
function(u) tidyr::pivot_longer(u,
names_to = "mn.name",
values_to = "mn",
cols = c("one", "two")))
colnames(a[[2]])[2:3] <- c("rg.name", "rg")
suppressMessages(a <- dplyr::bind_cols(a))
a$`.colname...4` <- NULL
a <- dplyr::rename(a, `.colname` = `.colname...1`)
a$mn.name <- ifelse(a$mn.name == "one", "mn", "md")
a$rg.name <- ifelse(a$rg.name == "one", "..1", "..2")
a
})
expect_identical(summ, summ_ref)
# error
expect_error(apply_row_dfl(student_results,
mn=mean,
reg = ~lm(.i ~ national_average + program)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results,
mn=mean,
reg = ~lm(.j ~ teacher + previous_year_score)),
"vectors must be of the same length")
# the trick
summ <- apply_row_dfl(student_results, mn=mean, reg = ~list(lm(.i ~ national_average + program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
reg = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average + program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfl(student_results, mn=mean, reg = ~list(lm(.j ~ teacher + previous_year_score)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
reg = unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher + previous_year_score)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_row_dfl(student_results, reg = ~list(lm(.i ~ national_average), lm(.i ~ program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
u <- tibble::tibble(
.rowname = rownames(student_results),
a=unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average)), envir = meta)
})),
b=unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ program)), envir = meta)
})))
u <- tidyr::pivot_longer(u, names_to = "reg.name",
values_to = "reg",
cols = c("a", "b"))
u$reg.name <- ifelse(u$reg.name == "a", "..1", "..2")
u
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfl(student_results, reg = ~ list(lm(.j ~ class), lm(.j ~ teacher)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
u <- tibble::tibble(
.colname = colnames(student_results),
a=unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ class)), envir = meta)
})),
b=unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher)), envir = meta)
})))
u <- tidyr::pivot_longer(u, names_to = "reg.name",
values_to = "reg",
cols = c("a", "b"))
u$reg.name <- ifelse(u$reg.name == "a", "..1", "..2")
u
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
# this should fail
expect_error(apply_row_dfl(student_results, mn=~mean(.i), rg=~range(.i)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results, mn=~mean(.j), rg=~range(.j)),
"vectors must be of the same length")
expect_error(apply_column_dfl(student_results, .colname = mean))
expect_error(apply_column_dfw(student_results, .colname = mean))
expect_error(apply_row_dfl(student_results, .rowname = mean))
expect_error(apply_row_dfw(student_results, .rowname = mean))
# grouped
grmn <- apply_row_dfl(column_group_by(student_results, program), mean, median)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), mean, median)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfl(column_group_by(student_results, program), mn=mean, md=~median(.i))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), mn=mean, md=~median(.j))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfl(column_group_by(student_results, program), ct=~c(mean(.i), median(.i)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) tibble::tibble(ct.name = c("..1", "..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfl(row_group_by(student_results, teacher, class), ct=~c(mean(.j), median(.j)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) tibble::tibble(ct.name = c("..1", "..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
})
test_that("matrixset 'wide' loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
# with null
expect_identical(apply_row_dfw(matrixset(NULL), mean), NULL)
expect_identical(apply_column_dfw(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_row_dfw(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 1, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".rowname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.rowname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
ct <- apply_column_dfw(student_results2, mn=mean, md=median)
M <- matrix_elm(student_results2,1)
ct_ref <- list(failure=t(apply(M, 2, function(u) c(mn=mean(u), md=median(u)),simplify = TRUE)))
ct_ref$failure <- tibble::as_tibble(ct_ref$failure, rownames = ".colname")
ct_ref <- c(ct_ref, remedial = list(NULL))
# ct_ref$remedial <- tibble::tibble(.colname = character(), mn = logical(), md = logical())
expect_identical(ct, ct_ref)
ct <- apply_row_dfw(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
md = unname(apply(m,1,median))))
expect_equal(ct, ct_ref)
ct <- apply_column_dfw(student_results, mn=mean, md=median)
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
ct_ref <- lapply(M,
function(m) tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
md = unname(apply(m,2,median))))
expect_equal(ct, ct_ref)
# showcase > 1 length answer
summ <- apply_row_dfw(student_results, mn=~c(mean(.i), median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,1, function(x) c(`mn ..1`=mean(x), `mn ..2`=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfw(student_results, mn=~c(mean(.j), median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,2, function(x) c(`mn ..1`=mean(x), `mn ..2`=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_row_dfw(student_results, mn=~c(mn=mean(.i), md=median(.i)), rg=~range(.i))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,1, function(x) c(`mn mn`=mean(x), `mn md`=median(x)))), rownames = ".rowname"),
tibble::as_tibble(t(apply(m,1, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
summ <- apply_column_dfw(student_results, mn=~c(mn=mean(.j), md=median(.j)), rg=~range(.j))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
summ_ref <- lapply(M,
function(m) {
dplyr::bind_cols(tibble::as_tibble(t(apply(m,2, function(x) c(`mn mn`=mean(x), `mn md`=median(x)))), rownames = ".colname"),
tibble::as_tibble(t(apply(m,2, function(x) setNames(range(x), c("rg ..1", "rg ..2"))))))
})
expect_identical(summ, summ_ref)
# error
expect_error(apply_row_dfw(student_results,
mn=mean,
reg = ~lm(.i ~ national_average + program)),
"vectors must be of the same length")
expect_error(apply_column_dfw(student_results,
mn=mean,
reg = ~lm(.j ~ teacher + previous_year_score)),
"vectors must be of the same length")
# the trick
summ <- apply_row_dfw(student_results, mn=mean, reg = ~list(lm(.i ~ national_average + program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
mn=unname(rowMeans(m)),
reg = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average + program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_column_dfw(student_results, mn=mean, reg = ~list(lm(.j ~ teacher + previous_year_score)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- row_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.colname = colnames(m),
mn=unname(colMeans(m)),
reg = unname(apply(m,2,function(x) {
meta$.j <- x
eval(quote(lm(.j ~ teacher + previous_year_score)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
summ <- apply_row_dfw(student_results, reg = ~list(national = lm(.i ~ national_average), program = lm(.i ~ program)))
M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
meta <- column_info(student_results)
summ_ref <- lapply(M,
function(m) {
tibble::tibble(.rowname = rownames(m),
`reg national` = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ national_average)), envir = meta)
})),
`reg program` = unname(apply(m,1,function(x) {
meta$.i <- x
eval(quote(lm(.i ~ program)), envir = meta)
})))
})
expect_equal(summ, summ_ref, ignore_attr = TRUE)
# summ <- apply_column_dfw(student_results, reg = list(teacher = lm(.j ~ teacher), score = lm(.j ~ previous_year_score)))
# M <- student_results[,,,keep_annotation = FALSE, warn_class_change = FALSE]
# meta <- column_info(student_results)
# summ_ref <- lapply(M,
# function(m) {
# tibble::tibble(.rowname = rownames(m),
# `reg national` = unname(apply(m,1,function(x) {
# meta$.i <- x
# eval(quote(lm(.i ~ national_average)), envir = meta)
# })),
# `reg program` = unname(apply(m,1,function(x) {
# meta$.i <- x
# eval(quote(lm(.i ~ program)), envir = meta)
# })))
# })
# expect_equal(summ, summ_ref, ignore_attr = TRUE)
#
# # this should fail
expect_error(apply_row_dfw(student_results, mn=~mean(.i), rg=~range(.i)),
"vectors must be of the same length")
expect_error(apply_column_dfw(student_results, mn=~mean(.j), rg=~range(.j)),
"vectors must be of the same length")
# grouped
grmn <- apply_row_dfw(column_group_by(student_results, program), mean, median)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), mean, median)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mean=mean(u), median = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program), mn=mean, md=~median(.i))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) {
u <- u[, c(1,4,2,3)]
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), mn=mean, md=~median(.j))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) list(mn=mean(u), md = median(u)),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) {
u <- u[, c(1,2,5,3,4)]
colnames(u)[3] <- ".colname"
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program), ct=~c(mean(.i), median(.i)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[, gr, drop = FALSE], 1, function(u) tibble::tibble(ct.name = c("ct ..1", "ct ..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_longer(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest_wider(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = "ct.name", values_from = "ct"))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[2] <- ".rowname"
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class), ct=~c(mean(.j), median(.j)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
grmn_ref <- lapply(seq(nmatrix(student_results)), function(m) {
ans <- grs
ans$.rows <- NULL
mn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 2, function(u) tibble::tibble(ct.name = c("d..1", "d..2"), ct=c(mean(u), median(u))),simplify = FALSE)
})
ans$.columns <- mn_ref
ans
})
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_longer(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest_wider(u, .columns))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::unnest(u, c(ct.name, ct)))
grmn_ref <- lapply(grmn_ref, function(u) tidyr::pivot_wider(u, names_from = "ct.name", values_from = "ct"))
grmn_ref <- lapply(grmn_ref, function(u) {
colnames(u)[3:5] <- c(".colname", "ct ..1", "ct ..2")
u
})
names(grmn_ref) <- matrixnames(student_results)
expect_identical(grmn, grmn_ref)
grmn <- apply_row_dfw(column_group_by(student_results, program),
ct=~c(mn=mean(.i), md=median(.i)),
rg=range,
fit=~list(lm(.i ~ 1), lm(.i ~ school_average)))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
meta <- column_info(student_results)
rows <- lapply(seq(nrow(M)), function(i) {
u <- M[i, gr]
info <- meta[gr, ]
info$.i <- u
tibble::tibble(ct.name = c("ct mn", "ct md"),
ct=c(mean(u), median(u)),
rg.name=c("rg ..1", "rg ..2"),
rg=range(u),
fit.name = c("fit ..1", "fit ..2"),
fit=list(eval(quote(lm(.i ~ 1)), info),
eval(quote(lm(.i ~ school_average)), info)))
})
names(rows) <- rownames(student_results)
dplyr::bind_rows(rows, .id = ".rowname")
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = c("ct.name", "rg.name", "fit.name"), values_from = c("ct", "rg", "fit")))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[3:8] <- c("ct mn", "ct md", "rg ..1", "rg ..2", "fit ..1", "fit ..2")
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref, ignore_attr = TRUE)
grmn <- apply_column_dfw(row_group_by(student_results, teacher, class),
ct=~c(mn=mean(.j), md=median(.j)),
rg=range,
fit=~list(lm(.j ~ 1), lm(.j ~ previous_year_score)))
grs <- row_group_meta(row_group_by(student_results, teacher, class))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
meta <- row_info(student_results)
cols <- lapply(seq(ncol(M)), function(j) {
u <- M[gr, j]
info <- meta[gr, ]
info$.j <- u
tibble::tibble(ct.name = c("ct mn", "ct md"),
ct=c(mean(u), median(u)),
rg.name=c("rg ..1", "rg ..2"),
rg=range(u),
fit.name = c("fit ..1", "fit ..2"),
fit=list(eval(quote(lm(.j ~ 1)), info),
eval(quote(lm(.j ~ previous_year_score)), info)))
})
names(cols) <- colnames(student_results)
dplyr::bind_rows(cols, .id = ".colname")
})
ans$.rows <- grmn_ref
ans
})
mn_ref <- lapply(mn_ref, function(u) tidyr::unnest(u, .rows))
mn_ref <- lapply(mn_ref, function(u) tidyr::pivot_wider(u, names_from = c("ct.name", "rg.name", "fit.name"), values_from = c("ct", "rg", "fit")))
mn_ref <- lapply(mn_ref, function(u) {
colnames(u)[3:8] <- c("ct mn", "ct md", "rg ..1", "rg ..2", "fit ..1", "fit ..2")
u
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref, ignore_attr = TRUE)
})
test_that("matrixset matrix loop works", {
withr::local_options(lifecycle_verbosity = "quiet")
expect_identical(apply_matrix(matrixset(NULL), mean), NULL)
student_results2 <- student_results
matrix_elm(student_results2,2) <- NULL
mn <- apply_matrix(student_results2, mean)
M <- matrix_elm(student_results2,1)
# mn_ref <- list(failure=list(mean=mean(M)), remedial=list(mean=NULL))
mn_ref <- list(failure=list(mean=mean(M)), remedial=NULL)
expect_equal(mn, mn_ref)
mn <- apply_matrix(student_results, mean)
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mean=mean(M))
})
names(mn_ref) <- matrixnames(student_results)
expect_equal(mn, mn_ref)
mn <- apply_matrix(student_results, mn=mean)
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M))
})
names(mn_ref) <- matrixnames(student_results)
expect_equal(mn, mn_ref)
ct <- apply_matrix(student_results, mn=mean, md=~median(.m))
ct_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M), md=median(M))
})
names(ct_ref) <- matrixnames(student_results)
expect_equal(ct, ct_ref)
ct <- apply_matrix(student_results, mn=mean, reg = ~lm(.m ~ teacher + class))
ct_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
meta <- row_info(student_results)
meta <- tibble::column_to_rownames(meta, ".rowname")
ans <- list(mn=mean(.m),
reg=eval(quote(lm(.m ~ teacher + class)), envir = meta))
ans
})
names(ct_ref) <- matrixnames(student_results)
expect_equal(ct, ct_ref, ignore_attr = TRUE)
ct <- apply_matrix(student_results, mn=mean, reg = ~lm(.m ~ teacher + class),
.matrix = 2)
ct_ref <- lapply(2,
function(m) {
.m <- matrix_elm(student_results,m)
meta <- row_info(student_results)
meta <- tibble::column_to_rownames(meta, ".rowname")
ans <- list(mn=mean(.m),
reg=eval(quote(lm(.m ~ teacher + class)), envir = meta))
ans
})
names(ct_ref) <- matrixnames(student_results)[2]
expect_equal(ct, ct_ref, ignore_attr = TRUE)
e <- apply_matrix(student_results,
mn = ~{
mm <- .m
mean(mm)
})
e_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
list(mn=mean(M))
})
names(e_ref) <- matrixnames(student_results)
expect_equal(e, e_ref, ignore_attr = TRUE)
e <- apply_matrix(student_results,
s=~{
.m + school_average + previous_year_score
})
e_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
col_meta <- column_info(student_results)
s <- list(s=.m + row_meta$previous_year_score + col_meta$school_average)
s
})
names(e_ref) <- matrixnames(student_results)
expect_equal(e, e_ref, ignore_attr = TRUE)
fc <- apply_matrix_dfl(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, median))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
.fc <- do.call(cbind,
list(FC = rowMeans(.m), FC_rob = apply(.m, 1, median)))
.fc <- tibble::as_tibble(.fc, rownames = "FC.name")
.fc <- dplyr::mutate(.fc, FC_rob.name = FC.name)
.fc[, c("FC.name", "FC", "FC_rob.name", "FC_rob")]
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(fc, fc_ref)
expect_error(apply_matrix_dfl(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 2, median)),
"vectors must be of the same length")
fc <- apply_matrix_dfw(student_results, FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, median))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
.m <- matrix_elm(student_results,m)
.fc <- do.call(cbind,
list(FC = rowMeans(.m), FC_rob = apply(.m, 1, median)))
.fc <- tibble::as_tibble(.fc, rownames = "FC.name")
.fc <- dplyr::mutate(.fc, FC_rob.name = FC.name)
.fc <- tidyr::pivot_wider(.fc,
names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
# .fc[, c("FC.name", "FC", "FC_rob.name", "FC_rob")]
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(fc, fc_ref)
# .data
rg <- apply_matrix(student_results, reg = ~unname(coef(lm(.m ~ .data[["teacher"]] + class))))
rg_ref <- apply_matrix(student_results, reg = ~unname(coef(lm(.m ~ teacher + class))))
expect_identical(rg, rg_ref)
previous_year_score <- 0.5
avr <- apply_matrix(student_results, av=~mean(c(.m, previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
row_meta <- row_info(student_results)
s <- list(av=mean(c(M, row_meta$previous_year_score)))
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
previous_year_score <- 0.5
avr <- apply_matrix(student_results, av=~mean(c(.m, .env$previous_year_score)))
avr_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
M <- matrix_elm(student_results,m)
s <- list(av=mean(c(M, previous_year_score)))
s
})
names(avr_ref) <- matrixnames(student_results)
expect_identical(avr, avr_ref)
# grouped
grmn <- apply_matrix(column_group_by(student_results, program), mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mean=mean(M[, gr]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mn=mean(M[, gr]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(row_group_by(student_results, teacher, class), mean, rg=range)
grs <- row_group_meta(row_group_by(student_results, teacher, class))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
list(mean=mean(M[gr, ]), rg=range(M[gr, ]))
})
ans$.rows <- NULL
ans$.vals <- grmn_ref
ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix(column_group_by(row_group_by(student_results, teacher, class), program), mean, rg=range)
grs_row <- row_group_meta(row_group_by(student_results, teacher, class))
grs_col <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
M <- matrix_elm(student_results,m)
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
list(mean=mean(M[grr, grc]), rg=range(M[grr, grc]))
})
})
unlist(grmn_ref, recursive = FALSE)
# grmn_ref
# ans$.rows <- NULL
# ans$.mats <- grmn_ref
# ans
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn$failure$.vals, mn_ref$failure)
expect_identical(grmn$remedial$.vals, mn_ref$remedial)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), mn=mean)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
mean(M[, gr])
})
ans$.rows <- NULL
ans$mn <- grmn_ref
ans %>% tidyr::unnest(mn)
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
Mgr <- M[, gr, drop = FALSE]
colMeans(Mgr)
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
Mgr <- M[, gr, drop = FALSE]
apply(Mgr, 2, median)
})
ans$FC_rob <- grmn_ref
ans$.rows <- NULL
ans %>% tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::select(program, FC.name = FC_id, FC,
FC_rob.name = FC_rob_id, FC_rob) %>%
dplyr::mutate(FC = unname(FC), FC_rob = unname(FC_rob))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~rowMeans(.m))
grs <- column_group_meta(column_group_by(student_results, program))
mn_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
rowMeans(M[, gr, drop = FALSE])
})
ans$.rows <- NULL
ans$FC <- grmn_ref
ans %>% tidyr::unnest_longer(FC) %>%
dplyr::select(program, FC.name=FC_id, FC) %>%
dplyr::mutate(FC=unname(FC))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~colMeans(.m))
grs <- row_group_meta(row_group_by(student_results, class, teacher))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
colMeans(M[gr, , drop = FALSE])
})
ans$.rows <- NULL
ans$FC <- grmn_ref
ans %>% tidyr::unnest_longer(FC) %>%
dplyr::select(class, teacher, FC.name=FC_id, FC) %>%
dplyr::mutate(FC=unname(FC))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~apply(.m, 1, mean))
grs <- row_group_meta(row_group_by(student_results, class, teacher))
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
rowMeans(M[gr, , drop = FALSE])
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs$.rows, function(gr) {
M <- matrix_elm(student_results,m)
apply(M[gr, , drop = FALSE], 1, mean)
})
ans$.rows <- NULL
ans$FC_rob <- grmn_ref
ans %>% tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::select(class, teacher, FC.name=FC_id, FC,
FC_rob.name=FC_rob_id, FC_rob) %>%
dplyr::mutate(FC=unname(FC), FC_rob=unname(FC_rob))
})
names(mn_ref) <- matrixnames(student_results)
expect_identical(grmn, mn_ref)
grfc <- apply_matrix_dfl(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
grs <- column_group_by(row_group_by(student_results, teacher), program)
grs_row <- row_group_meta(grs)
grs_col <- column_group_meta(grs)
fc_ref <- lapply(seq(nmatrix(student_results)),
function(m) {
ans <- grs_row
M <- matrix_elm(student_results,m)
ans$.rows <- NULL
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
colMeans(M[grr, grc, drop = FALSE])
})
})
ans$FC <- grmn_ref
grmn_ref <- lapply(grs_row$.rows, function(grr) {
lapply(grs_col$.rows, function(grc) {
apply(M[grr, grc, drop = FALSE], 2, median)
})
})
ans$FC_rob <- grmn_ref
ans %>%
tidyr::unnest(c(FC, FC_rob)) %>%
tidyr::unnest_longer(c(FC, FC_rob)) %>%
dplyr::left_join(column_info(student_results) %>%
dplyr::select(FC_id=.colname, program),
by = "FC_id") %>%
dplyr::select(teacher, program, FC.name=FC_id, FC,
FC_rob.name=FC_rob_id, FC_rob) %>%
dplyr::mutate(FC=unname(FC), FC_rob=unname(FC_rob))
})
names(fc_ref) <- matrixnames(student_results)
expect_identical(grfc, fc_ref)
#dfw
grmn <- apply_matrix_dfw(column_group_by(student_results, program), mn=mean)
mn_ref <- apply_matrix_dfl(column_group_by(student_results, program), mn=mean)
expect_identical(grmn, mn_ref)
grmn <- apply_matrix_dfw(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
mn_ref <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(grmn, names)))
nms_ref <- unlist(unique(lapply(mn_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
mn_ref <- purrr::map2(mn_ref, grmn, ~ .x[, names(.y)])
expect_identical(grmn, mn_ref)
fc <- apply_matrix_dfw(column_group_by(student_results, program), FC = ~rowMeans(.m))
fc_ref <- apply_matrix_dfl(column_group_by(student_results, program), FC = ~rowMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = FC.name, values_from = FC,
names_glue = "{.value} {FC.name}")
})
expect_identical(fc, fc_ref)
fc <- apply_matrix_dfw(row_group_by(student_results, class, teacher),
FC = ~colMeans(.m))
fc_ref <- apply_matrix_dfl(row_group_by(student_results, class, teacher),
FC = ~colMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = FC.name, values_from = FC,
names_glue = "{.value} {FC.name}")
})
expect_identical(fc, fc_ref)
mn <- apply_matrix_dfw(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~rowMeans(.m))
mn_ref <- apply_matrix_dfl(row_group_by(student_results, class, teacher), FC = ~rowMeans(.m),
FC_rob = ~rowMeans(.m)) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(mn, names)))
nms_ref <- unlist(unique(lapply(mn_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
mn_ref <- purrr::map2(mn_ref, mn, ~ .x[, names(.y)])
expect_identical(mn, mn_ref)
ct <- apply_matrix_dfw(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE)
ct_ref <- apply_matrix_dfl(column_group_by(row_group_by(student_results, teacher), program),
FC = ~colMeans(.m),
FC_rob = ~apply(.m, 2, median), .force_name = TRUE) %>%
lapply(function(m) {
m %>% tidyr::pivot_wider(names_from = c(FC.name, FC_rob.name),
values_from = c(FC, FC_rob),
names_glue = "{.value} {FC.name}")
})
nms <- unlist(unique(lapply(ct, names)))
nms_ref <- unlist(unique(lapply(ct_ref, names)))
expect_true(all(nms %in% nms_ref))
expect_true(all(nms_ref %in% nms))
ct_ref <- purrr::map2(ct_ref, ct, ~ .x[, names(.y)])
expect_identical(ct, ct_ref)
})
Try the matrixset package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.