test_that("matrixset general loop works", { 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=lapply(mn_ref$failure, function(u) lapply(u, function(v) NULL)))) expect_equal(mn, mn_ref) 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_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_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) 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_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_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_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_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_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) 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_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) }) test_that("matrixset 'long' loop works", { # 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$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$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", { # 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$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$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) # # # 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", { 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)) 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)) %>% # 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) })