diff --git a/NAMESPACE b/NAMESPACE index 1a073f2a0..c71e6db5f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,7 +87,6 @@ importFrom(pillar,type_sum) importFrom(pkgconfig,set_config) importFrom(utils,head) importFrom(utils,tail) -importFrom(vctrs,"vec_slice<-") importFrom(vctrs,num_as_location) importFrom(vctrs,unspecified) importFrom(vctrs,vec_as_location) @@ -95,6 +94,7 @@ importFrom(vctrs,vec_as_location2) importFrom(vctrs,vec_as_names) importFrom(vctrs,vec_as_names_legacy) importFrom(vctrs,vec_as_subscript2) +importFrom(vctrs,vec_assign) importFrom(vctrs,vec_c) importFrom(vctrs,vec_is) importFrom(vctrs,vec_names2) diff --git a/R/subsetting-matrix.R b/R/subsetting-matrix.R index 619bcc2d2..f643039ef 100644 --- a/R/subsetting-matrix.R +++ b/R/subsetting-matrix.R @@ -28,9 +28,7 @@ tbl_subassign_matrix <- function(x, j, value, j_arg, value_arg) { withCallingHandlers( for (j in col_idx) { - xj <- x[[j]] - vec_slice(xj, cells[[j]]) <- value - x[[j]] <- xj + x[[j]] <- vectbl_assign(x[[j]], cells[[j]], value) }, vctrs_error_incompatible_type = function(cnd) { diff --git a/R/subsetting.R b/R/subsetting.R index b5648ebc3..b818bfe22 100644 --- a/R/subsetting.R +++ b/R/subsetting.R @@ -646,9 +646,7 @@ tbl_subassign_row <- function(x, i, value, value_arg) { withCallingHandlers( for (j in seq_along(x)) { - xj <- x[[j]] - vec_slice(xj, i) <- value[[j]] - x[[j]] <- xj + x[[j]] <- vectbl_assign(x[[j]], i, value[[j]]) }, vctrs_error = function(cnd) { @@ -663,6 +661,24 @@ fast_nrow <- function(x) { .row_names_info(x, 2L) } +vectbl_assign <- function(x, i, value) { + if (is.logical(value)) { + if (.Call("tibble_need_coerce", value)) { + value <- vec_slice(x, NA_integer_) + } + } else { + if (.Call("tibble_need_coerce", x)) { + d <- dim(x) + dn <- dimnames(x) + x <- vec_slice(value, rep(NA_integer_, length(x))) + dim(x) <- d + dimnames(x) <- dn + } + } + + vec_assign(x, i, value) +} + vectbl_strip_names <- function(x) { maybe_row_names <- is.data.frame(x) || is.array(x) diff --git a/R/tibble-package.R b/R/tibble-package.R index 94f6708cf..ab597a14d 100644 --- a/R/tibble-package.R +++ b/R/tibble-package.R @@ -5,7 +5,7 @@ #' @import lifecycle #' @import ellipsis #' @importFrom vctrs vec_as_location vec_as_location2 vec_as_names vec_as_names_legacy vec_c -#' @importFrom vctrs vec_is vec_rbind vec_recycle vec_size vec_slice vec_slice<- +#' @importFrom vctrs vec_is vec_rbind vec_recycle vec_size vec_slice vec_assign #' @importFrom vctrs unspecified vec_as_subscript2 num_as_location vec_ptype_abbr #' @importFrom vctrs vec_names2 vec_set_names #' @aliases NULL tibble-package diff --git a/src/coerce.c b/src/coerce.c index 5b32a8a82..bcf6cc7f4 100644 --- a/src/coerce.c +++ b/src/coerce.c @@ -61,3 +61,19 @@ SEXP tibble_string_to_indices(SEXP x) { UNPROTECT(1); return out; } + +SEXP tibble_need_coerce(SEXP x) { + if (TYPEOF(x) != LGLSXP) { + return(Rf_ScalarLogical(0)); + } + + const R_xlen_t len = Rf_xlength(x); + const int* px = LOGICAL(x); + for (R_xlen_t i = 0; i < len; ++i) { + if (px[i] != NA_LOGICAL) { + return(Rf_ScalarLogical(0)); + } + } + + return(Rf_ScalarLogical(1)); +} diff --git a/src/init.c b/src/init.c index 9354eca7d..e37781391 100644 --- a/src/init.c +++ b/src/init.c @@ -9,6 +9,7 @@ static const R_CallMethodDef CallEntries[] = { {"tibble_string_to_indices", (DL_FUNC) &tibble_string_to_indices, 1}, {"tibble_update_attrs", (DL_FUNC) &tibble_update_attrs, 2}, {"tibble_restore_impl", (DL_FUNC) &tibble_restore_impl, 2}, + {"tibble_need_coerce", (DL_FUNC) &tibble_need_coerce, 1}, {NULL, NULL, 0} }; diff --git a/src/tibble.h b/src/tibble.h index 5fab472fb..b1c762fb2 100644 --- a/src/tibble.h +++ b/src/tibble.h @@ -6,6 +6,7 @@ SEXP tibble_matrixToDataFrame(SEXP xSEXP); SEXP tibble_string_to_indices(SEXP x); +SEXP tibble_need_coerce(SEXP x); SEXP tibble_update_attrs(SEXP x, SEXP dots); SEXP tibble_restore_impl(SEXP xo, SEXP x); diff --git a/tests/testthat/_snaps/invariants.md b/tests/testthat/_snaps/invariants.md index dcf1b96a7..9a848c7d0 100644 --- a/tests/testthat/_snaps/invariants.md +++ b/tests/testthat/_snaps/invariants.md @@ -1191,11 +1191,14 @@ df$x <- NA df[2:3, "x"] <- 3:2 }) - Error - Assigned data `3:2` must be compatible with existing data. - i Error occurred for column `x`. - x Can't convert from to due to loss of precision. - * Locations: 1, 2. + Output + # A tibble: 4 x 4 + n c li x + + 1 1 e NA + 2 NA f 3 + 3 3 g 2 + 4 NA h NA Code with_df({ df$x <- NA_integer_ diff --git a/tests/testthat/_snaps/subsetting.md b/tests/testthat/_snaps/subsetting.md index a985af3c2..db611d566 100644 --- a/tests/testthat/_snaps/subsetting.md +++ b/tests/testthat/_snaps/subsetting.md @@ -557,13 +557,66 @@ `NULL` must be a vector, a bare list, a data frame or a matrix. Code # # [<-.tbl_df and overwriting NA - df <- tibble(x = rep(NA, 3)) + df <- tibble(x = rep(NA, 3), z = matrix(NA, ncol = 2, dimnames = list(NULL, c( + "a", "b")))) df[1, "x"] <- 5 - Error - Assigned data `5` must be compatible with existing data. - i Error occurred for column `x`. - x Can't convert from to due to loss of precision. - * Locations: 1. + df[1, "z"] <- 5 + df + Output + # A tibble: 3 x 2 + x z[,"a"] [,"b"] + + 1 5 5 5 + 2 NA NA NA + 3 NA NA NA + Code + # # [<-.tbl_df and overwriting with NA + df <- tibble(a = TRUE, b = 1L, c = sqrt(2), d = 0+3i + 1, e = "e", f = raw(1), + g = tibble(x = 1, y = 1), h = matrix(1:3, nrow = 1)) + df[FALSE, "a"] <- NA + df[FALSE, "b"] <- NA + df[FALSE, "c"] <- NA + df[FALSE, "d"] <- NA + df[FALSE, "e"] <- NA + df[FALSE, "f"] <- NA + df[FALSE, "g"] <- NA + df[FALSE, "h"] <- NA + df + Output + # A tibble: 1 x 8 + a b c d e f g$x $y h[,1] [,2] [,3] + + 1 TRUE 1 1.41 1+3i e 00 1 1 1 2 3 + Code + df[integer(), "a"] <- NA + df[integer(), "b"] <- NA + df[integer(), "c"] <- NA + df[integer(), "d"] <- NA + df[integer(), "e"] <- NA + df[integer(), "f"] <- NA + df[integer(), "g"] <- NA + df[integer(), "h"] <- NA + df + Output + # A tibble: 1 x 8 + a b c d e f g$x $y h[,1] [,2] [,3] + + 1 TRUE 1 1.41 1+3i e 00 1 1 1 2 3 + Code + df[1, "a"] <- NA + df[1, "b"] <- NA + df[1, "c"] <- NA + df[1, "d"] <- NA + df[1, "e"] <- NA + df[1, "f"] <- NA + df[1, "g"] <- NA + df[1, "h"] <- NA + df + Output + # A tibble: 1 x 8 + a b c d e f g$x $y h[,1] [,2] [,3] + + 1 NA NA NA NA 00 NA NA NA NA NA Code # # [<-.tbl_df and matrix subsetting foo <- tibble(a = 1:3, b = letters[1:3]) diff --git a/tests/testthat/test-subsetting.R b/tests/testthat/test-subsetting.R index 881b06d9f..24352c57d 100644 --- a/tests/testthat/test-subsetting.R +++ b/tests/testthat/test-subsetting.R @@ -924,8 +924,49 @@ test_that("output test", { df[1:3, 1:3] <- NULL "# [<-.tbl_df and overwriting NA" - df <- tibble(x = rep(NA, 3)) + df <- tibble(x = rep(NA, 3), z = matrix(NA, ncol = 2, dimnames = list(NULL, c("a", "b")))) df[1, "x"] <- 5 + df[1, "z"] <- 5 + df + + "# [<-.tbl_df and overwriting with NA" + df <- tibble( + a = TRUE, + b = 1L, + c = sqrt(2), + d = 3i + 1, + e = "e", + f = raw(1), + g = tibble(x = 1, y = 1), + h = matrix(1:3, nrow = 1) + ) + df[FALSE, "a"] <- NA + df[FALSE, "b"] <- NA + df[FALSE, "c"] <- NA + df[FALSE, "d"] <- NA + df[FALSE, "e"] <- NA + df[FALSE, "f"] <- NA + df[FALSE, "g"] <- NA + df[FALSE, "h"] <- NA + df + df[integer(), "a"] <- NA + df[integer(), "b"] <- NA + df[integer(), "c"] <- NA + df[integer(), "d"] <- NA + df[integer(), "e"] <- NA + df[integer(), "f"] <- NA + df[integer(), "g"] <- NA + df[integer(), "h"] <- NA + df + df[1, "a"] <- NA + df[1, "b"] <- NA + df[1, "c"] <- NA + df[1, "d"] <- NA + df[1, "e"] <- NA + df[1, "f"] <- NA + df[1, "g"] <- NA + df[1, "h"] <- NA + df "# [<-.tbl_df and matrix subsetting" foo <- tibble(a = 1:3, b = letters[1:3])