Merge pull request #903 from tidyverse/b-773-na-subassign

- `tbl[row, col] <- rhs` treats an all-`NA` logical vector as a missing value both for existing data (#773) and for the right-hand side value (#868). This means that a column initialized with `NA` (of type `logical`) will change its type when a row is updated to a value of a different type.
tidyverse · Jul 21, 2021 · de2abba · de2abba
2 parents 8994e1e + f30b5d9
commit de2abba
Show file tree

Hide file tree

Showing 10 changed files with 149 additions and 20 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -87,14 +87,14 @@ 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)
 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -1191,11 +1191,14 @@
         df$x <- NA
         df[2:3, "x"] <- 3:2
       })
-    Error <tibble_error_assign_incompatible_type>
-      Assigned data `3:2` must be compatible with existing data.
-      i Error occurred for column `x`.
-      x Can't convert from <integer> to <logical> due to loss of precision.
-      * Locations: 1, 2.
+    Output
+      # A tibble: 4 x 4
+            n c     li            x
+        <int> <chr> <list>    <int>
+      1     1 e     <dbl [1]>    NA
+      2    NA f     <int [2]>     3
+      3     3 g     <int [3]>     2
+      4    NA h     <chr [1]>    NA
     Code
       with_df({
         df$x <- NA_integer_

diff --git 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 <tibble_error_assign_incompatible_type>
-      Assigned data `5` must be compatible with existing data.
-      i Error occurred for column `x`.
-      x Can't convert from <double> to <logical> due to loss of precision.
-      * Locations: 1.
+      df[1, "z"] <- 5
+      df
+    Output
+      # A tibble: 3 x 2
+            x z[,"a"] [,"b"]
+        <dbl>   <dbl>  <dbl>
+      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]
+        <lgl> <int> <dbl> <cpl> <chr> <raw> <dbl> <dbl> <int> <int> <int>
+      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]
+        <lgl> <int> <dbl> <cpl> <chr> <raw> <dbl> <dbl> <int> <int> <int>
+      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]
+        <lgl> <int> <dbl> <cpl> <chr> <raw> <dbl> <dbl> <int> <int> <int>
+      1 NA       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
@@ -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])