Skip to content

FS2-3518: support data frame subscripting #119

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 4 commits into
base: master
Choose a base branch
from
Draft

FS2-3518: support data frame subscripting #119

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
b396f2c
WIP
JustinCCYap May 7, 2025
8b8013c
Revert "WIP"
JustinCCYap May 7, 2025
553f028
Support data frame subscripting
JustinCCYap May 8, 2025
fa9add2
Add tests
JustinCCYap May 12, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
80 changes: 66 additions & 14 deletions R/table-subscript.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,17 +15,19 @@
# 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)

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)
Expand All @@ -47,8 +49,23 @@
if (!identical(as.character(called.args[[i]]), ""))
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)
}

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)
Expand All @@ -57,7 +74,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
Expand All @@ -77,9 +94,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 <- "_@_"
Expand All @@ -106,10 +126,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))
Expand All @@ -118,8 +142,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
Comment on lines +145 to +151
Copy link
Contributor

@jrwishart jrwishart May 8, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't quite understand this.

Copy link
Contributor Author

@JustinCCYap JustinCCYap May 8, 2025 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The idea is to pass a matrix with the same dimensions and attributes as the data frame to updateTableAttributes, so that existing code works to modify the attributes.


# 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)
Expand Down Expand Up @@ -239,7 +271,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
}

Expand All @@ -259,7 +291,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)
Expand All @@ -278,7 +310,7 @@ updateTableAttributes <- function(y, x, called.args, 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
}
Expand Down Expand Up @@ -313,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)
Expand All @@ -330,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)
Expand Down Expand Up @@ -1035,3 +1066,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
}
Binary file added tablesAsDataFrame.rds
View file
Open in desktop
Binary file not shown.
Binary file added tests/testthat/tablesAsDataFrame.rds
View file
Open in desktop
Binary file not shown.
48 changes: 48 additions & 0 deletions tests/testthat/test-table-subscript.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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")