From b396f2c8b5c00db84f7318daa12e49c78cd7fad3 Mon Sep 17 00:00:00 2001 From: Justin Yap Date: Wed, 7 May 2025 16:40:39 +1000 Subject: [PATCH 1/4] WIP --- R/table-subscript.R | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/R/table-subscript.R b/R/table-subscript.R index f297ed09..bce59c60 100644 --- a/R/table-subscript.R +++ b/R/table-subscript.R @@ -15,14 +15,18 @@ # Catch empty input e.g. x[] or x[drop = TRUE/FALSE] (when ... is empty) if (empty.ind) return(x) + input.is.data.frame <- is.data.frame(x) + # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array) + if (input.is.not.array && !input.is.data.frame) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" x <- deduplicateQTableLabels(x, DUPLICATE.LABEL.SUFFIX) + y <- NextMethod(`[`, x) + x.dim <- dim(x) n.dim <- length(x.dim) if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) @@ -37,8 +41,6 @@ if (missing.names) # Add names for subsetting QStatisticsTestingInfo dimnames(x) <- makeNumericDimNames(dim(x)) - y <- NextMethod(`[`, x) - called.args <- as.list(called.args[["..."]]) ## Need to evaluate the arguments here to alleviate possible NSE issues; c.f.: ## http://adv-r.had.co.nz/Computing-on-the-language.html#calling-from-another-function @@ -47,8 +49,10 @@ if (!identical(as.character(called.args[[i]]), "")) evaluated.args[[i]] <- eval(called.args[[i]], parent.frame()) + x2 <- as.matrix(x) + # Update Attributes here - y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = drop, + y <- updateTableAttributes(y, x2, evaluated.args, drop = drop, missing.names, DUPLICATE.LABEL.SUFFIX) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[") throwWarningIfDuplicateLabels(x, evaluated.args, sep = DUPLICATE.LABEL.SUFFIX) @@ -57,7 +61,7 @@ if (missing.names) y <- unname(y) - if (input.is.not.array && is.array(y)) + if (input.is.not.array && !input.is.data.frame && is.array(y)) y <- dropTableToVector(y) y @@ -77,9 +81,12 @@ StopForUserError("exact argument should be TRUE or FALSE") called.args <- match.call(expand.dots = FALSE) empty.ind <- providedArgumentEmpty(called.args, optional.arg = "exact") + + input.is.data.frame <- is.data.frame(x) + # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array) + if (input.is.not.array && !input.is.data.frame) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" @@ -109,6 +116,8 @@ if (!valid.args) throwErrorTableDoubleIndex(input.name, x.dim) + y <- NextMethod(`[[`, x) + if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) x <- nameDimensionAttributes(x) @@ -116,10 +125,10 @@ if (missing.names) dimnames(x) <- makeNumericDimNames(dim(x)) - y <- NextMethod(`[[`, x) + x2 <- as.matrix(x) # Update Attributes here - y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = TRUE, missing.names) + y <- updateTableAttributes(y, x2, evaluated.args, drop = TRUE, missing.names) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[[") y <- removeDeduplicationSuffixFromLabels(y, DUPLICATE.LABEL.SUFFIX) if (missing.names) @@ -239,7 +248,7 @@ throwErrorOnlyNamed <- function(named.arg, function.name) { sQuote(function.name)) } -isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class")) { +isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class", "row.names")) { attribute.names %in% basic.attr } @@ -259,7 +268,7 @@ IsQTableAttribute <- function(attribute.names, attribute.names %in% qtable.attrs } -updateTableAttributes <- function(y, x, called.args, evaluated.args, drop = TRUE, +updateTableAttributes <- function(y, x, evaluated.args, drop = TRUE, original.missing.names = FALSE, sep = "_@_") { class(y) <- c("QTable", class(y)) y.attributes <- attributes(y) From 8b8013c152b29d015d3198322543cb10e804f55b Mon Sep 17 00:00:00 2001 From: Justin Yap Date: Wed, 7 May 2025 16:43:55 +1000 Subject: [PATCH 2/4] Revert "WIP" This reverts commit b396f2c8b5c00db84f7318daa12e49c78cd7fad3. --- R/table-subscript.R | 29 ++++++++++------------------- 1 file changed, 10 insertions(+), 19 deletions(-) diff --git a/R/table-subscript.R b/R/table-subscript.R index bce59c60..f297ed09 100644 --- a/R/table-subscript.R +++ b/R/table-subscript.R @@ -15,18 +15,14 @@ # Catch empty input e.g. x[] or x[drop = TRUE/FALSE] (when ... is empty) if (empty.ind) return(x) - input.is.data.frame <- is.data.frame(x) - # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array && !input.is.data.frame) + if (input.is.not.array) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" x <- deduplicateQTableLabels(x, DUPLICATE.LABEL.SUFFIX) - y <- NextMethod(`[`, x) - x.dim <- dim(x) n.dim <- length(x.dim) if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) @@ -41,6 +37,8 @@ if (missing.names) # Add names for subsetting QStatisticsTestingInfo dimnames(x) <- makeNumericDimNames(dim(x)) + y <- NextMethod(`[`, x) + called.args <- as.list(called.args[["..."]]) ## Need to evaluate the arguments here to alleviate possible NSE issues; c.f.: ## http://adv-r.had.co.nz/Computing-on-the-language.html#calling-from-another-function @@ -49,10 +47,8 @@ if (!identical(as.character(called.args[[i]]), "")) evaluated.args[[i]] <- eval(called.args[[i]], parent.frame()) - x2 <- as.matrix(x) - # Update Attributes here - y <- updateTableAttributes(y, x2, evaluated.args, drop = drop, + y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = drop, missing.names, DUPLICATE.LABEL.SUFFIX) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[") throwWarningIfDuplicateLabels(x, evaluated.args, sep = DUPLICATE.LABEL.SUFFIX) @@ -61,7 +57,7 @@ if (missing.names) y <- unname(y) - if (input.is.not.array && !input.is.data.frame && is.array(y)) + if (input.is.not.array && is.array(y)) y <- dropTableToVector(y) y @@ -81,12 +77,9 @@ StopForUserError("exact argument should be TRUE or FALSE") called.args <- match.call(expand.dots = FALSE) empty.ind <- providedArgumentEmpty(called.args, optional.arg = "exact") - - input.is.data.frame <- is.data.frame(x) - # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array && !input.is.data.frame) + if (input.is.not.array) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" @@ -116,8 +109,6 @@ if (!valid.args) throwErrorTableDoubleIndex(input.name, x.dim) - y <- NextMethod(`[[`, x) - if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) x <- nameDimensionAttributes(x) @@ -125,10 +116,10 @@ if (missing.names) dimnames(x) <- makeNumericDimNames(dim(x)) - x2 <- as.matrix(x) + y <- NextMethod(`[[`, x) # Update Attributes here - y <- updateTableAttributes(y, x2, evaluated.args, drop = TRUE, missing.names) + y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = TRUE, missing.names) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[[") y <- removeDeduplicationSuffixFromLabels(y, DUPLICATE.LABEL.SUFFIX) if (missing.names) @@ -248,7 +239,7 @@ throwErrorOnlyNamed <- function(named.arg, function.name) { sQuote(function.name)) } -isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class", "row.names")) { +isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class")) { attribute.names %in% basic.attr } @@ -268,7 +259,7 @@ IsQTableAttribute <- function(attribute.names, attribute.names %in% qtable.attrs } -updateTableAttributes <- function(y, x, evaluated.args, drop = TRUE, +updateTableAttributes <- function(y, x, called.args, evaluated.args, drop = TRUE, original.missing.names = FALSE, sep = "_@_") { class(y) <- c("QTable", class(y)) y.attributes <- attributes(y) From 553f028228e2e47bd19042a7d7dfbbe7ef8f85ef Mon Sep 17 00:00:00 2001 From: Justin Yap Date: Thu, 8 May 2025 15:23:42 +1000 Subject: [PATCH 3/4] Support data frame subscripting --- R/table-subscript.R | 70 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 60 insertions(+), 10 deletions(-) diff --git a/R/table-subscript.R b/R/table-subscript.R index f297ed09..ee69fe18 100644 --- a/R/table-subscript.R +++ b/R/table-subscript.R @@ -15,9 +15,11 @@ # Catch empty input e.g. x[] or x[drop = TRUE/FALSE] (when ... is empty) if (empty.ind) return(x) + input.is.data.frame <- is.data.frame(x) + # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array) + if (input.is.not.array && !input.is.data.frame) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" @@ -25,7 +27,7 @@ x.dim <- dim(x) n.dim <- length(x.dim) - if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) + if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x))) && !input.is.data.frame) x <- nameDimensionAttributes(x) n.index.args <- nargs() - 1L - !missing(drop) @@ -47,8 +49,20 @@ if (!identical(as.character(called.args[[i]]), "")) evaluated.args[[i]] <- eval(called.args[[i]], parent.frame()) + if (input.is.data.frame) { + evaluated.args <- mapArgsFromDataFrame(evaluated.args, FALSE) + } + + if (input.is.data.frame) { + x2 <- as.matrix(x) + mostattributes(x2) <- c(attributes(x2)[isBasicAttribute(names(attributes(x2)))], + attributes(x)[!isBasicAttribute(names(attributes(x)))]) + } + else + x2 <- x + # Update Attributes here - y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = drop, + y <- updateTableAttributes(y, x2, evaluated.args, drop = drop, missing.names, DUPLICATE.LABEL.SUFFIX) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[") throwWarningIfDuplicateLabels(x, evaluated.args, sep = DUPLICATE.LABEL.SUFFIX) @@ -57,7 +71,7 @@ if (missing.names) y <- unname(y) - if (input.is.not.array && is.array(y)) + if (input.is.not.array && !input.is.data.frame && is.array(y)) y <- dropTableToVector(y) y @@ -77,9 +91,12 @@ StopForUserError("exact argument should be TRUE or FALSE") called.args <- match.call(expand.dots = FALSE) empty.ind <- providedArgumentEmpty(called.args, optional.arg = "exact") + + input.is.data.frame <- is.data.frame(x) + # Force array class for custom QTable subscripting code input.is.not.array <- !is.array(x) - if (input.is.not.array) + if (input.is.not.array && !input.is.data.frame) x <- as.array(x) DUPLICATE.LABEL.SUFFIX <- "_@_" @@ -106,10 +123,14 @@ all.unit.length <- all(lengths(evaluated.args) == 1L) valid.args <- all.unit.length && (single.arg || correct.n.args) - if (!valid.args) + if (!valid.args && !input.is.data.frame) throwErrorTableDoubleIndex(input.name, x.dim) - if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x)))) + if (input.is.data.frame) { + evaluated.args <- mapArgsFromDataFrame(evaluated.args, TRUE) + } + + if (n.dim > 0 && !is.null(dimnames(x)) && is.null(names(dimnames(x))) && !input.is.data.frame) x <- nameDimensionAttributes(x) missing.names <- is.null(dimnames(x)) @@ -118,8 +139,16 @@ y <- NextMethod(`[[`, x) + if (input.is.data.frame) { + x2 <- as.matrix(x) + mostattributes(x2) <- c(attributes(x2)[isBasicAttribute(names(attributes(x2)))], + attributes(x)[!isBasicAttribute(names(attributes(x)))]) + } + else + x2 <- x + # Update Attributes here - y <- updateTableAttributes(y, x, called.args, evaluated.args, drop = TRUE, missing.names) + y <- updateTableAttributes(y, x2, evaluated.args, drop = TRUE, missing.names) y <- updateNameAttribute(y, attr(x, "name"), called.args, "[[") y <- removeDeduplicationSuffixFromLabels(y, DUPLICATE.LABEL.SUFFIX) if (missing.names) @@ -239,7 +268,7 @@ throwErrorOnlyNamed <- function(named.arg, function.name) { sQuote(function.name)) } -isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class")) { +isBasicAttribute <- function(attribute.names, basic.attr = c("dim", "names", "dimnames", "class", "row.names")) { attribute.names %in% basic.attr } @@ -259,7 +288,7 @@ IsQTableAttribute <- function(attribute.names, attribute.names %in% qtable.attrs } -updateTableAttributes <- function(y, x, called.args, evaluated.args, drop = TRUE, +updateTableAttributes <- function(y, x, evaluated.args, drop = TRUE, original.missing.names = FALSE, sep = "_@_") { class(y) <- c("QTable", class(y)) y.attributes <- attributes(y) @@ -1035,3 +1064,24 @@ productNameOrIsNotQ <- function() { if (is.null(product.name)) return(TRUE) length(product.name) == 1L && product.name != "Q" } + +mapArgsFromDataFrame <- function(evaluated.args, is.double.bracket) { + # single bracket, single parameter, multiple elements [x] -> [TRUE, x] + if (!is.double.bracket && length(evaluated.args) == 1) { + evaluated.args <- c(TRUE, evaluated.args) + } + + # double bracket, single parameter, single element [[x]] -> [, x] + if (is.double.bracket && length(evaluated.args) == 1 && + length(evaluated.args[[1]]) == 1) { + evaluated.args <- c(TRUE, evaluated.args) + } + + # double bracket, single parameter, double element [[x]] -> [x2, x1] + if (is.double.bracket && length(evaluated.args) == 1 && + length(evaluated.args[[1]]) == 2) { + evaluated.args <- list(evaluated.args[[1]][2], evaluated.args[[1]][1]) + } + + evaluated.args +} From fa9add216485433025079b7f4e934747ef1cb1a7 Mon Sep 17 00:00:00 2001 From: Justin Yap Date: Mon, 12 May 2025 16:15:10 +1000 Subject: [PATCH 4/4] Add tests --- R/table-subscript.R | 10 +++--- tablesAsDataFrame.rds | Bin 0 -> 1295 bytes tests/testthat/tablesAsDataFrame.rds | Bin 0 -> 1295 bytes tests/testthat/test-table-subscript.R | 48 ++++++++++++++++++++++++++ 4 files changed, 54 insertions(+), 4 deletions(-) create mode 100644 tablesAsDataFrame.rds create mode 100644 tests/testthat/tablesAsDataFrame.rds diff --git a/R/table-subscript.R b/R/table-subscript.R index ee69fe18..9f005df3 100644 --- a/R/table-subscript.R +++ b/R/table-subscript.R @@ -50,6 +50,9 @@ evaluated.args[[i]] <- eval(called.args[[i]], parent.frame()) if (input.is.data.frame) { + if (length(evaluated.args) == 1) { + drop = FALSE + } evaluated.args <- mapArgsFromDataFrame(evaluated.args, FALSE) } @@ -307,7 +310,7 @@ updateTableAttributes <- function(y, x, evaluated.args, drop = TRUE, y <- updateNameDimensionAttr(y, x.attributes[["dim"]]) y <- updateSpanIfNecessary(y, x.attributes, evaluated.args) y <- updateIsSubscriptedAttr(y, x) - y <- updateCellText(y, x.attributes, evaluated.args) + y <- updateCellText(y, x.attributes, evaluated.args, drop) y <- keepMappedDimnames(y) y } @@ -342,7 +345,7 @@ updateIsSubscriptedAttr <- function(y, x) { y } -updateCellText <- function(y, x.attributes, evaluated.args) { +updateCellText <- function(y, x.attributes, evaluated.args, drop) { cell.text <- x.attributes$celltext if (!is.array(cell.text)) { return (y) @@ -359,8 +362,7 @@ updateCellText <- function(y, x.attributes, evaluated.args) { evaluated.args[[i]] } }) - - subscripted <- do.call(`[`, c(list(cell.text), indices)) + subscripted <- do.call(`[`, c(list(cell.text), indices, drop = drop)) if (!is.array(subscripted)) { subscripted <- array(subscripted) diff --git a/tablesAsDataFrame.rds b/tablesAsDataFrame.rds new file mode 100644 index 0000000000000000000000000000000000000000..57c1dc8ddea059e56d3a40892959ee023e99d4da GIT binary patch literal 1295 zcmV+q1@QVGiwFP!000002HjV0OdLfN-}{3chg9L}wJPG)NU0j2aCa0efA%b538iqy zVQtb7mbHKDHIbxEiK#JKO{1ob z5+jKpr02}u%-peeS5Vt8PO_Q#z2BR+``*5{^Y$q_!!Q=cYBe#I0=Q%f`U4%+jSORU zKwyF#n$7T91FvER5ANY#x)yf5x1X!JBo>91X1NDz{`|xHMG?2rdUF4T!R=gS^#0ys z^HZGX!{|>R-y7xF7bd@}m}=%W4JWr8J@6b?TjzJZtyXjQ=yr}~+3&#fwu#it;rTHv z_hRguP0d@eydBS-m~S8!t!CXHD^rA=l=v7>;o?r+xs=dUN!V?2Leh*|f+DYyEfy@i z%@^Q@M1YY!#A|#_Sb?^&q_7=Ipo+m(ks^=OWIjSMCT`yWRF&1Dyu{WuVwtV3k=10j z-c4}5N5@SByEY^2qP$DzU6gn0yqoY2!n2RC2Fm8vDL38f(RmN$Jv!e&u)V><$_g8k z6=3kNFeJnzpdtTo9x)|3-a`pg3nk*B5acyrR7P{5VS`nT^O7MsP5-kXnv>WeQ;xjS zHB3eg99K&cht8bJe!ZTq=hSp!#`W(-%XfX zHZSwb0&|Uo2ZzR-!+pmPuYwRzgNhK>1X)T&Vp-%$RX!FM0jmn5fNf!2^;--!?l9QE z32RFyw&@AO+Kv;M$*q$mM_)@5x0@kjO@_E*&ZVg8^iaK)1U zd61VjQmE*ap#r;3iwzfNyF5bTW!))DB*5nWcn;~UUf-O%=CP9HY5oYM-uSudf-_Ci zwdBpTCHHJvJac3Z#s6{U97lA6tJb&su1;2b&}FE>XPw$*!@nUK7P{ef!n;War_P>mcW0JQ`2%75#-AbLgzSKr>%eXxq?5v(RZ|}Pn$7YwHMY~aApk4#%{|$PZR)-G{ F0027Qlm!3) literal 0 HcmV?d00001 diff --git a/tests/testthat/tablesAsDataFrame.rds b/tests/testthat/tablesAsDataFrame.rds new file mode 100644 index 0000000000000000000000000000000000000000..57c1dc8ddea059e56d3a40892959ee023e99d4da GIT binary patch literal 1295 zcmV+q1@QVGiwFP!000002HjV0OdLfN-}{3chg9L}wJPG)NU0j2aCa0efA%b538iqy zVQtb7mbHKDHIbxEiK#JKO{1ob z5+jKpr02}u%-peeS5Vt8PO_Q#z2BR+``*5{^Y$q_!!Q=cYBe#I0=Q%f`U4%+jSORU zKwyF#n$7T91FvER5ANY#x)yf5x1X!JBo>91X1NDz{`|xHMG?2rdUF4T!R=gS^#0ys z^HZGX!{|>R-y7xF7bd@}m}=%W4JWr8J@6b?TjzJZtyXjQ=yr}~+3&#fwu#it;rTHv z_hRguP0d@eydBS-m~S8!t!CXHD^rA=l=v7>;o?r+xs=dUN!V?2Leh*|f+DYyEfy@i z%@^Q@M1YY!#A|#_Sb?^&q_7=Ipo+m(ks^=OWIjSMCT`yWRF&1Dyu{WuVwtV3k=10j z-c4}5N5@SByEY^2qP$DzU6gn0yqoY2!n2RC2Fm8vDL38f(RmN$Jv!e&u)V><$_g8k z6=3kNFeJnzpdtTo9x)|3-a`pg3nk*B5acyrR7P{5VS`nT^O7MsP5-kXnv>WeQ;xjS zHB3eg99K&cht8bJe!ZTq=hSp!#`W(-%XfX zHZSwb0&|Uo2ZzR-!+pmPuYwRzgNhK>1X)T&Vp-%$RX!FM0jmn5fNf!2^;--!?l9QE z32RFyw&@AO+Kv;M$*q$mM_)@5x0@kjO@_E*&ZVg8^iaK)1U zd61VjQmE*ap#r;3iwzfNyF5bTW!))DB*5nWcn;~UUf-O%=CP9HY5oYM-uSudf-_Ci zwdBpTCHHJvJac3Z#s6{U97lA6tJb&su1;2b&}FE>XPw$*!@nUK7P{ef!n;War_P>mcW0JQ`2%75#-AbLgzSKr>%eXxq?5v(RZ|}Pn$7YwHMY~aApk4#%{|$PZR)-G{ F0027Qlm!3) literal 0 HcmV?d00001 diff --git a/tests/testthat/test-table-subscript.R b/tests/testthat/test-table-subscript.R index 1aa17e46..a80284c3 100644 --- a/tests/testthat/test-table-subscript.R +++ b/tests/testthat/test-table-subscript.R @@ -2581,3 +2581,51 @@ test_that("celltext attribute is correctly subscripted in tables", { expect_equal(attr(t[3:10], "celltext"), structure(c("c", "d", "e", "f", "g", "h", "i", "j"), dim = c(8L))) }) +test_that("data frame is subscripted with single bracket and single parameter", { + tbls <- readRDS("tablesAsDataFrame.rds") + + t <- tbls[["PickOneWithMultiStat"]] + + vals <- as.matrix(t) + + # single bracket, double parameter + subscripted <- t[2:3, 1] + expect_equal(as.numeric(subscripted), unname(vals[2:3,1])) + expect_equal(attr(subscripted, "celltext"), array(c("!", "!"))) + expect_equal(attr(subscripted, "QStatisticsTestingInfo"), attr(t, "QStatisticsTestingInfo")[c(3,5),]) + expect_equal(attr(subscripted, "span")$rows, structure(list(row.names(vals)[2:3]), names = "", row.names = 2:3, class = "data.frame")) + # figure out why cols is missing + # expect_equal(attr(subscripted, "span")$rows, structure(list("18 to 24"), names = "", row.names = 2L, class = "data.frame")) + + # single bracket, single parameter + subscripted <- t[1] + expect_equal(as.matrix(subscripted), vals[, 1, drop = FALSE]) + expect_equal(attr(subscripted, "celltext"), array(c(NA, "!", "!", "!", "!", "!", "!", NA, "!", "!", NA), dim = c(11, 1))) + expect_equal(attr(subscripted, "QStatisticsTestingInfo"), attr(t, "QStatisticsTestingInfo")[seq(1,21,2),]) + expect_equal(attr(subscripted, "span")$rows, attr(t, "span")$rows) + # figure out why cols is missing + + # double bracket, single parameter, single element + subscripted <- t[[2]] + expect_equal(as.numeric(subscripted), unname(vals[, 2])) + expect_equal(attr(subscripted, "celltext"), array(rep(NA_character_, 11))) + expect_equal(attr(subscripted, "QStatisticsTestingInfo"), attr(t, "QStatisticsTestingInfo")[seq(2,22,2),]) + expect_equal(attr(subscripted, "span")$rows, attr(t, "span")$rows) + # figure out why cols is missing + + # double bracket, single parameter, double element + subscripted <- t[[1:2]] + expect_equal(as.numeric(subscripted), unname(vals[2, 1])) + expect_equal(attr(subscripted, "celltext"), array("!")) + expect_equal(attr(subscripted, "QStatisticsTestingInfo"), attr(t, "QStatisticsTestingInfo")[3,]) + expect_equal(attr(subscripted, "span")$rows, structure(list("18 to 24"), names = "", row.names = 2L, class = "data.frame")) + + # double bracket, double parameter + subscripted <- t[[2, 1]] + expect_equal(as.numeric(subscripted), unname(vals[2, 1])) + expect_equal(attr(subscripted, "celltext"), array("!")) + expect_equal(attr(subscripted, "QStatisticsTestingInfo"), attr(t, "QStatisticsTestingInfo")[3,]) + expect_equal(attr(subscripted, "span")$rows, structure(list("18 to 24"), names = "", row.names = 2L, class = "data.frame")) +}) + +# devtools::test_active_file("tests/testthat/test-table-subscript.R")