diff --git a/NAMESPACE b/NAMESPACE index baf27afad..4f76bcca4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -95,6 +95,7 @@ importFrom(vctrs,vec_as_location) importFrom(vctrs,vec_as_location2) importFrom(vctrs,vec_as_names) importFrom(vctrs,vec_as_names_legacy) +importFrom(vctrs,vec_as_subscript) importFrom(vctrs,vec_as_subscript2) importFrom(vctrs,vec_assign) importFrom(vctrs,vec_c) diff --git a/R/subsetting.R b/R/subsetting.R index 088b952b9..29c4f3fcd 100644 --- a/R/subsetting.R +++ b/R/subsetting.R @@ -416,7 +416,7 @@ tbl_subset2 <- function(x, j, j_arg) { .subset2(x, j) } -tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) { +tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg, call = caller_env()) { if (is.null(i)) { xo <- unclass(x) @@ -426,7 +426,7 @@ tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) { j <- seq_along(xo) names(j) <- names2(j) } else if (!is.null(j_arg)) { - j <- vectbl_as_new_col_index(j, xo, j_arg, names2(value), value_arg) + j <- vectbl_as_new_col_index(j, xo, j_arg, names2(value), value_arg, call = call) } value <- vectbl_recycle_rhs_rows(value, fast_nrow(xo), i_arg = NULL, value_arg) @@ -453,7 +453,7 @@ tbl_subassign <- function(x, i, j, value, i_arg, j_arg, value_arg) { # (Invariant: x[[j]] is equivalent to x[[vec_as_location(j)]], # allowed by corollary that only existing columns can be updated) if (!is.null(j_arg)) { - j <- vectbl_as_new_col_index(j, xo, j_arg, names2(value), value_arg) + j <- vectbl_as_new_col_index(j, xo, j_arg, names2(value), value_arg, call = call) } # Fill up columns if necessary @@ -496,12 +496,16 @@ vectbl_as_new_row_index <- function(i, x, i_arg) { } } -vectbl_as_new_col_index <- function(j, x, j_arg, names = "", value_arg = NULL) { +vectbl_as_new_col_index <- function(j, x, j_arg, names = "", value_arg = NULL, call = caller_env()) { # Creates a named index vector # Values: index # Name: column name (for all columns) - if (is_bare_character(j)) { + if (is.object(j)) { + j <- vectbl_as_col_subscript(j, j_arg = j_arg, assign = TRUE, call = call) + } + + if (is.character(j)) { if (anyNA(j)) { abort_assign_columns_non_na_only() } @@ -516,7 +520,7 @@ vectbl_as_new_col_index <- function(j, x, j_arg, names = "", value_arg = NULL) { } else { new <- NULL } - } else if (is_bare_numeric(j)) { + } else if (is.numeric(j)) { if (anyNA(j)) { abort_assign_columns_non_na_only() } @@ -627,8 +631,20 @@ vectbl_as_col_location2 <- function(j, n, names = NULL, j_arg, assign = FALSE, c subclass_col_index_errors(vec_as_location2(j, n, names, call = call), j_arg = j_arg, assign = assign) } +vectbl_as_col_subscript <- function(j, j_arg, assign = FALSE, call = caller_env()) { + subclass_col_index_errors( + vec_as_subscript(j, call = call), + j_arg = j_arg, + assign = assign + ) +} + vectbl_as_col_subscript2 <- function(j, j_arg, assign = FALSE, call = my_caller_env()) { - subclass_col_index_errors(vec_as_subscript2(j, logical = "error", call = call), j_arg = j_arg, assign = assign) + subclass_col_index_errors( + vec_as_subscript2(j, logical = "error", call = call), + j_arg = j_arg, + assign = assign + ) } is_tight_sequence_at_end <- function(i_new, n) { diff --git a/R/tibble-package.R b/R/tibble-package.R index 6ecf3a7d0..fee9a431a 100644 --- a/R/tibble-package.R +++ b/R/tibble-package.R @@ -12,6 +12,7 @@ #' @importFrom vctrs vec_as_location2 #' @importFrom vctrs vec_as_names #' @importFrom vctrs vec_as_names_legacy +#' @importFrom vctrs vec_as_subscript #' @importFrom vctrs vec_as_subscript2 #' @importFrom vctrs vec_assign #' @importFrom vctrs vec_c diff --git a/tests/testthat/_snaps/subsetting.md b/tests/testthat/_snaps/subsetting.md index a9b98e393..313cc59c3 100644 --- a/tests/testthat/_snaps/subsetting.md +++ b/tests/testthat/_snaps/subsetting.md @@ -423,11 +423,6 @@ x `as.list(1:3)` must be logical, numeric, or character, not a list. Code foo[factor(1:3)] <- 1 - Condition - Error in `[<-`: - ! Can't assign to columns that don't exist. - x Columns `1`, `2`, and `3` don't exist. - Code foo[Sys.Date()] <- 1 Condition Error in `[<-`: diff --git a/tests/testthat/test-subsetting.R b/tests/testthat/test-subsetting.R index 5ef30d0d0..497f55a5b 100644 --- a/tests/testthat/test-subsetting.R +++ b/tests/testthat/test-subsetting.R @@ -403,6 +403,7 @@ test_that("can use classed character indexes (#778)", { expect_null(df[[mychr("c")]]) expect_silent(df[mychr(letters[1:2])] <- df) + expect_silent(df[mychr(letters[3:4])] <- df) expect_silent(df[[mychr("c")]] <- 1) expect_silent(df[[mychr("a")]] <- df[["a"]]) }) @@ -413,7 +414,8 @@ test_that("can use classed integer indexes (#778)", { expect_identical(df[myint(1:3), myint(1:2)], df) expect_identical(df[[myint(2)]], df[[2]]) - expect_silent(df[mylgl(TRUE), ] <- df) + expect_silent(df[myint(1:2)] <- df) + expect_silent(df[myint(3:4)] <- list(c = 4, d = 5)) expect_silent(df[[myint(2)]] <- df[[2]]) expect_silent(df[[myint(3)]] <- 1) }) @@ -422,6 +424,8 @@ test_that("can use classed logical indexes (#778)", { df <- tibble::tibble(a = 1:3, b = LETTERS[1:3]) expect_identical(df[mylgl(TRUE), mylgl(TRUE)], df) + + expect_silent(df[mylgl(TRUE), ] <- df) expect_silent(df[mylgl(TRUE), mylgl(TRUE)] <- df) })