Use data.table subsetting to avoid copy of large objects (#180)

* Use drop=FALSE to avoid losing dimension in double-elided case

* avoid copy of potentially large data.table input

* Need drop=FALSE for data.table too

* test

* Redundant withr Suggests

* importFrom(utils,str)

Author: MichaelChirico

DESCRIPTION

@@ -32,7 +32,8 @@ Suggests:
     Cairo,
     stringr,
     testthat (>= 3.0.0),
-    leaflet
+    leaflet,
+    withr
 Enhances:
     data.table,
     tibble,

NAMESPACE

@@ -1,5 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(partition_from_parts,data.table)
+S3method(partition_from_parts,default)
 S3method(repr_geojson,SpatialCollections)
 S3method(repr_geojson,SpatialGrid)
 S3method(repr_geojson,SpatialGridDataFrame)
@@ -137,4 +139,5 @@ importFrom(tools,Rd2latex)
 importFrom(tools,Rd2txt)
 importFrom(utils,capture.output)
 importFrom(utils,head)
+importFrom(utils,str)
 importFrom(utils,tail)

R/repr_matrix_df.r

@@ -33,18 +33,20 @@ onload_chars <- function() {
 	chars$times_s <- .char_fallback('\u00D7', 'x')
 }
 
-arr_partition <- function(a, rows, cols) {
-	stopifnot(rows >= 2L, cols >= 2L)
-	
-	# create sequences of indices to bisect rows and columns
-	part_r <- partition(nrow(a), rows)
-	part_c <- partition(ncol(a), cols)
-	
-	# assign a list of parts that can be coerced to strings
+#' Assign a list of parts that can be coerced to strings
+#' @noRd
+partition_from_parts <- function(a, part_r, part_c) {
+	UseMethod("partition_from_parts")
+}
+
+#' @export
+partition_from_parts.default <- function(a, part_r, part_c) {
 	if (!is.null(part_r) && !is.null(part_c)) {
 		structure(list(
-			ul = a[part_r$start, part_c$start], ll = a[part_r$end, part_c$start],
-			ur = a[part_r$start, part_c$end  ], lr = a[part_r$end, part_c$end  ]),
+			ul = a[part_r$start, part_c$start, drop = FALSE],
+			ll = a[part_r$end  , part_c$start, drop = FALSE],
+			ur = a[part_r$start,   part_c$end, drop = FALSE],
+			lr = a[part_r$end  ,   part_c$end, drop = FALSE]),
 		omit = 'both')
 	} else if (!is.null(part_r)) {
 		structure(list(
@@ -61,6 +63,40 @@ arr_partition <- function(a, rows, cols) {
 	}
 }
 
+#' @export
+partition_from_parts.data.table <- function(a, part_r, part_c) {
+	if (!is.null(part_r) && !is.null(part_c)) {
+		structure(list(
+			ul = a[part_r$start, part_c$start, with = FALSE, drop = FALSE],
+			ll = a[part_r$end  , part_c$start, with = FALSE, drop = FALSE],
+			ur = a[part_r$start,   part_c$end, with = FALSE, drop = FALSE],
+			lr = a[part_r$end  ,   part_c$end, with = FALSE, drop = FALSE]),
+		omit = 'both')
+	} else if (!is.null(part_r)) {
+		structure(list(
+			upper = a[part_r$start, , with = FALSE, drop = FALSE],
+			lower = a[part_r$end,   , with = FALSE, drop = FALSE]),
+		omit = 'rows')
+	} else if (!is.null(part_c)) {
+		structure(list(
+			left  = a[, part_c$start,  with = FALSE, drop = FALSE],
+			right = a[, part_c$end,    with = FALSE, drop = FALSE]),
+		omit = 'cols')
+	} else {
+		structure(list(full = a), omit = 'none')
+	}
+}
+
+arr_partition <- function(a, rows, cols) {
+	stopifnot(rows >= 2L, cols >= 2L)
+	
+	# create sequences of indices to bisect rows and columns
+	part_r <- partition(nrow(a), rows)
+	part_c <- partition(ncol(a), cols)
+	
+	partition_from_parts(a, part_r, part_c)
+}
+
 # unpack tibble and coerce to data.frame
 arr_part_unpack_tbl <- function(tbl) {
   tbl_col_format <- function(col, prefix = '') {
@@ -84,6 +120,7 @@ arr_part_unpack_tbl <- function(tbl) {
 }
 
 arr_parts_format <- function(parts) structure(lapply(parts, arr_part_format), omit = attr(parts, 'omit'))
+#' @importFrom utils capture.output str
 arr_part_format <- function(part) {
 	if (inherits(part, 'tbl')) {
 		part <- arr_part_unpack_tbl(part)

tests/testthat/test_repr_array_df.r

@@ -204,3 +204,48 @@ test_that('data.frame with list columns can be displayed', {
 		expect_identical(repr_html(data.table::as.data.table(df)), sub('data\\.frame','data.table',expected))
 	}
 })
+
+test_that('forced-narrow inputs work', {
+	withr::local_options(repr.matrix.max.rows = 2L, repr.matrix.max.cols = 2L)
+	df <- data.frame(a = 1:3, b = 4:6, c = 7:9)
+	expect_silent(repr_text(df))
+	expect_identical(
+		# Scrub non-ASCII characters to make the test platform-agnostic.
+		gsub("[^a-zA-Z0-9.&;<>= '\"/:\n\t]", "*", repr_html(df)),
+		"<table class=\"dataframe\">
+<caption>A data.frame: 3 * 3</caption>
+<thead>
+\t<tr><th scope=col>a</th><th scope=col>*</th><th scope=col>c</th></tr>
+\t<tr><th scope=col>&lt;int&gt;</th><th scope=col>*</th><th scope=col>&lt;int&gt;</th></tr>
+</thead>
+<tbody>
+\t<tr><td>1</td><td>*</td><td>7</td></tr>
+\t<tr><td>*</td><td>*</td><td>*</td></tr>
+\t<tr><td>3</td><td>*</td><td>9</td></tr>
+</tbody>
+</table>
+")
+})
+
+test_that('data.table and data.frame elision is the same', {
+	skip_if_not_installed('data.table')
+	withr::local_options(list(repr.matrix.max.rows = 10L, repr.matrix.max.cols = 10L))
+	DF <- data.frame(matrix(rnorm(100L*100L), 100L, 100L))
+	expect_identical(repr_text(DF), repr_text(data.table::as.data.table(DF)))
+	expect_identical(repr_text(DF[1:10, ]), repr_text(data.table::as.data.table(DF[1:10, ])))
+	expect_identical(repr_text(DF[1:10, 1:10]), repr_text(data.table::as.data.table(DF[1:10, 1:10])))
+})
+
+test_that('data.table elision works in 1-column and 1-row edge cases', {
+	skip_if_not_installed('data.table')
+	withr::local_options(list(repr.matrix.max.rows = 2L, repr.matrix.max.cols = 2L))
+
+	DF <- data.frame(a = 1:3)
+	expect_identical(repr_text(DF), repr_text(data.table::as.data.table(DF)))
+
+	DF <- data.frame(a = 1L, b = 2L, c = 3L)
+	expect_identical(repr_text(DF), repr_text(data.table::as.data.table(DF)))
+
+	DF <- data.frame(a = 1:3, b = 4:6, c = 7:9)
+	expect_identical(repr_text(DF), repr_text(data.table::as.data.table(DF)))
+})