Skip to content
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

Jump to bottom

[dims] simplify wb_dims(). fixes #1124 #1125

Merged
merged 2 commits into from
Sep 2, 2024
Merged

[dims] simplify wb_dims(). fixes #1124 #1125

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
9c54db0
[dims] simplify `wb_dims()`. This breaks a few previously valid cases…
JanMarvin Aug 31, 2024
b4de294
[misc] cleanup
JanMarvin Aug 31, 2024
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
256 changes: 103 additions & 153 deletions R/utils.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -676,20 +676,29 @@ wb_dims <- function(..., select = NULL) {
)
}

rows_arg <- args$rows
cols_arg <- args$cols

if (n_unnamed_args == 1 && len > 1 && !"rows" %in% nams) {
message("Assuming the first unnamed argument to be `rows`.")
nams[which(nams == "")[1]] <- "rows"
rows_pos <- which(nams == "")[1]
nams[rows_pos] <- "rows"
names(args) <- nams
n_unnamed_args <- length(which(!nzchar(nams)))
all_args_unnamed <- n_unnamed_args == len

rows_arg <- args[[rows_pos]]
}

if (n_unnamed_args == 1 && len > 1 && "rows" %in% nams) {
message("Assuming the first unnamed argument to be `cols`.")
nams[which(nams == "")[1]] <- "cols"
cols_pos <- which(nams == "")[1]
nams[cols_pos] <- "cols"
names(args) <- nams
n_unnamed_args <- length(which(!nzchar(nams)))
all_args_unnamed <- n_unnamed_args == len

cols_arg <- args[[cols_pos]]
}

# if 2 unnamed arguments, will be rows, cols.
Expand All @@ -701,6 +710,22 @@ wb_dims <- function(..., select = NULL) {
names(args) <- nams
n_unnamed_args <- length(which(!nzchar(nams)))
all_args_unnamed <- n_unnamed_args == len

rows_arg <- args[[rows_pos]]
cols_arg <- args[[cols_pos]]
}
Copy link
Owner Author

Choose a reason for hiding this comment

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

Either have x or rows_arg/cols_arg.


if (!is.null(cols_arg) && (min(col2int(cols_arg)) < 1L)) {
stop("You must supply positive values to `cols`")
}

# in case the user mixes up column and row
if (is.character(rows_arg) && !all(is_charnum(rows_arg))) {
stop("`rows` is character and contains nothing that can be interpreted as number.")
}

if (!is.null(rows_arg) && (min(as.integer(rows_arg)) < 1L)) {
stop("You must supply positive values to `rows`.")
}

# Just keeping this as a safeguard
Expand All @@ -709,23 +734,28 @@ 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) {
if (length(args$from_col) > 1 || length(args$from_row) > 1 ||
(!is.null(args$from_row) && is.character(args$from_row) && !is_charnum(args$from_row))) {
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]])
fcol <- from_row_and_col[[1]]
frow <- from_row_and_col[[2]]
} else {
fcol <- args$from_col %||% 1L
frow <- args$from_row %||% 1L
}

fcol <- col2int(fcol)
frow <- col2int(frow)

left <- args$left
right <- args$right
above <- args$above
Expand Down Expand Up @@ -792,198 +822,118 @@ wb_dims <- function(..., select = NULL) {
# little helper that streamlines which inputs cannot be
select <- determine_select_valid(args = args, select = select)

# TODO: we warn, but fail not? Shouldn't we fail?
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)
} else if (!is.null(rows_arg)) {
as.integer(rows_arg)
} else if (!is.null(args$x)) {
# rows_arg <- seq_len(nrow(args$x))
rows_arg <- NULL
} else {
1L
}
if (!is.null(rows_arg)) rows_arg <- as.integer(rows_arg)
if (!is.null(frow)) frow <- as.integer(frow)

assert_class(rows_arg, class = "integer", arg_nm = "rows", or_null = TRUE)
# Checking cols (if it is a column name)
cols_arg <- args$cols
x_has_named_dims <- inherits(x, "data.frame") || inherits(x, "matrix")
x_has_colnames <- !is.null(colnames(x))

if (!is.null(x)) {
x <- as.data.frame(x)
}

cnam_null <- is.null(args$col_names)
col_names <- args$col_names %||% x_has_named_dims
cnam <- isTRUE(args$col_names)
col_names <- if (!is.null(args$col_names)) args$col_names else x_has_named_dims
row_names <- if (!is.null(args$row_names)) args$row_names else FALSE

