tests/testthat/test-join.R

In matrixset: Creating, Manipulating and Annotating Matrix Ensemble

test_that("matrixset row info join works", {

  ms1 <- remove_row_annotation(student_results, class, teacher)
  suppressWarnings(ms <- join_row_info(ms1, student_results))
  ms_ref <- student_results
  ri <- row_info(ms_ref)
  ri <- dplyr::mutate(ri, previous_year_score.y = previous_year_score)
  ri <- dplyr::rename(ri, previous_year_score.x = previous_year_score)
  ri <- ri[, c(".rowname", "previous_year_score.x", "class", "teacher", "previous_year_score.y")]
  row_info(ms_ref) <- ri
  expect_identical(ms, ms_ref)



  ms <- join_row_info(ms1, student_results, by = c(".rowname", "previous_year_score"))
  ms_ref <- student_results
  ri <- row_info(ms_ref)
  ri <- ri[, c(".rowname", "previous_year_score", "class", "teacher")]
  row_info(ms_ref) <- ri
  expect_identical(ms, ms_ref)



  expect_error(join_row_info(ms1, student_results, by = c(".rowname", "previous_score")),
               "variable \"previous_score\" is not a known trait")


  meta <- tibble::tibble(sample = c("student 2", "student 2"),
                         msr = c("height", "weight"),
                         value = c(145, 32))
  expect_error(join_row_info(student_results, meta, by = c(".rowname"="sample")),
               "'by' does not result in unique row names")


  expect_warning(join_row_info(student_results, meta, by = c(".rowname"="sample"),
                               adjust = TRUE, names_glue = TRUE),
                 "row names \\(\\.rowname\\) have changed following matrix adjustment")


  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = TRUE))
  ms_ref_inf <- dplyr::left_join(row_info(student_results), meta,
                                 by = c(".rowname"="sample"))
  nms <- ms_ref_inf$.rowname
  idx <- match(nms, rownames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], unq_id[unq_id > 0], sep = "..")
  ms_ref_inf$.rowname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][idx, ]
    rownames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = ms_ref_inf, row_key = ".rowname",
                      column_info = column_info(student_results),
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = "{.tag}"))
  expect_identical(ms, ms_ref)

  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = "{.tag}_{msr}"))
  ms_ref_inf <- dplyr::left_join(row_info(student_results), meta,
                                 by = c(".rowname"="sample"))
  nms <- ms_ref_inf$.rowname
  idx <- match(nms, rownames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], ms_ref_inf$msr[unq_id > 0], sep = "_")
  ms_ref_inf$.rowname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][idx, ]
    rownames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = ms_ref_inf, row_key = ".rowname",
                      column_info = column_info(student_results),
                      column_key = ".colname")
  expect_identical(ms, ms_ref)

  expect_error(purrr::quietly(join_row_info)(student_results, meta, by = c(".rowname"="sample"),
                             adjust = TRUE, names_glue = "{.tag}_{msr2}"),
               "object 'msr2' not found")


  meta <- tibble::tibble(sample = c("student 2", "student 2"),
                         class = c("classA", "classA"),
                         msr = c("height", "weight"),
                         value = c(145, 32))
  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = TRUE))
  ms_ref_inf <- dplyr::left_join(row_info(student_results), meta,
                                 by = c(".rowname"="sample"))
  nms <- ms_ref_inf$.rowname
  idx <- match(nms, rownames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], unq_id[unq_id > 0], sep = "..")
  ms_ref_inf$.rowname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][idx, ]
    rownames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = ms_ref_inf, row_key = ".rowname",
                      column_info = column_info(student_results),
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = "{.tag}"))
  expect_identical(ms, ms_ref)

  w <- purrr::quietly(join_row_info)(student_results, meta,
                                     by = c(".rowname"="sample", "class"),
                                     adjust = TRUE, names_glue = TRUE)
  w <- w$warnings
  expect_true(any(w == "some traits have changed type ('class')"))


  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample", "class"),
                      adjust = TRUE, names_glue = TRUE))
  ms_ref_inf <- dplyr::left_join(row_info(student_results), meta,
                                 by = c(".rowname"="sample", "class"))
  nms <- ms_ref_inf$.rowname
  idx <- match(nms, rownames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], unq_id[unq_id > 0], sep = "..")
  ms_ref_inf$.rowname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][idx, ]
    rownames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = ms_ref_inf, row_key = ".rowname",
                      column_info = column_info(student_results),
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  suppressWarnings(ms <- join_row_info(student_results, meta, by = c(".rowname"="sample"),
                      adjust = TRUE, names_glue = "{.tag}_{msr}"))
  ms_ref_inf <- dplyr::left_join(row_info(student_results), meta,
                                 by = c(".rowname"="sample"))
  nms <- ms_ref_inf$.rowname
  idx <- match(nms, rownames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], ms_ref_inf$msr[unq_id > 0], sep = "_")
  ms_ref_inf$.rowname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][idx, ]
    rownames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = ms_ref_inf, row_key = ".rowname",
                      column_info = column_info(student_results),
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  w <- purrr::quietly(join_row_info)(row_group_by(student_results, class), meta,
                by = c(".rowname"="sample"), adjust = TRUE, names_glue = TRUE)
  w <- w$warnings
  expect_true(any(w == "grouping structure of '.ms_x' has changed."))


  ms1 <- remove_column_annotation(student_results, national_average, school_average)
  suppressWarnings(ms <- join_column_info(ms1, student_results))
  ms_ref <- student_results
  ci <- column_info(ms_ref)
  ci <- dplyr::mutate(ci, program.y = program)
  ci <- dplyr::rename(ci, program.x = program)
  ci <- ci[, c(".colname", "program.x", "national_average", "school_average", "program.y")]
  column_info(ms_ref) <- ci
  expect_identical(ms, ms_ref)



  meta <- tibble::tibble(field = c("Mathematics", "Mathematics"),
                         level = c("regular", "advanced"),
                         value = c(100, 250))
  expect_error(join_column_info(student_results, meta, by = c(".colname"="field")),
               "'by' does not result in unique col names")

  expect_warning(join_column_info(student_results, meta, by = c(".colname"="field"),
                                  adjust = TRUE, names_glue = TRUE),
                 "col names \\(\\.colname\\) have changed following matrix adjustment")

  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                         adjust = TRUE, names_glue = TRUE))
  ms_ref_inf <- dplyr::left_join(column_info(student_results), meta,
                                 by = c(".colname"="field"))
  nms <- ms_ref_inf$.colname
  idx <- match(nms, colnames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], unq_id[unq_id > 0], sep = "..")
  ms_ref_inf$.colname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][, idx]
    colnames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = row_info(student_results),
                      row_key = ".rowname",
                      column_info = ms_ref_inf,
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                         adjust = TRUE, names_glue = "{.tag}"))
  expect_identical(ms, ms_ref)

  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                         adjust = TRUE, names_glue = "{.tag}_{level}"))
  ms_ref_inf <- dplyr::left_join(column_info(student_results), meta,
                                 by = c(".colname"="field"))
  nms <- ms_ref_inf$.colname
  idx <- match(nms, colnames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], ms_ref_inf$level[unq_id > 0], sep = "_")
  ms_ref_inf$.colname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][, idx]
    colnames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = row_info(student_results),
                      row_key = ".rowname",
                      column_info = ms_ref_inf, column_key = ".colname")
  expect_identical(ms, ms_ref)

  expect_error(purrr::quietly(join_column_info)(student_results, meta, by = c(".colname"="field"),
                                adjust = TRUE, names_glue = "{.tag}_{level2}"),
               "object 'level2' not found")


  meta <- tibble::tibble(field = c("Mathematics", "Mathematics"),
                         program = c("Applied Science", "Applied Science"),
                         level = c("regular", "advanced"),
                         value = c(100, 250))
  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                                          adjust = TRUE, names_glue = TRUE))
  ms_ref_inf <- dplyr::left_join(column_info(student_results), meta,
                                 by = c(".colname"="field"))
  nms <- ms_ref_inf$.colname
  idx <- match(nms, colnames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], unq_id[unq_id > 0], sep = "..")
  ms_ref_inf$.colname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][, idx]
    colnames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = row_info(student_results),
                      row_key = ".rowname", column_info = ms_ref_inf,
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                                          adjust = TRUE, names_glue = "{.tag}"))
  expect_identical(ms, ms_ref)

  suppressWarnings(ms <- join_column_info(student_results, meta, by = c(".colname"="field"),
                                          adjust = TRUE, names_glue = "{.tag}_{level}"))
  ms_ref_inf <- dplyr::left_join(column_info(student_results), meta,
                                 by = c(".colname"="field"))
  nms <- ms_ref_inf$.colname
  idx <- match(nms, colnames(student_results))
  unq_id <- unique_id(nms, length(nms))
  nms[unq_id > 0] <- paste(nms[unq_id > 0], ms_ref_inf$level[unq_id > 0], sep = "_")
  ms_ref_inf$.colname <- nms
  m <- student_results[,,, keep_annotation = FALSE, warn_class_change = FALSE]
  m <- lapply(seq_along(m), function(mi) {
    M <- m[[mi]][, idx]
    colnames(M) <- nms
    M
  })
  names(m) <- matrixnames(student_results)
  ms_ref <- matrixset(m, row_info = row_info(student_results),
                      row_key = ".rowname", column_info = ms_ref_inf,
                      column_key = ".colname")
  expect_identical(ms, ms_ref)




  ms1 <- remove_row_annotation(filter_row(student_results, class %in% c("classA", "classC")),
                               class, teacher)
  suppressWarnings(ms <- join_row_info(ms1, student_results))
  ms_ref <- filter_row(student_results, class %in% c("classA", "classC"))
  ri <- row_info(ms_ref)
  ri <- dplyr::mutate(ri, previous_year_score.y = previous_year_score)
  ri <- dplyr::rename(ri, previous_year_score.x = previous_year_score)
  ri <- ri[, c(".rowname", "previous_year_score.x", "class", "teacher", "previous_year_score.y")]
  row_info(ms_ref) <- ri
  expect_identical(ms, ms_ref)



  expect_error(join_row_info(ms1, student_results, type = "full"),
               "the number of rows is modified by the join operation, which is against the 'matrixset' paradigm\\. Use 'adjust' to still perform the operation\\.")



  ms2 <- remove_row_annotation(ms1, previous_year_score)
  ms <- join_row_info(ms2, student_results, type = "full", adjust = TRUE)
  m <- student_results[c(1:5, 11:15), , , keep_annotation = FALSE, warn_class_change = FALSE]
  mNA <- matrix(NA_real_, 10, 3)
  rownames(mNA) <- paste("student", c(6:10, 16:20))
  colnames(mNA) <- colnames(student_results)
  m <- lapply(m, function(M) rbind(M, mNA))
  ri <- row_info(student_results)
  ri <- ri[c(1:5, 11:15, 6:10, 16:20), ]
  ci <- column_info(student_results)
  ms_ref <- matrixset(m, row_info = ri, column_info = ci, row_key = ".rowname",
                      column_key = ".colname")
  expect_identical(ms, ms_ref)



  ms1 <- remove_column_annotation(filter_column(student_results, program == "Applied Science"),
                                  program)
  suppressWarnings(ms <- join_column_info(ms1, student_results))
  ms_ref <- filter_column(student_results, program == "Applied Science")
  ci <- column_info(ms_ref)
  ci <- dplyr::mutate(ci, national_average.y = national_average,
                      school_average.y = school_average)
  ci <- dplyr::rename(ci, national_average.x = national_average,
                      school_average.x = school_average)
  ci <- ci[, c(".colname", "national_average.x", "school_average.x",
               "national_average.y", "school_average.y", "program")]
  column_info(ms_ref) <- ci
  expect_identical(ms, ms_ref)






  ms1 <- remove_row_annotation(filter_row(student_results, class %in% c("classA", "classC")),
                               class, teacher)


  expect_error(join_row_info(ms1, student_results, type = "full"),
               "the number of rows is modified by the join operation, which is against the 'matrixset' paradigm\\. Use 'adjust' to still perform the operation\\.")



  ms2 <- remove_row_annotation(ms1, previous_year_score)
  ms <- join_row_info(ms2, student_results, type = "full", adjust = TRUE)
  m <- student_results[c(1:5, 11:15), , , keep_annotation = FALSE, warn_class_change = FALSE]
  mNA <- matrix(NA_real_, 10, 3)
  rownames(mNA) <- paste("student", c(6:10, 16:20))
  colnames(mNA) <- colnames(student_results)
  m <- lapply(m, function(M) rbind(M, mNA))
  ri <- row_info(student_results)
  ri <- ri[c(1:5, 11:15, 6:10, 16:20), ]
  ci <- column_info(student_results)
  ms_ref <- matrixset(m, row_info = ri, column_info = ci, row_key = ".rowname",
                      column_key = ".colname")
  expect_identical(ms, ms_ref)






