Correct bug with wb_dims() and above (#1107)

* Add brackets * Disallow infinite values in int2col. int2col(Inf) would return "". which is problematic. * Correct typo in warning and in comment * Correct for length(x) > 1 * Add tests * Refactor code * [tests] fix check * [doc] roxygen2::roxygenize() * [wb_dims] extend tests and minor code indentations --------- Co-authored-by: Jan Marvin Garbuszus <jan.garbuszus@rub.de>
JanMarvin · Aug 16, 2024 · cc3c4e6 · cc3c4e6
1 parent bfaacd2
commit cc3c4e6
Show file tree

Hide file tree

Showing 6 changed files with 133 additions and 72 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -10,6 +10,7 @@
 
 * Previously, if only `cols` and `rows` were passed to `wb_dims()` and row `1` was selected, incorrect results were returned. This has been fixed. [1094](https://github.com/JanMarvin/openxlsx2/pull/1094)
 
+* `wb_dims()` no longer ignores `above`, `below`, `left`, `right` if `from_dims` is not supplied [1104](https://github.com/JanMarvin/openxlsx2/pull/1104)
 
 ***************************************************************************
 

diff --git a/R/converters.R b/R/converters.R
@@ -10,8 +10,8 @@
 #' @examples
 #' int2col(1:10)
 int2col <- function(x) {
- if (!is.numeric(x)) {
- stop("x must be numeric.")
+ if (!is.numeric(x) || any(is.infinite(x))) {
+ stop("x must be finite and numeric.")
  }
 
  sapply(x, int_to_col)

diff --git a/R/utils.R b/R/utils.R
@@ -322,7 +322,7 @@ check_wb_dims_args <- function(args, select = NULL) {
  cnam_null <- is.null(args$col_names)
  rnam_null <- is.null(args$row_names)
  if (is.character(args$rows) || is.character(args$from_row)) {
- warning("`rows` and `from_rows` in `wb_dims()` should not be a character. Please supply an integer vector.", call. = FALSE)
+ warning("`rows` and `from_row` in `wb_dims()` should not be a character. Please supply an integer vector.", call. = FALSE)
  }
 
  if (is.null(args$x)) {
@@ -709,71 +709,78 @@ wb_dims <- function(..., select = NULL) {
  stop("Internal error, all arguments should be named after this point.")
  }
 
+ if (length(args$from_col) > 1 || length(args$from_row) > 1) {
+ stop("from_col/from_row must be positive integers if supplied.")
+ }
  # handle from_dims
  if (!is.null(args$from_dims)) {
  if (!is.null(args$from_col) || !is.null(args$from_row)) {
  stop("Can't handle `from_row` and `from_col` if `from_dims` is supplied.")
  }
  # transform to
  from_row_and_col <- dims_to_rowcol(args$from_dims, as_integer = TRUE)
+ fcol <- col2int(from_row_and_col[[1]])
+ frow <- as.integer(from_row_and_col[[2]])
+ } else {
+ fcol <- args$from_col %||% 1L
+ frow <- args$from_row %||% 1L
+ }
 
- left <- args$left
- right <- args$right
- above <- args$above
- below <- args$below
-
- from_col <- col2int(from_row_and_col[[1]])
- from_row <- as.integer(from_row_and_col[[2]])
-
- # there can be only one
- if (length(c(left, right, above, below)) > 1)
- stop("can only be one direction")
-
- # default is column names and no row names
- cnms <- args$col_names %||% 1
- rnms <- args$row_names %||% 0
+ left <- args$left
+ right <- args$right
+ above <- args$above
+ below <- args$below
 
- # NCOL(NULL)/NROW(NULL) could work as well, but the behavior might have
- # changed recently.
- if (!is.null(args$x)) {
- width_x <- ncol(args$x) + rnms
- height_x <- nrow(args$x) + cnms
- } else {
- width_x <- 1
- height_x <- 1
- }
 
- if (!is.null(left)) {
- fcol <- min(from_col) - left - width_x + 1L
- frow <- min(from_row)
- } else if (!is.null(right)) {
- fcol <- max(from_col) + right
- frow <- min(from_row)
- } else if (!is.null(above)) {
- fcol <- min(from_col)
- frow <- min(from_row) - above - height_x + 1L
- } else if (!is.null(below)) {
- fcol <- min(from_col)
- frow <- max(from_row) + below
- } else {
- fcol <- max(from_col)
- frow <- max(from_row)
- }
-
- # guard against negative values
- if (fcol < 1) {
- warning("columns cannot be left of column A (integer position 1). resetting")
- fcol <- 1
- }
- if (frow < 1) {
- warning("rows cannot be above of row 1 (integer position 1). resetting")
- frow <- 1
- }
+ # there can be only one
+ if (length(c(left, right, above, below)) > 1) {
+ stop("can only be one direction")
+ }
 
-  args$from_col <- int2col(fcol)
-   args$from_row <- frow
-   args$from_dims <- NULL
+ # default is column names and no row names
+ cnms <- args$col_names %||% 1
+ rnms <- args$row_names %||% 0
 
+ # NCOL(NULL)/NROW(NULL) could work as well, but the behavior might have
+ # changed recently.
+ if (!is.null(args$x)) {
+ width_x <- NCOL(args$x) + rnms
+ height_x <- NROW(args$x) + cnms
+ } else {
+ width_x <- 1
+ height_x <- 1
+ }
+
+ if (!is.null(left)) {
+ fcol <- min(fcol) - left - width_x + 1L
+ frow <- min(frow)
+ } else if (!is.null(right)) {
+ fcol <- max(fcol) + right
+ frow <- min(frow)
+ } else if (!is.null(above)) {
+ fcol <- min(fcol)
+ frow <- min(frow) - above - height_x + 1L
+ } else if (!is.null(below)) {
+ fcol <- min(fcol)
+ frow <- max(frow) + below
+ } else {
+ fcol <- max(fcol)
+ frow <- max(frow)
+ }
+ if (length(fcol) == 0) {
+ fcol <- 1
+ }
+ if (length(frow) == 0) {
+ frow <- 1
+ }
+ # guard against negative values
+ if (fcol < 1) {
+ warning("columns cannot be left of column A (integer position 1). resetting")
+ fcol <- 1
+ }
+ if (frow < 1) {
+ warning("rows cannot be above of row 1 (integer position 1). resetting")
+ frow <- 1
  }
 
  # After this point, all unnamed problems are solved ;)
@@ -786,6 +793,11 @@ wb_dims <- function(..., select = NULL) {
  select <- determine_select_valid(args = args, select = select)
 
  check_wb_dims_args(args, select = select)
+
+ args$from_col <- col2int(fcol)
+ args$from_row <- frow
+ args$from_dims <- NULL
+
  rows_arg <- args$rows
  rows_arg <- if (is.character(rows_arg)) {
  col2int(rows_arg)
@@ -852,7 +864,7 @@ wb_dims <- function(..., select = NULL) {
  frow <- as.integer(frow)
  }
 
- # from_row is a function of col_names, from_rows and cols.
+ # from_row is a function of col_names, from_row and cols.
  # cols_seq should start at 1 after this
  # if from_row = 4, rows = 4:7,
  # then frow = 4 + 4 et rows = seq_len(length(rows))
@@ -861,24 +873,26 @@ wb_dims <- function(..., select = NULL) {
 
  # from_row / from_col = 0 only acceptable in certain cases.
  if (!all(length(fcol) == 1, length(frow) == 1, fcol >= 1, frow >= 1)) {
- stop("`from_col` / `from_row` should have length 1, and be positive.")
+ stop("`from_col` / `from_row` must be a single positive number.")
  }
 
  if (select == "col_names") {
- if (is.null(cols_arg) || length(cols_arg) %in% c(0, 1))
+ if (is.null(cols_arg) || length(cols_arg) %in% c(0, 1)) {
  ncol_to_span <- ncol(x)
- else
+ } else {
  ncol_to_span <- cols_arg
+ }
  nrow_to_span <- 1L
  } else if (select == "row_names") {
  ncol_to_span <- 1L
  nrow_to_span <- nrow(x) %||% 1L
  } else if (select %in% c("x", "data")) {
  if (!is.null(cols_arg)) {
- if (length(cols_arg) == 1)
+ if (length(cols_arg) == 1) {
  ncol_to_span <- length(cols_arg)
- else
+ } else {
  ncol_to_span <- cols_arg
+ }
  } else {
  ncol_to_span <- ncol(x) %||% 1L
  }
@@ -912,10 +926,11 @@ wb_dims <- function(..., select = NULL) {
 
  if (!is.null(rows_arg)) { # && length(rows_arg) == 1L && all(diff(rows_arg) == 1L)) {
  if (min(rows_arg) > 1) {
- if (all(diff(rows_arg) == 1L))
+ if (all(diff(rows_arg) == 1L)) {
  frow <- frow + min(rows_arg) - 1L
- else
+ } else {
  frow <- vapply(rows_arg, function(x) frow + min(x) - 1L, NA_real_)
+ }
  }
  }
 
@@ -942,16 +957,17 @@ wb_dims <- function(..., select = NULL) {
  ncol_to_span <- 1L
  }
 
- if (all(diff(frow) == 1))
+ if (all(diff(frow) == 1)) {
  row_span <- frow + seq_len(nrow_to_span) - 1L
- else
+ } else {
  row_span <- frow
+ }
 
- if (length(ncol_to_span) == 1)
+ if (length(ncol_to_span) == 1) {
  col_span <- fcol + seq_len(ncol_to_span) - 1L
- else # what does this do?
+ } else { # what does this do?
  col_span <- fcol + ncol_to_span - 1L
-
+ }
  # return single cells (A1 or A1,B1)
  if (length(row_span) == 1 && (length(col_span) == 1 || any(diff(col_span) != 1L))) {
 

diff --git a/man/openxlsx2-package.Rd b/man/openxlsx2-package.Rd
diff --git a/tests/testthat/test-converters.R b/tests/testthat/test-converters.R
@@ -1,7 +1,7 @@
 test_that("int2col", {
-
  expect_equal(int2col(1:10), LETTERS[1:10])
- expect_error(int2col("a"), "x must be numeric.")
+ expect_error(int2col("a"), "x must be finite and numeric.")
+ expect_error(int2col(Inf))
 })
 
 test_that("col2int", {

diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
@@ -125,6 +125,50 @@ test_that("wb_dims() works when not supplying `x`.", {
  expect_error(wb_dims(1, 1, row_names = FALSE), "`row_names`")
 })
 
+test_that("wb_dims() works with above and one line", {
+ expect_equal(wb_dims(x = names(mtcars), from_row = 2), "A2:A12")
+
+ # doesn't work
+ # expect_equal(wb_dims(x = names(mtcars), from_row = 3, above = 1), "A2:A12")
+
+ expect_warning(
+ expect_equal(
+ wb_dims(x = names(mtcars), from_row = 2, above = 1),
+ "A1:A11"
+ ),
+ "rows cannot be above of row 1 "
+ )
+
+ expect_warning(
+ expect_equal(
+ wb_dims(x = names(mtcars), from_dims = "A2", above = 1),
+ "A1:A11"),
+ "rows cannot be above of row 1 "
+ )
+
+ # Doesn't work returns A1:A11
+ # expect_equal(wb_dims(x = names(mtcars), from_dims = "A3", above = 1), "A2:A12")
+ # Doesn't work returns A1:A11
+ # expect_equal(wb_dims(x = names(mtcars), from_dims = "A4", above = 1), "A3:A13")
+
+ # currently the only ways to create horizontal single row dims with wb_dims()
+
+ nms <- mtcars[NULL, ]
+
+ expect_equal(wb_dims(x = nms, from_row = 3), "A3:K3")
+ expect_equal(wb_dims(x = nms, from_row = 3, above = 1), "A2:K2")
+ expect_equal(wb_dims(x = nms, from_dims = "A3"), "A3:K3")
+ expect_equal(wb_dims(x = nms, from_dims = "A3", above = 1), "A2:K2")
+ expect_equal(wb_dims(x = nms, from_dims = "A4", above = 1), "A3:K3")
+
+ expect_equal(wb_dims(x = t(names(mtcars)), col_names = FALSE, from_row = 3), "A3:K3")
+ expect_equal(wb_dims(x = t(names(mtcars)), col_names = FALSE, from_row = 3, above = 1), "A2:K2")
+ expect_equal(wb_dims(x = t(names(mtcars)), col_names = FALSE, from_dims = "A3"), "A3:K3")
+ expect_equal(wb_dims(x = t(names(mtcars)), col_names = FALSE, from_dims = "A3", above = 1), "A2:K2")
+ expect_equal(wb_dims(x = t(names(mtcars)), col_names = FALSE, from_dims = "A4", above = 1), "A3:K3")
+
+})
+
 test_that("`wb_dims()` can select content in a nice fashion with `x`", {
  # Selecting content
  # Assuming that the data was written to a workbook with: