1
2test_that("vec_slice throws error with non-vector inputs", {
3  expect_error(vec_slice(environment(), 1L), class = "vctrs_error_scalar_type")
4})
5
6test_that("vec_slice throws error with non-vector subscripts", {
7  verify_errors({
8    expect_error(vec_slice(1:3, Sys.Date()), class = "vctrs_error_subscript_type")
9    expect_error(vec_slice(1:3, matrix(TRUE, nrow = 1)), class = "vctrs_error_subscript_type")
10  })
11})
12
13test_that("can subset base vectors", {
14  i <- 2:3
15  expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, 1))
16  expect_identical(vec_slice(int(1, 2, 3), i), int(2, 3))
17  expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, 3))
18  expect_identical(vec_slice(cpl(1, 2, 3), i), cpl(2, 3))
19  expect_identical(vec_slice(chr("1", "2", "3"), i), chr("2", "3"))
20  expect_identical(vec_slice(bytes(1, 2, 3), i), bytes(2, 3))
21  expect_identical(vec_slice(list(1, 2, 3), i), list(2, 3))
22})
23
24test_that("can subset shaped base vectors", {
25  i <- 2:3
26  mat <- as.matrix
27  expect_identical(vec_slice(mat(lgl(1, 0, 1)), i), mat(lgl(0, 1)))
28  expect_identical(vec_slice(mat(int(1, 2, 3)), i), mat(int(2, 3)))
29  expect_identical(vec_slice(mat(dbl(1, 2, 3)), i), mat(dbl(2, 3)))
30  expect_identical(vec_slice(mat(cpl(1, 2, 3)), i), mat(cpl(2, 3)))
31  expect_identical(vec_slice(mat(chr("1", "2", "3")), i), mat(chr("2", "3")))
32  expect_identical(vec_slice(mat(bytes(1, 2, 3)), i), mat(bytes(2, 3)))
33  expect_identical(vec_slice(mat(list(1, 2, 3)), i), mat(list(2, 3)))
34})
35
36test_that("can subset with missing indices", {
37  for (i in list(int(2L, NA), lgl(FALSE, TRUE, NA))) {
38    expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, NA))
39    expect_identical(vec_slice(int(1, 2, 3), i), int(2, NA))
40    expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, NA))
41    expect_identical(vec_slice(cpl(1, 2, 3), i), cpl(2, NA))
42    expect_identical(vec_slice(chr("1", "2", "3"), i), c("2", NA))
43    expect_identical(vec_slice(bytes(1, 2, 3), i), bytes(2, 0))
44    expect_identical(vec_slice(list(1, 2, 3), i), list(2, NULL))
45  }
46})
47
48test_that("can subset with a recycled NA", {
49  expect_identical(vec_slice(1:3, NA), int(NA, NA, NA))
50  expect_identical(vec_slice(new_vctr(1:3), NA), new_vctr(int(NA, NA, NA)))
51
52  rownames <- rep_len("", nrow(mtcars))
53  rownames <- vec_as_names(rownames, repair = "unique")
54  expect_identical(vec_slice(mtcars, NA), structure(mtcars[NA, ], row.names = rownames))
55})
56
57test_that("can subset with a recycled TRUE", {
58  expect_identical(vec_slice(1:3, TRUE), 1:3)
59  expect_identical(vec_slice(mtcars, TRUE), mtcars)
60  expect_identical(vec_slice(new_vctr(1:3), TRUE), new_vctr(1:3))
61  expect_identical(vec_as_location(TRUE, 2), 1:2)
62})
63
64test_that("can subset with a recycled FALSE", {
65  expect_identical(vec_slice(1:3, FALSE), int())
66  expect_identical(vec_slice(mtcars, FALSE), mtcars[NULL, ])
67  expect_identical(vec_slice(new_vctr(1:3), FALSE), new_vctr(integer()))
68})
69
70test_that("can't index beyond the end of a vector", {
71  verify_errors({
72    expect_error(vec_slice(1:2, 3L), class = "vctrs_error_subscript_oob")
73    expect_error(vec_slice(1:2, -3L), class = "vctrs_error_subscript_oob")
74  })
75})
76
77test_that("slicing non existing elements fails", {
78  expect_error(vec_as_location("foo", 1L, "f"), class = "vctrs_error_subscript_oob")
79  expect_error(vec_slice(c(f = 1), "foo"), class = "vctrs_error_subscript_oob")
80})
81
82test_that("can subset object of any dimensionality", {
83  x0 <- c(1, 1)
84  x1 <- ones(2)
85  x2 <- ones(2, 3)
86  x3 <- ones(2, 3, 4)
87  x4 <- ones(2, 3, 4, 5)
88
89  expect_equal(vec_slice(x0, 1L), 1)
90  expect_identical(vec_slice(x1, 1L), ones(1))
91  expect_identical(vec_slice(x2, 1L), ones(1, 3))
92  expect_identical(vec_slice(x3, 1L), ones(1, 3, 4))
93  expect_identical(vec_slice(x4, 1L), ones(1, 3, 4, 5))
94})
95
96test_that("can subset using logical subscript", {
97  x0 <- c(1, 1)
98
99  expect_identical(vec_slice(x0, TRUE), x0)
100  expect_identical(vec_slice(x0, c(TRUE, FALSE)), 1)
101
102  expect_error(
103    vec_slice(x0, c(TRUE, FALSE, TRUE)),
104    class = "vctrs_error_subscript_size"
105  )
106
107  expect_error(
108    vec_slice(x0, lgl()),
109    class = "vctrs_error_subscript_size"
110  )
111
112  expect_error(
113    vec_slice(mtcars, c(TRUE, FALSE)),
114    class = "vctrs_error_subscript_size"
115  )
116})
117
118test_that("can subset data frame columns", {
119  df <- data.frame(x = 1:2)
120  df$y <- data.frame(a = 2:1)
121
122  expect_equal(vec_slice(df, 1L)$y, vec_slice(df$y, 1L))
123})
124
125test_that("can subset empty data frames", {
126  df <- new_data_frame(n = 3L)
127  expect_equal(vec_size(vec_slice(df, integer())), 0)
128  expect_equal(vec_size(vec_slice(df, 1L)), 1)
129  expect_equal(vec_size(vec_slice(df, 1:3)), 3)
130
131  df$df <- df
132  expect_equal(vec_size(vec_slice(df, integer())), 0)
133  expect_equal(vec_size(vec_slice(df, 1L)), 1)
134  expect_equal(vec_size(vec_slice(df, 1:3)), 3)
135})
136
137test_that("ignores NA in logical subsetting", {
138  x <- c(NA, 1, 2)
139  expect_equal(vec_slice(x, x > 0), c(NA, 1, 2))
140})
141
142test_that("ignores NA in integer subsetting", {
143  expect_equal(vec_slice(0:2, c(NA, 2:3)), c(NA, 1, 2))
144})
145
146test_that("can't slice with missing argument", {
147  expect_error(vec_slice(1:3))
148  expect_error(vec_slice(mtcars))
149  expect_error(vec_slice(new_vctr(1:3)))
150})
151
152test_that("can slice with NULL argument", {
153  expect_identical(vec_slice(1:3, NULL), integer())
154  expect_identical(vec_slice(iris, NULL), iris[0, ])
155  expect_identical(vec_slice(new_vctr(1:3), NULL), new_vctr(integer()))
156})
157
158test_that("slicing unclassed structures preserves attributes", {
159  x <- structure(1:3, foo = "bar")
160  expect_identical(vec_slice(x, 1L), structure(1L, foo = "bar"))
161})
162
163test_that("can slice with negative indices", {
164  expect_identical(vec_slice(1:3, -c(1L, 3L)), 2L)
165  expect_identical(vec_slice(mtcars, -(1:30)), vec_slice(mtcars, 31:32))
166
167  expect_error(vec_slice(1:3, -c(1L, NA)), class = "vctrs_error_subscript_type")
168  expect_error(vec_slice(1:3, c(-1L, 1L)), class = "vctrs_error_subscript_type")
169})
170
171test_that("0 is ignored in negative indices", {
172  expect_identical(vec_slice(1:3, c(-2L, 0L)), int(1L, 3L))
173  expect_identical(vec_slice(1:3, c(0L, -2L)), int(1L, 3L))
174})
175
176test_that("0 is ignored in positive indices", {
177  expect_identical(vec_slice(1:3, 0L), int())
178  expect_identical(vec_slice(1:3, c(0L, 0L)), int())
179  expect_identical(vec_slice(1:3, c(0L, 2L, 0L)), 2L)
180})
181
182test_that("can slice with double indices", {
183  expect_identical(vec_slice(1:3, dbl(2, 3)), 2:3)
184  err <- expect_error(vec_as_location(2^31, 3L), class = "vctrs_error_subscript_type")
185  expect_s3_class(err$parent, "vctrs_error_cast_lossy")
186})
187
188test_that("can slice with symbols", {
189  expect_identical(vec_as_location(quote(b), 26, letters), 2L)
190})
191
192test_that("can `vec_slice()` S3 objects without dispatch infloop", {
193  expect_identical(new_vctr(1:3)[1], new_vctr(1L))
194  expect_identical(new_vctr(as.list(1:3))[1], new_vctr(list(1L)))
195})
196
197test_that("can `vec_slice()` records", {
198  out <- vec_slice(new_rcrd(list(a = 1L, b = 2L)), rep(1, 3))
199  expect_size(out, 3)
200
201  out <- vec_init(new_rcrd(list(a = 1L, b = 2L)), 2)
202  expect_size(out, 2)
203})
204
205test_that("vec_restore() is called after proxied slicing", {
206  local_methods(
207    vec_proxy.vctrs_foobar = identity,
208    vec_restore.vctrs_foobar = function(x, to, ...) "dispatch"
209  )
210  expect_identical(vec_slice(foobar(1:3), 2), "dispatch")
211})
212
213test_that("vec_slice() is proxied", {
214  local_proxy()
215  x <- vec_slice(new_proxy(1:3), 2:3)
216  expect_identical(proxy_deref(x), 2:3)
217})
218
219test_that("dimensions are preserved by vec_slice()", {
220  # Fallback case
221  x <- foobar(1:4)
222  dim(x) <- c(2, 2)
223  dimnames(x) <- list(a = c("foo", "bar"), b = c("quux", "hunoz"))
224
225  out <- vec_slice(x, 1)
226  exp <- foobar(
227    c(1L, 3L),
228    dim = c(1, 2),
229    dimnames = list(a = "foo", b = c("quux", "hunoz")
230  ))
231  expect_identical(out, exp)
232
233
234  # Native case
235  attrib <- NULL
236
237  local_methods(
238    vec_proxy.vctrs_foobar = identity,
239    vec_restore.vctrs_foobar = function(x, to, ...) attrib <<- attributes(x)
240  )
241
242  vec_slice(x, 1)
243
244  exp <- list(dim = 1:2, dimnames = list(a = "foo", b = c("quux", "hunoz")))
245  expect_identical(attrib, exp)
246})
247
248test_that("can slice shaped objects by name", {
249  x <- matrix(1:2)
250
251  expect_error(vec_slice(x, "foo"), "unnamed")
252
253  dimnames(x) <- list(c("foo", "bar"))
254
255  expect_equal(vec_slice(x, "foo"), vec_slice(x, 1L))
256  expect_error(vec_slice(x, "baz"), class = "vctrs_error_subscript_oob")
257})
258
259test_that("vec_slice() unclasses input before calling `vec_restore()`", {
260  oo <- NULL
261  local_methods(
262    vec_proxy.vctrs_foobar = identity,
263    vec_restore.vctrs_foobar = function(x, ...) oo <<- is.object(x)
264  )
265
266  x <- foobar(1:4)
267  dim(x) <- c(2, 2)
268
269  vec_slice(x, 1)
270  expect_false(oo)
271})
272
273test_that("can call `vec_slice()` from `[` methods with shaped objects without infloop", {
274  local_methods(
275    `[.vctrs_foobar` = function(x, i, ...) vec_slice(x, i)
276  )
277
278  x <- foobar(1:4)
279  dim(x) <- c(2, 2)
280
281  exp <- foobar(c(1L, 3L))
282  dim(exp) <- c(1, 2)
283  expect_identical(x[1], exp)
284})
285
286test_that("vec_slice() restores attributes on shaped S3 objects correctly", {
287  x <- factor(c("a", "b", "c", "d", "e", "f"))
288  dim(x) <- c(3, 2)
289
290  expect <- factor(c("a", "c", "d", "f"), levels = levels(x))
291  dim(expect) <- c(2, 2)
292
293  expect_identical(vec_slice(x, c(1, 3)), expect)
294})
295
296test_that("vec_slice() falls back to `[` with S3 objects", {
297  local_methods(
298    `[.vctrs_foobar` = function(x, i, ...) "dispatched"
299  )
300  expect_identical(vec_slice(foobar(NA), 1), "dispatched")
301
302  expect_error(vec_slice(foobar(list(NA)), 1), class = "vctrs_error_scalar_type")
303  local_methods(
304    vec_proxy.vctrs_foobar = identity
305  )
306  expect_identical(vec_slice(foobar(list(NA)), 1), foobar(list(NA)))
307})
308
309test_that("vec_slice() doesn't restore when attributes have already been restored", {
310  local_methods(
311    `[.vctrs_foobar` = function(x, i, ...) structure("dispatched", foo = "bar"),
312    vec_restore.vctrs_foobar = function(...) stop("not called")
313  )
314  expect_error(vec_slice(foobar(NA), 1), NA)
315})
316
317test_that("vec_slice() doesn't restore when `[` method intentionally dropped attributes", {
318  local_methods(
319    `[.vctrs_foobar` = function(x, i, ...) unstructure(NextMethod()),
320    vec_restore.vctrs_foobar = function(...) stop("not called")
321  )
322  expect_identical(vec_slice(foobar(NA), 1), NA)
323})
324
325test_that("can vec_slice() without inflooping when restore calls math generics", {
326  local_methods(
327    new_foobar = function(x) {
328      new_vctr(as.double(x), class = "vctrs_foobar")
329    },
330    vec_restore.vctrs_foobar = function(x, ...) {
331      abs(x)
332      sum(x)
333      mean(x)
334      is.finite(x)
335      is.infinite(x)
336      is.nan(x)
337      new_foobar(x)
338    }
339  )
340  expect_identical(new_foobar(1:10)[1:2], new_foobar(1:2))
341})
342
343test_that("vec_restore() is called after slicing data frames", {
344  local_methods(
345    vec_restore.vctrs_tabble = function(...) "dispatched"
346  )
347  df <- structure(mtcars, class = c("vctrs_tabble", "data.frame"))
348  expect_identical(vec_slice(df, 1), "dispatched")
349})
350
351test_that("additional subscripts are forwarded to `[`", {
352  local_methods(
353    `[.vctrs_foobar` = function(x, i, ...) vec_index(x, i, ...)
354  )
355
356  x <- foobar(c("foo", "bar", "quux", "hunoz"))
357  dim(x) <- c(2, 2)
358
359  exp <- foobar("quux")
360  dim(exp) <- c(1, 1)
361
362  expect_identical(x[1, 2], exp)
363})
364
365test_that("can use names to vec_slice() a named object", {
366  x0 <- c(a = 1, b = 2)
367  x1 <- c(a = 1, a = 2)
368
369  expect_identical(vec_slice(x0, letters[1]), c(a = 1))
370  expect_identical(vec_slice(x0, letters[2:1]), c(b = 2, a = 1))
371  expect_identical(vec_slice(x1, letters[1]), c(a = 1))
372
373  expect_error(vec_slice(x0, letters[3:1]), class = "vctrs_error_subscript_oob")
374  expect_error(vec_slice(x1, letters[2]), class = "vctrs_error_subscript_oob")
375})
376
377test_that("can't use names to vec_slice() an unnamed object", {
378  expect_error(
379    vec_slice(1:3, letters[1]),
380    "Can't use character names to index an unnamed vector.",
381    fixed = TRUE
382  )
383  expect_error(
384    vec_slice(1:3, letters[25:27]),
385    "Can't use character names to index an unnamed vector.",
386    fixed = TRUE
387  )
388})
389
390test_that("can slice with missing character indices (#244)", {
391  expect_identical(vec_as_location(na_chr, 2L, c("x", "")), na_int)
392  expect_identical(vec_slice(c(x = 1), na_chr), set_names(na_dbl, ""))
393  expect_identical(vec_slice(c(x = "foo"), na_chr), set_names(na_chr, ""))
394})
395
396test_that("can slice with numerics (#577)", {
397  expect_identical(vec_as_location(1:2, 3), 1:2)
398  expect_error(vec_as_location(1:2, 3.5), class = "vctrs_error_cast_lossy")
399})
400
401test_that("missing indices don't create NA names", {
402  x <- set_names(letters)
403  expect_identical(vec_slice(x, na_int), set_names(na_chr, ""))
404  expect_identical(vec_slice(x, int(1, NA, 3, NA)), chr(a = "a", NA, c = "c", NA))
405
406  # Preserves existing NA names
407  x <- set_names(1:2, c(NA, "foo"))
408  expect_identical(vec_slice(x, 1:2), x)
409})
410
411test_that("vec_slice() asserts vectorness (#301)", {
412  expect_error(vec_slice(NULL, 1), class = "vctrs_error_scalar_type")
413})
414
415test_that("slicing an unspecified logical vector returns a logical vector", {
416  expect_identical(vec_slice(NA, integer()), logical())
417  expect_identical(vec_slice(NA, c(1, 1)), c(NA, NA))
418})
419
420test_that("slicing an unspecified() object returns an unspecified()", {
421  expect_identical(vec_slice(unspecified(1), integer()), unspecified())
422  expect_identical(vec_slice(unspecified(1), c(1, 1)), unspecified(2))
423})
424
425
426test_that("vec_slice() works with Altrep classes with custom extract methods", {
427  skip_if(getRversion() < "3.5")
428
429  x <- .Call(vctrs_altrep_rle_Make, c(foo = 10L, bar = 5L))
430
431  idx <- c(9, 10, 11)
432  expect_equal(vec_slice(x, idx), c("foo", "foo", "bar"))
433})
434
435test_that("slice has informative error messages", {
436  verify_output(test_path("error", "test-slice.txt"), {
437    "# Unnamed vector with character subscript"
438    vec_slice(1:3, letters[1])
439
440    "# Negative subscripts are checked"
441    vec_slice(1:3, -c(1L, NA))
442    vec_slice(1:3, c(-1L, 1L))
443
444    "# oob error messages are properly constructed"
445    vec_slice(c(bar = 1), "foo")
446
447    "Multiple OOB indices"
448    vec_slice(letters, c(100, 1000))
449    vec_slice(letters, c(1, 100:103, 2, 104:110))
450    vec_slice(set_names(letters), c("foo", "bar"))
451    vec_slice(set_names(letters), toupper(letters))
452
453    "# Can't index beyond the end of a vector"
454    vec_slice(1:2, 3L)
455    vec_slice(1:2, -3L)
456
457    "# vec_slice throws error with non-vector subscripts"
458    vec_slice(1:3, Sys.Date())
459    vec_slice(1:3, matrix(TRUE, ncol = 1))
460  })
461})
462
463# vec_init ----------------------------------------------------------------
464
465test_that("na of atomic vectors is as expected", {
466  expect_equal(vec_init(TRUE), NA)
467  expect_equal(vec_init(1L), NA_integer_)
468  expect_equal(vec_init(1), NA_real_)
469  expect_equal(vec_init("x"), NA_character_)
470  expect_equal(vec_init(1i), NA_complex_)
471})
472
473test_that("na of factor preserves levels", {
474  f1 <- factor("a", levels = c("a", "b"))
475  f2 <- vec_init(f1)
476
477  expect_equal(levels(f1), levels(f2))
478})
479
480test_that("na of POSIXct preserves tz", {
481  dt1 <- as.POSIXct("2010-01-01", tz = "America/New_York")
482  dt2 <- vec_init(dt1)
483  expect_equal(attr(dt2, "tzone"), "America/New_York")
484})
485
486test_that("na of list is list(NULL)", {
487  expect_equal(vec_init(list()), list(NULL))
488})
489
490test_that("na of array is 1d slice", {
491  x1 <- array(1:12, c(2, 3, 4))
492  x2 <- vec_init(x1)
493
494  expect_equal(x2, array(NA_integer_, c(1, 3, 4)))
495})
496
497test_that("na of list-array is 1d slice", {
498  x1 <- array(as.list(1:12), c(2, 3, 4))
499  x2 <- vec_init(x1)
500
501  expect_equal(x2, array(list(), c(1, 3, 4)))
502})
503
504test_that("vec_init() asserts vectorness (#301)", {
505  expect_error(vec_init(NULL, 1L), class = "vctrs_error_scalar_type")
506})
507
508test_that("vec_init() works with Altrep classes", {
509  skip_if(getRversion() < "3.5")
510
511  x <- .Call(vctrs_altrep_rle_Make, c(foo = 1L, bar = 2L))
512
513  expect_equal(vec_init(x, 2), rep(NA_character_, 2))
514})
515
516# vec_slice + compact_rep -------------------------------------------------
517
518# `i` is 1-based
519
520test_that("names are repaired correctly with compact reps and `NA_integer_`", {
521  x <- list(a = 1L, b = 2L)
522  expect <- set_names(list(NULL, NULL), c("", ""))
523
524  expect_equal(vec_slice_rep(x, NA_integer_, 2L), expect)
525})
526
527test_that("names are recycled correctly with compact reps", {
528  expect_named(vec_slice_rep(c(x = 1L), 1L, 3L), c("x", "x", "x"))
529})
530
531test_that("vec_slice() with compact_reps work with Altrep classes", {
532  skip_if(getRversion() < "3.5")
533
534  x <- .Call(vctrs_altrep_rle_Make, c(foo = 10L, bar = 5L))
535
536  expect_equal(vec_slice_rep(x, 10L, 3L), rep("foo", 3))
537})
538
539# vec_slice + compact_seq -------------------------------------------------
540
541# `start` is 0-based
542
543test_that("can subset base vectors with compact seqs", {
544  start <- 1L
545  size <- 2L
546  increasing <- TRUE
547  expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(0, 1))
548  expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(2, 3))
549  expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(2, 3))
550  expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(2, 3))
551  expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("2", "3"))
552  expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes(2, 3))
553  expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(2, 3))
554})
555
556test_that("can subset base vectors with decreasing compact seqs", {
557  start <- 2L
558  size <- 2L
559  increasing <- FALSE
560  expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(1, 0))
561  expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(3, 2))
562  expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(3, 2))
563  expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(3, 2))
564  expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("3", "2"))
565  expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes(3, 2))
566  expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(3, 2))
567})
568
569test_that("can subset base vectors with size 0 compact seqs", {
570  start <- 1L
571  size <- 0L
572  increasing <- TRUE
573  expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl())
574  expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int())
575  expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl())
576  expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl())
577  expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr())
578  expect_identical(vec_slice_seq(bytes(1, 2, 3), start, size, increasing), bytes())
579  expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list())
580})
581
582test_that("can subset shaped base vectors with compact seqs", {
583  start <- 1L
584  size <- 2L
585  increasing <- TRUE
586  mat <- as.matrix
587  expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(0, 1)))
588  expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(2, 3)))
589  expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(2, 3)))
590  expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(2, 3)))
591  expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("2", "3")))
592  expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes(2, 3)))
593  expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(2, 3)))
594})
595
596test_that("can subset shaped base vectors with decreasing compact seqs", {
597  start <- 2L
598  size <- 2L
599  increasing <- FALSE
600  mat <- as.matrix
601  expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(1, 0)))
602  expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(3, 2)))
603  expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(3, 2)))
604  expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(3, 2)))
605  expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("3", "2")))
606  expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes(3, 2)))
607  expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(3, 2)))
608})
609
610test_that("can subset shaped base vectors with size 0 compact seqs", {
611  start <- 1L
612  size <- 0L
613  increasing <- TRUE
614  mat <- as.matrix
615  expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl()))
616  expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int()))
617  expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl()))
618  expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl()))
619  expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr()))
620  expect_identical(vec_slice_seq(mat(bytes(1, 2, 3)), start, size, increasing), mat(bytes()))
621  expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list()))
622})
623
624test_that("can subset object of any dimensionality with compact seqs", {
625  x0 <- c(1, 1)
626  x1 <- ones(2)
627  x2 <- ones(2, 3)
628  x3 <- ones(2, 3, 4)
629  x4 <- ones(2, 3, 4, 5)
630
631  expect_equal(vec_slice_seq(x0, 0L, 1L), 1)
632  expect_identical(vec_slice_seq(x1, 0L, 1L), ones(1))
633  expect_identical(vec_slice_seq(x2, 0L, 1L), ones(1, 3))
634  expect_identical(vec_slice_seq(x3, 0L, 1L), ones(1, 3, 4))
635  expect_identical(vec_slice_seq(x4, 0L, 1L), ones(1, 3, 4, 5))
636})
637
638test_that("can subset data frames with compact seqs", {
639  df <- data_frame(x = 1:5, y = letters[1:5])
640  expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer()))
641  expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L))
642  expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3))
643  expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1))
644
645  df$df <- df
646  expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer()))
647  expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L))
648  expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3))
649  expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1))
650})
651
652test_that("can subset S3 objects using the fallback method with compact seqs", {
653  x <- factor(c("a", "b", "c", "d"))
654  expect_equal(vec_slice_seq(x, 0L, 0L), vec_slice(x, integer()))
655  expect_equal(vec_slice_seq(x, 0L, 1L), vec_slice(x, 1L))
656  expect_equal(vec_slice_seq(x, 2L, 2L), vec_slice(x, 3:4))
657  expect_equal(vec_slice_seq(x, 3L, 2L, FALSE), vec_slice(x, 4:3))
658})
659
660test_that("vec_slice() with compact_seqs work with Altrep classes", {
661  skip_if(getRversion() < "3.5")
662
663  x <- .Call(vctrs_altrep_rle_Make, c(foo = 2L, bar = 3L))
664
665  expect_equal(vec_slice_seq(x, 1L, 3L), c("foo", "bar", "bar"))
666})
667
668test_that("vec_slice() handles symbols and OO objects", {
669  expect_identical(vec_slice(c(a = 1, b = 2), quote(b)), c(b = 2))
670  expect_identical(vec_slice(c(a = 1, b = 2), factor("b")), c(b = 2))
671  expect_error(vec_slice(c(a = 1, b = 2), foobar("b")), class = "vctrs_error_subscript_type")
672})
673
674test_that("vec_init() handles names in columns", {
675  expect_identical(
676    vec_init(data_frame(x = c(a = 1, b = 2)))$x,
677    named(na_dbl)
678  )
679  expect_identical(
680    vec_init(data_frame(x = c(1, 2)))$x,
681    na_dbl
682  )
683})
684
685test_that("vec_slice() restores unrestored but named foreign classes", {
686  x <- foobar(c(x = 1))
687
688  expect_identical(vec_slice(x, 1), x)
689  expect_identical(vec_chop(x), list(x))
690  expect_identical(vec_chop(x, list(1)), list(x))
691  expect_identical(vec_ptype(x), foobar(named(dbl())))
692  expect_identical(vec_ptype(x), foobar(named(dbl())))
693  expect_identical(vec_ptype_common(x, x), foobar(named(dbl())))
694
695  out <- vec_ptype_common_fallback(x, x)
696  expect_true(is_common_class_fallback(out))
697  expect_identical(fallback_class(out), "vctrs_foobar")
698})
699
700test_that("scalar type error is thrown when `vec_slice_impl()` is called directly (#1139)", {
701  x <- foobar(as.list(1:3))
702  expect_error(vec_slice_seq(x, 1L, 1L), class = "vctrs_error_scalar_type")
703})
704
705test_that("column sizes are checked before slicing (#552)", {
706  x <- structure(list(a = 1, b = 2:3), row.names = 1:2, class = "data.frame")
707  expect_error(vctrs::vec_slice(x, 2), "must match the data frame size")
708})
709
710test_that("base_vec_rep() slices data frames with the base::rep() UI", {
711  df <- data_frame(x = data_frame(y = 1:2))
712  expect_identical(
713    base_vec_rep(df, length.out = 4),
714    vec_slice(df, c(1:2, 1:2))
715  )
716})
717
718test_that("vec_size_assign() slices data frames with the base::rep() UI", {
719  df <- data_frame(x = data_frame(y = 1:3))
720
721  expect_identical(
722    vec_size_assign(df, 2),
723    vec_slice(df, 1:2)
724  )
725
726  expect_identical(
727    vec_size_assign(df, 4),
728    vec_slice(df, c(1:3, NA))
729  )
730})
731