expect_warning(join_row_info(ms2, row_info(student_results), type = "full", adjust = "from_y"),
               "'adjust' has been forced to")

ms <- join_row_info(ms2, row_info(student_results), type = "full", adjust = TRUE)
expect_identical(ms, ms_ref)

expect_error(join_row_info(ms2, student_results, type = "full", adjust = "from_x"),
             "'from_x' is not valid")

ms <- join_row_info(ms2, student_results, type = "full", adjust = "pad_x")
m <- student_results[c(1:5, 11:15), , , keep_annotation = FALSE, warn_class_change = FALSE]
mNA <- matrix(NA_real_, 10, 3)
rownames(mNA) <- paste("student", c(6:10, 16:20))
colnames(mNA) <- colnames(student_results)
m <- lapply(m, function(M) rbind(M, mNA))
ri <- row_info(student_results)
ri <- ri[c(1:5, 11:15, 6:10, 16:20), ]
ci <- column_info(student_results)
ms_ref <- matrixset(m, row_info = ri, column_info = ci, row_key = ".rowname",
                    column_key = ".colname")
expect_identical(ms, ms_ref)



  ms2 <- remove_row_annotation(ms1, previous_year_score)
  ms <- join_row_info(ms2, student_results[, -3, ], type = "full", adjust = "from_y")
  m <- student_results[c(1:5, 11:15), , , keep_annotation = FALSE, warn_class_change = FALSE]
  nms <- paste("student", c(6:10, 16:20))
  mats <- student_results[nms, 1:2, , keep_annotation = FALSE, warn_class_change=FALSE]
  mats <- lapply(mats, function(m) {
    m <- cbind(m, NA)
    colnames(m)[3] <- "Science"
    m
  })
  m <- lapply(1:length(m), function(i) rbind(m[[i]], mats[[i]]))
  names(m) <- names(mats)
  ri <- row_info(student_results)
  ri <- ri[c(1:5, 11:15, 6:10, 16:20), ]
  ci <- column_info(student_results)
  ms_ref <- matrixset(m, row_info = ri, column_info = ci, row_key = ".rowname",
                      column_key = ".colname")
  expect_identical(ms, ms_ref)


  expect_error(join_row_info(student_results, ms1, type = "inner"),
               "the number of rows is modified by the join operation, which is against the 'matrixset' paradigm\\. Use 'adjust' to still perform the operation\\.")


  ms2 <- remove_row_annotation(student_results, previous_year_score)
  ms <- join_row_info(ms2, ms1, type = "inner", adjust = TRUE)
  ms_ref <- filter_row(student_results, class %in% c("classA", "classC"))
  expect_identical(ms, ms_ref)



  ms3 <- remove_row_annotation(student_results, class)
  ms <- join_row_info(row_group_by(ms3, teacher), student_results, by = c(".rowname", "previous_year_score", "teacher"))
  ms_ref <- student_results
  ri <- row_info(ms_ref)
  ri <- ri[, c(".rowname", "teacher", "previous_year_score", "class")]
  row_info(ms_ref) <- ri
  ms_ref <- row_group_by(ms_ref, teacher)
  expect_identical(ms, ms_ref)



  ms3 <- remove_row_annotation(student_results, class)
  suppressWarnings(ms <- join_row_info(row_group_by(ms3, teacher), student_results, by = c(".rowname", "previous_year_score")))
  ms_ref <- student_results
  ri <- row_info(ms_ref)
  ri$teacher.x <- ri$teacher
  ri$teacher.y <- ri$teacher
  ri <- ri[, c(".rowname", "teacher.x", "previous_year_score", "class", "teacher.y")]
  row_info(ms_ref) <- ri
  expect_identical(ms, ms_ref)



  ms1 <- filter_row(student_results, class %in% c("classA", "classC"))
  ms <- join_row_info(remove_row_annotation(student_results, class, teacher),
                      ms1, type = "anti", adjust = TRUE)
  ms_ref <- remove_row_annotation(filter_row(student_results, class %in% c("classB", "classD")),
                                  class, teacher)
  expect_identical(ms, ms_ref)


  expect_identical(join_row_info(remove_row_annotation(student_results, class),
                                 ms1, type = "semi", adjust = TRUE),
                   remove_row_annotation(ms1, class))


  expect_identical(join_row_info(ms1, student_results, type = "anti", adjust = TRUE),
                   filter_row(ms1, class == "none"))
})