Add from_dims to wb_dims (#960)

* Add from_dims to wb_dims

* [wb_dims] implement a poor mans solution for left, right, above and below

* [wb_dims] handle col_names and row_names with from_dims

---------

Co-authored-by: Jan Marvin Garbuszus <jan.garbuszus@rub.de>

NEWS.md

@@ -6,6 +6,8 @@
 
 * `wb_add_data_table()` gained a new `total_row` argument. This allows to add a total row to spreadsheets including text and spreadsheet formulas.
 
+* `wb_dims()` now accepts `from_dims` to specify a starting cell [960](https://github.com/JanMarvin/openxlsx2/pull/960).
+
 ## Fixes
 
 * Export `wb_add_ignore_error()`. [955](https://github.com/JanMarvin/openxlsx2/pull/955)

R/class-workbook.R

@@ -43,7 +43,7 @@
 #' # add some data
 #' wb$add_data("sheet", cars)
 #' # Add data with piping in a different location
-#' wb <- wb %>% wb_add_data(x = cars, dims = wb_dims(from_col = "D", from_row = 4))
+#' wb <- wb %>% wb_add_data(x = cars, dims = wb_dims(from_dims = "D4"))
 #' # open it in your default spreadsheet software
 #' if (interactive()) wb$open()
 #' ```

R/utils.R

@@ -177,6 +177,9 @@ NULL
 #' @export
 dims_to_rowcol <- function(x, as_integer = FALSE) {
 
+  # FIXME gives a hard to debug error if providing garbage x
+  # dims_to_rowcol("65")
+  #> Error stoi
   dims <- x
   if (length(x) == 1 && grepl(";", x))
     dims <- unlist(strsplit(x, ";"))
@@ -250,7 +253,7 @@ rowcol_to_dim <- function(row, col) {
 check_wb_dims_args <- function(args, select = NULL) {
   select <- match.arg(select, c("x", "data", "col_names", "row_names"))
 
-  cond_acceptable_len_1 <- !is.null(args$from_row) || !is.null(args$from_col) || !is.null(args$x)
+  cond_acceptable_len_1 <- !is.null(args$from_row) || !is.null(args$from_col) || !is.null(args$x) || !is.null(args$from_dims)
   nams <- names(args) %||% rep("", length(args))
   all_args_unnamed <- !any(nzchar(nams))
 
@@ -259,7 +262,7 @@ check_wb_dims_args <- function(args, select = NULL) {
     sentence_unnamed <- ifelse(all_args_unnamed, " unnamed ", " ")
     stop(
       "Supplying a single", sentence_unnamed, "argument to `wb_dims()` is not supported. \n",
-      "Use any of `x`, `from_row` `from_col`. You can also use `rows` and `cols`, or `dims = NULL`",
+      "Use any of `x`, `from_dims`, `from_row` `from_col`. You can also use `rows` and `cols`, or `dims = NULL`",
       call. = FALSE
     )
   }
@@ -422,7 +425,7 @@ determine_select_valid <- function(args, select = NULL) {
 #' If you need another behavior, use `wb_dims()` without supplying `x`.
 #'
 #' * `x` An object (typically a `matrix` or a `data.frame`, but a vector is also accepted.)
-#' * `from_row` / `from_col` the starting position of `x`
+#' * `from_row` / `from_col` / `from_dims` the starting position of `x`
 #'   (The `dims` returned will assume that the top left corner of `x` is at `from_row / from_col`
 #' * `rows` Optional Which row span in `x` should this apply to.
 #'   If `rows` = 0, only column names will be affected.
@@ -440,7 +443,7 @@ determine_select_valid <- function(args, select = NULL) {
 #' In the `add_data()` / `add_font()` example, if writing the data with row names
 #'
 #' @param ... construct `dims` arguments, from rows/cols vectors or objects that
-#'   can be coerced to data frame. `x`, `rows`, `cols`, `from_row`, `from_col`,
+#'   can be coerced to data frame. `x`, `rows`, `cols`, `from_row`, `from_col`, `from_dims`
 #'   `row_names`, and `col_names` are accepted.
 #' @param select A string, one of the followings.
 #'    it improves the selection of various parts of `x`
@@ -466,7 +469,7 @@ determine_select_valid <- function(args, select = NULL) {
 #' # provide `from_col` / `from_row`
 #' wb_dims(rows = 1:10, cols = c("A", "B", "C"), from_row = 2)
 #' wb_dims(rows = 1:10, cols = 1:10, from_col = 2)
-#'
+#' wb_dims(rows = 1:10, cols = 1:10, from_dims = "B1")
 #' # or objects
 #' wb_dims(x = mtcars, col_names = TRUE)
 #'
@@ -510,13 +513,13 @@ wb_dims <- function(..., select = NULL) {
   len <- length(args)
 
   if (len == 0 || (len == 1 && is.null(args[[1]]))) {
-    stop("`wb_dims()` requires `rows`, `cols`, `from_row`, `from_col`, or `x`.")
-    return("A1")
+    stop("`wb_dims()` requires `rows`, `cols`, `from_row`, `from_col`, `from_dims`, or `x`.")
   }
 
   # nams cannot be NULL now
   nams <- names(args) %||% rep("", len)
-  valid_arg_nams <- c("x", "rows", "cols", "from_row", "from_col", "row_names", "col_names")
+  valid_arg_nams <- c("x", "rows", "cols", "from_row", "from_col", "from_dims", "row_names", "col_names",
+                      "left", "right", "above", "below")
   any_args_named <- any(nzchar(nams))
   # unused, but can be used, if we need to check if any, but not all
   # Check if valid args were provided if any argument is named.
@@ -550,7 +553,7 @@ wb_dims <- function(..., select = NULL) {
   if (nams[1] == "" && !ok_if_arg1_unnamed) {
     stop(
       "The first argument must either be named or be a vector.",
-      "Providing a single named argument must either be `from_row`, `from_col` or `x`."
+      "Providing a single named argument must either be `from_dims` `from_row`, `from_col` or `x`."
     )
   }
 
@@ -587,10 +590,77 @@ wb_dims <- function(..., select = NULL) {
     stop("Internal error, all arguments should be named after this point.")
   }
 
+  # 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)
+
+    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
+
+    # 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
+    }
+
+    args$from_col  <- int2col(fcol)
+    args$from_row  <- frow
+    args$from_dims <- NULL
+
+  }
+
   # After this point, all unnamed problems are solved ;)
   x <- args$x
   if (!is.null(select) && is.null(args$x)) {
-    stop("`select` should only be provided with `x`.")
+    stop("`select` must only be provided with `x`.")
   }
 
   # little helper that streamlines which inputs cannot be
@@ -680,7 +750,7 @@ 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` should have length 1, and be positive.")
   }
 
   if (select == "col_names") {

tests/testthat/test-utils.R

@@ -256,6 +256,27 @@ test_that("`wb_dims()` handles row_names = TRUE consistenly.", {
   # Style row names of an object
 })
 
+test_that("wb_dims() handles `from_dims`", {
+  expect_equal(
+    wb_dims(from_dims = "A3"),
+    "A3"
+  )
+  expect_error(
+    wb_dims(from_dims = "A1", from_col = 2)
+  )
+  expect_error(
+    wb_dims(from_dims = "A1", from_row = 2)
+  )
+  expect_error(
+    wb_dims(from_dims = "A1", from_row = 2, from_col = 2)
+  )
+  expect_equal(
+    wb_dims(x = mtcars, from_dims = "B7"),
+    wb_dims(x = mtcars, from_col = "B", from_row = 7)
+  )
+  expect_error(wb_dims(from_dims = "65"))
+})
+
 test_that("create_char_dataframe", {
 
   exp <- data.frame(x1 = rep("", 5), z1 = rep("", 5), stringsAsFactors = FALSE)
@@ -424,3 +445,53 @@ test_that("fmt_txt works", {
   expect_equal(exp, got)
 
 })
+
+test_that("wb_dims(from_dims) positioning works", {
+
+  mm <- matrix(1:4, 2, 2)
+
+  # positioning
+  dims1 <- wb_dims(from_dims = "B2")
+  dims2 <- wb_dims(from_dims = dims1, below = 2)
+  dims3 <- wb_dims(from_dims = dims2, right = 2)
+  dims4 <- wb_dims(from_dims = dims3, above = 2)
+  dims5 <- wb_dims(from_dims = dims4, left = 2)
+
+  exp <- c("B2", "B4", "D4", "D2", "B2")
+  got <- c(dims1, dims2, dims3, dims4, dims5)
+  expect_equal(exp, got)
+
+  # positioning with x
+  dims1 <- wb_dims(from_dims = "B2", x = mm)
+  dims2 <- wb_dims(from_dims = dims1, x = mm, below = 2)
+  dims3 <- wb_dims(from_dims = dims2, x = mm, right = 2)
+  dims4 <- wb_dims(from_dims = dims3, x = mm, above = 2)
+  dims5 <- wb_dims(from_dims = dims4, x = mm, left = 2)
+
+  exp <- c("B2:C4", "B6:C8", "E6:F8", "E2:F4", "B2:C4")
+  got <- c(dims1, dims2, dims3, dims4, dims5)
+  expect_equal(exp, got)
+
+  # col_names = FALSE
+  dims1 <- wb_dims(from_dims = "B2", x = mm, col_names = FALSE)
+  dims2 <- wb_dims(from_dims = dims1, x = mm, below = 2, col_names = FALSE)
+  dims3 <- wb_dims(from_dims = dims2, x = mm, right = 2, col_names = FALSE)
+  dims4 <- wb_dims(from_dims = dims3, x = mm, above = 2, col_names = FALSE)
+  dims5 <- wb_dims(from_dims = dims4, x = mm, left = 2, col_names = FALSE)
+
+  exp <- c("B2:C3", "B5:C6", "E5:F6", "E2:F3", "B2:C3")
+  got <- c(dims1, dims2, dims3, dims4, dims5)
+  expect_equal(exp, got)
+
+  # row_names = TRUE
+  dims1 <- wb_dims(from_dims = "B2", x = mm, row_names = TRUE)
+  dims2 <- wb_dims(from_dims = dims1, x = mm, below = 2, row_names = TRUE)
+  dims3 <- wb_dims(from_dims = dims2, x = mm, right = 2, row_names = TRUE)
+  dims4 <- wb_dims(from_dims = dims3, x = mm, above = 2, row_names = TRUE)
+  dims5 <- wb_dims(from_dims = dims4, x = mm, left = 2, row_names = TRUE)
+
+  exp <- c("B2:D4", "B6:D8", "F6:H8", "F2:H4", "B2:D4")
+  got <- c(dims1, dims2, dims3, dims4, dims5)
+  expect_equal(exp, got)
+
+})

vignettes/openxlsx2_style_manual.Rmd

@@ -298,7 +298,7 @@ colnames(mat) <- make.names(seq_len(ncol(mat)))
 
 wb <- wb_workbook() %>%
   wb_add_worksheet("test") %>%
-  wb_add_data(x = mat, dims = wb_dims(from_row = 2, from_col = 2)) %>%
+  wb_add_data(x = mat, dims = wb_dims(from_dims = "B2")) %>%
   # center first row
   wb_add_cell_style(dims = "B2:C2", horizontal = "center") %>%
   # add border for first row