Fix internal error in pivot_wider()

NEWS.md

@@ -1,5 +1,7 @@
 # tidyr (development version)
 
+* Fixed an internal error in `pivot_wider()` (#1609, @krlmlr).
+
 * The base pipe is now used throughout the documentation (#1613).
 
 * R >=4.1.0 is now required, in line with the [tidyverse

R/pivot-wide.R

@@ -653,16 +653,17 @@ select_wider_id_cols <- function(
 rethrow_id_cols_oob <- function(cnd, names_from_cols, values_from_cols, call) {
   i <- cnd[["i"]]
 
-  check_string(i, .internal = TRUE)
-
-  if (i %in% names_from_cols) {
-    stop_id_cols_oob(i, "names_from", call = call)
-  } else if (i %in% values_from_cols) {
-    stop_id_cols_oob(i, "values_from", call = call)
-  } else {
-    # Zap this special handler, throw the normal condition
-    zap()
+  if (is_string(i)) {
+    # Try to throw our custom error
+    if (i %in% names_from_cols) {
+      stop_id_cols_oob(i, "names_from", call = call)
+    } else if (i %in% values_from_cols) {
+      stop_id_cols_oob(i, "values_from", call = call)
+    }
   }
+
+  # Otherwise fall through and throw standard tidyselect error
+  zap()
 }
 
 stop_id_cols_oob <- function(i, arg, call) {

tests/testthat/_snaps/pivot-wide.md

@@ -111,6 +111,47 @@
       x Problematic argument:
       * name_repair = "check_unique"
 
+# doesn't crash when `id_cols` selects column removed by `names_from` (#1609)
+
+    Code
+      pivot_wider(df, id_cols = x, values_from = y, names_from = x)
+    Condition
+      Error in `pivot_wider()`:
+      ! Can't select columns past the end.
+      i Locations 1, 100, 200, and 300 don't exist.
+      i There are only 0 columns.
+
+# doesn't crash when `id_cols` selects non-existent column (#1482)
+
+    Code
+      pivot_wider(df, id_cols = c("non", "existent"), names_from = name, values_from = value)
+    Condition
+      Error in `pivot_wider()`:
+      ! Can't select columns that don't exist.
+      x Column `non` doesn't exist.
+
+---
+
+    Code
+      pivot_wider(df2, id_cols = all_of(c("a", "b", "c")), names_from = y,
+      values_from = z)
+    Condition
+      Error in `pivot_wider()`:
+      i In argument: `all_of(c("a", "b", "c"))`.
+      Caused by error in `all_of()`:
+      ! Can't subset elements that don't exist.
+      x Elements `a`, `b`, and `c` don't exist.
+
+---
+
+    Code
+      pivot_wider(df2, id_cols = 1:2, names_from = y, values_from = z)
+    Condition
+      Error in `pivot_wider()`:
+      ! Can't select columns past the end.
+      i Locations 1 and 2 don't exist.
+      i There are only 0 columns.
+
 # `names_vary` is validated
 
     Code

tests/testthat/test-pivot-wide.R

@@ -246,6 +246,60 @@ test_that("`pivot_wider_spec()` requires empty dots", {
   })
 })
 
+
+test_that("doesn't crash when `id_cols` selects column removed by `names_from` (#1609)", {
+  local_options(lifecycle_verbosity = "quiet")
+
+  # Note how we have an "external vector" here. Ideally tidyselect would error
+  # on this, but for legacy reasons we currently allow it with a warning, and it
+  # produces a weird (but correct) tidyselect error
+  x <- c(1, 100, 200, 300)
+
+  df <- tibble(
+    x = x,
+    y = c(1, 2, 3, 4)
+  )
+
+  # Should get tidyselect error, not internal error
+  expect_snapshot(error = TRUE, {
+    pivot_wider(
+      df,
+      id_cols = x,
+      values_from = y,
+      names_from = x
+    )
+  })
+})
+
+test_that("doesn't crash when `id_cols` selects non-existent column (#1482)", {
+  df <- tibble(name = c("x", "y"), value = c(1, 2))
+
+  # Should get tidyselect error, not internal error
+  expect_snapshot(error = TRUE, {
+    pivot_wider(
+      df,
+      id_cols = c("non", "existent"),
+      names_from = name,
+      values_from = value
+    )
+  })
+
+  df2 <- tibble(y = c("a", "a", "b", "c"), z = c(21, 22, 23, 24))
+
+  expect_snapshot(error = TRUE, {
+    pivot_wider(
+      df2,
+      id_cols = all_of(c("a", "b", "c")),
+      names_from = y,
+      values_from = z
+    )
+  })
+
+  expect_snapshot(error = TRUE, {
+    pivot_wider(df2, id_cols = 1:2, names_from = y, values_from = z)
+  })
+})
+
 # column names -------------------------------------------------------------
 
 test_that("names_glue affects output names", {