if (!cnam_null && !x_has_named_dims) {
if (cnam && !x_has_named_dims) {
stop("Can't supply `col_names` when `x` is a vector.\n", "Transform `x` to a data.frame")
}

row_names <- args$row_names %||% FALSE
assert_class(col_names, "logical")
assert_class(row_names, "logical")

# Find column location id if `cols` is a character and is a colname of x
if (x_has_colnames && !is.null(cols_arg)) {
is_cols_a_colname <- cols_arg %in% colnames(x)

if (any(is_cols_a_colname)) {
cols_arg <- which(colnames(x) %in% cols_arg)
}
}

if (!is.null(cols_arg)) {
# special condition, can be cell reference
if (is.null(x) && is.character(cols_arg)) {
cols_arg <- col2int(cols_arg)
assert_class(cols_arg, class = "integer", arg_nm = "cols")
} else if (!is.null(args$x)) {
cols_arg <- NULL
} else {
cols_arg <- 1L # no more NULL for cols_arg and rows_arg if `x` is not supplied
}

if (!is.null(cols_arg) && (min(cols_arg) < 1L)) {
stop("You must supply positive values to `cols`")
}

if (!is.null(rows_arg) && (min(rows_arg) < 1L)) {
stop("You must supply positive values to `rows`.")
}

# assess from_row / from_col
if (is.character(args$from_row)) {
frow <- col2int(args$from_row)
} else {
frow <- args$from_row %||% 1L
frow <- as.integer(frow)
}
# get base dimensions
cols_all <- if (!is.null(x)) seq_len(NCOL(x)) else cols_arg
rows_all <- if (!is.null(x)) seq_len(NROW(x)) else rows_arg

# 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))
fcol <- col2int(args$from_col) %||% 1L
# after this point, no assertion, assuming all elements to be acceptable

# 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` must be a single positive number.")
}
# get selections in this base
cols_sel <- if (is.null(cols_arg)) cols_all else cols_arg
rows_sel <- if (is.null(rows_arg)) rows_all else rows_arg

if (select == "col_names") {
if (is.null(cols_arg) || length(cols_arg) %in% c(0, 1)) {
ncol_to_span <- ncol(x)
} 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) {
ncol_to_span <- length(cols_arg)
} else {
ncol_to_span <- cols_arg
}
} else {
ncol_to_span <- ncol(x) %||% 1L
}
if (!is.null(rows_arg)) {
nrow_to_span <- length(rows_arg)
} else {
nrow_to_span <- nrow(x) %||% 1L
}

if (select == "x") {
nrow_to_span <- nrow_to_span + col_names
ncol_to_span <- ncol_to_span + row_names
# if cols is a column name from x
if (!is.null(x) && is.character(cols_sel) && any(cols_sel %in% names(x))) {
names(cols_all) <- names(x)
cols_sel <- match(cols_sel, names(cols_all))
if (length(cols_sel) == 0) {
warning("selected column not found in `x`.")
cols_sel <- cols_all
}
}

# Setting frow / fcol correctly.
if (select == "row_names") {
fcol <- fcol
frow <- frow + col_names
} else if (select == "col_names") {
fcol <- fcol + row_names
frow <- frow
} else if (select %in% c("x", "data")) {
if (!is.null(cols_arg) && length(cols_arg) == 1L && all(diff(cols_arg) == 1L)) {
if (min(cols_arg) > 1) {
fcol <- fcol + min(cols_arg) - 1L # does not work with multi select
}
} else {
fcol <- fcol #+ row_names
}

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)) {
frow <- frow + min(rows_arg) - 1L
} else {
frow <- vapply(rows_arg, function(x) frow + min(x) - 1L, NA_real_)
}
}
}
# reduce to required length
col_span <- cols_all[cols_all %in% cols_sel]
row_span <- rows_all[rows_all %in% rows_sel]

if (select == "data") {
fcol <- fcol + row_names
frow <- frow + col_names
}
# if required add column name and row name
if (col_names) row_span <- c(max(min(row_span, 1), 1L), row_span + 1L)
if (row_names) col_span <- c(max(min(col_span, 1), 1L), col_span + 1L)

# for cases were cols and rows are vectors and row 1 is selected
# frow is a scalar and rows_arg is a vector. We need the vector.
# it's mystery, why crossing 1 is such an issue.
if (is.null(args$x) && !all(diff(rows_arg) == 1L)) {
diff <- min(frow) - min(rows_arg)
frow <- diff + rows_arg
}
# data has no column name
if (!is.null(x) && select == "data") {
if (col_names) row_span <- row_span[-1]
if (row_names) col_span <- col_span[-1]
}

# Ensure we are spanning at least 1 row and 1 col
if (identical(nrow_to_span, 0L)) {
nrow_to_span <- 1L
# column name has only the column name
if (!is.null(x) && select == "col_names") {
if (col_names) row_span <- row_span[1] # else 0?
if (row_names) col_span <- col_span[-1]
}

if (identical(ncol_to_span, 0L)) {
ncol_to_span <- 1L
if (!is.null(x) && select == "row_names") {
if (col_names) row_span <- row_span[-1]
if (row_names) col_span <- col_span[1] # else 0?
}

if (all(diff(frow) == 1)) {
row_span <- frow + seq_len(nrow_to_span) - 1L
} else {
row_span <- frow
}
# This can happen if only from_col or from_row is supplied
if (length(row_span) == 0) row_span <- 1L
if (length(col_span) == 0) col_span <- 1L

# frow & fcol start at 1
row_span <- row_span + (frow - 1L)
col_span <- col_span + (fcol - 1L)

if (length(ncol_to_span) == 1) {
col_span <- fcol + seq_len(ncol_to_span) - 1L
} 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))) {
if ((length(row_span) == 1 || any(diff(row_span) != 1L)) && (length(col_span) == 1 || any(diff(col_span) != 1L))) {

# A1
row_start <- row_span
col_start <- col_span

dims <- NULL

if (any(diff(col_span) != 1L)) {
for (col_start in col_span) {
tmp <- rowcol_to_dim(row_start, col_start)
dims <- c(dims, tmp)
if (any(diff(row_span) != 1L)) {
for (row_start in row_span) {
cdims <- NULL
if (any(diff(col_span) != 1L)) {
for (col_start in col_span) {
tmp <- rowcol_to_dim(row_start, col_start)
cdims <- c(cdims, tmp)
}
} else {
cdims <- rowcol_to_dim(row_start, col_span)
}
dims <- c(dims, cdims)
}
} else {
dims <- rowcol_to_dim(row_start, col_start)
if (any(diff(col_span) != 1L)) {
for (col_start in col_span) {
tmp <- rowcol_to_dim(row_span, col_start)
dims <- c(dims, tmp)
}
} else {
dims <- rowcol_to_dim(row_span, col_span)
}
}

} else { # return range "A1:A7" or "A1:A7,B1:B7"
Expand Down
Loading
Loading