}-gggCVVRRR4TUU;D())Aee%x< x< a``P2Xǣ\1www :T\\\ 233eee(++CII "Fۓn
O 5
fcgr8055˗/QQQQ Ǐ ݻ@ =#F #::Ң*)) X[[(d ==lmmkL8TWWڭs[n{o
R$Ɛ< //
c8p !*III=(ԁ1*Zg؈vaWVV. 244Fo344P($zQc9www8::BZZ>LMMajjJMBk D D~Ѭ +.A - l@+ KVp+mfTt թ $&L(TUU?YRҷuww^, 5wgcۋ0~qu
9S '1Lbe~P24&. nfp{-dn8>xHΉE.,~m(m%yf;~*( &" P P P P P @@@@@@@@@@,eD yL7" IENDB` vctrs/man/howto-faq-fix-scalar-type-error.Rd 0000644 0001762 0000144 00000006424 14417765645 020550 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/faq-developer.R
\name{howto-faq-fix-scalar-type-error}
\alias{howto-faq-fix-scalar-type-error}
\title{FAQ - Why isn't my class treated as a vector?}
\description{
The tidyverse is a bit stricter than base R regarding what kind of
objects are considered as vectors (see the \link[=faq-error-scalar-type]{user FAQ} about this topic). Sometimes vctrs won’t
treat your class as a vector when it should.
\subsection{Why isn’t my list class considered a vector?}{
By default, S3 lists are not considered to be vectors by vctrs:
\if{html}{\out{}}\preformatted{my_list <- structure(list(), class = "my_class")
vctrs::vec_is(my_list)
#> [1] FALSE
}\if{html}{\out{
}}
To be treated as a vector, the class must either inherit from \code{"list"}
explicitly:
\if{html}{\out{}}\preformatted{my_explicit_list <- structure(list(), class = c("my_class", "list"))
vctrs::vec_is(my_explicit_list)
#> [1] TRUE
}\if{html}{\out{
}}
Or it should implement a \code{vec_proxy()} method that returns its input if
explicit inheritance is not possible or troublesome:
\if{html}{\out{}}\preformatted{#' @export
vec_proxy.my_class <- function(x, ...) x
vctrs::vec_is(my_list)
#> [1] FALSE
}\if{html}{\out{
}}
Note that explicit inheritance is the preferred way because this makes
it possible for your class to dispatch on \code{list} methods of S3 generics:
\if{html}{\out{}}\preformatted{my_generic <- function(x) UseMethod("my_generic")
my_generic.list <- function(x) "dispatched!"
my_generic(my_list)
#> Error in UseMethod("my_generic"): no applicable method for 'my_generic' applied to an object of class "my_class"
my_generic(my_explicit_list)
#> [1] "dispatched!"
}\if{html}{\out{
}}
}
\subsection{Why isn’t my data frame class considered a vector?}{
The most likely explanation is that the data frame has not been properly
constructed.
However, if you get an “Input must be a vector” error with a data frame
subclass, it probably means that the data frame has not been properly
constructed. The main cause of these errors are data frames whose \emph{base
class} is not \code{"data.frame"}:
\if{html}{\out{}}\preformatted{my_df <- data.frame(x = 1)
class(my_df) <- c("data.frame", "my_class")
vctrs::obj_check_vector(my_df)
#> Error:
#> ! `my_df` must be a vector, not a object.
}\if{html}{\out{
}}
This is problematic as many tidyverse functions won’t work properly:
\if{html}{\out{}}\preformatted{dplyr::slice(my_df, 1)
#> Error in `vec_slice()`:
#> ! `x` must be a vector, not a object.
}\if{html}{\out{
}}
It is generally not appropriate to declare your class to be a superclass
of another class. We generally consider this undefined behaviour (UB).
To fix these errors, you can simply change the construction of your data
frame class so that \code{"data.frame"} is a base class, i.e. it should come
last in the class vector:
\if{html}{\out{}}\preformatted{class(my_df) <- c("my_class", "data.frame")
vctrs::obj_check_vector(my_df)
dplyr::slice(my_df, 1)
#> x
#> 1 1
}\if{html}{\out{
}}
}
}
vctrs/man/partial_frame.Rd 0000644 0001762 0000144 00000001423 14276722575 015304 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/partial-frame.R
\name{partial_frame}
\alias{partial_frame}
\title{Partially specify columns of a data frame}
\usage{
partial_frame(...)
}
\arguments{
\item{...}{Attributes of subclass}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
This special class can be passed to \code{.ptype} in order to specify the
types of only some of the columns in a data frame.
}
\examples{
pf <- partial_frame(x = double())
pf
vec_rbind(
data.frame(x = 1L, y = "a"),
data.frame(x = FALSE, z = 10),
.ptype = partial_frame(x = double(), a = character())
)
}
\keyword{internal}
vctrs/man/vec_as_names.Rd 0000644 0001762 0000144 00000015517 14362266120 015113 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/names.R
\name{vec_as_names}
\alias{vec_as_names}
\title{Retrieve and repair names}
\usage{
vec_as_names(
names,
...,
repair = c("minimal", "unique", "universal", "check_unique", "unique_quiet",
"universal_quiet"),
repair_arg = NULL,
quiet = FALSE,
call = caller_env()
)
}
\arguments{
\item{names}{A character vector.}
\item{...}{These dots are for future extensions and must be empty.}
\item{repair}{Either a string or a function. If a string, it must be one of
\code{"check_unique"}, \code{"minimal"}, \code{"unique"}, \code{"universal"}, \code{"unique_quiet"},
or \code{"universal_quiet"}. If a function, it is invoked with a vector of
minimal names and must return minimal names, otherwise an error is thrown.
\itemize{
\item Minimal names are never \code{NULL} or \code{NA}. When an element doesn't
have a name, its minimal name is an empty string.
\item Unique names are unique. A suffix is appended to duplicate
names to make them unique.
\item Universal names are unique and syntactic, meaning that you can
safely use the names as variables without causing a syntax
error.
}
The \code{"check_unique"} option doesn't perform any name repair.
Instead, an error is raised if the names don't suit the
\code{"unique"} criteria.
The options \code{"unique_quiet"} and \code{"universal_quiet"} are here to help the
user who calls this function indirectly, via another function which exposes
\code{repair} but not \code{quiet}. Specifying \code{repair = "unique_quiet"} is like
specifying \verb{repair = "unique", quiet = TRUE}. When the \code{"*_quiet"} options
are used, any setting of \code{quiet} is silently overridden.}
\item{repair_arg}{If specified and \code{repair = "check_unique"}, any errors
will include a hint to set the \code{repair_arg}.}
\item{quiet}{By default, the user is informed of any renaming
caused by repairing the names. This only concerns unique and
universal repairing. Set \code{quiet} to \code{TRUE} to silence the
messages.
Users can silence the name repair messages by setting the
\code{"rlib_name_repair_verbosity"} global option to \code{"quiet"}.}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\description{
\code{vec_as_names()} takes a character vector of names and repairs it
according to the \code{repair} argument. It is the r-lib and tidyverse
equivalent of \code{\link[base:make.names]{base::make.names()}}.
vctrs deals with a few levels of name repair:
\itemize{
\item \code{minimal} names exist. The \code{names} attribute is not \code{NULL}. The
name of an unnamed element is \code{""} and never \code{NA}. For instance,
\code{vec_as_names()} always returns minimal names and data frames
created by the tibble package have names that are, at least,
\code{minimal}.
\item \code{unique} names are \code{minimal}, have no duplicates, and can be used
where a variable name is expected. Empty names, \code{...}, and
\code{..} followed by a sequence of digits are banned.
\itemize{
\item All columns can be accessed by name via \code{df[["name"]]} and
\code{df$`name` } and \code{with(df, `name`)}.
}
\item \code{universal} names are \code{unique} and syntactic (see Details for
more).
\itemize{
\item Names work everywhere, without quoting: \code{df$name} and \code{with(df, name)} and \code{lm(name1 ~ name2, data = df)} and
\code{dplyr::select(df, name)} all work.
}
}
\code{universal} implies \code{unique}, \code{unique} implies \code{minimal}. These
levels are nested.
}
\section{\code{minimal} names}{
\code{minimal} names exist. The \code{names} attribute is not \code{NULL}. The
name of an unnamed element is \code{""} and never \code{NA}.
Examples:
\if{html}{\out{}}\preformatted{Original names of a vector with length 3: NULL
minimal names: "" "" ""
Original names: "x" NA
minimal names: "x" ""
}\if{html}{\out{
}}
}
\section{\code{unique} names}{
\code{unique} names are \code{minimal}, have no duplicates, and can be used
(possibly with backticks) in contexts where a variable is
expected. Empty names, \code{...}, and \code{..} followed by a sequence of
digits are banned. If a data frame has \code{unique} names, you can
index it by name, and also access the columns by name. In
particular, \code{df[["name"]]} and \code{df$`name`} and also \code{with(df, `name`)} always work.
There are many ways to make names \code{unique}. We append a suffix of the form
\code{...j} to any name that is \code{""} or a duplicate, where \code{j} is the position.
We also change \code{..#} and \code{...} to \code{...#}.
Example:
\if{html}{\out{}}\preformatted{Original names: "" "x" "" "y" "x" "..2" "..."
unique names: "...1" "x...2" "...3" "y" "x...5" "...6" "...7"
}\if{html}{\out{
}}
Pre-existing suffixes of the form \code{...j} are always stripped, prior
to making names \code{unique}, i.e. reconstructing the suffixes. If this
interacts poorly with your names, you should take control of name
repair.
}
\section{\code{universal} names}{
\code{universal} names are \code{unique} and syntactic, meaning they:
\itemize{
\item Are never empty (inherited from \code{unique}).
\item Have no duplicates (inherited from \code{unique}).
\item Are not \code{...}. Do not have the form \code{..i}, where \code{i} is a
number (inherited from \code{unique}).
\item Consist of letters, numbers, and the dot \code{.} or underscore \verb{_}
characters.
\item Start with a letter or start with the dot \code{.} not followed by a
number.
\item Are not a \link{reserved} word, e.g., \code{if} or \code{function} or \code{TRUE}.
}
If a vector has \code{universal} names, variable names can be used
"as is" in code. They work well with nonstandard evaluation, e.g.,
\code{df$name} works.
vctrs has a different method of making names syntactic than
\code{\link[base:make.names]{base::make.names()}}. In general, vctrs prepends one or more dots
\code{.} until the name is syntactic.
Examples:
\if{html}{\out{}}\preformatted{ Original names: "" "x" NA "x"
universal names: "...1" "x...2" "...3" "x...4"
Original names: "(y)" "_z" ".2fa" "FALSE"
universal names: ".y." "._z" "..2fa" ".FALSE"
}\if{html}{\out{
}}
}
\examples{
# By default, `vec_as_names()` returns minimal names:
vec_as_names(c(NA, NA, "foo"))
# You can make them unique:
vec_as_names(c(NA, NA, "foo"), repair = "unique")
# Universal repairing fixes any non-syntactic name:
vec_as_names(c("_foo", "+"), repair = "universal")
}
\seealso{
\code{\link[rlang:names2]{rlang::names2()}} returns the names of an object, after
making them \code{minimal}.
}
vctrs/man/vec_count.Rd 0000644 0001762 0000144 00000003406 14315060307 014444 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/dictionary.R
\name{vec_count}
\alias{vec_count}
\title{Count unique values in a vector}
\usage{
vec_count(x, sort = c("count", "key", "location", "none"))
}
\arguments{
\item{x}{A vector (including a data frame).}
\item{sort}{One of "count", "key", "location", or "none".
\itemize{
\item "count", the default, puts most frequent values at top
\item "key", orders by the output key column (i.e. unique values of \code{x})
\item "location", orders by location where key first seen. This is useful
if you want to match the counts up to other unique/duplicated functions.
\item "none", leaves unordered. This is not guaranteed to produce the same
ordering across R sessions, but is the fastest method.
}}
}
\value{
A data frame with columns \code{key} (same type as \code{x}) and
\code{count} (an integer vector).
}
\description{
Count the number of unique values in a vector. \code{vec_count()} has two
important differences to \code{table()}: it returns a data frame, and when
given multiple inputs (as a data frame), it only counts combinations that
appear in the input.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_proxy_equal]{vec_proxy_equal()}}
\item \code{\link[=vec_slice]{vec_slice()}}
\item \code{\link[=vec_order]{vec_order()}}
}
}
\examples{
vec_count(mtcars$vs)
vec_count(iris$Species)
# If you count a data frame you'll get a data frame
# column in the output
str(vec_count(mtcars[c("vs", "am")]))
# Sorting ---------------------------------------
x <- letters[rpois(100, 6)]
# default is to sort by frequency
vec_count(x)
# by can sort by key
vec_count(x, sort = "key")
# or location of first value
vec_count(x, sort = "location")
head(x)
# or not at all
vec_count(x, sort = "none")
}
vctrs/man/vec_bind.Rd 0000644 0001762 0000144 00000015662 14511524374 014246 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/bind.R
\name{vec_bind}
\alias{vec_bind}
\alias{vec_rbind}
\alias{vec_cbind}
\title{Combine many data frames into one data frame}
\usage{
vec_rbind(
...,
.ptype = NULL,
.names_to = rlang::zap(),
.name_repair = c("unique", "universal", "check_unique", "unique_quiet",
"universal_quiet"),
.name_spec = NULL,
.error_call = current_env()
)
vec_cbind(
...,
.ptype = NULL,
.size = NULL,
.name_repair = c("unique", "universal", "check_unique", "minimal", "unique_quiet",
"universal_quiet"),
.error_call = current_env()
)
}
\arguments{
\item{...}{Data frames or vectors.
When the inputs are named:
\itemize{
\item \code{vec_rbind()} assigns names to row names unless \code{.names_to} is
supplied. In that case the names are assigned in the column
defined by \code{.names_to}.
\item \code{vec_cbind()} creates packed data frame columns with named
inputs.
}
\code{NULL} inputs are silently ignored. Empty (e.g. zero row) inputs
will not appear in the output, but will affect the derived \code{.ptype}.}
\item{.ptype}{If \code{NULL}, the default, the output type is determined by
computing the common type across all elements of \code{...}.
Alternatively, you can supply \code{.ptype} to give the output known type.
If \code{getOption("vctrs.no_guessing")} is \code{TRUE} you must supply this value:
this is a convenient way to make production code demand fixed types.}
\item{.names_to}{This controls what to do with input names supplied in \code{...}.
\itemize{
\item By default, input names are \link[rlang:zap]{zapped}.
\item If a string, specifies a column where the input names will be
copied. These names are often useful to identify rows with
their original input. If a column name is supplied and \code{...} is
not named, an integer column is used instead.
\item If \code{NULL}, the input names are used as row names.
}}
\item{.name_repair}{One of \code{"unique"}, \code{"universal"}, \code{"check_unique"},
\code{"unique_quiet"}, or \code{"universal_quiet"}. See \code{\link[=vec_as_names]{vec_as_names()}} for the
meaning of these options.
With \code{vec_rbind()}, the repair function is applied to all inputs
separately. This is because \code{vec_rbind()} needs to align their
columns before binding the rows, and thus needs all inputs to
have unique names. On the other hand, \code{vec_cbind()} applies the
repair function after all inputs have been concatenated together
in a final data frame. Hence \code{vec_cbind()} allows the more
permissive minimal names repair.}
\item{.name_spec}{A name specification (as documented in \code{\link[=vec_c]{vec_c()}})
for combining the outer inputs names in \code{...} and the inner row
names of the inputs. This only has an effect when \code{.names_to} is
set to \code{NULL}, which causes the input names to be assigned as row
names.}
\item{.error_call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
\item{.size}{If, \code{NULL}, the default, will determine the number of rows in
\code{vec_cbind()} output by using the tidyverse \link[=theory-faq-recycling]{recycling rules}.
Alternatively, specify the desired number of rows, and any inputs of length
1 will be recycled appropriately.}
}
\value{
A data frame, or subclass of data frame.
If \code{...} is a mix of different data frame subclasses, \code{vec_ptype2()}
will be used to determine the output type. For \code{vec_rbind()}, this
will determine the type of the container and the type of each column;
for \code{vec_cbind()} it only determines the type of the output container.
If there are no non-\code{NULL} inputs, the result will be \code{data.frame()}.
}
\description{
This pair of functions binds together data frames (and vectors), either
row-wise or column-wise. Row-binding creates a data frame with common type
across all arguments. Column-binding creates a data frame with common length
across all arguments.
}
\section{Invariants}{
All inputs are first converted to a data frame. The conversion for
1d vectors depends on the direction of binding:
\itemize{
\item For \code{vec_rbind()}, each element of the vector becomes a column in
a single row.
\item For \code{vec_cbind()}, each element of the vector becomes a row in a
single column.
}
Once the inputs have all become data frames, the following
invariants are observed for row-binding:
\itemize{
\item \code{vec_size(vec_rbind(x, y)) == vec_size(x) + vec_size(y)}
\item \code{vec_ptype(vec_rbind(x, y)) = vec_ptype_common(x, y)}
}
Note that if an input is an empty vector, it is first converted to
a 1-row data frame with 0 columns. Despite being empty, its
effective size for the total number of rows is 1.
For column-binding, the following invariants apply:
\itemize{
\item \code{vec_size(vec_cbind(x, y)) == vec_size_common(x, y)}
\item \code{vec_ptype(vec_cbind(x, y)) == vec_cbind(vec_ptype(x), vec_ptype(x))}
}
}
\section{Dependencies}{
\subsection{vctrs dependencies}{
\itemize{
\item \code{\link[=vec_cast_common]{vec_cast_common()}}
\item \code{\link[=vec_proxy]{vec_proxy()}}
\item \code{\link[=vec_init]{vec_init()}}
\item \code{\link[=vec_assign]{vec_assign()}}
\item \code{\link[=vec_restore]{vec_restore()}}
}
}
\subsection{base dependencies of \code{vec_rbind()}}{
\itemize{
\item \code{\link[base:c]{base::c()}}
}
If columns to combine inherit from a common class,
\code{vec_rbind()} falls back to \code{base::c()} if there exists a \code{c()}
method implemented for this class hierarchy.
}
}
\examples{
# row binding -----------------------------------------
# common columns are coerced to common class
vec_rbind(
data.frame(x = 1),
data.frame(x = FALSE)
)
# unique columns are filled with NAs
vec_rbind(
data.frame(x = 1),
data.frame(y = "x")
)
# null inputs are ignored
vec_rbind(
data.frame(x = 1),
NULL,
data.frame(x = 2)
)
# bare vectors are treated as rows
vec_rbind(
c(x = 1, y = 2),
c(x = 3)
)
# default names will be supplied if arguments are not named
vec_rbind(
1:2,
1:3,
1:4
)
# column binding --------------------------------------
# each input is recycled to have common length
vec_cbind(
data.frame(x = 1),
data.frame(y = 1:3)
)
# bare vectors are treated as columns
vec_cbind(
data.frame(x = 1),
y = letters[1:3]
)
# if you supply a named data frame, it is packed in a single column
data <- vec_cbind(
x = data.frame(a = 1, b = 2),
y = 1
)
data
# Packed data frames are nested in a single column. This makes it
# possible to access it through a single name:
data$x
# since the base print method is suboptimal with packed data
# frames, it is recommended to use tibble to work with these:
if (rlang::is_installed("tibble")) {
vec_cbind(x = tibble::tibble(a = 1, b = 2), y = 1)
}
# duplicate names are flagged
vec_cbind(x = 1, x = 2)
}
\seealso{
\code{\link[=vec_c]{vec_c()}} for combining 1d vectors.
}
vctrs/man/vec_size.Rd 0000644 0001762 0000144 00000010144 14511524374 014272 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/size.R
\name{vec_size}
\alias{vec_size}
\alias{vec_size_common}
\alias{list_sizes}
\alias{vec_is_empty}
\title{Number of observations}
\usage{
vec_size(x)
vec_size_common(
...,
.size = NULL,
.absent = 0L,
.arg = "",
.call = caller_env()
)
list_sizes(x)
vec_is_empty(x)
}
\arguments{
\item{x, ...}{Vector inputs or \code{NULL}.}
\item{.size}{If \code{NULL}, the default, the output size is determined by
recycling the lengths of all elements of \code{...}. Alternatively, you can
supply \code{.size} to force a known size; in this case, \code{x} and \code{...} are
ignored.}
\item{.absent}{The size used when no input is provided, or when all input
is \code{NULL}. If left as \code{NULL} when no input is supplied, an error is thrown.}
\item{.arg}{An argument name as a string. This argument
will be mentioned in error messages as the input that is at the
origin of a problem.}
\item{.call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\value{
An integer (or double for long vectors).
\code{vec_size_common()} returns \code{.absent} if all inputs are \code{NULL} or
absent, \code{0L} by default.
}
\description{
\code{vec_size(x)} returns the size of a vector. \code{vec_is_empty()}
returns \code{TRUE} if the size is zero, \code{FALSE} otherwise.
The size is distinct from the \code{\link[=length]{length()}} of a vector because it
generalises to the "number of observations" for 2d structures,
i.e. it's the number of rows in matrix or a data frame. This
definition has the important property that every column of a data
frame (even data frame and matrix columns) have the same size.
\code{vec_size_common(...)} returns the common size of multiple vectors.
\code{list_sizes()} returns an integer vector containing the size of each element
of a list. It is nearly equivalent to, but faster than,
\code{map_int(x, vec_size)}, with the exception that \code{list_sizes()} will
error on non-list inputs, as defined by \code{\link[=obj_is_list]{obj_is_list()}}. \code{list_sizes()} is
to \code{vec_size()} as \code{\link[=lengths]{lengths()}} is to \code{\link[=length]{length()}}.
}
\details{
There is no vctrs helper that retrieves the number of columns: as this
is a property of the \link[=vec_ptype_show]{type}.
\code{vec_size()} is equivalent to \code{NROW()} but has a name that is easier to
pronounce, and throws an error when passed non-vector inputs.
}
\section{Invariants}{
\itemize{
\item \code{vec_size(dataframe)} == \code{vec_size(dataframe[[i]])}
\item \code{vec_size(matrix)} == \code{vec_size(matrix[, i, drop = FALSE])}
\item \code{vec_size(vec_c(x, y))} == \code{vec_size(x)} + \code{vec_size(y)}
}
}
\section{The size of NULL}{
The size of \code{NULL} is hard-coded to \code{0L} in \code{vec_size()}.
\code{vec_size_common()} returns \code{.absent} when all inputs are \code{NULL}
(if only some inputs are \code{NULL}, they are simply ignored).
A default size of 0 makes sense because sizes are most often
queried in order to compute a total size while assembling a
collection of vectors. Since we treat \code{NULL} as an absent input by
principle, we return the identity of sizes under addition to
reflect that an absent input doesn't take up any size.
Note that other defaults might make sense under different
circumstances. For instance, a default size of 1 makes sense for
finding the common size because 1 is the identity of the recycling
rules.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_proxy]{vec_proxy()}}
}
}
\examples{
vec_size(1:100)
vec_size(mtcars)
vec_size(array(dim = c(3, 5, 10)))
vec_size_common(1:10, 1:10)
vec_size_common(1:10, 1)
vec_size_common(integer(), 1)
list_sizes(list("a", 1:5, letters))
}
\seealso{
\code{\link[=vec_slice]{vec_slice()}} for a variation of \code{[} compatible with \code{vec_size()},
and \code{\link[=vec_recycle]{vec_recycle()}} to \link[=theory-faq-recycling]{recycle} vectors to common
length.
}
vctrs/man/vec_assert.Rd 0000644 0001762 0000144 00000007644 14401377400 014626 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/assert.R
\name{vec_assert}
\alias{vec_assert}
\alias{vec_is}
\title{Assert an argument has known prototype and/or size}
\usage{
vec_assert(
x,
ptype = NULL,
size = NULL,
arg = caller_arg(x),
call = caller_env()
)
vec_is(x, ptype = NULL, size = NULL)
}
\arguments{
\item{x}{A vector argument to check.}
\item{ptype}{Prototype to compare against. If the prototype has a
class, its \code{\link[=vec_ptype]{vec_ptype()}} is compared to that of \code{x} with
\code{identical()}. Otherwise, its \code{\link[=typeof]{typeof()}} is compared to that of
\code{x} with \code{==}.}
\item{size}{A single integer size against which to compare.}
\item{arg}{Name of argument being checked. This is used in error
messages. The label of the expression passed as \code{x} is taken as
default.}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\value{
\code{vec_is()} returns \code{TRUE} or \code{FALSE}. \code{vec_assert()} either
throws a typed error (see section on error types) or returns \code{x},
invisibly.
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}}
\itemize{
\item \code{vec_is()} is a predicate that checks if its input is a vector that
conforms to a prototype and/or a size.
\item \code{vec_assert()} throws an error when the input is not a vector or
doesn't conform.
}
}
\section{Error types}{
\code{vec_is()} never throws.
\code{vec_assert()} throws the following errors:
\itemize{
\item If the input is not a vector, an error of class
\code{"vctrs_error_scalar_type"} is raised.
\item If the prototype doesn't match, an error of class
\code{"vctrs_error_assert_ptype"} is raised.
\item If the size doesn't match, an error of class
\code{"vctrs_error_assert_size"} is raised.
}
Both errors inherit from \code{"vctrs_error_assert"}.
}
\section{Lifecycle}{
Both \code{vec_is()} and \code{vec_assert()} are questioning because their \code{ptype}
arguments have semantics that are challenging to define clearly and are
rarely useful.
\itemize{
\item Use \code{\link[=obj_is_vector]{obj_is_vector()}} or \code{\link[=obj_check_vector]{obj_check_vector()}} for vector checks
\item Use \code{\link[=vec_check_size]{vec_check_size()}} for size checks
\item Use \code{\link[=vec_cast]{vec_cast()}}, \code{\link[=inherits]{inherits()}}, or simple type predicates like
\code{\link[rlang:type-predicates]{rlang::is_logical()}} for specific type checks
}
}
\section{Vectors and scalars}{
Informally, a vector is a collection that makes sense to use as column in a
data frame. The following rules define whether or not \code{x} is considered a
vector.
If no \code{\link[=vec_proxy]{vec_proxy()}} method has been registered, \code{x} is a vector if:
\itemize{
\item The \link[=typeof]{base type} of the object is atomic: \code{"logical"}, \code{"integer"},
\code{"double"}, \code{"complex"}, \code{"character"}, or \code{"raw"}.
\item \code{x} is a list, as defined by \code{\link[=obj_is_list]{obj_is_list()}}.
\item \code{x} is a \link{data.frame}.
}
If a \code{vec_proxy()} method has been registered, \code{x} is a vector if:
\itemize{
\item The proxy satisfies one of the above conditions.
\item The base type of the proxy is \code{"list"}, regardless of its class. S3 lists
are thus treated as scalars unless they implement a \code{vec_proxy()} method.
}
Otherwise an object is treated as scalar and cannot be used as a vector.
In particular:
\itemize{
\item \code{NULL} is not a vector.
\item S3 lists like \code{lm} objects are treated as scalars by default.
\item Objects of type \link{expression} are not treated as vectors.
}
}
\keyword{internal}
vctrs/man/vec_as_index.Rd 0000644 0001762 0000144 00000002264 14276722575 015131 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/vctrs-deprecated.R
\name{vec_as_index}
\alias{vec_as_index}
\title{Convert to an index vector}
\usage{
vec_as_index(i, n, names = NULL)
}
\arguments{
\item{i}{An integer, character or logical vector specifying the
locations or names of the observations to get/set. Specify
\code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or
\code{integer()} to index none (as in \code{x[NULL]}).}
\item{n}{A single integer representing the total size of the
object that \code{i} is meant to index into.}
\item{names}{If \code{i} is a character vector, \code{names} should be a character
vector that \code{i} will be matched against to construct the index. Otherwise,
not used. The default value of \code{NULL} will result in an error
if \code{i} is a character vector.}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}}
\code{vec_as_index()} has been renamed to \code{\link[=vec_as_location]{vec_as_location()}} and is
deprecated as of vctrs 0.2.2.
}
\keyword{internal}
vctrs/man/vec_locate_matches.Rd 0000644 0001762 0000144 00000034165 14376174332 016310 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/match.R
\name{vec_locate_matches}
\alias{vec_locate_matches}
\title{Locate observations matching specified conditions}
\usage{
vec_locate_matches(
needles,
haystack,
...,
condition = "==",
filter = "none",
incomplete = "compare",
no_match = NA_integer_,
remaining = "drop",
multiple = "all",
relationship = "none",
nan_distinct = FALSE,
chr_proxy_collate = NULL,
needles_arg = "needles",
haystack_arg = "haystack",
error_call = current_env()
)
}
\arguments{
\item{needles, haystack}{Vectors used for matching.
\itemize{
\item \code{needles} represents the vector to search for.
\item \code{haystack} represents the vector to search in.
}
Prior to comparison, \code{needles} and \code{haystack} are coerced to the same type.}
\item{...}{These dots are for future extensions and must be empty.}
\item{condition}{Condition controlling how \code{needles} should be compared
against \code{haystack} to identify a successful match.
\itemize{
\item One of: \code{"=="}, \code{">"}, \code{">="}, \code{"<"}, or \code{"<="}.
\item For data frames, a length \code{1} or \code{ncol(needles)} character vector
containing only the above options, specifying how matching is determined
for each column.
}}
\item{filter}{Filter to be applied to the matched results.
\itemize{
\item \code{"none"} doesn't apply any filter.
\item \code{"min"} returns only the minimum haystack value matching the current
needle.
\item \code{"max"} returns only the maximum haystack value matching the current
needle.
\item For data frames, a length \code{1} or \code{ncol(needles)} character vector
containing only the above options, specifying a filter to apply to
each column.
}
Filters don't have any effect on \code{"=="} conditions, but are useful for
computing "rolling" matches with other conditions.
A filter can return multiple haystack matches for a particular needle
if the maximum or minimum haystack value is duplicated in \code{haystack}. These
can be further controlled with \code{multiple}.}
\item{incomplete}{Handling of missing and \link[=vec_detect_complete]{incomplete}
values in \code{needles}.
\itemize{
\item \code{"compare"} uses \code{condition} to determine whether or not a missing value
in \code{needles} matches a missing value in \code{haystack}. If \code{condition} is
\code{==}, \code{>=}, or \code{<=}, then missing values will match.
\item \code{"match"} always allows missing values in \code{needles} to match missing
values in \code{haystack}, regardless of the \code{condition}.
\item \code{"drop"} drops incomplete values in \code{needles} from the result.
\item \code{"error"} throws an error if any \code{needles} are incomplete.
\item If a single integer is provided, this represents the value returned
in the \code{haystack} column for values of \code{needles} that are incomplete. If
\code{no_match = NA}, setting \code{incomplete = NA} forces incomplete values in
\code{needles} to be treated like unmatched values.
}
\code{nan_distinct} determines whether a \code{NA} is allowed to match a \code{NaN}.}
\item{no_match}{Handling of \code{needles} without a match.
\itemize{
\item \code{"drop"} drops \code{needles} with zero matches from the result.
\item \code{"error"} throws an error if any \code{needles} have zero matches.
\item If a single integer is provided, this represents the value returned in
the \code{haystack} column for values of \code{needles} that have zero matches. The
default represents an unmatched needle with \code{NA}.
}}
\item{remaining}{Handling of \code{haystack} values that \code{needles} never matched.
\itemize{
\item \code{"drop"} drops remaining \code{haystack} values from the result.
Typically, this is the desired behavior if you only care when \code{needles}
has a match.
\item \code{"error"} throws an error if there are any remaining \code{haystack}
values.
\item If a single integer is provided (often \code{NA}), this represents the value
returned in the \code{needles} column for the remaining \code{haystack} values
that \code{needles} never matched. Remaining \code{haystack} values are always
returned at the end of the result.
}}
\item{multiple}{Handling of \code{needles} with multiple matches. For each needle:
\itemize{
\item \code{"all"} returns all matches detected in \code{haystack}.
\item \code{"any"} returns any match detected in \code{haystack} with no guarantees on
which match will be returned. It is often faster than \code{"first"} and
\code{"last"} if you just need to detect if there is at least one match.
\item \code{"first"} returns the first match detected in \code{haystack}.
\item \code{"last"} returns the last match detected in \code{haystack}.
}}
\item{relationship}{Handling of the expected relationship between
\code{needles} and \code{haystack}. If the expectations chosen from the list below
are invalidated, an error is thrown.
\itemize{
\item \code{"none"} doesn't perform any relationship checks.
\item \code{"one-to-one"} expects:
\itemize{
\item Each value in \code{needles} matches at most 1 value in \code{haystack}.
\item Each value in \code{haystack} matches at most 1 value in \code{needles}.
}
\item \code{"one-to-many"} expects:
\itemize{
\item Each value in \code{needles} matches any number of values in \code{haystack}.
\item Each value in \code{haystack} matches at most 1 value in \code{needles}.
}
\item \code{"many-to-one"} expects:
\itemize{
\item Each value in \code{needles} matches at most 1 value in \code{haystack}.
\item Each value in \code{haystack} matches any number of values in \code{needles}.
}
\item \code{"many-to-many"} expects:
\itemize{
\item Each value in \code{needles} matches any number of values in \code{haystack}.
\item Each value in \code{haystack} matches any number of values in \code{needles}.
}
This performs no checks, and is identical to \code{"none"}, but is provided to
allow you to be explicit about this relationship if you know it exists.
\item \code{"warn-many-to-many"} doesn't assume there is any known relationship, but
will warn if \code{needles} and \code{haystack} have a many-to-many relationship
(which is typically unexpected), encouraging you to either take a closer
look at your inputs or make this relationship explicit by specifying
\code{"many-to-many"}.
}
\code{relationship} is applied after \code{filter} and \code{multiple} to allow potential
multiple matches to be filtered out first.
\code{relationship} doesn't handle cases where there are zero matches. For that,
see \code{no_match} and \code{remaining}.}
\item{nan_distinct}{A single logical specifying whether or not \code{NaN} should
be considered distinct from \code{NA} for double and complex vectors. If \code{TRUE},
\code{NaN} will always be ordered between \code{NA} and non-missing numbers.}
\item{chr_proxy_collate}{A function generating an alternate representation
of character vectors to use for collation, often used for locale-aware
ordering.
\itemize{
\item If \code{NULL}, no transformation is done.
\item Otherwise, this must be a function of one argument. If the input contains
a character vector, it will be passed to this function after it has been
translated to UTF-8. This function should return a character vector with
the same length as the input. The result should sort as expected in the
C-locale, regardless of encoding.
}
For data frames, \code{chr_proxy_collate} will be applied to all character
columns.
Common transformation functions include: \code{tolower()} for case-insensitive
ordering and \code{stringi::stri_sort_key()} for locale-aware ordering.}
\item{needles_arg, haystack_arg}{Argument tags for \code{needles} and \code{haystack}
used in error messages.}
\item{error_call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\value{
A two column data frame containing the locations of the matches.
\itemize{
\item \code{needles} is an integer vector containing the location of
the needle currently being matched.
\item \code{haystack} is an integer vector containing the location of the
corresponding match in the haystack for the current needle.
}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
\code{vec_locate_matches()} is a more flexible version of \code{\link[=vec_match]{vec_match()}} used to
identify locations where each value of \code{needles} matches one or multiple
values in \code{haystack}. Unlike \code{vec_match()}, \code{vec_locate_matches()} returns
all matches by default, and can match on binary conditions other than
equality, such as \code{>}, \code{>=}, \code{<}, and \code{<=}.
}
\details{
\code{\link[=vec_match]{vec_match()}} is identical to (but often slightly faster than):
\if{html}{\out{}}\preformatted{vec_locate_matches(
needles,
haystack,
condition = "==",
multiple = "first",
nan_distinct = TRUE
)
}\if{html}{\out{
}}
\code{vec_locate_matches()} is extremely similar to a SQL join between \code{needles}
and \code{haystack}, with the default being most similar to a left join.
Be very careful when specifying match \code{condition}s. If a condition is
misspecified, it is very easy to accidentally generate an exponentially
large number of matches.
}
\section{Dependencies of \code{vec_locate_matches()}}{
\itemize{
\item \code{\link[=vec_order_radix]{vec_order_radix()}}
\item \code{\link[=vec_detect_complete]{vec_detect_complete()}}
}
}
\examples{
x <- c(1, 2, NA, 3, NaN)
y <- c(2, 1, 4, NA, 1, 2, NaN)
# By default, for each value of `x`, all matching locations in `y` are
# returned
matches <- vec_locate_matches(x, y)
matches
# The result can be used to slice the inputs to align them
data_frame(
x = vec_slice(x, matches$needles),
y = vec_slice(y, matches$haystack)
)
# If multiple matches are present, control which is returned with `multiple`
vec_locate_matches(x, y, multiple = "first")
vec_locate_matches(x, y, multiple = "last")
vec_locate_matches(x, y, multiple = "any")
# Use `relationship` to add constraints and error on multiple matches if
# they aren't expected
try(vec_locate_matches(x, y, relationship = "one-to-one"))
# In this case, the `NA` in `y` matches two rows in `x`
try(vec_locate_matches(x, y, relationship = "one-to-many"))
# By default, `NA` is treated as being identical to `NaN`.
# Using `nan_distinct = TRUE` treats `NA` and `NaN` as different values, so
# `NA` can only match `NA`, and `NaN` can only match `NaN`.
vec_locate_matches(x, y, nan_distinct = TRUE)
# If you never want missing values to match, set `incomplete = NA` to return
# `NA` in the `haystack` column anytime there was an incomplete value
# in `needles`.
vec_locate_matches(x, y, incomplete = NA)
# Using `incomplete = NA` allows us to enforce the one-to-many relationship
# that we couldn't before
vec_locate_matches(x, y, relationship = "one-to-many", incomplete = NA)
# `no_match` allows you to specify the returned value for a needle with
# zero matches. Note that this is different from an incomplete value,
# so specifying `no_match` allows you to differentiate between incomplete
# values and unmatched values.
vec_locate_matches(x, y, incomplete = NA, no_match = 0L)
# If you want to require that every `needle` has at least 1 match, set
# `no_match` to `"error"`:
try(vec_locate_matches(x, y, incomplete = NA, no_match = "error"))
# By default, `vec_locate_matches()` detects equality between `needles` and
# `haystack`. Using `condition`, you can detect where an inequality holds
# true instead. For example, to find every location where `x[[i]] >= y`:
matches <- vec_locate_matches(x, y, condition = ">=")
data_frame(
x = vec_slice(x, matches$needles),
y = vec_slice(y, matches$haystack)
)
# You can limit which matches are returned with a `filter`. For example,
# with the above example you can filter the matches returned by `x[[i]] >= y`
# down to only the ones containing the maximum `y` value of those matches.
matches <- vec_locate_matches(x, y, condition = ">=", filter = "max")
# Here, the matches for the `3` needle value have been filtered down to
# only include the maximum haystack value of those matches, `2`. This is
# often referred to as a rolling join.
data_frame(
x = vec_slice(x, matches$needles),
y = vec_slice(y, matches$haystack)
)
# In the very rare case that you need to generate locations for a
# cross match, where every value of `x` is forced to match every
# value of `y` regardless of what the actual values are, you can
# replace `x` and `y` with integer vectors of the same size that contain
# a single value and match on those instead.
x_proxy <- vec_rep(1L, vec_size(x))
y_proxy <- vec_rep(1L, vec_size(y))
nrow(vec_locate_matches(x_proxy, y_proxy))
vec_size(x) * vec_size(y)
# By default, missing values will match other missing values when using
# `==`, `>=`, or `<=` conditions, but not when using `>` or `<` conditions.
# This is similar to how `vec_compare(x, y, na_equal = TRUE)` works.
x <- c(1, NA)
y <- c(NA, 2)
vec_locate_matches(x, y, condition = "<=")
vec_locate_matches(x, y, condition = "<")
# You can force missing values to match regardless of the `condition`
# by using `incomplete = "match"`
vec_locate_matches(x, y, condition = "<", incomplete = "match")
# You can also use data frames for `needles` and `haystack`. The
# `condition` will be recycled to the number of columns in `needles`, or
# you can specify varying conditions per column. In this example, we take
# a vector of date `values` and find all locations where each value is
# between lower and upper bounds specified by the `haystack`.
values <- as.Date("2019-01-01") + 0:9
needles <- data_frame(lower = values, upper = values)
set.seed(123)
lower <- as.Date("2019-01-01") + sample(10, 10, replace = TRUE)
upper <- lower + sample(3, 10, replace = TRUE)
haystack <- data_frame(lower = lower, upper = upper)
# (values >= lower) & (values <= upper)
matches <- vec_locate_matches(needles, haystack, condition = c(">=", "<="))
data_frame(
lower = vec_slice(lower, matches$haystack),
value = vec_slice(values, matches$needle),
upper = vec_slice(upper, matches$haystack)
)
}
vctrs/man/vec_default_ptype2.Rd 0000644 0001762 0000144 00000004313 14315060307 016241 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/cast.R, R/type2.R
\name{vec_default_cast}
\alias{vec_default_cast}
\alias{vec_default_ptype2}
\title{Default cast and ptype2 methods}
\usage{
vec_default_cast(x, to, ..., x_arg = "", to_arg = "", call = caller_env())
vec_default_ptype2(x, y, ..., x_arg = "", y_arg = "", call = caller_env())
}
\arguments{
\item{x}{Vectors to cast.}
\item{to}{Type to cast to. If \code{NULL}, \code{x} will be returned as is.}
\item{...}{For \code{vec_cast_common()}, vectors to cast. For
\code{vec_cast()}, \code{vec_cast_default()}, and \code{vec_restore()}, these
dots are only for future extensions and should be empty.}
\item{x_arg}{Argument name for \code{x}, used in error messages to
inform the user about the locations of incompatible types
(see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).}
\item{to_arg}{Argument name \code{to} used in error messages to
inform the user about the locations of incompatible types
(see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}}).}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\description{
These functions are automatically called when no \code{\link[=vec_ptype2]{vec_ptype2()}} or
\code{\link[=vec_cast]{vec_cast()}} method is implemented for a pair of types.
\itemize{
\item They apply special handling if one of the inputs is of type
\code{AsIs} or \code{sfc}.
\item They attempt a number of fallbacks in cases where it would be too
inconvenient to be strict:
\itemize{
\item If the class and attributes are the same they are considered
compatible. \code{vec_default_cast()} returns \code{x} in this case.
\item In case of incompatible data frame classes, they fall back to
\code{data.frame}. If an incompatible subclass of tibble is
involved, they fall back to \code{tbl_df}.
}
\item Otherwise, an error is thrown with \code{\link[=stop_incompatible_type]{stop_incompatible_type()}} or
\code{\link[=stop_incompatible_cast]{stop_incompatible_cast()}}.
}
}
\keyword{internal}
vctrs/man/vec_match.Rd 0000644 0001762 0000144 00000004662 14276722575 014437 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/dictionary.R
\name{vec_match}
\alias{vec_match}
\alias{vec_in}
\title{Find matching observations across vectors}
\usage{
vec_match(
needles,
haystack,
...,
na_equal = TRUE,
needles_arg = "",
haystack_arg = ""
)
vec_in(
needles,
haystack,
...,
na_equal = TRUE,
needles_arg = "",
haystack_arg = ""
)
}
\arguments{
\item{needles, haystack}{Vector of \code{needles} to search for in vector haystack.
\code{haystack} should usually be unique; if not \code{vec_match()} will only
return the location of the first match.
\code{needles} and \code{haystack} are coerced to the same type prior to
comparison.}
\item{...}{These dots are for future extensions and must be empty.}
\item{na_equal}{If \code{TRUE}, missing values in \code{needles} can be
matched to missing values in \code{haystack}. If \code{FALSE}, they
propagate, missing values in \code{needles} are represented as \code{NA} in
the return value.}
\item{needles_arg, haystack_arg}{Argument tags for \code{needles} and
\code{haystack} used in error messages.}
}
\value{
A vector the same length as \code{needles}. \code{vec_in()} returns a
logical vector; \code{vec_match()} returns an integer vector.
}
\description{
\code{vec_in()} returns a logical vector based on whether \code{needle} is found in
haystack. \code{vec_match()} returns an integer vector giving location of
\code{needle} in \code{haystack}, or \code{NA} if it's not found.
}
\details{
\code{vec_in()} is equivalent to \link{\%in\%}; \code{vec_match()} is equivalent to \code{match()}.
}
\section{Missing values}{
In most cases places in R, missing values are not considered to be equal,
i.e. \code{NA == NA} is not \code{TRUE}. The exception is in matching functions
like \code{\link[=match]{match()}} and \code{\link[=merge]{merge()}}, where an \code{NA} will match another \code{NA}.
By \code{vec_match()} and \code{vec_in()} will match \code{NA}s; but you can control
this behaviour with the \code{na_equal} argument.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_cast_common]{vec_cast_common()}} with fallback
\item \code{\link[=vec_proxy_equal]{vec_proxy_equal()}}
}
}
\examples{
hadley <- strsplit("hadley", "")[[1]]
vec_match(hadley, letters)
vowels <- c("a", "e", "i", "o", "u")
vec_match(hadley, vowels)
vec_in(hadley, vowels)
# Only the first index of duplicates is returned
vec_match(c("a", "b"), c("a", "b", "a", "b"))
}
vctrs/man/vec_slice.Rd 0000644 0001762 0000144 00000007536 14373205357 014435 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/slice.R
\name{vec_slice}
\alias{vec_slice}
\alias{vec_slice<-}
\alias{vec_assign}
\title{Get or set observations in a vector}
\usage{
vec_slice(x, i, ..., error_call = current_env())
vec_slice(x, i) <- value
vec_assign(x, i, value, ..., x_arg = "", value_arg = "")
}
\arguments{
\item{x}{A vector}
\item{i}{An integer, character or logical vector specifying the
locations or names of the observations to get/set. Specify
\code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or
\code{integer()} to index none (as in \code{x[NULL]}).}
\item{...}{These dots are for future extensions and must be empty.}
\item{error_call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
\item{value}{Replacement values. \code{value} is cast to the type of
\code{x}, but only if they have a common type. See below for examples
of this rule.}
\item{x_arg, value_arg}{Argument names for \code{x} and \code{value}. These are used
in error messages to inform the user about the locations of
incompatible types and sizes (see \code{\link[=stop_incompatible_type]{stop_incompatible_type()}} and
\code{\link[=stop_incompatible_size]{stop_incompatible_size()}}).}
}
\value{
A vector of the same type as \code{x}.
}
\description{
This provides a common interface to extracting and modifying observations
for all vector types, regardless of dimensionality. It is an analog to \code{[}
that matches \code{\link[=vec_size]{vec_size()}} instead of \code{length()}.
}
\section{Genericity}{
Support for S3 objects depends on whether the object implements a
\code{\link[=vec_proxy]{vec_proxy()}} method.
\itemize{
\item When a \code{vec_proxy()} method exists, the proxy is sliced and
\code{vec_restore()} is called on the result.
\item Otherwise \code{vec_slice()} falls back to the base generic \code{[}.
}
Note that S3 lists are treated as scalars by default, and will
cause an error if they don't implement a \code{\link[=vec_proxy]{vec_proxy()}} method.
}
\section{Differences with base R subsetting}{
\itemize{
\item \code{vec_slice()} only slices along one dimension. For
two-dimensional types, the first dimension is subsetted.
\item \code{vec_slice()} preserves attributes by default.
\item \verb{vec_slice<-()} is type-stable and always returns the same type
as the LHS.
}
}
\section{Dependencies}{
\subsection{vctrs dependencies}{
\itemize{
\item \code{\link[=vec_proxy]{vec_proxy()}}
\item \code{\link[=vec_restore]{vec_restore()}}
}
}
\subsection{base dependencies}{
\itemize{
\item \code{base::`[`}
}
If a non-data-frame vector class doesn't have a \code{\link[=vec_proxy]{vec_proxy()}}
method, the vector is sliced with \code{[} instead.
}
}
\examples{
x <- sample(10)
x
vec_slice(x, 1:3)
# You can assign with the infix variant:
vec_slice(x, 2) <- 100
x
# Or with the regular variant that doesn't modify the original input:
y <- vec_assign(x, 3, 500)
y
x
# Slicing objects of higher dimension:
vec_slice(mtcars, 1:3)
# Type stability --------------------------------------------------
# The assign variant is type stable. It always returns the same
# type as the input.
x <- 1:5
vec_slice(x, 2) <- 20.0
# `x` is still an integer vector because the RHS was cast to the
# type of the LHS:
vec_ptype(x)
# Compare to `[<-`:
x[2] <- 20.0
vec_ptype(x)
# Note that the types must be coercible for the cast to happen.
# For instance, you can cast a double vector of whole numbers to an
# integer vector:
vec_cast(1, integer())
# But not fractional doubles:
try(vec_cast(1.5, integer()))
# For this reason you can't assign fractional values in an integer
# vector:
x <- 1:3
try(vec_slice(x, 2) <- 1.5)
}
\keyword{internal}
vctrs/man/s3_register.Rd 0000644 0001762 0000144 00000005074 14315060307 014713 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/register-s3.R
\name{s3_register}
\alias{s3_register}
\title{Register a method for a suggested dependency}
\arguments{
\item{generic}{Name of the generic in the form \code{pkg::generic}.}
\item{class}{Name of the class}
\item{method}{Optionally, the implementation of the method. By default,
this will be found by looking for a function called \code{generic.class}
in the package environment.
Note that providing \code{method} can be dangerous if you use
devtools. When the namespace of the method is reloaded by
\code{devtools::load_all()}, the function will keep inheriting from
the old namespace. This might cause crashes because of dangling
\code{.Call()} pointers.}
}
\description{
Generally, the recommend way to register an S3 method is to use the
\code{S3Method()} namespace directive (often generated automatically by the
\verb{@export} roxygen2 tag). However, this technique requires that the generic
be in an imported package, and sometimes you want to suggest a package,
and only provide a method when that package is loaded. \code{s3_register()}
can be called from your package's \code{.onLoad()} to dynamically register
a method only if the generic's package is loaded.
}
\details{
For R 3.5.0 and later, \code{s3_register()} is also useful when demonstrating
class creation in a vignette, since method lookup no longer always involves
the lexical scope. For R 3.6.0 and later, you can achieve a similar effect
by using "delayed method registration", i.e. placing the following in your
\code{NAMESPACE} file:
\if{html}{\out{}}\preformatted{if (getRversion() >= "3.6.0") \{
S3method(package::generic, class)
\}
}\if{html}{\out{
}}
}
\section{Usage in other packages}{
To avoid taking a dependency on vctrs, you copy the source of
\href{https://github.com/r-lib/vctrs/blob/main/R/register-s3.R}{\code{s3_register()}}
into your own package. It is licensed under the permissive
\href{https://choosealicense.com/licenses/unlicense/}{unlicense} to make it
crystal clear that we're happy for you to do this. There's no need to include
the license or even credit us when using this function.
}
\examples{
# A typical use case is to dynamically register tibble/pillar methods
# for your class. That way you avoid creating a hard dependency on packages
# that are not essential, while still providing finer control over
# printing when they are used.
.onLoad <- function(...) {
s3_register("pillar::pillar_shaft", "vctrs_vctr")
s3_register("tibble::type_sum", "vctrs_vctr")
}
}
\keyword{internal}
vctrs/man/partial_factor.Rd 0000644 0001762 0000144 00000001370 14376223321 015453 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/partial-factor.R
\name{partial_factor}
\alias{partial_factor}
\title{Partially specify a factor}
\usage{
partial_factor(levels = character())
}
\arguments{
\item{levels}{Character vector of labels.}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
This special class can be passed as a \code{ptype} in order to specify that the
result should be a factor that contains at least the specified levels.
}
\examples{
pf <- partial_factor(levels = c("x", "y"))
pf
vec_ptype_common(factor("v"), factor("w"), .ptype = pf)
}
\keyword{internal}
vctrs/man/new_vctr.Rd 0000644 0001762 0000144 00000007042 14401377400 014307 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/type-vctr.R
\name{new_vctr}
\alias{new_vctr}
\alias{vctr}
\title{vctr (vector) S3 class}
\usage{
new_vctr(.data, ..., class = character(), inherit_base_type = NULL)
}
\arguments{
\item{.data}{Foundation of class. Must be a vector}
\item{...}{Name-value pairs defining attributes}
\item{class}{Name of subclass.}
\item{inherit_base_type}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
A single logical, or \code{NULL}. Does this class extend the base type of
\code{.data}? i.e. does the resulting object extend the behaviour of the
underlying type? Defaults to \code{FALSE} for all types except lists, which
are required to inherit from the base type.}
}
\description{
This abstract class provides a set of useful default methods that makes it
considerably easier to get started with a new S3 vector class. See
\code{vignette("s3-vector")} to learn how to use it to create your own S3
vector classes.
}
\details{
List vctrs are special cases. When created through \code{new_vctr()}, the
resulting list vctr should always be recognized as a list by
\code{obj_is_list()}. Because of this, if \code{inherit_base_type} is \code{FALSE}
an error is thrown.
}
\section{Base methods}{
The vctr class provides methods for many base generics using a smaller
set of generics defined by this package. Generally, you should think
carefully before overriding any of the methods that vctrs implements for
you as they've been carefully planned to be internally consistent.
\itemize{
\item \code{[[} and \code{[} use \code{NextMethod()} dispatch to the underlying base function,
then restore attributes with \code{vec_restore()}.
\code{rep()} and \verb{length<-} work similarly.
\item \verb{[[<-} and \verb{[<-} cast \code{value} to same type as \code{x}, then call
\code{NextMethod()}.
\item \code{as.logical()}, \code{as.integer()}, \code{as.numeric()}, \code{as.character()},
\code{as.Date()} and \code{as.POSIXct()} methods call \code{vec_cast()}.
The \code{as.list()} method calls \code{[[} repeatedly, and the \code{as.data.frame()}
method uses a standard technique to wrap a vector in a data frame.
\item \code{as.factor()}, \code{as.ordered()} and \code{as.difftime()} are not generic functions
in base R, but have been reimplemented as generics in the \code{generics}
package. \code{vctrs} extends these and calls \code{vec_cast()}. To inherit this
behaviour in a package, import and re-export the generic of interest
from \code{generics}.
\item \code{==}, \code{!=}, \code{unique()}, \code{anyDuplicated()}, and \code{is.na()} use
\code{\link[=vec_proxy]{vec_proxy()}}.
\item \code{<}, \code{<=}, \code{>=}, \code{>}, \code{min()}, \code{max()}, \code{range()}, \code{median()},
\code{quantile()}, and \code{xtfrm()} methods use \code{\link[=vec_proxy_compare]{vec_proxy_compare()}}.
\item \code{+}, \code{-}, \code{/}, \code{*}, \code{^}, \code{\%\%}, \code{\%/\%}, \code{!}, \code{&}, and \code{|} operators
use \code{\link[=vec_arith]{vec_arith()}}.
\item Mathematical operations including the Summary group generics (\code{prod()},
\code{sum()}, \code{any()}, \code{all()}), the Math group generics (\code{abs()}, \code{sign()},
etc), \code{mean()}, \code{is.nan()}, \code{is.finite()}, and \code{is.infinite()}
use \code{\link[=vec_math]{vec_math()}}.
\item \code{dims()}, \verb{dims<-}, \code{dimnames()}, \verb{dimnames<-}, \code{levels()}, and
\verb{levels<-} methods throw errors.
}
}
\keyword{internal}
vctrs/man/vec_names.Rd 0000644 0001762 0000144 00000006754 14362266120 014433 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/names.R
\name{vec_names}
\alias{vec_names}
\alias{vec_names2}
\alias{vec_set_names}
\title{Get or set the names of a vector}
\usage{
vec_names2(
x,
...,
repair = c("minimal", "unique", "universal", "check_unique", "unique_quiet",
"universal_quiet"),
quiet = FALSE
)
vec_names(x)
vec_set_names(x, names)
}
\arguments{
\item{x}{A vector with names}
\item{...}{These dots are for future extensions and must be empty.}
\item{repair}{Either a string or a function. If a string, it must be one of
\code{"check_unique"}, \code{"minimal"}, \code{"unique"}, \code{"universal"}, \code{"unique_quiet"},
or \code{"universal_quiet"}. If a function, it is invoked with a vector of
minimal names and must return minimal names, otherwise an error is thrown.
\itemize{
\item Minimal names are never \code{NULL} or \code{NA}. When an element doesn't
have a name, its minimal name is an empty string.
\item Unique names are unique. A suffix is appended to duplicate
names to make them unique.
\item Universal names are unique and syntactic, meaning that you can
safely use the names as variables without causing a syntax
error.
}
The \code{"check_unique"} option doesn't perform any name repair.
Instead, an error is raised if the names don't suit the
\code{"unique"} criteria.
The options \code{"unique_quiet"} and \code{"universal_quiet"} are here to help the
user who calls this function indirectly, via another function which exposes
\code{repair} but not \code{quiet}. Specifying \code{repair = "unique_quiet"} is like
specifying \verb{repair = "unique", quiet = TRUE}. When the \code{"*_quiet"} options
are used, any setting of \code{quiet} is silently overridden.}
\item{quiet}{By default, the user is informed of any renaming
caused by repairing the names. This only concerns unique and
universal repairing. Set \code{quiet} to \code{TRUE} to silence the
messages.
Users can silence the name repair messages by setting the
\code{"rlib_name_repair_verbosity"} global option to \code{"quiet"}.}
\item{names}{A character vector, or \code{NULL}.}
}
\value{
\code{vec_names2()} returns the names of \code{x}, repaired.
\code{vec_names()} returns the names of \code{x} or \code{NULL} if unnamed.
\code{vec_set_names()} returns \code{x} with names updated.
}
\description{
These functions work like \code{\link[rlang:names2]{rlang::names2()}}, \code{\link[=names]{names()}} and \code{\link[=names<-]{names<-()}},
except that they return or modify the the rowwise names of the vector. These are:
\itemize{
\item The usual \code{names()} for atomic vectors and lists
\item The row names for data frames and matrices
\item The names of the first dimension for arrays
Rowwise names are size consistent: the length of the names always equals
\code{\link[=vec_size]{vec_size()}}.
}
\code{vec_names2()} returns the repaired names from a vector, even if it is unnamed.
See \code{\link[=vec_as_names]{vec_as_names()}} for details on name repair.
\code{vec_names()} is a bare-bones version that returns \code{NULL} if the vector is
unnamed.
\code{vec_set_names()} sets the names or removes them.
}
\examples{
vec_names2(1:3)
vec_names2(1:3, repair = "unique")
vec_names2(c(a = 1, b = 2))
# `vec_names()` consistently returns the rowwise names of data frames and arrays:
vec_names(data.frame(a = 1, b = 2))
names(data.frame(a = 1, b = 2))
vec_names(mtcars)
names(mtcars)
vec_names(Titanic)
names(Titanic)
vec_set_names(1:3, letters[1:3])
vec_set_names(data.frame(a = 1:3), letters[1:3])
}
vctrs/man/vec_as_location.Rd 0000644 0001762 0000144 00000011727 14315060307 015614 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/subscript-loc.R
\name{vec_as_location}
\alias{vec_as_location}
\alias{num_as_location}
\alias{vec_as_location2}
\alias{num_as_location2}
\title{Create a vector of locations}
\usage{
vec_as_location(
i,
n,
names = NULL,
...,
missing = c("propagate", "remove", "error"),
arg = caller_arg(i),
call = caller_env()
)
num_as_location(
i,
n,
...,
missing = c("propagate", "remove", "error"),
negative = c("invert", "error", "ignore"),
oob = c("error", "remove", "extend"),
zero = c("remove", "error", "ignore"),
arg = caller_arg(i),
call = caller_env()
)
vec_as_location2(
i,
n,
names = NULL,
...,
missing = c("error", "propagate"),
arg = caller_arg(i),
call = caller_env()
)
num_as_location2(
i,
n,
...,
negative = c("error", "ignore"),
missing = c("error", "propagate"),
arg = caller_arg(i),
call = caller_env()
)
}
\arguments{
\item{i}{An integer, character or logical vector specifying the
locations or names of the observations to get/set. Specify
\code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or
\code{integer()} to index none (as in \code{x[NULL]}).}
\item{n}{A single integer representing the total size of the
object that \code{i} is meant to index into.}
\item{names}{If \code{i} is a character vector, \code{names} should be a character
vector that \code{i} will be matched against to construct the index. Otherwise,
not used. The default value of \code{NULL} will result in an error
if \code{i} is a character vector.}
\item{...}{These dots are for future extensions and must be empty.}
\item{missing}{How should missing \code{i} values be handled?
\itemize{
\item \code{"error"} throws an error.
\item \code{"propagate"} returns them as is.
\item \code{"remove"} removes them.
}
By default, vector subscripts propagate missing values but scalar
subscripts error on them.
Propagated missing values can't be combined with negative indices when
\code{negative = "invert"}, because they can't be meaningfully inverted.}
\item{arg}{The argument name to be displayed in error messages.}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
\item{negative}{How should negative \code{i} values be handled?
\itemize{
\item \code{"error"} throws an error.
\item \code{"ignore"} returns them as is.
\item \code{"invert"} returns the positive location generated by inverting the
negative location. When inverting, positive and negative locations
can't be mixed. This option is only applicable for \code{num_as_location()}.
}}
\item{oob}{How should out-of-bounds \code{i} values be handled?
\itemize{
\item \code{"error"} throws an error.
\item \code{"remove"} removes both positive and negative out-of-bounds locations.
\item \code{"extend"} allows positive out-of-bounds locations if they directly
follow the end of a vector. This can be used to implement extendable
vectors, like \code{letters[1:30]}.
}}
\item{zero}{How should zero \code{i} values be handled?
\itemize{
\item \code{"error"} throws an error.
\item \code{"remove"} removes them.
\item \code{"ignore"} returns them as is.
}}
}
\value{
\itemize{
\item \code{vec_as_location()} and \code{num_as_location()} return an integer vector that
can be used as an index in a subsetting operation.
\item \code{vec_as_location2()} and \code{num_as_location2()} return an integer of size 1
that can be used a scalar index for extracting an element.
}
}
\description{
These helpers provide a means of standardizing common indexing
methods such as integer, character or logical indexing.
\itemize{
\item \code{vec_as_location()} accepts integer, character, or logical vectors
of any size. The output is always an integer vector that is
suitable for subsetting with \code{[} or \code{\link[=vec_slice]{vec_slice()}}. It might be a
different size than the input because negative selections are
transformed to positive ones and logical vectors are transformed
to a vector of indices for the \code{TRUE} locations.
\item \code{vec_as_location2()} accepts a single number or string. It returns
a single location as a integer vector of size 1. This is suitable
for extracting with \code{[[}.
\item \code{num_as_location()} and \code{num_as_location2()} are specialized variants
that have extra options for numeric indices.
}
}
\examples{
x <- array(1:6, c(2, 3))
dimnames(x) <- list(c("r1", "r2"), c("c1", "c2", "c3"))
# The most common use case validates row indices
vec_as_location(1, vec_size(x))
# Negative indices can be used to index from the back
vec_as_location(-1, vec_size(x))
# Character vectors can be used if `names` are provided
vec_as_location("r2", vec_size(x), rownames(x))
# You can also construct an index for dimensions other than the first
vec_as_location(c("c2", "c1"), ncol(x), colnames(x))
}
\keyword{internal}
vctrs/man/order-radix.Rd 0000644 0001762 0000144 00000013505 14315060307 014700 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/order.R
\name{order-radix}
\alias{order-radix}
\alias{vec_order_radix}
\alias{vec_sort_radix}
\title{Order and sort vectors}
\usage{
vec_order_radix(
x,
...,
direction = "asc",
na_value = "largest",
nan_distinct = FALSE,
chr_proxy_collate = NULL
)
vec_sort_radix(
x,
...,
direction = "asc",
na_value = "largest",
nan_distinct = FALSE,
chr_proxy_collate = NULL
)
}
\arguments{
\item{x}{A vector}
\item{...}{These dots are for future extensions and must be empty.}
\item{direction}{Direction to sort in.
\itemize{
\item A single \code{"asc"} or \code{"desc"} for ascending or descending order
respectively.
\item For data frames, a length \code{1} or \code{ncol(x)} character vector containing
only \code{"asc"} or \code{"desc"}, specifying the direction for each column.
}}
\item{na_value}{Ordering of missing values.
\itemize{
\item A single \code{"largest"} or \code{"smallest"} for ordering missing values as the
largest or smallest values respectively.
\item For data frames, a length \code{1} or \code{ncol(x)} character vector containing
only \code{"largest"} or \code{"smallest"}, specifying how missing values should
be ordered within each column.
}}
\item{nan_distinct}{A single logical specifying whether or not \code{NaN} should
be considered distinct from \code{NA} for double and complex vectors. If \code{TRUE},
\code{NaN} will always be ordered between \code{NA} and non-missing numbers.}
\item{chr_proxy_collate}{A function generating an alternate representation
of character vectors to use for collation, often used for locale-aware
ordering.
\itemize{
\item If \code{NULL}, no transformation is done.
\item Otherwise, this must be a function of one argument. If the input contains
a character vector, it will be passed to this function after it has been
translated to UTF-8. This function should return a character vector with
the same length as the input. The result should sort as expected in the
C-locale, regardless of encoding.
}
For data frames, \code{chr_proxy_collate} will be applied to all character
columns.
Common transformation functions include: \code{tolower()} for case-insensitive
ordering and \code{stringi::stri_sort_key()} for locale-aware ordering.}
}
\value{
\itemize{
\item \code{vec_order_radix()} an integer vector the same size as \code{x}.
\item \code{vec_sort_radix()} a vector with the same size and type as \code{x}.
}
}
\description{
\code{vec_order_radix()} computes the order of \code{x}. For data frames, the order is
computed along the rows by computing the order of the first column and
using subsequent columns to break ties.
\code{vec_sort_radix()} sorts \code{x}. It is equivalent to \code{vec_slice(x, vec_order_radix(x))}.
}
\section{Differences with \code{order()}}{
Unlike the \code{na.last} argument of \code{order()} which decides the positions of
missing values irrespective of the \code{decreasing} argument, the \code{na_value}
argument of \code{vec_order_radix()} interacts with \code{direction}. If missing values
are considered the largest value, they will appear last in ascending order,
and first in descending order.
Character vectors are ordered in the C-locale. This is different from
\code{base::order()}, which respects \code{base::Sys.setlocale()}. Sorting in a
consistent locale can produce more reproducible results between different
sessions and platforms, however, the results of sorting in the C-locale
can be surprising. For example, capital letters sort before lower case
letters. Sorting \code{c("b", "C", "a")} with \code{vec_sort_radix()} will return
\code{c("C", "a", "b")}, but with \code{base::order()} will return \code{c("a", "b", "C")}
unless \code{base::order(method = "radix")} is explicitly set, which also uses
the C-locale. While sorting with the C-locale can be useful for
algorithmic efficiency, in many real world uses it can be the cause of
data analysis mistakes. To balance these trade-offs, you can supply a
\code{chr_proxy_collate} function to transform character vectors into an
alternative representation that orders in the C-locale in a less surprising
way. For example, providing \code{\link[base:chartr]{base::tolower()}} as a transform will order the
original vector in a case-insensitive manner. Locale-aware ordering can be
achieved by providing \code{stringi::stri_sort_key()} as a transform, setting the
collation options as appropriate for your locale.
Character vectors are always translated to UTF-8 before ordering, and before
any transform is applied by \code{chr_proxy_collate}.
For complex vectors, if either the real or imaginary component is \code{NA} or
\code{NaN}, then the entire observation is considered missing.
}
\section{Dependencies of \code{vec_order_radix()}}{
\itemize{
\item \code{\link[=vec_proxy_order]{vec_proxy_order()}}
}
}
\section{Dependencies of \code{vec_sort_radix()}}{
\itemize{
\item \code{\link[=vec_order_radix]{vec_order_radix()}}
\item \code{\link[=vec_slice]{vec_slice()}}
}
}
\examples{
if (FALSE) {
x <- round(sample(runif(5), 9, replace = TRUE), 3)
x <- c(x, NA)
vec_order_radix(x)
vec_sort_radix(x)
vec_sort_radix(x, direction = "desc")
# Can also handle data frames
df <- data.frame(g = sample(2, 10, replace = TRUE), x = x)
vec_order_radix(df)
vec_sort_radix(df)
vec_sort_radix(df, direction = "desc")
# For data frames, `direction` and `na_value` are allowed to be vectors
# with length equal to the number of columns in the data frame
vec_sort_radix(
df,
direction = c("desc", "asc"),
na_value = c("largest", "smallest")
)
# Character vectors are ordered in the C locale, which orders capital letters
# below lowercase ones
y <- c("B", "A", "a")
vec_sort_radix(y)
# To order in a case-insensitive manner, provide a `chr_proxy_collate`
# function that transforms the strings to all lowercase
vec_sort_radix(y, chr_proxy_collate = tolower)
}
}
\keyword{internal}
vctrs/man/table.Rd 0000644 0001762 0000144 00000000446 14276722575 013571 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/type-table.R
\name{table}
\alias{table}
\title{Table S3 class}
\description{
These functions help the base table class fit into the vctrs type system
by providing coercion and casting functions.
}
\keyword{internal}
vctrs/man/obj_is_list.Rd 0000644 0001762 0000144 00000004454 14401377400 014764 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/assert.R
\name{obj_is_list}
\alias{obj_is_list}
\alias{obj_check_list}
\alias{list_all_vectors}
\alias{list_check_all_vectors}
\alias{list_all_size}
\alias{list_check_all_size}
\title{List checks}
\usage{
obj_is_list(x)
obj_check_list(x, ..., arg = caller_arg(x), call = caller_env())
list_all_vectors(x)
list_check_all_vectors(x, ..., arg = caller_arg(x), call = caller_env())
list_all_size(x, size)
list_check_all_size(x, size, ..., arg = caller_arg(x), call = caller_env())
}
\arguments{
\item{x}{For \verb{vec_*()} functions, an object. For \verb{list_*()} functions, a
list.}
\item{...}{These dots are for future extensions and must be empty.}
\item{arg}{An argument name as a string. This argument
will be mentioned in error messages as the input that is at the
origin of a problem.}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
\item{size}{The size to check each element for.}
}
\description{
\itemize{
\item \code{obj_is_list()} tests if \code{x} is considered a list in the vctrs sense. It
returns \code{TRUE} if:
\itemize{
\item \code{x} is a bare list with no class.
\item \code{x} is a list explicitly inheriting from \code{"list"}.
}
\item \code{list_all_vectors()} takes a list and returns \code{TRUE} if all elements of
that list are vectors.
\item \code{list_all_size()} takes a list and returns \code{TRUE} if all elements of that
list have the same \code{size}.
\item \code{obj_check_list()}, \code{list_check_all_vectors()}, and \code{list_check_all_size()}
use the above functions, but throw a standardized and informative error if
they return \code{FALSE}.
}
}
\details{
Notably, data frames and S3 record style classes like POSIXlt are not
considered lists.
}
\examples{
obj_is_list(list())
obj_is_list(list_of(1))
obj_is_list(data.frame())
list_all_vectors(list(1, mtcars))
list_all_vectors(list(1, environment()))
list_all_size(list(1:2, 2:3), 2)
list_all_size(list(1:2, 2:4), 2)
# `list_`-prefixed functions assume a list:
try(list_all_vectors(environment()))
}
\seealso{
\code{\link[=list_sizes]{list_sizes()}}
}
vctrs/man/vec_proxy.Rd 0000644 0001762 0000144 00000013574 14315060307 014504 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/proxy.R
\name{vec_proxy}
\alias{vec_proxy}
\alias{vec_restore}
\title{Proxy and restore}
\usage{
vec_proxy(x, ...)
vec_restore(x, to, ...)
}
\arguments{
\item{x}{A vector.}
\item{...}{These dots are for future extensions and must be empty.}
\item{to}{The original vector to restore to.}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
\code{vec_proxy()} returns the data structure containing the values of a
vector. This data structure is usually the vector itself. In this
case the proxy is the \link[base:identity]{identity function}, which is
the default \code{vec_proxy()} method.
Only experts should implement special \code{vec_proxy()} methods, for
these cases:
\itemize{
\item A vector has vectorised attributes, i.e. metadata for
each element of the vector. These \emph{record types} are implemented
in vctrs by returning a data frame in the proxy method. If you're
starting your class from scratch, consider deriving from the
\code{\link[=new_rcrd]{rcrd}} class. It implements the appropriate data
frame proxy and is generally the preferred way to create a record
class.
\item When you're implementing a vector on top of a non-vector type,
like an environment or an S4 object. This is currently only
partially supported.
\item S3 lists are considered scalars by default. This is the safe
choice for list objects such as returned by \code{stats::lm()}. To
declare that your S3 list class is a vector, you normally add
\code{"list"} to the right of your class vector. Explicit inheritance
from list is generally the preferred way to declare an S3 list in
R, for instance it makes it possible to dispatch on
\code{generic.list} S3 methods.
If you can't modify your class vector, you can implement an
identity proxy (i.e. a proxy method that just returns its input)
to let vctrs know this is a vector list and not a scalar.
}
\code{vec_restore()} is the inverse operation of \code{vec_proxy()}. It
should only be called on vector proxies.
\itemize{
\item It undoes the transformations of \code{vec_proxy()}.
\item It restores attributes and classes. These may be lost when the
memory values are manipulated. For example slicing a subset of a
vector's proxy causes a new proxy to be allocated.
}
By default vctrs restores all attributes and classes
automatically. You only need to implement a \code{vec_restore()} method
if your class has attributes that depend on the data.
}
\section{Proxying}{
You should only implement \code{vec_proxy()} when your type is designed
around a non-vector class. I.e. anything that is not either:
\itemize{
\item An atomic vector
\item A bare list
\item A data frame
}
In this case, implement \code{vec_proxy()} to return such a vector
class. The vctrs operations such as \code{\link[=vec_slice]{vec_slice()}} are applied on
the proxy and \code{vec_restore()} is called to restore the original
representation of your type.
The most common case where you need to implement \code{vec_proxy()} is
for S3 lists. In vctrs, S3 lists are treated as scalars by
default. This way we don't treat objects like model fits as
vectors. To prevent vctrs from treating your S3 list as a scalar,
unclass it in the \code{vec_proxy()} method. For instance, here is the
definition for \code{list_of}:
\if{html}{\out{}}\preformatted{vec_proxy.vctrs_list_of <- function(x) \{
unclass(x)
\}
}\if{html}{\out{
}}
Another case where you need to implement a proxy is \link[=new_rcrd]{record types}. Record types should return a data frame, as in
the \code{POSIXlt} method:
\if{html}{\out{}}\preformatted{vec_proxy.POSIXlt <- function(x) \{
new_data_frame(unclass(x))
\}
}\if{html}{\out{
}}
Note that you don't need to implement \code{vec_proxy()} when your class
inherits from \code{vctrs_vctr} or \code{vctrs_rcrd}.
}
\section{Restoring}{
A restore is a specialised type of cast, primarily used in
conjunction with \code{NextMethod()} or a C-level function that works on
the underlying data structure. A \code{vec_restore()} method can make
the following assumptions about \code{x}:
\itemize{
\item It has the correct type.
\item It has the correct names.
\item It has the correct \code{dim} and \code{dimnames} attributes.
\item It is unclassed. This way you can call vctrs generics with \code{x}
without triggering an infinite loop of restoration.
}
The length may be different (for example after \code{\link[=vec_slice]{vec_slice()}} has
been called), and all other attributes may have been lost. The
method should restore all attributes so that after restoration,
\code{vec_restore(vec_data(x), x)} yields \code{x}.
To understand the difference between \code{vec_cast()} and \code{vec_restore()}
think about factors: it doesn't make sense to cast an integer to a factor,
but if \code{NextMethod()} or another low-level function has stripped attributes,
you still need to be able to restore them.
The default method copies across all attributes so you only need to
provide your own method if your attributes require special care
(i.e. they are dependent on the data in some way). When implementing
your own method, bear in mind that many R users add attributes to track
additional metadata that is important to them, so you should preserve any
attributes that don't require special handling for your class.
}
\section{Dependencies}{
\itemize{
\item \code{x} must be a vector in the vctrs sense (see \code{\link[=vec_is]{vec_is()}})
\item By default the underlying data is returned as is (identity proxy)
}
All vector classes have a proxy, even those who don't implement any
vctrs methods. The exception is S3 lists that don't inherit from
\code{"list"} explicitly. These might have to implement an identity
proxy for compatibility with vctrs (see discussion above).
}
\keyword{internal}
vctrs/man/vec_recycle.Rd 0000644 0001762 0000144 00000004022 14511524374 014744 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/recycle.R
\name{vec_recycle}
\alias{vec_recycle}
\alias{vec_recycle_common}
\title{Vector recycling}
\usage{
vec_recycle(x, size, ..., x_arg = "", call = caller_env())
vec_recycle_common(..., .size = NULL, .arg = "", .call = caller_env())
}
\arguments{
\item{x}{A vector to recycle.}
\item{size}{Desired output size.}
\item{...}{Depending on the function used:
\itemize{
\item For \code{vec_recycle_common()}, vectors to recycle.
\item For \code{vec_recycle()}, these dots should be empty.
}}
\item{x_arg}{Argument name for \code{x}. These are used in error
messages to inform the user about which argument has an
incompatible size.}
\item{call, .call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
\item{.size}{Desired output size. If omitted,
will use the common size from \code{\link[=vec_size_common]{vec_size_common()}}.}
\item{.arg}{An argument name as a string. This argument
will be mentioned in error messages as the input that is at the
origin of a problem.}
}
\description{
\code{vec_recycle(x, size)} recycles a single vector to a given size.
\code{vec_recycle_common(...)} recycles multiple vectors to their common size. All
functions obey the \link[=theory-faq-recycling]{vctrs recycling rules}, and will
throw an error if recycling is not possible. See \code{\link[=vec_size]{vec_size()}} for the precise
definition of size.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_slice]{vec_slice()}}
}
}
\examples{
# Inputs with 1 observation are recycled
vec_recycle_common(1:5, 5)
vec_recycle_common(integer(), 5)
\dontrun{
vec_recycle_common(1:5, 1:2)
}
# Data frames and matrices are recycled along their rows
vec_recycle_common(data.frame(x = 1), 1:5)
vec_recycle_common(array(1:2, c(1, 2)), 1:5)
vec_recycle_common(array(1:3, c(1, 3, 1)), 1:5)
}
vctrs/man/vec_detect_complete.Rd 0000644 0001762 0000144 00000002672 14315060307 016460 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/complete.R
\name{vec_detect_complete}
\alias{vec_detect_complete}
\title{Complete}
\usage{
vec_detect_complete(x)
}
\arguments{
\item{x}{A vector}
}
\value{
A logical vector with the same size as \code{x}.
}
\description{
\code{vec_detect_complete()} detects "complete" observations. An observation is
considered complete if it is non-missing. For most vectors, this implies that
\code{vec_detect_complete(x) == !vec_detect_missing(x)}.
For data frames and matrices, a row is only considered complete if all
elements of that row are non-missing. To compare, \code{!vec_detect_missing(x)}
detects rows that are partially complete (they have at least one non-missing
value).
}
\details{
A \link[=new_rcrd]{record} type vector is similar to a data frame, and is only
considered complete if all fields are non-missing.
}
\examples{
x <- c(1, 2, NA, 4, NA)
# For most vectors, this is identical to `!vec_detect_missing(x)`
vec_detect_complete(x)
!vec_detect_missing(x)
df <- data_frame(
x = x,
y = c("a", "b", NA, "d", "e")
)
# This returns `TRUE` where all elements of the row are non-missing.
# Compare that with `!vec_detect_missing()`, which detects rows that have at
# least one non-missing value.
df2 <- df
df2$all_non_missing <- vec_detect_complete(df)
df2$any_non_missing <- !vec_detect_missing(df)
df2
}
\seealso{
\code{\link[stats:complete.cases]{stats::complete.cases()}}
}
vctrs/man/new_factor.Rd 0000644 0001762 0000144 00000002573 14276722575 014634 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/type-factor.R
\name{new_factor}
\alias{new_factor}
\alias{new_ordered}
\alias{vec_ptype2.factor}
\alias{vec_ptype2.ordered}
\alias{vec_cast.factor}
\alias{vec_cast.ordered}
\title{Factor/ordered factor S3 class}
\usage{
new_factor(x = integer(), levels = character(), ..., class = character())
new_ordered(x = integer(), levels = character())
\method{vec_ptype2}{factor}(x, y, ...)
\method{vec_ptype2}{ordered}(x, y, ...)
\method{vec_cast}{factor}(x, to, ...)
\method{vec_cast}{ordered}(x, to, ...)
}
\arguments{
\item{x}{Integer values which index in to \code{levels}.}
\item{levels}{Character vector of labels.}
\item{..., class}{Used to for subclasses.}
}
\description{
A \link{factor} is an integer with attribute \code{levels}, a character vector. There
should be one level for each integer between 1 and \code{max(x)}.
An \link{ordered} factor has the same properties as a factor, but possesses
an extra class that marks levels as having a total ordering.
}
\details{
These functions help the base factor and ordered factor classes fit in to
the vctrs type system by providing constructors, coercion functions,
and casting functions. \code{new_factor()} and \code{new_ordered()} are low-level
constructors - they only check that types, but not values, are valid, so
are for expert use only.
}
\keyword{internal}
vctrs/man/vec_split.Rd 0000644 0001762 0000144 00000002406 14276722575 014470 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/split.R
\name{vec_split}
\alias{vec_split}
\title{Split a vector into groups}
\usage{
vec_split(x, by)
}
\arguments{
\item{x}{Vector to divide into groups.}
\item{by}{Vector whose unique values defines the groups.}
}
\value{
A data frame with two columns and size equal to
\code{vec_size(vec_unique(by))}. The \code{key} column has the same type as
\code{by}, and the \code{val} column is a list containing elements of type
\code{vec_ptype(x)}.
Note for complex types, the default \code{data.frame} print method will be
suboptimal, and you will want to coerce into a tibble to better
understand the output.
}
\description{
This is a generalisation of \code{\link[=split]{split()}} that can split by any type of vector,
not just factors. Instead of returning the keys in the character names,
the are returned in a separate parallel vector.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_group_loc]{vec_group_loc()}}
\item \code{\link[=vec_chop]{vec_chop()}}
}
}
\examples{
vec_split(mtcars$cyl, mtcars$vs)
vec_split(mtcars$cyl, mtcars[c("vs", "am")])
if (require("tibble")) {
as_tibble(vec_split(mtcars$cyl, mtcars[c("vs", "am")]))
as_tibble(vec_split(mtcars, mtcars[c("vs", "am")]))
}
}
vctrs/man/int64.Rd 0000644 0001762 0000144 00000001344 13532250523 013423 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/type-integer64.R
\name{vec_ptype_full.integer64}
\alias{vec_ptype_full.integer64}
\alias{vec_ptype_abbr.integer64}
\alias{vec_ptype2.integer64}
\alias{vec_cast.integer64}
\title{64 bit integers}
\usage{
\method{vec_ptype_full}{integer64}(x, ...)
\method{vec_ptype_abbr}{integer64}(x, ...)
\method{vec_ptype2}{integer64}(x, y, ...)
\method{vec_cast}{integer64}(x, to, ...)
}
\description{
A \code{integer64} is a 64 bits integer vector, implemented in the \code{bit64} package.
}
\details{
These functions help the \code{integer64} class from \code{bit64} in to
the vctrs type system by providing coercion functions
and casting functions.
}
\keyword{internal}
vctrs/man/vec_locate_sorted_groups.Rd 0000644 0001762 0000144 00000006754 14341667017 017565 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/order.R
\name{vec_locate_sorted_groups}
\alias{vec_locate_sorted_groups}
\title{Locate sorted groups}
\usage{
vec_locate_sorted_groups(
x,
...,
direction = "asc",
na_value = "largest",
nan_distinct = FALSE,
chr_proxy_collate = NULL
)
}
\arguments{
\item{x}{A vector}
\item{...}{These dots are for future extensions and must be empty.}
\item{direction}{Direction to sort in.
\itemize{
\item A single \code{"asc"} or \code{"desc"} for ascending or descending order
respectively.
\item For data frames, a length \code{1} or \code{ncol(x)} character vector containing
only \code{"asc"} or \code{"desc"}, specifying the direction for each column.
}}
\item{na_value}{Ordering of missing values.
\itemize{
\item A single \code{"largest"} or \code{"smallest"} for ordering missing values as the
largest or smallest values respectively.
\item For data frames, a length \code{1} or \code{ncol(x)} character vector containing
only \code{"largest"} or \code{"smallest"}, specifying how missing values should
be ordered within each column.
}}
\item{nan_distinct}{A single logical specifying whether or not \code{NaN} should
be considered distinct from \code{NA} for double and complex vectors. If \code{TRUE},
\code{NaN} will always be ordered between \code{NA} and non-missing numbers.}
\item{chr_proxy_collate}{A function generating an alternate representation
of character vectors to use for collation, often used for locale-aware
ordering.
\itemize{
\item If \code{NULL}, no transformation is done.
\item Otherwise, this must be a function of one argument. If the input contains
a character vector, it will be passed to this function after it has been
translated to UTF-8. This function should return a character vector with
the same length as the input. The result should sort as expected in the
C-locale, regardless of encoding.
}
For data frames, \code{chr_proxy_collate} will be applied to all character
columns.
Common transformation functions include: \code{tolower()} for case-insensitive
ordering and \code{stringi::stri_sort_key()} for locale-aware ordering.}
}
\value{
A two column data frame with size equal to \code{vec_size(vec_unique(x))}.
\itemize{
\item A \code{key} column of type \code{vec_ptype(x)}.
\item A \code{loc} column of type list, with elements of type integer.
}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
\code{vec_locate_sorted_groups()} returns a data frame containing a \code{key} column
with sorted unique groups, and a \code{loc} column with the locations of each
group in \code{x}. It is similar to \code{\link[=vec_group_loc]{vec_group_loc()}}, except the groups are
returned sorted rather than by first appearance.
}
\details{
\code{vec_locate_sorted_groups(x)} is equivalent to, but faster than:
\if{html}{\out{}}\preformatted{info <- vec_group_loc(x)
vec_slice(info, vec_order(info$key))
}\if{html}{\out{
}}
}
\section{Dependencies of \code{vec_locate_sorted_groups()}}{
\itemize{
\item \code{\link[=vec_proxy_order]{vec_proxy_order()}}
}
}
\examples{
df <- data.frame(
g = sample(2, 10, replace = TRUE),
x = c(NA, sample(5, 9, replace = TRUE))
)
# `vec_locate_sorted_groups()` is similar to `vec_group_loc()`, except keys
# are returned ordered rather than by first appearance.
vec_locate_sorted_groups(df)
vec_group_loc(df)
}
\keyword{internal}
vctrs/man/vec_expand_grid.Rd 0000644 0001762 0000144 00000004625 14362266120 015607 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/expand.R
\name{vec_expand_grid}
\alias{vec_expand_grid}
\title{Create a data frame from all combinations of the inputs}
\usage{
vec_expand_grid(
...,
.vary = "slowest",
.name_repair = "check_unique",
.error_call = current_env()
)
}
\arguments{
\item{...}{Name-value pairs. The name will become the column name in the
resulting data frame.}
\item{.vary}{One of:
\itemize{
\item \code{"slowest"} to vary the first column slowest. This produces sorted
output and is generally the most useful.
\item \code{"fastest"} to vary the first column fastest. This matches the behavior
of \code{\link[=expand.grid]{expand.grid()}}.
}}
\item{.name_repair}{One of \code{"check_unique"}, \code{"unique"}, \code{"universal"},
\code{"minimal"}, \code{"unique_quiet"}, or \code{"universal_quiet"}. See \code{\link[=vec_as_names]{vec_as_names()}}
for the meaning of these options.}
\item{.error_call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\value{
A data frame with as many columns as there are inputs in \code{...} and as many
rows as the \code{\link[=prod]{prod()}} of the sizes of the inputs.
}
\description{
\code{vec_expand_grid()} creates a new data frame by creating a grid of all
possible combinations of the input vectors. It is inspired by
\code{\link[=expand.grid]{expand.grid()}}. Compared with \code{expand.grid()}, it:
\itemize{
\item Produces sorted output by default by varying the first column the slowest,
rather than the fastest. Control this with \code{.vary}.
\item Never converts strings to factors.
\item Does not add additional attributes.
\item Drops \code{NULL} inputs.
\item Can expand any vector type, including data frames and \link[=new_rcrd]{records}.
}
}
\details{
If any input is empty (i.e. size 0), then the result will have 0 rows.
If no inputs are provided, the result is a 1 row data frame with 0 columns.
This is consistent with the fact that \code{prod()} with no inputs returns \code{1}.
}
\examples{
vec_expand_grid(x = 1:2, y = 1:3)
# Use `.vary` to match `expand.grid()`:
vec_expand_grid(x = 1:2, y = 1:3, .vary = "fastest")
# Can also expand data frames
vec_expand_grid(
x = data_frame(a = 1:2, b = 3:4),
y = 1:4
)
}
vctrs/man/vec_as_subscript.Rd 0000644 0001762 0000144 00000004350 14512002264 016011 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/subscript.R
\name{vec_as_subscript}
\alias{vec_as_subscript}
\alias{vec_as_subscript2}
\title{Convert to a base subscript type}
\usage{
vec_as_subscript(
i,
...,
logical = c("cast", "error"),
numeric = c("cast", "error"),
character = c("cast", "error"),
arg = NULL,
call = caller_env()
)
vec_as_subscript2(
i,
...,
numeric = c("cast", "error"),
character = c("cast", "error"),
arg = NULL,
call = caller_env()
)
}
\arguments{
\item{i}{An integer, character or logical vector specifying the
locations or names of the observations to get/set. Specify
\code{TRUE} to index all elements (as in \code{x[]}), or \code{NULL}, \code{FALSE} or
\code{integer()} to index none (as in \code{x[NULL]}).}
\item{...}{These dots are for future extensions and must be empty.}
\item{logical, numeric, character}{How to handle logical, numeric,
and character subscripts.
If \code{"cast"} and the subscript is not one of the three base types
(logical, integer or character), the subscript is
\link[=vec_cast]{cast} to the relevant base type, e.g. factors are
coerced to character. \code{NULL} is treated as an empty integer
vector, and is thus coercible depending on the setting of
\code{numeric}. Symbols are treated as character vectors and thus
coercible depending on the setting of \code{character}.
If \code{"error"}, the subscript type is disallowed and triggers an
informative error.}
\item{arg}{The argument name to be displayed in error messages.}
\item{call}{The execution environment of a currently
running function, e.g. \code{caller_env()}. The function will be
mentioned in error messages as the source of the error. See the
\code{call} argument of \code{\link[rlang:abort]{abort()}} for more information.}
}
\description{
\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}
Convert \code{i} to the base type expected by \code{\link[=vec_as_location]{vec_as_location()}} or
\code{\link[=vec_as_location2]{vec_as_location2()}}. The values of the subscript type are
not checked in any way (length, missingness, negative elements).
}
\keyword{internal}
vctrs/man/vec_unique.Rd 0000644 0001762 0000144 00000003434 14276722575 014645 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/dictionary.R
\name{vec_unique}
\alias{vec_unique}
\alias{vec_unique_loc}
\alias{vec_unique_count}
\title{Find and count unique values}
\usage{
vec_unique(x)
vec_unique_loc(x)
vec_unique_count(x)
}
\arguments{
\item{x}{A vector (including a data frame).}
}
\value{
\itemize{
\item \code{vec_unique()}: a vector the same type as \code{x} containing only unique
values.
\item \code{vec_unique_loc()}: an integer vector, giving locations of unique values.
\item \code{vec_unique_count()}: an integer vector of length 1, giving the
number of unique values.
}
}
\description{
\itemize{
\item \code{vec_unique()}: the unique values. Equivalent to \code{\link[=unique]{unique()}}.
\item \code{vec_unique_loc()}: the locations of the unique values.
\item \code{vec_unique_count()}: the number of unique values.
}
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_proxy_equal]{vec_proxy_equal()}}
}
}
\section{Missing values}{
In most cases, missing values are not considered to be equal, i.e.
\code{NA == NA} is not \code{TRUE}. This behaviour would be unappealing here,
so these functions consider all \code{NAs} to be equal. (Similarly,
all \code{NaN} are also considered to be equal.)
}
\examples{
x <- rpois(100, 8)
vec_unique(x)
vec_unique_loc(x)
vec_unique_count(x)
# `vec_unique()` returns values in the order that encounters them
# use sort = "location" to match to the result of `vec_count()`
head(vec_unique(x))
head(vec_count(x, sort = "location"))
# Normally missing values are not considered to be equal
NA == NA
# But they are for the purposes of considering uniqueness
vec_unique(c(NA, NA, NA, NA, 1, 2, 1))
}
\seealso{
\link{vec_duplicate} for functions that work with the dual of
unique values: duplicated values.
}
vctrs/man/vec_compare.Rd 0000644 0001762 0000144 00000002542 14315060307 014742 0 ustar ligges users % Generated by roxygen2: do not edit by hand
% Please edit documentation in R/compare.R
\name{vec_compare}
\alias{vec_compare}
\title{Compare two vectors}
\usage{
vec_compare(x, y, na_equal = FALSE, .ptype = NULL)
}
\arguments{
\item{x, y}{Vectors with compatible types and lengths.}
\item{na_equal}{Should \code{NA} values be considered equal?}
\item{.ptype}{Override to optionally specify common type}
}
\value{
An integer vector with values -1 for \code{x < y}, 0 if \code{x == y},
and 1 if \code{x > y}. If \code{na_equal} is \code{FALSE}, the result will be \code{NA}
if either \code{x} or \code{y} is \code{NA}.
}
\description{
Compare two vectors
}
\section{S3 dispatch}{
\code{vec_compare()} is not generic for performance; instead it uses
\code{\link[=vec_proxy_compare]{vec_proxy_compare()}} to create a proxy that is used in the comparison.
}
\section{Dependencies}{
\itemize{
\item \code{\link[=vec_cast_common]{vec_cast_common()}} with fallback
\item \code{\link[=vec_recycle_common]{vec_recycle_common()}}
\item \code{\link[=vec_proxy_compare]{vec_proxy_compare()}}
}
}
\examples{
vec_compare(c(TRUE, FALSE, NA), FALSE)
vec_compare(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE)
vec_compare(1:10, 5)
vec_compare(runif(10), 0.5)
vec_compare(letters[1:10], "d")
df <- data.frame(x = c(1, 1, 1, 2), y = c(0, 1, 2, 1))
vec_compare(df, data.frame(x = 1, y = 1))
}
vctrs/DESCRIPTION 0000644 0001762 0000144 00000003316 14532470452 013132 0 ustar ligges users Package: vctrs
Title: Vector Helpers
Version: 0.6.5
Authors@R: c(
person("Hadley", "Wickham", , "hadley@posit.co", role = "aut"),
person("Lionel", "Henry", , "lionel@posit.co", role = "aut"),
person("Davis", "Vaughan", , "davis@posit.co", role = c("aut", "cre")),
person("data.table team", role = "cph",
comment = "Radix sort based on data.table's forder() and their contribution to R's order()"),
person("Posit Software, PBC", role = c("cph", "fnd"))
)
Description: Defines new notions of prototype and size that are used to
provide tools for consistent and well-founded type-coercion and
size-recycling, and are in turn connected to ideas of type- and
size-stability useful for analysing function interfaces.
License: MIT + file LICENSE
URL: https://vctrs.r-lib.org/, https://github.com/r-lib/vctrs
BugReports: https://github.com/r-lib/vctrs/issues
Depends: R (>= 3.5.0)
Imports: cli (>= 3.4.0), glue, lifecycle (>= 1.0.3), rlang (>= 1.1.0)
Suggests: bit64, covr, crayon, dplyr (>= 0.8.5), generics, knitr,
pillar (>= 1.4.4), pkgdown (>= 2.0.1), rmarkdown, testthat (>=
3.0.0), tibble (>= 3.1.3), waldo (>= 0.2.0), withr, xml2,
zeallot
VignetteBuilder: knitr
Config/Needs/website: tidyverse/tidytemplate
Config/testthat/edition: 3
Encoding: UTF-8
Language: en-GB
RoxygenNote: 7.2.3
NeedsCompilation: yes
Packaged: 2023-12-01 16:27:12 UTC; davis
Author: Hadley Wickham [aut],
Lionel Henry [aut],
Davis Vaughan [aut, cre],
data.table team [cph] (Radix sort based on data.table's forder() and
their contribution to R's order()),
Posit Software, PBC [cph, fnd]
Maintainer: Davis Vaughan
Repository: CRAN
Date/Publication: 2023-12-01 23:50:02 UTC
vctrs/build/ 0000755 0001762 0000144 00000000000 14532404540 012513 5 ustar ligges users vctrs/build/vignette.rds 0000644 0001762 0000144 00000000457 14532404540 015060 0 ustar ligges users AO0afLf>.
.^@&q ܈W`ھ 1!dF0 9wpGp-ak!%sY82'm5eB
یmj1p*jP$f9
Ze,e9< @2UNzo>Օ:s̙Öҡۡ ZO F00DqAOϼhKମ+HF{!9& A`;^sUY A and a > B
res <- vec_locate_matches(x, y, condition = "<")
expect_identical(res$needles, c(1L, 2L, 2L, 2L))
expect_identical(res$haystack, c(3L, 1L, 3L, 4L))
})
test_that("`chr_proxy_collate` can affect the matching process", {
x <- c("a", "A")
y <- c("a", "A")
res <- vec_locate_matches(x, y, condition = "==")
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, 1:2)
res <- vec_locate_matches(x, y, condition = "==", chr_proxy_collate = tolower)
expect_identical(res$needles, c(1L, 1L, 2L, 2L))
expect_identical(res$haystack, c(1L, 2L, 1L, 2L))
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - lists
test_that("lists can be matched", {
x <- list(1, 2, 1, NULL)
y <- list(1, 1, 3, NULL)
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L, 4L))
expect_identical(res$haystack, c(1L, 2L, NA, 1L, 2L, 4L))
})
test_that("list incompleteness is detected", {
res <- vec_locate_matches(list(NULL), list(NULL), incomplete = NA)
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
})
test_that("list ordering is by first appearance in `needles` (so non-equi joins don't make much sense)", {
x <- list(3, 2, 1, NULL)
y <- list(1, 3, 1, 3)
res <- vec_locate_matches(x, y, condition = ">")
# x[1] appears first, so it isn't greater than anything
# x[2] is greater than x[1] (when x[1] is in y)
# and so on...
# NULL still doesn't match anything
expect_identical(res$needles, c(1L, 2L, 2L, 3L, 3L, 4L))
expect_identical(res$haystack, c(NA, 2L, 4L, 2L, 4L, NA))
# With data frame columns containing list-columns
df1 <- data_frame(col = data_frame(x = x))
df2 <- data_frame(col = data_frame(x = y))
expect_identical(vec_locate_matches(x, y, condition = ">"), res)
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - data frame
test_that("can match with 1 column data frames", {
df1 <- data_frame(x = c(1L, 3L, 1L, 3L))
df2 <- data_frame(x = c(1L, 3L, 1L))
expect_identical(
vec_locate_matches(df1, df2),
vec_locate_matches(df1$x, df2$x)
)
})
test_that("can match with >1 column data frames", {
df1 <- data_frame(x = c(1L, 3L, 1L, 3L), y = c(1L, 4L, 1L, 2L))
df2 <- data_frame(x = c(1L, 3L, 1L), y = c(1L, 2L, 1L))
res <- vec_locate_matches(df1, df2, condition = c("==", "=="))
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L, 4L))
expect_identical(res$haystack, c(1L, 3L, NA, 1L, 3L, 2L))
})
test_that("can match with df-cols of varying types", {
y <- c(1L, 1L)
expect_needles <- c(1L, 2L)
expect_haystack <- c(NA, 1L)
df1 <- data_frame(x = data_frame(x = c(2L, 1L), y = y))
df2 <- data_frame(x = data_frame(x = c(1L, 3L), y = y))
res <- vec_locate_matches(df1, df2)
expect_identical(res$needles, expect_needles)
expect_identical(res$haystack, expect_haystack)
df1 <- data_frame(x = data_frame(x = c(2, 1), y = y))
df2 <- data_frame(x = data_frame(x = c(1, 3), y = y))
res <- vec_locate_matches(df1, df2)
expect_identical(res$needles, expect_needles)
expect_identical(res$haystack, expect_haystack)
df1 <- data_frame(x = data_frame(x = c(TRUE, FALSE), y = y))
df2 <- data_frame(x = data_frame(x = c(FALSE, NA), y = y))
res <- vec_locate_matches(df1, df2)
expect_identical(res$needles, expect_needles)
expect_identical(res$haystack, expect_haystack)
df1 <- data_frame(x = data_frame(x = c("x", "y"), y = y))
df2 <- data_frame(x = data_frame(x = c("y", "z"), y = y))
res <- vec_locate_matches(df1, df2)
expect_identical(res$needles, expect_needles)
expect_identical(res$haystack, expect_haystack)
df1 <- data_frame(x = data_frame(x = complex(real = c(1, 2), imaginary = c(2, 1)), y = y))
df2 <- data_frame(x = data_frame(x = complex(real = c(2, 3), imaginary = c(1, 1)), y = y))
res <- vec_locate_matches(df1, df2)
expect_identical(res$needles, expect_needles)
expect_identical(res$haystack, expect_haystack)
})
test_that("ensure that matching works if outer runs are present (i.e. `==` comes before non-equi condition)", {
df1 <- data_frame(x = c(1, 2, 1, 1), y = c(2, 2, 3, 2))
df2 <- data_frame(x = c(1, 1), y = c(2, 3))
res <- vec_locate_matches(df1, df2, condition = c("==", "<="))
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 4L, 4L))
expect_identical(res$haystack, c(1L, 2L, NA, 2L, 1L, 2L))
df1$z <- c(1L, 2L, 1L, 3L)
df2$z <- c(5L, 2L)
res <- vec_locate_matches(df1, df2, condition = c("==", "==", "<"))
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(1L, NA, 2L, 1L))
res <- vec_locate_matches(df1, df2, condition = c("==", ">=", "<"))
expect_identical(res$needles, c(1L, 2L, 3L, 3L, 4L))
expect_identical(res$haystack, c(1L, NA, 1L, 2L, 1L))
})
test_that("df-cols propagate an NA if any columns are incomplete", {
df <- data_frame(x = 1, y = data_frame(x = c(1, 1, NA), y = c(1, NA, 2)))
res <- vec_locate_matches(df, df, incomplete = "compare")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, 1:3)
res <- vec_locate_matches(df, df, incomplete = "match")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, 1:3)
# 2nd and 3rd rows aren't fully complete
res <- vec_locate_matches(df, df, incomplete = NA)
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, c(1L, NA, NA))
res <- vec_locate_matches(df, df, incomplete = "drop")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 1L)
})
test_that("df-cols aren't flattened, so `condition` is applied jointly on the df-col columns", {
x <- data_frame(a = 1L, b = data_frame(x = 3L, y = 4L))
y <- data_frame(a = 1L, b = data_frame(x = 2L, y = 5L))
# In particular `x$b[1,] > y$b[1,]` because `3 > 4` and that breaks the tie
# before any values of the `x$b$y` column are checked
res <- vec_locate_matches(x, y, condition = c("==", ">"))
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 1L)
})
test_that("must have at least 1 column to match", {
expect_snapshot(error = TRUE, {
vec_locate_matches(data_frame(), data_frame())
})
expect_snapshot(error = TRUE, {
vec_locate_matches(data_frame(), data_frame(), error_call = call("foo"))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - rcrd
test_that("rcrd types can be matched", {
x <- new_rcrd(list(x = c(1L, 3L), y = c(1L, 4L)))
y <- new_rcrd(list(x = c(1L, 2L), y = c(1L, 5L)))
res <- vec_locate_matches(x, y, condition = "<=")
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(1L, 2L, NA))
# In particular: `(3, 4) > (2, 5)` since the first elt breaks the tie
res <- vec_locate_matches(x, y, condition = ">")
expect_identical(res$needles, c(1L, 2L, 2L))
expect_identical(res$haystack, c(NA, 1L, 2L))
})
test_that("rcrd type matching works with rcrd-cols", {
x <- data_frame(a = c(1L, 1L), b = new_rcrd(list(x = c(1L, 3L), y = c(1L, 4L))))
y <- data_frame(a = c(1L, 1L), b = new_rcrd(list(x = c(1L, 2L), y = c(1L, 5L))))
res <- vec_locate_matches(x, y, condition = c("==", "<="))
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(1L, 2L, NA))
res <- vec_locate_matches(x, y, condition = c("==", ">"))
expect_identical(res$needles, c(1L, 2L, 2L))
expect_identical(res$haystack, c(NA, 1L, 2L))
})
test_that("rcrd type incompleteness is handled correctly", {
x <- new_rcrd(list(x = c(1L, NA), y = c(NA_integer_, NA_integer_)))
y <- new_rcrd(list(x = c(1L, 2L, NA), y = c(NA, 5L, NA)))
# When `incomplete = "compare"`, the types of incompleteness still must
# match exactly to have a match. i.e. (x=1L, y=NA) doesn't match (x=NA, y=1L).
# This is the same as the rule for data frames.
res <- vec_locate_matches(x, y, condition = "==", incomplete = "compare")
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(1L, 3L))
res <- vec_locate_matches(x, y, condition = "==", incomplete = "match")
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(1L, 3L))
# If any field contains NA, the entire observation is incomplete.
res <- vec_locate_matches(x, y, condition = "==", incomplete = NA)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(NA_integer_, NA_integer_))
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - S3
test_that("S3 types with order proxies that depend on the data are combined before the proxy is taken", {
# i.e. `bignum:::vec_proxy_order.bignum_biginteger()`
x <- structure(c(5L, 1L), class = "foo")
y <- structure(c(8L, 5L), class = "foo")
local_methods(
vec_proxy_order.foo = function(x, ...) {
rank(unclass(x))
}
)
# Can't take the order proxies separately because they are the same!
expect_identical(vec_proxy_order(x), vec_proxy_order(y))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, NA))
x_df <- data_frame(a = x, b = x)
y_df <- data_frame(a = y, b = y)
res <- vec_locate_matches(x_df, y_df)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, NA))
})
test_that("Works with base R S3 types we support natively", {
x <- new_factor(c(1L, 2L), levels = c("x", "y"))
y <- new_factor(c(3L, 1L, 1L), levels = c("x", "y", "z"))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, NA))
x <- new_ordered(c(1L, 2L), levels = c("x", "y"))
y <- new_ordered(c(2L, 1L, 1L), levels = c("x", "y"))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, 1L))
x <- new_date(c(1, 2))
y <- new_date(c(3, 1, 1))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, NA))
x <- new_datetime(c(1, 2))
y <- new_datetime(c(3, 1, 1))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, NA))
x <- as.POSIXlt(new_datetime(c(1, 2)))
y <- as.POSIXlt(new_datetime(c(3, 1, 1)))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, NA))
})
test_that("Works with classed data frame columns", {
x_col <- new_data_frame(list(a = c(1L, 2L), b = c(2, 3)), class = "foo")
y_col <- new_data_frame(list(a = c(1L, 1L, 1L), b = c(2, 4, 2)), class = "foo")
x <- new_data_frame(list(c = c(1L, 1L), d = x_col))
y <- new_data_frame(list(c = c(1L, 1L, 1L), d = y_col))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(1L, 3L, NA))
})
test_that("AsIs types are combined before order proxies are taken (#1557)", {
x <- I(list(5, 1))
y <- I(list(8, 5, 5))
res <- vec_locate_matches(x, y)
expect_identical(res$needles, c(1L, 1L, 2L))
expect_identical(res$haystack, c(2L, 3L, NA))
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - ptype2 / casting
test_that("common type of `needles` and `haystack` is taken", {
x <- 1
y <- "a"
expect_snapshot(error = TRUE, {
vec_locate_matches(x, y)
})
expect_snapshot(error = TRUE, {
vec_locate_matches(x, y, needles_arg = "x", error_call = call("foo"))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - missing values
test_that("integer missing values match with `==`, `>=`, and `<=` when `incomplete = 'compare'", {
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "==")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">=")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
})
test_that("integer missing values can match with any condition when `incomplete = 'match'`", {
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "==", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">=", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
})
test_that("integer missing values report all matches even with a `filter`", {
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=", filter = "min")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<", filter = "min", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">=", filter = "max")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = ">", filter = "max", incomplete = "match")
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(2L, 4L))
})
test_that("integer missing value matches can be limited by `multiple`", {
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=", multiple = "first")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 2L)
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=", multiple = "last")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 4L)
res <- vec_locate_matches(NA_integer_, c(1L, NA, 2L, NA), condition = "<=", multiple = "any")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 2L)
})
test_that("missing values match within columns", {
df1 <- data_frame(x = c(1L, 2L, 1L), y = rep(NA_integer_, 3))
df2 <- data_frame(x = c(2L, 1L, 1L), y = c(1L, NA, NA))
res <- vec_locate_matches(df1, df2, condition = c("==", "=="))
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L))
expect_identical(res$haystack, c(2L, 3L, NA, 2L, 3L))
expect_identical(
vec_locate_matches(df1, df2, condition = c("<=", ">=")),
vec_locate_matches(df1, df2, condition = c("==", "=="))
)
res <- vec_locate_matches(df1, df2, condition = c("<", ">"))
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, rep(NA_integer_, 3))
res <- vec_locate_matches(df1, df2, condition = c("<=", ">"), incomplete = "compare")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, rep(NA_integer_, 3))
res <- vec_locate_matches(df1, df2, condition = c("<=", ">"), incomplete = "match")
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L))
expect_identical(res$haystack, c(2L, 3L, NA, 2L, 3L))
})
test_that("missing values being 'match'ed hands off correctly to next column", {
df1 <- data_frame(x = c(NA, NA, 1L, 2L, NA), y = c(2, 3, 0, 1, NA))
df2 <- data_frame(x = c(NA, NA, NA, 3L), y = c(2, 1, NA, 0))
res <- vec_locate_matches(df1, df2, condition = c("<", ">"), incomplete = "match")
expect_identical(res$needles, c(1L, 2L, 2L, 3L, 4L, 5L))
expect_identical(res$haystack, c(2L, 1L, 2L, NA, 4L, 3L))
})
test_that("integer needles can't match NAs in the haystack", {
# At the C level, 1L > NA_integer_ (INT_MIN),
# but we are careful to work around this
res <- vec_locate_matches(1L, c(1L, NA, 2L, NA), condition = ">=")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 1L)
res <- vec_locate_matches(1L, c(1L, NA, 2L, NA), condition = ">")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
})
test_that("double needles can't match NAs or NaNs in the haystack", {
# At the C level, our helpers assumg NA and NaN are the smallest values,
# so we are careful to avoid including them with >= and > conditions
res <- vec_locate_matches(1, c(1, NA, 2, NaN), condition = ">=")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, 1L)
res <- vec_locate_matches(1, c(1, NA, 2, NaN), condition = ">")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
})
test_that("NA and NaN match correctly with non-equi conditions and `nan_distinct`", {
res <- vec_locate_matches(c(NA, NaN), c(1L, NA, 2L, NaN), condition = "<=", nan_distinct = TRUE)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(c(NA, NaN), c(1L, NA, 2L, NaN), condition = "<", nan_distinct = TRUE)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(NA_integer_, NA_integer_))
res <- vec_locate_matches(c(NA, NaN), c(1L, NA, 2L, NaN), condition = "<", nan_distinct = TRUE, incomplete = "match")
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, 4L))
res <- vec_locate_matches(c(NA, NaN), c(1L, NA, 2L, NaN), condition = ">=", nan_distinct = FALSE)
expect_identical(res$needles, c(1L, 1L, 2L, 2L))
expect_identical(res$haystack, c(2L, 4L, 2L, 4L))
res <- vec_locate_matches(c(NA, NaN), c(1L, NA, 2L, NaN), condition = ">", nan_distinct = FALSE, incomplete = "match")
expect_identical(res$needles, c(1L, 1L, 2L, 2L))
expect_identical(res$haystack, c(2L, 4L, 2L, 4L))
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `incomplete`
test_that("can handle incomplete needles with `incomplete = `", {
x <- c(1L, NA, 2L)
y <- c(NA, 1L, 1L)
res <- vec_locate_matches(x, y, condition = "==", incomplete = NA)
expect_identical(res$needles, c(1L, 1L, 2L, 3L))
expect_identical(res$haystack, c(2L, 3L, NA, NA))
res <- vec_locate_matches(x, y, condition = "<=", incomplete = 0L)
expect_identical(res$needles, c(1L, 1L, 2L, 3L))
expect_identical(res$haystack, c(2L, 3L, 0L, NA))
res <- vec_locate_matches(x, y, condition = ">=", incomplete = -1L)
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L))
expect_identical(res$haystack, c(2L, 3L, -1L, 2L, 3L))
})
test_that("can drop incomplete needle rows with `incomplete = 'drop'", {
x <- c(1L, NA, 2L)
y <- c(NA, 1L, 1L)
res <- vec_locate_matches(x, y, condition = "==", incomplete = "drop")
expect_identical(res$needles, c(1L, 1L, 3L))
expect_identical(res$haystack, c(2L, 3L, NA))
})
test_that("if `incomplete = `, an NA in any column results in the value", {
df1 <- data_frame(x = c(1L, NA, 2L, 1L, 1L), y = c(2L, 2L, NA, 1L, 1L))
df2 <- data_frame(x = c(1L, 1L, 2L), y = c(1L, 1L, NA))
res <- vec_locate_matches(df1, df2, condition = c("==", "=="), incomplete = NA)
expect_identical(res$needles, c(1L, 2L, 3L, 4L, 4L, 5L, 5L))
expect_identical(res$haystack, c(NA, NA, NA, 1L, 2L, 1L, 2L))
res <- vec_locate_matches(df1, df2, condition = c(">=", ">="), incomplete = NA)
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 4L, 4L, 5L, 5L))
expect_identical(res$haystack, c(1L, 2L, NA, NA, 1L, 2L, 1L, 2L))
})
test_that("`incomplete = / 'drop'` still handles NAs in future columns when an earlier column has no matches", {
df1 <- data_frame(x = c(1, 1, 2, 3), y = c(1, NA, NA, 4))
df2 <- data_frame(x = c(1, 3), y = c(1, 5))
# The 2 in row 3 of df1 has no match, but the NA in the 2nd column still propagates
res <- vec_locate_matches(df1, df2, incomplete = NA, no_match = -1L)
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(1L, NA, NA, -1L))
res <- vec_locate_matches(df1, df2, incomplete = "drop", no_match = -1L)
expect_identical(res$needles, c(1L, 4L))
expect_identical(res$haystack, c(1L, -1L))
# The 1 in row 1 and 2 of df1 have no match, but the NA in row 2 of the 2nd column propagates
res <- vec_locate_matches(df1, df2, incomplete = NA, no_match = -1L, condition = ">")
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(-1L, NA, NA, 1L))
res <- vec_locate_matches(df1, df2, incomplete = "drop", no_match = -1L, condition = ">")
expect_identical(res$needles, c(1L, 4L))
expect_identical(res$haystack, c(-1L, 1L))
})
test_that("`incomplete` can error informatively", {
expect_snapshot({
(expect_error(vec_locate_matches(NA, 1, incomplete = "error")))
(expect_error(vec_locate_matches(NA, 1, incomplete = "error", needles_arg = "foo")))
(expect_error(vec_locate_matches(NA, 1, incomplete = "error", needles_arg = "foo", error_call = call("fn"))))
})
})
test_that("`incomplete` error is classed", {
expect_error(vec_locate_matches(NA, 1, incomplete = "error"), class = "vctrs_error_matches_incomplete")
})
test_that("`incomplete` is validated", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, incomplete = 1.5)))
(expect_error(vec_locate_matches(1, 2, incomplete = c("match", "drop"))))
(expect_error(vec_locate_matches(1, 2, incomplete = "x")))
# Uses internal call
(expect_error(vec_locate_matches(1, 2, incomplete = "x", error_call = call("fn"))))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `condition`
test_that("multiple matches from a non-equi condition are returned in first appearance order", {
res <- vec_locate_matches(0L, c(1L, 0L, -1L, 0L), condition = "<=")
expect_identical(res$needles, rep(1L, 3))
expect_identical(res$haystack, c(1L, 2L, 4L))
# Checking equi for good measure
res <- vec_locate_matches(0L, c(1L, 0L, -1L, 0L), condition = "==")
expect_identical(res$needles, rep(1L, 2))
expect_identical(res$haystack, c(2L, 4L))
})
test_that("multiple matches from a non-equi condition are returned in first appearance order when the matches are in different nesting containers", {
df <- data_frame(x = 0, y = 0)
df2 <- data_frame(x = 2:1, y = 1:2)
res <- vec_locate_matches(df, df2, condition = c("<=", "<="))
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(1L, 2L))
})
test_that("`condition` is validated", {
expect_error(vec_locate_matches(1, 2, condition = 1), "`condition` must be a character vector")
expect_error(vec_locate_matches(1, 2, condition = "x"), 'must only contain "==", ">", ">=", "<", or "<="')
expect_error(vec_locate_matches(1, 2, condition = c("==", "==")), "must be length 1, or the same length as the number of columns of the input")
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `multiple`
test_that("can get all matches", {
x <- vec_locate_matches(c(1L, 3L), c(1L, 3L, 1L, 3L), multiple = "all")
expect_identical(x$needles, c(1L, 1L, 2L, 2L))
expect_identical(x$haystack, c(1L, 3L, 2L, 4L))
})
test_that("can get first match", {
x <- vec_locate_matches(c(1L, 3L), c(1L, 3L, 1L, 3L), multiple = "first")
expect_identical(x$needles, 1:2)
expect_identical(x$haystack, 1:2)
})
test_that("can get last match", {
x <- vec_locate_matches(c(1L, 3L), c(1L, 3L, 1L, 3L), multiple = "last")
expect_identical(x$needles, 1:2)
expect_identical(x$haystack, 3:4)
})
test_that("can get any match", {
x <- vec_locate_matches(c(1L, 3L), c(1L, 3L, 1L, 3L), multiple = "any")
expect_identical(x$needles, 1:2)
expect_identical(x$haystack, 1:2)
})
test_that("duplicate needles match the same haystack locations", {
x <- vec_locate_matches(c(1L, 3L, 1L, 3L), c(1L, 3L, 1L), multiple = "all")
expect_identical(x$needles, c(1L, 1L, 2L, 3L, 3L, 4L))
expect_identical(x$haystack, c(1L, 3L, 2L, 1L, 3L, 2L))
})
test_that("correctly gets all matches when they come from different nesting containers", {
needles <- data_frame(
a = c(1, 8),
b = c(2, 9)
)
haystack <- data_frame(
a = c(6, 5),
b = c(6, 7)
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "all"),
data_frame(needles = c(1L, 1L, 2L), haystack = c(1L, 2L, NA))
)
})
test_that("correctly gets first/last/any match when they come from different nesting containers", {
needles <- data_frame(
a = c(1, 8),
b = c(2, 9)
)
haystack <- data_frame(
a = c(6, 5, 0),
b = c(6, 7, 1)
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "first"),
data_frame(needles = c(1L, 2L), haystack = c(1L, NA))
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "last"),
data_frame(needles = c(1L, 2L), haystack = c(2L, NA))
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "any"),
data_frame(needles = c(1L, 2L), haystack = c(2L, NA))
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "first", remaining = NA_integer_),
data_frame(needles = c(1L, 2L, NA, NA), haystack = c(1L, NA, 2L, 3L))
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "last", remaining = NA_integer_),
data_frame(needles = c(1L, 2L, NA, NA), haystack = c(2L, NA, 1L, 3L))
)
expect_identical(
vec_locate_matches(needles, haystack, condition = "<", multiple = "any", remaining = NA_integer_),
data_frame(needles = c(1L, 2L, NA, NA), haystack = c(2L, NA, 1L, 3L))
)
})
test_that("`multiple` is validated", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, multiple = 1.5)))
(expect_error(vec_locate_matches(1, 2, multiple = c("first", "last"))))
(expect_error(vec_locate_matches(1, 2, multiple = "x")))
# Uses internal error
(expect_error(vec_locate_matches(1, 2, multiple = "x", error_call = call("fn"))))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `multiple` (deprecated)
test_that("`multiple` can error informatively", {
expect_snapshot({
(expect_error(vec_locate_matches(1L, c(1L, 1L), multiple = "error")))
(expect_error(vec_locate_matches(1L, c(1L, 1L), multiple = "error", needles_arg = "foo")))
(expect_error(vec_locate_matches(1L, c(1L, 1L), multiple = "error", needles_arg = "foo", error_call = call("fn"))))
(expect_error(vec_locate_matches(1L, c(1L, 1L), multiple = "error", needles_arg = "foo", haystack_arg = "bar")))
})
})
test_that("`multiple` can warn informatively", {
expect_snapshot({
(expect_warning(vec_locate_matches(1L, c(1L, 1L), multiple = "warning")))
(expect_warning(vec_locate_matches(1L, c(1L, 1L), multiple = "warning", needles_arg = "foo")))
(expect_warning(vec_locate_matches(1L, c(1L, 1L), multiple = "warning", needles_arg = "foo", error_call = call("fn"))))
(expect_warning(vec_locate_matches(1L, c(1L, 1L), multiple = "warning", needles_arg = "foo", haystack_arg = "bar")))
})
})
test_that("warning falls back to 'all'", {
expect_warning(
result <- vec_locate_matches(c(1L, 3L, 1L, 3L), c(1L, 3L, 1L), multiple = "warning"),
class = "vctrs_warning_matches_multiple"
)
expect_identical(
result,
vec_locate_matches(c(1L, 3L, 1L, 3L), c(1L, 3L, 1L), multiple = "all")
)
})
test_that("errors on multiple matches that come from different nesting containers", {
df <- data_frame(x = 0, y = 0)
df2 <- data_frame(x = 1:2, y = 2:1)
expect_snapshot(error = TRUE, {
vec_locate_matches(df, df2, condition = c("<=", "<="), multiple = "error")
})
})
test_that("errors when a match from a different nesting container is processed early on", {
# Row 1 has 2 matches
# Row 2 has 0 matches
needles <- data_frame(
a = c(1, 8),
b = c(2, 9)
)
# Rows 1 and 2 end up in different nesting containers
haystack <- data_frame(
a = c(5, 6),
b = c(7, 6)
)
# needles[1,] records the haystack[1,] match first, which is in the 1st
# value of `loc_first_match_o_haystack`, then records the haystack[3,] match
# which is in the 3rd value of `loc_first_match_o_haystack` even though it
# is processed 2nd (i.e. we need to use `loc` rather than `i` when detecting
# multiple matches)
expect_snapshot(error = TRUE, {
vec_locate_matches(needles, haystack, condition = "<", multiple = "error")
})
})
test_that("`multiple = 'error'` doesn't error errneously on the last observation", {
expect_error(res <- vec_locate_matches(1:2, 1:2, multiple = "error"), NA)
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, 1:2)
})
test_that("`multiple = 'error' / 'warning'` throw correctly when combined with `relationship`", {
x <- c(1, 2, 2)
y <- c(2, 1, 2)
# `multiple` error technically fires first
expect_snapshot({
(expect_error(vec_locate_matches(x, y, relationship = "one-to-one", multiple = "error")))
})
# Works when warning is also requested
expect_snapshot({
(expect_error(vec_locate_matches(x, y, relationship = "warn-many-to-many", multiple = "error")))
})
# Both warnings are thrown if applicable
expect_snapshot({
vec_locate_matches(x, y, relationship = "warn-many-to-many", multiple = "warning")
})
# Both warning and error are thrown if applicable
expect_snapshot(error = TRUE, {
vec_locate_matches(x, y, relationship = "one-to-one", multiple = "warning")
})
x <- c(1, 2)
y <- c(2, 1, 2)
expect_snapshot({
(expect_error(vec_locate_matches(x, y, relationship = "warn-many-to-many", multiple = "error")))
})
# Only `multiple` warning is applicable here
expect_snapshot({
vec_locate_matches(x, y, relationship = "warn-many-to-many", multiple = "warning")
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `relationship`
test_that("`relationship` handles one-to-one case", {
# No error
expect_identical(
vec_locate_matches(1:2, 2:1, relationship = "one-to-one"),
vec_locate_matches(1:2, 2:1)
)
# Doesn't care about the zero match case
expect_identical(
vec_locate_matches(1:2, 3:4, relationship = "one-to-one"),
vec_locate_matches(1:2, 3:4)
)
expect_snapshot({
(expect_error(vec_locate_matches(c(2, 1), c(1, 1), relationship = "one-to-one")))
(expect_error(vec_locate_matches(c(1, 1), c(1, 2), relationship = "one-to-one")))
})
})
test_that("`relationship` handles one-to-many case", {
# No error
expect_identical(
vec_locate_matches(c(1, 2), c(1, 2, 2), relationship = "one-to-many"),
vec_locate_matches(c(1, 2), c(1, 2, 2))
)
# Doesn't care about the zero match case
expect_identical(
vec_locate_matches(1:2, 3:4, relationship = "one-to-many"),
vec_locate_matches(1:2, 3:4)
)
expect_snapshot({
(expect_error(vec_locate_matches(c(1, 2, 2), c(2, 1), relationship = "one-to-many")))
})
})
test_that("`relationship` handles many-to-one case", {
# No error
expect_identical(
vec_locate_matches(c(1, 2, 2), c(1, 2), relationship = "many-to-one"),
vec_locate_matches(c(1, 2, 2), c(1, 2))
)
# Doesn't care about the zero match case
expect_identical(
vec_locate_matches(1:2, 3:4, relationship = "many-to-one"),
vec_locate_matches(1:2, 3:4)
)
expect_snapshot({
(expect_error(vec_locate_matches(c(1, 2), c(1, 2, 2), relationship = "many-to-one")))
})
})
test_that("`relationship` handles many-to-many case", {
# No error
expect_identical(
vec_locate_matches(c(1, 2, 2), c(1, 2), relationship = "many-to-many"),
vec_locate_matches(c(1, 2, 2), c(1, 2))
)
# No error
expect_identical(
vec_locate_matches(c(1, 2), c(1, 2, 2), relationship = "many-to-many"),
vec_locate_matches(c(1, 2), c(1, 2, 2))
)
# No error
expect_identical(
vec_locate_matches(c(1, 1, 2), c(1, 2, 2), relationship = "many-to-many"),
vec_locate_matches(c(1, 1, 2), c(1, 2, 2))
)
# Doesn't care about the zero match case
expect_identical(
vec_locate_matches(1:2, 3:4, relationship = "many-to-many"),
vec_locate_matches(1:2, 3:4)
)
})
test_that("`relationship` handles warn-many-to-many case", {
# No warning
expect_identical(
expect_silent(
vec_locate_matches(c(1, 2, 2), c(1, 2), relationship = "warn-many-to-many")
),
vec_locate_matches(c(1, 2, 2), c(1, 2))
)
# No warning
expect_identical(
expect_silent(
vec_locate_matches(c(1, 2), c(1, 2, 2), relationship = "warn-many-to-many")
),
vec_locate_matches(c(1, 2), c(1, 2, 2))
)
# Doesn't care about the zero match case
expect_identical(
expect_silent(
vec_locate_matches(1:2, 3:4, relationship = "warn-many-to-many")
),
vec_locate_matches(1:2, 3:4)
)
# Specifically designed to ensure we test both:
# - Finding multiple `needles` matches before multiple `haystack` matches
# - Finding multiple `haystack` matches before multiple `needles` matches
expect_snapshot({
(expect_warning(vec_locate_matches(c(1, 2, 1), c(1, 2, 2), relationship = "warn-many-to-many")))
(expect_warning(vec_locate_matches(c(1, 1, 2), c(2, 2, 1), relationship = "warn-many-to-many")))
})
})
test_that("`relationship` considers `incomplete` matches as possible multiple matches", {
x <- c(1, NA, NaN)
y <- c(NA, 1)
expect_snapshot({
(expect_error(vec_locate_matches(x, y, relationship = "one-to-many")))
})
# No error
expect_identical(
vec_locate_matches(x, y, relationship = "one-to-many", incomplete = NA),
vec_locate_matches(x, y, incomplete = NA)
)
# No error
expect_identical(
vec_locate_matches(x, y, relationship = "one-to-many", nan_distinct = TRUE),
vec_locate_matches(x, y, nan_distinct = TRUE)
)
})
test_that("`relationship` errors on multiple matches that come from different nesting containers", {
df <- data_frame(x = 0, y = 0)
df2 <- data_frame(x = 1:2, y = 2:1)
expect_snapshot({
(expect_error(vec_locate_matches(df, df2, condition = c("<=", "<="), relationship = "many-to-one")))
})
})
test_that("`relationship` errors when a match from a different nesting container is processed early on", {
# Row 1 has 2 matches
# Row 2 has 0 matches
needles <- data_frame(
a = c(1, 8),
b = c(2, 9)
)
# Rows 1 and 2 end up in different nesting containers
haystack <- data_frame(
a = c(5, 6),
b = c(7, 6)
)
# needles[1,] records the haystack[1,] match first, which is in the 1st
# value of `loc_first_match_o_haystack`, then records the haystack[3,] match
# which is in the 3rd value of `loc_first_match_o_haystack` even though it
# is processed 2nd (i.e. we need to use `loc` rather than `i` when detecting
# multiple matches)
expect_snapshot({
(expect_error(vec_locate_matches(needles, haystack, condition = "<", relationship = "many-to-one")))
})
})
test_that("`relationship` doesn't error errneously on the last observation", {
expect_error(res <- vec_locate_matches(1:2, 1:2, relationship = "many-to-one"), NA)
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, 1:2)
})
test_that("`relationship` doesn't error if `multiple` removes multiple matches", {
out <- vec_locate_matches(c(1, 2), c(1, 1), multiple = "any", relationship = "one-to-one")
expect_identical(out$needles, c(1L, 2L))
expect_identical(out$haystack, c(1L, NA))
out <- vec_locate_matches(c(1, 2), c(1, 1), multiple = "first", relationship = "one-to-one")
expect_identical(out$needles, c(1L, 2L))
expect_identical(out$haystack, c(1L, NA))
out <- vec_locate_matches(c(1, 2), c(1, 1), multiple = "last", relationship = "one-to-one")
expect_identical(out$needles, c(1L, 2L))
expect_identical(out$haystack, c(2L, NA))
})
test_that("`relationship` can still detect problematic `haystack` relationships when `multiple = first/last` are used", {
expect_snapshot({
(expect_error(vec_locate_matches(c(3, 1, 1), c(2, 1, 3, 3), multiple = "first", relationship = "one-to-one")))
(expect_error(vec_locate_matches(c(3, 1, 1), c(2, 1, 3, 3), multiple = "first", relationship = "one-to-many")))
})
})
test_that("`relationship` and `remaining` work properly together", {
expect_snapshot({
out <- vec_locate_matches(
c(1, 2, 2),
c(2, 3, 1, 1, 4),
relationship = "warn-many-to-many",
remaining = NA_integer_
)
})
expect_identical(out$needles, c(1L, 1L, 2L, 3L, NA, NA))
expect_identical(out$haystack, c(3L, 4L, 1L, 1L, 2L, 5L))
})
test_that("`relationship` errors if `condition` creates multiple matches", {
expect_snapshot({
(expect_error(vec_locate_matches(1, c(1, 2), condition = "<=", relationship = "many-to-one")))
})
})
test_that("`relationship` doesn't error if `filter` removes multiple matches", {
out <- vec_locate_matches(1, c(1, 2), condition = "<=", filter = "min", relationship = "many-to-one")
expect_identical(out$needles, 1L)
expect_identical(out$haystack, 1L)
out <- vec_locate_matches(1, c(1, 2), condition = "<=", filter = "max", relationship = "many-to-one")
expect_identical(out$needles, 1L)
expect_identical(out$haystack, 2L)
})
test_that("`relationship` still errors if `filter` hasn't removed all multiple matches", {
expect_snapshot({
(expect_error(vec_locate_matches(1, c(1, 2, 1), condition = "<=", filter = "min", relationship = "many-to-one")))
})
# But not here
out <- vec_locate_matches(c(1, 1), c(1, 2, 1), condition = "<=", filter = "max", relationship = "many-to-one")
expect_identical(out$needles, c(1L, 2L))
expect_identical(out$haystack, c(2L, 2L))
})
test_that("`relationship` errors when we have >1 size 1 matches across containers (tidyverse/dplyr#6835)", {
# Carefully designed to ensure we get 2 nested containment groups that split
# up the rows of `y`, but each of the nested containment groups contain exactly
# 1 match, so `size_match` in `expand_compact_indices()` won't ever be >1
x <- data_frame(a = 1L, b = 5L)
y <- data_frame(a = c(1L, 2L), b = c(4L, 3L))
expect_snapshot(error = TRUE, {
vec_locate_matches(
x,
y,
condition = c("<=", ">="),
filter = c("none", "none"),
relationship = "one-to-one"
)
})
})
test_that("`relationship` doesn't error when the first match from a different container gets filtered out (tidyverse/dplyr#6835)", {
# Carefully designed to ensure we get 2 nested containment groups that split
# up the rows of `y`. Row 1 (processed first) doesn't hold the minimum `b`
# value, so it gets filtered out. Row 2 is in the "extra" matches section
# but is actually the first (and only) real match, so we don't want to error
# on it.
x <- data_frame(a = 1L, b = 5L)
y <- data_frame(a = c(1L, 2L), b = c(4L, 3L))
out <- vec_locate_matches(
x,
y,
condition = c("<=", ">="),
filter = c("none", "min"),
relationship = "one-to-one"
)
expect_identical(out$needles, 1L)
expect_identical(out$haystack, 2L)
# Similar to the above example, but with a `max` filter. Row 1 doesn't hold
# the max `c` value so it is filtered out even though it is a `>=` match.
x <- data_frame(a = 1L, b = 5L, c = 3L)
y <- data_frame(a = c(1L, 2L), b = c(4L, 3L), c = c(1L, 2L))
out <- vec_locate_matches(
x,
y,
condition = c("<=", ">=", ">="),
filter = c("none", "none", "max"),
relationship = "one-to-one"
)
expect_identical(out$needles, 1L)
expect_identical(out$haystack, 2L)
})
test_that("`relationship` errors respect argument tags and error call", {
expect_snapshot({
(expect_error(vec_locate_matches(1L, c(1L, 1L), relationship = "one-to-one", needles_arg = "foo", haystack_arg = "bar", error_call = call("fn"))))
(expect_error(vec_locate_matches(c(1L, 1L), 1L, relationship = "one-to-one", needles_arg = "foo", haystack_arg = "bar", error_call = call("fn"))))
(expect_error(vec_locate_matches(c(1L, 1L), 1L, relationship = "one-to-many", needles_arg = "foo", haystack_arg = "bar", error_call = call("fn"))))
(expect_error(vec_locate_matches(1L, c(1L, 1L), relationship = "many-to-one", needles_arg = "foo", haystack_arg = "bar", error_call = call("fn"))))
})
})
test_that("`relationship` warnings respect argument tags and error call", {
expect_snapshot({
(expect_warning(vec_locate_matches(c(1L, 1L), c(1L, 1L), relationship = "warn-many-to-many", needles_arg = "foo", haystack_arg = "bar", error_call = call("fn"))))
(expect_warning(vec_locate_matches(c(1L, 1L), c(1L, 1L), relationship = "warn-many-to-many", needles_arg = "foo", error_call = call("fn"))))
(expect_warning(vec_locate_matches(c(1L, 1L), c(1L, 1L), relationship = "warn-many-to-many", haystack_arg = "bar", error_call = call("fn"))))
})
})
test_that("`relationship` is validated", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, relationship = 1.5)))
(expect_error(vec_locate_matches(1, 2, relationship = c("one-to-one", "one-to-many"))))
(expect_error(vec_locate_matches(1, 2, relationship = "x")))
# Uses internal error
(expect_error(vec_locate_matches(1, 2, relationship = "x", error_call = call("fn"))))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `no_match`
test_that("can control `no_match`", {
x <- vec_locate_matches(1:3, 1L)
expect_identical(x$haystack, c(1L, NA, NA))
x <- vec_locate_matches(1:3, 1L, no_match = 0L)
expect_identical(x$haystack, c(1L, 0L, 0L))
})
test_that("can drop unmatched needles", {
x <- vec_locate_matches(1:3, 2L, no_match = "drop")
expect_identical(x$needles, 2L)
expect_identical(x$haystack, 1L)
})
test_that("can drop unmatched missings when `incomplete = 'match'`", {
x <- vec_locate_matches(c(NaN, 2, NA), 2, no_match = "drop")
expect_identical(x$needles, 2L)
expect_identical(x$haystack, 1L)
x <- vec_locate_matches(c(NaN, 2, NA), NA, no_match = "drop", nan_distinct = FALSE)
expect_identical(x$needles, c(1L, 3L))
expect_identical(x$haystack, c(1L, 1L))
x <- vec_locate_matches(c(NaN, 2, NA), NA, no_match = "drop", nan_distinct = TRUE)
expect_identical(x$needles, 3L)
expect_identical(x$haystack, 1L)
})
test_that("can differentiate between `no_match` and `incomplete`", {
res <- vec_locate_matches(c(1, NA), 2, incomplete = NA, no_match = -1L)
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, c(-1L, NA))
})
test_that("`no_match` can error informatively", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, no_match = "error")))
(expect_error(vec_locate_matches(1, 2, no_match = "error", needles_arg = "foo")))
(expect_error(vec_locate_matches(1, 2, no_match = "error", needles_arg = "foo", error_call = call("fn"))))
(expect_error(vec_locate_matches(1, 2, no_match = "error", needles_arg = "foo", haystack_arg = "bar")))
})
})
test_that("`no_match = 'error'` doesn't error on handled incomplete values", {
res <- vec_locate_matches(c(NA, NaN, NA, 1), c(NA, 1), incomplete = NA, no_match = "error")
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(rep(NA, 3), 2L))
})
test_that("`no_match = 'drop'` doesn't drop handled incomplete values", {
res <- vec_locate_matches(c(NA, NaN, NA, 1), c(NA, 1), incomplete = NA, no_match = "drop")
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(rep(NA, 3), 2L))
})
test_that("errors with the right location on unmatched needles when different nesting containers are present", {
df <- data_frame(x = 2:1, y = 2:1)
df2 <- data_frame(x = 1:2, y = 2:1)
# i.e. should be location 2
expect_snapshot(
(expect_error(vec_locate_matches(df, df2, condition = ">=", no_match = "error")))
)
})
test_that("`no_match` is validated", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, no_match = 1.5)))
(expect_error(vec_locate_matches(1, 2, no_match = c(1L, 2L))))
(expect_error(vec_locate_matches(1, 2, no_match = "x")))
# Uses internal call
(expect_error(vec_locate_matches(1, 2, no_match = "x", error_call = call("fn"))))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - `remaining`
test_that("`remaining` can retain `haystack` values that `needles` didn't match", {
res <- vec_locate_matches(1, 0:2, remaining = NA)
expect_identical(res$needles, c(1L, NA, NA))
expect_identical(res$haystack, c(2L, 1L, 3L))
res <- vec_locate_matches(1, 0:2, remaining = NA, condition = ">=")
expect_identical(res$needles, c(1L, 1L, NA))
expect_identical(res$haystack, c(1L, 2L, 3L))
res <- vec_locate_matches(1, 0:2, remaining = NA, condition = "<")
expect_identical(res$needles, c(1L, NA, NA))
expect_identical(res$haystack, c(3L, 1L, 2L))
})
test_that("`incomplete` affects `needles` but not `haystack`", {
# Matches NA to NA, so nothing remaining
res <- vec_locate_matches(c(1, NA), c(NA, 1), incomplete = "compare", remaining = NA)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, 1L))
# Matches NA to NA, so nothing remaining
res <- vec_locate_matches(c(1, NA), c(NA, 1), incomplete = "match", remaining = NA)
expect_identical(res$needles, c(1L, 2L))
expect_identical(res$haystack, c(2L, 1L))
# Doesn't match NA to NA, so `haystack` is left with remaining values
res <- vec_locate_matches(c(1, NA), c(NA, 1), condition = "<", incomplete = "compare", remaining = NA)
expect_identical(res$needles, c(1L, 2L, NA, NA))
expect_identical(res$haystack, c(NA, NA, 1L, 2L))
# Matches NA to NA, so only remaining value is for `1`
res <- vec_locate_matches(c(1, NA), c(NA, 1), condition = "<", incomplete = "match", remaining = NA)
expect_identical(res$needles, c(1L, 2L, NA))
expect_identical(res$haystack, c(NA, 1L, 2L))
# `needles` NA value is propagated, so `haystack` is left with a remaining value
res <- vec_locate_matches(c(1, NA), c(NA, 1), incomplete = NA, remaining = NA)
expect_identical(res$needles, c(1L, 2L, NA))
expect_identical(res$haystack, c(2L, NA, 1L))
# `needles` NA value is dropped, so `haystack` is left with a remaining value
res <- vec_locate_matches(c(1, NA), c(NA, 1), incomplete = "drop", remaining = NA)
expect_identical(res$needles, c(1L, NA))
expect_identical(res$haystack, c(2L, 1L))
})
test_that("`remaining` combined with `multiple = 'first/last'` treats non-first/last matches as remaining", {
x <- c(1, 2)
y <- c(1, 2, 2)
res <- vec_locate_matches(x, y, remaining = NA, multiple = "first")
expect_identical(res$needles, c(1L, 2L, NA))
expect_identical(res$haystack, c(1L, 2L, 3L))
res <- vec_locate_matches(x, y, remaining = NA, multiple = "last")
expect_identical(res$needles, c(1L, 2L, NA))
expect_identical(res$haystack, c(1L, 3L, 2L))
res <- vec_locate_matches(x, y, remaining = NA, multiple = "any")
expect_identical(res$needles, c(1L, 2L, NA))
expect_identical(res$haystack, c(1L, 2L, 3L))
})
test_that("`remaining` combined with the haystack reordering retains appearance order", {
x <- data_frame(a = 1, b = 4)
y <- data_frame(a = c(2, 1, 0), b = c(2, 1, 0))
# Appearance order for the haystack locations
res <- vec_locate_matches(x, y, condition = c("<=", ">="))
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(1L, 2L))
# Retain that appearance order of the matches, with remaining values appended
res <- vec_locate_matches(x, y, condition = c("<=", ">="), remaining = NA)
expect_identical(res$needles, c(1L, 1L, NA))
expect_identical(res$haystack, c(1L, 2L, 3L))
})
test_that("`remaining` can error informatively", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, remaining = "error")))
(expect_error(vec_locate_matches(1, 2, remaining = "error", needles_arg = "foo")))
(expect_error(vec_locate_matches(1, 2, remaining = "error", needles_arg = "foo", error_call = call("fn"))))
(expect_error(vec_locate_matches(1, 2, remaining = "error", needles_arg = "foo", haystack_arg = "bar")))
})
})
test_that("`remaining` is validated", {
expect_snapshot({
(expect_error(vec_locate_matches(1, 2, remaining = 1.5)))
(expect_error(vec_locate_matches(1, 2, remaining = c(1L, 2L))))
(expect_error(vec_locate_matches(1, 2, remaining = "x")))
# Uses internal call
(expect_error(vec_locate_matches(1, 2, remaining = "x", error_call = call("fn"))))
})
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - filter
test_that("simple `filter`s work", {
needles <- c(1, 2, 4)
haystack <- c(2, 1, 3, 0)
res <- vec_locate_matches(needles, haystack, condition = "<", filter = "max")
expect_identical(res$haystack, c(3L, 3L, NA))
res <- vec_locate_matches(needles, haystack, condition = "<", filter = "min")
expect_identical(res$haystack, c(1L, 3L, NA))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max")
expect_identical(res$haystack, c(2L, 1L, 3L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "min")
expect_identical(res$haystack, c(4L, 4L, 4L))
})
test_that("haystack duplicates are preserved", {
needles <- c(1, 2, 4)
haystack <- c(2, 1, 2, 3, 0, 1, 0)
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max")
expect_identical(res$needles, c(1L, 1L, 2L, 2L, 3L))
expect_identical(res$haystack, c(2L, 6L, 1L, 3L, 4L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "min")
expect_identical(res$needles, c(1L, 1L, 2L, 2L, 3L, 3L))
expect_identical(res$haystack, c(5L, 7L, 5L, 7L, 5L, 7L))
})
test_that("haystack duplicates can be controlled by `multiple`", {
needles <- c(1, 2, 4)
haystack <- c(2, 1, 2, 3, 0, 1, 0)
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", multiple = "first")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, c(2L, 1L, 4L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", multiple = "last")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, c(6L, 3L, 4L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", multiple = "any")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, c(2L, 1L, 4L))
})
test_that("`filter` works when valid matches are in different nesting containers", {
needles <- data_frame(x = 0L, y = 1L, z = 2L)
haystack <- data_frame(x = c(1L, 2L, 1L, 0L), y = c(2L, 1L, 2L, 3L), z = c(3L, 3L, 2L, 2L))
info <- compute_nesting_container_info(haystack, c("<=", "<=", "<="))
haystack_order <- info[[1]]
container_ids <- info[[2]]
# Rows 1 and 2 of haystack are in different nesting containers, but
# both have the "max" filter value of `z=3` so both should be in the result.
# Row 4 is in its own container, so it will be considered the "max"
# of its group, but it is less than rows 1 and 2 so it will ultimately be
# filtered out.
expect_identical(container_ids, c(1L, 2L, 1L, 0L))
expect_identical(haystack_order, c(4L, 3L, 1L, 2L))
res <- vec_locate_matches(needles, haystack, condition = c("<=", "<=", "<="), filter = c("none", "none", "max"))
expect_identical(res$needles, c(1L, 1L))
expect_identical(res$haystack, c(1L, 2L))
res <- vec_locate_matches(needles, haystack, condition = c("<=", "<=", "<="), filter = c("none", "none", "max"), multiple = "first")
expect_identical(res$haystack, 1L)
res <- vec_locate_matches(needles, haystack, condition = c("<=", "<=", "<="), filter = c("none", "none", "max"), multiple = "last")
expect_identical(res$haystack, 2L)
res <- vec_locate_matches(needles, haystack, condition = c("<=", "<=", "<="), filter = c("none", "none", "max"), multiple = "any")
expect_identical(res$haystack, 1L)
})
test_that("single filter is applied to all columns", {
needles <- data_frame(x = 5L, y = 8L, z = 4L)
haystack <- data_frame(x = c(1L, 3L, 2L, 2L), y = c(1L, 3L, 2L, 3L), z = c(1L, 2L, 3L, 3L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max")
expect_identical(res$haystack, 2L)
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "min")
expect_identical(res$haystack, 1L)
})
test_that("different `filter`s can be used per column", {
needles <- data_frame(x = c(0, 2, 1, 1), y = c(2, 0, 0, 4))
haystack <- data_frame(x = c(2, 2, 2, 1, 1), y = c(1, 1, 2, 2, 1))
res <- vec_locate_matches(needles, haystack, condition = c(">=", "<"), filter = c("max", "min"))
expect_identical(res$needles, c(1L, 2L, 2L, 3L, 4L))
expect_identical(res$haystack, c(NA, 1L, 2L, 5L, NA))
})
test_that("`filter` works with incomplete values", {
needles <- c(1, NA, 4, NA)
haystack <- c(NA, 1, NA, 1, 3)
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", incomplete = "compare")
expect_identical(res$needles, c(1L, 1L, 2L, 2L, 3L, 4L, 4L))
expect_identical(res$haystack, c(2L, 4L, 1L, 3L, 5L, 1L, 3L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", incomplete = "compare", multiple = "first")
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(2L, 1L, 5L, 1L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", incomplete = "compare", multiple = "any")
expect_identical(res$needles, 1:4)
expect_identical(res$haystack, c(2L, 1L, 5L, 1L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "max", incomplete = NA)
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 4L))
expect_identical(res$haystack, c(2L, 4L, NA, 5L, NA))
})
test_that("`filter` works with mixed NA and NaN", {
needles <- c(1, NA, 4, NaN)
haystack <- c(NA, 1, NaN, 1, 3)
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "min", incomplete = "compare", nan_distinct = FALSE)
expect_identical(res$needles, c(1L, 1L, 2L, 2L, 3L, 3L, 4L, 4L))
expect_identical(res$haystack, c(2L, 4L, 1L, 3L, 2L, 4L, 1L, 3L))
res <- vec_locate_matches(needles, haystack, condition = ">=", filter = "min", incomplete = "compare", nan_distinct = TRUE)
expect_identical(res$needles, c(1L, 1L, 2L, 3L, 3L, 4L))
expect_identical(res$haystack, c(2L, 4L, 1L, 2L, 4L, 3L))
})
test_that("`filter` is validated", {
expect_error(vec_locate_matches(1, 2, filter = 1.5), "character vector")
expect_error(vec_locate_matches(1, 2, filter = "x"), 'one of "none", "min", or "max"')
expect_error(vec_locate_matches(1, 2, filter = c("min", "max")), "length 1, or the same length as")
})
# ------------------------------------------------------------------------------
# vec_locate_matches() - edge cases
test_that("zero row `needles` results in zero row data frame output", {
res <- vec_locate_matches(integer(), 1:3)
expect_identical(res$needles, integer())
expect_identical(res$haystack, integer())
res <- vec_locate_matches(integer(), 1:3, condition = "<")
expect_identical(res$needles, integer())
expect_identical(res$haystack, integer())
})
test_that("zero row `haystack` results in no-matches for all needles", {
res <- vec_locate_matches(1:3, integer())
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, rep(NA_integer_, 3))
res <- vec_locate_matches(1:3, integer(), condition = "<")
expect_identical(res$needles, 1:3)
expect_identical(res$haystack, rep(NA_integer_, 3))
})
test_that("zero row `haystack` still allows needle incomplete handling", {
res <- vec_locate_matches(c(1, NA), integer(), incomplete = NA, no_match = 0L)
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, c(0L, NA))
res <- vec_locate_matches(c(1, NA), integer(), incomplete = NA, no_match = 0L, condition = "<")
expect_identical(res$needles, 1:2)
expect_identical(res$haystack, c(0L, NA))
})
test_that("zero column data frames are not allowed", {
expect_error(
vec_locate_matches(data_frame(.size = 2L), data_frame(.size = 2L)),
"at least 1 column"
)
})
test_that("zero column input still checks `condition` correctness", {
x <- data_frame(.size = 2)
y <- data_frame(.size = 3)
expect_error(
vec_locate_matches(x, y, condition = c("==", "<=")),
"length 1, or the same length as the number of columns"
)
})
test_that("`multiple = 'first'/'last'` returns the first/last by appearance", {
x <- c(1, 2, 3)
y <- c(2, 1, 0)
res <- vec_locate_matches(x, y, condition = ">=", multiple = "first")
expect_identical(res$haystack, c(2L, 1L, 1L))
res <- vec_locate_matches(x, y, condition = ">=", multiple = "last")
expect_identical(res$haystack, c(3L, 3L, 3L))
})
test_that("NA adjustment of `>` and `>=` conditions is protected from empty haystack", {
res <- vec_locate_matches(1L, integer(), condition = ">")
expect_identical(res$needles, 1L)
expect_identical(res$haystack, NA_integer_)
})
test_that("potential overflow on large output size is caught informatively", {
# Windows 32-bit doesn't support long vectors of this size, and the
# intermediate `r_ssize` will be too large
skip_if(.Machine$sizeof.pointer < 8L, message = "No long vector support")
expect_snapshot({
(expect_error(vec_locate_matches(1:1e7, 1:1e7, condition = ">=")))
})
})
vctrs/tests/testthat/test-vctrs.R 0000644 0001762 0000144 00000001555 14276722575 016705 0 ustar ligges users
test_that("generics are extensible", {
expect_error(vec_cast(NA, NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_restore(NA, NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_proxy(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_proxy_equal(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_proxy_compare(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_ptype2(NA, NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_ptype_abbr(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_ptype_full(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_arith(NA, NA, NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_ptype_finalise(NA, NA), class = "rlib_error_dots_nonempty")
expect_error(vec_assign(NA, NA, NA, NA), class = "rlib_error_dots_nonempty")
})
vctrs/tests/testthat/test-complete.R 0000644 0001762 0000144 00000010374 14315060310 017323 0 ustar ligges users # vec_slice_complete -----------------------------------------------------------
test_that("can slice complete", {
df <- data_frame(x = c(1, NA, 3), y = c(1, 2, NA))
expect_identical(vec_slice_complete(df), vec_slice(df, 1))
})
test_that("vec_slice_complete() works with size 0 input", {
expect_identical(vec_slice_complete(integer()), integer())
expect_identical(vec_slice_complete(data.frame()), data.frame())
})
# vec_locate_complete ----------------------------------------------------------
test_that("vec_locate_complete() can locate complete", {
df <- data_frame(x = c(1, NA, 3), y = c(1, 2, NA))
expect_identical(vec_locate_complete(df), 1L)
})
test_that("vec_locate_complete() works with size 0 input", {
expect_identical(vec_locate_complete(logical()), integer())
expect_identical(vec_locate_complete(data.frame()), integer())
})
# vec_detect_complete ----------------------------------------------------------
test_that("works with size zero input", {
expect_identical(vec_detect_complete(integer()), logical())
expect_identical(vec_detect_complete(data.frame()), logical())
})
test_that("NA_real_ and NaN are both missing", {
expect_identical(vec_detect_complete(c(NA_real_, NaN)), c(FALSE, FALSE))
})
test_that("works rowwise", {
df <- data_frame(x = c(NA, 1, NA, 2), y = c(NA, NA, 2, 3))
expect <- c(FALSE, FALSE, FALSE, TRUE)
expect_identical(vec_detect_complete(df), expect)
df <- data_frame(x = c(1, 1), y = c(2, 2), z = c(1, NA))
expect <- c(TRUE, FALSE)
expect_identical(vec_detect_complete(df), expect)
})
test_that("works with data frames with rows but no columns", {
expect_identical(vec_detect_complete(new_data_frame(n = 5L)), rep(TRUE, 5))
})
test_that("works with data frame columns", {
col <- data_frame(a = c(1, NA, 2, 2), b = c(1, 2, NA, 3))
df <- data_frame(x = rep(1, 4), y = col)
expect <- c(TRUE, FALSE, FALSE, TRUE)
expect_identical(vec_detect_complete(df), expect)
})
test_that("works with various types", {
expect <- c(TRUE, TRUE, FALSE, TRUE, FALSE)
expect_identical(vec_detect_complete(c(TRUE, TRUE, NA, FALSE, NA)), expect)
expect_identical(vec_detect_complete(c(1L, 1L, NA, 2L, NA)), expect)
expect_identical(vec_detect_complete(c(1, 1, NA, 2, NA)), expect)
expect_identical(vec_detect_complete(complex(real = c(1, 1, NA, 2, 2), imaginary = c(1, 1, 2, 2, NA))), expect)
expect_identical(vec_detect_complete(c("a", "a", NA, "b", NA)), expect)
expect_identical(vec_detect_complete(list(1, 1, NULL, 2, NULL)), expect)
# No missing raw value
expect_identical(vec_detect_complete(as.raw(c(1, 1, 2, 2, 3))), rep(TRUE, 5))
})
test_that("takes the equality proxy", {
x <- as.POSIXlt(c(NA, 0), origin = "1970-01-01")
df <- data_frame(a = 1:2, x = x)
expect <- c(FALSE, TRUE)
expect_identical(vec_detect_complete(x), expect)
expect_identical(vec_detect_complete(df), expect)
})
test_that("columns with a data frame proxy are incomplete if any columns of the proxy are incomplete (#1404)", {
df <- data_frame(
x = c(NA, 0, 1, 2, 3),
y = new_rcrd(list(a = c(1, 1, 1, NA, NA), b = c(2, 2, 2, 2, NA))),
z = new_rcrd(list(a = c(1, 1, NA, 1, 1), b = c(2, 2, NA, NA, 1)))
)
expect_identical(vec_detect_complete(df), c(FALSE, TRUE, FALSE, FALSE, FALSE))
})
test_that("can have rcrd fields of all types", {
make_rcrd <- function(x) {
new_rcrd(list(x = x))
}
expect <- c(TRUE, TRUE, FALSE, TRUE, FALSE)
expect_identical(vec_detect_complete(make_rcrd(c(TRUE, TRUE, NA, FALSE, NA))), expect)
expect_identical(vec_detect_complete(make_rcrd(c(1L, 1L, NA, 2L, NA))), expect)
expect_identical(vec_detect_complete(make_rcrd(c(1, 1, NA, 2, NA))), expect)
expect_identical(vec_detect_complete(make_rcrd(complex(real = c(1, 1, NA, 2, 2), imaginary = c(1, 1, 2, 2, NA)))), expect)
expect_identical(vec_detect_complete(make_rcrd(c("a", "a", NA, "b", NA))), expect)
expect_identical(vec_detect_complete(make_rcrd(list(1, 1, NULL, 2, NULL))), expect)
# No missing raw value
expect_identical(vec_detect_complete(make_rcrd(as.raw(c(1, 1, 2, 2, 3)))), rep(TRUE, 5))
})
test_that("works with arrays", {
x <- array(c(1, 2, 3, NA), c(2, 2))
y <- array(c(1:3, NA, 5:8), c(2, 2, 2))
expect_identical(vec_detect_complete(x), c(TRUE, FALSE))
expect_identical(vec_detect_complete(y), c(TRUE, FALSE))
})
vctrs/tests/testthat/test-type-rational.R 0000644 0001762 0000144 00000001265 14315060310 020302 0 ustar ligges users
# These tests check the rational type from the S3 vignette
test_that("equality proxy is taken (#375)", {
local_rational_class()
x <- rational(c(1, 2, 1, 2, 6), c(1, 1, 2, 2, 2))
expect_identical(x == rational(3, 1), c(FALSE, FALSE, FALSE, FALSE, TRUE))
expect_identical(unique(x), rational(c(1, 2, 1, 6), c(1, 1, 2, 2)))
})
test_that("order proxy is taken", {
local_rational_class()
x <- rational(c(1, 2, 1, 2, 6), c(1, 1, 2, 2, 2))
expect_identical(sort(x), rational(c(1, 1, 2, 2, 6), c(2, 1, 2, 1, 2)))
})
test_that("can find common type and cast to rational", {
local_rational_class()
x <- rational(1:2, 2:1)
expect_identical(vec_cast_common(x, x), list(x, x))
})
vctrs/tests/testthat/test-fill.R 0000644 0001762 0000144 00000007635 14276722575 016477 0 ustar ligges users test_that("works with empty input", {
x <- integer()
expect_identical(vec_fill_missing(x, direction = "down"), x)
expect_identical(vec_fill_missing(x, direction = "up"), x)
expect_identical(vec_fill_missing(x, direction = "downup"), x)
expect_identical(vec_fill_missing(x, direction = "updown"), x)
expect_identical(vec_fill_missing(x, direction = "downup", max_fill = 1), x)
expect_identical(vec_fill_missing(x, direction = "updown", max_fill = 1), x)
})
test_that("works with data frames with rows but no columns", {
x <- new_data_frame(n = 2L)
expect_identical(vec_fill_missing(x, direction = "down"), x)
expect_identical(vec_fill_missing(x, direction = "up"), x)
expect_identical(vec_fill_missing(x, direction = "downup"), x)
expect_identical(vec_fill_missing(x, direction = "updown"), x)
expect_identical(vec_fill_missing(x, direction = "downup", max_fill = 1), x)
expect_identical(vec_fill_missing(x, direction = "updown", max_fill = 1), x)
})
test_that("vectors with all missing values are left unchanged", {
x <- c(NA, NA, NA)
expect_identical(vec_fill_missing(x, direction = "down"), x)
expect_identical(vec_fill_missing(x, direction = "up"), x)
expect_identical(vec_fill_missing(x, direction = "downup"), x)
expect_identical(vec_fill_missing(x, direction = "updown"), x)
expect_identical(vec_fill_missing(x, direction = "downup", max_fill = 1), x)
expect_identical(vec_fill_missing(x, direction = "updown", max_fill = 1), x)
})
test_that("`NA_real_` and `NaN` are both considered missing", {
expect_identical(
vec_fill_missing(c(1, NA_real_, NaN)),
c(1, 1, 1)
)
})
test_that("missings are filled correctly", {
x <- c(NA, 1, NA, 2, NA, NA)
expect_identical(vec_fill_missing(x, "down"), c(NA, 1, 1, 2, 2, 2))
expect_identical(vec_fill_missing(x, "up"), c(1, 1, 2, 2, NA, NA))
expect_identical(vec_fill_missing(x, "downup"), c(1, 1, 1, 2, 2, 2))
expect_identical(vec_fill_missing(x, "updown"), c(1, 1, 2, 2, 2, 2))
})
test_that("`max_fill` limits the sequential fill amount", {
x <- c(NA, NA, 1, NA, NA, NA, 3, NA, NA)
expect_identical(vec_fill_missing(x, "down", max_fill = 1), c(NA, NA, 1, 1, NA, NA, 3, 3, NA))
expect_identical(vec_fill_missing(x, "downup", max_fill = 1), c(NA, 1, 1, 1, NA, NA, 3, 3, NA))
expect_identical(vec_fill_missing(x, "down", max_fill = 2), c(NA, NA, 1, 1, 1, NA, 3, 3, 3))
expect_identical(vec_fill_missing(x, "downup", max_fill = 2), c(1, 1, 1, 1, 1, NA, 3, 3, 3))
expect_identical(vec_fill_missing(x, "up", max_fill = 1), c(NA, 1, 1, NA, NA, 3, 3, NA, NA))
expect_identical(vec_fill_missing(x, "updown", max_fill = 1), c(NA, 1, 1, NA, NA, 3, 3, 3, NA))
expect_identical(vec_fill_missing(x, "up", max_fill = 2), c(1, 1, 1, NA, 3, 3, 3, NA, NA))
expect_identical(vec_fill_missing(x, "updown", max_fill = 2), c(1, 1, 1, NA, 3, 3, 3, 3, 3))
})
test_that("fills data frames", {
df <- data_frame(x = c(NA, NA, NA, 2), y = c(NA, 1, NA, 3))
expect_identical(vec_fill_missing(df, "down"), vec_slice(df, c(1, 2, 2, 4)))
expect_identical(vec_fill_missing(df, "up"), vec_slice(df, c(2, 2, 4, 4)))
})
test_that("can fill rcrd types", {
x <- new_rcrd(list(x = c(1, NA, NA), y = c(1, 2, NA)))
expect_identical(vec_fill_missing(x, "down"), vec_slice(x, c(1, 2, 2)))
expect_identical(vec_fill_missing(x, "up"), vec_slice(x, c(1, 2, 3)))
expect_identical(vec_fill_missing(x, "updown"), vec_slice(x, c(1, 2, 2)))
})
test_that("validates `direction`", {
expect_error(vec_fill_missing(1, 1), "`direction` must be one of")
expect_error(vec_fill_missing(1, "foo"), "`direction` must be one of")
})
test_that("validates `max_fill`", {
expect_error(vec_fill_missing(1, max_fill = -1), "`max_fill` must be")
expect_error(vec_fill_missing(1, max_fill = c(1L, 2L)), "`max_fill` must be")
expect_error(vec_fill_missing(1, max_fill = NA_integer_), "`max_fill` must be")
expect_error(vec_fill_missing(1, max_fill = "x"), class = "vctrs_error_incompatible_type")
})
vctrs/tests/testthat/test-ptype-abbr-full.R 0000644 0001762 0000144 00000006022 14315060310 020513 0 ustar ligges users
test_that("input must be a vector", {
expect_error(vec_ptype_abbr(sum), "Not a vector")
expect_error(vec_ptype_full(sum), "Not a vector")
})
test_that("NULL has method", {
expect_equal(vec_ptype_abbr(NULL), "NULL")
expect_equal(vec_ptype_full(NULL), "NULL")
})
test_that("non objects default to type + shape", {
expect_equal(vec_ptype_abbr(ones(10)), "dbl[1d]")
expect_equal(vec_ptype_abbr(ones(0, 10)), "dbl[,10]")
expect_equal(vec_ptype_abbr(ones(10, 0)), "dbl[,0]")
expect_equal(vec_ptype_full(ones(10)), "double[1d]")
expect_equal(vec_ptype_full(ones(0, 10)), "double[,10]")
expect_equal(vec_ptype_full(ones(10, 0)), "double[,0]")
})
test_that("non objects can omit shape", {
expect_equal(vec_ptype_abbr(ones(10), suffix_shape = FALSE), "dbl")
expect_equal(vec_ptype_abbr(ones(0, 10), suffix_shape = FALSE), "dbl")
expect_equal(vec_ptype_abbr(ones(10, 0), suffix_shape = FALSE), "dbl")
})
test_that("objects default to first class", {
x <- structure(1, class = c("foofy", "goofy"))
expect_equal(vec_ptype_full(x), "foofy")
expect_equal(vec_ptype_abbr(x), "foofy")
})
test_that("atomic vectors and arrays as expected", {
expect_equal(vec_ptype_full(1:5), "integer")
dbl_mat <- array(double(), c(0, 3))
expect_equal(vec_ptype_full(dbl_mat), "double[,3]")
})
test_that("complex and factor as expected (#323)", {
expect_equal(vec_ptype_abbr(0i), "cpl")
expect_equal(vec_ptype_abbr(factor()), "fct")
})
test_that("named lists are always tagged (#322)", {
expect_identical(vec_ptype_abbr(list(x = 1, y = 2)), "named list")
expect_identical(vec_ptype_abbr(list(x = 1, y = 2), prefix_named = TRUE), "named list")
})
test_that("named atomics are tagged optionally (#781)", {
expect_identical(vec_ptype_abbr(c(x = 1, y = 2), prefix_named = TRUE), "named dbl")
expect_identical(vec_ptype_abbr(c(x = 1L, y = 2L), prefix_named = TRUE), "named int")
})
test_that("vec_ptype_abbr() adds named tag in case of row names", {
expect_equal(
vec_ptype_abbr(mtcars, prefix_named = TRUE),
"named df[,11]"
)
mat <- matrix(1:4, 2)
rownames(mat) <- c("foo", "bar")
expect_equal(
vec_ptype_abbr(mat, prefix_named = TRUE),
"named int[,2]"
)
})
test_that("vec_ptype_abbr() and vec_ptype_full() are not inherited (#1549)", {
foobar <- foobar(class = c("vctrs_bar", "vctrs_foo"))
local_methods(
vec_ptype_abbr.vctrs_foo = function(...) "foo_abbr",
vec_ptype_full.vctrs_foo = function(...) "foo_full"
)
expect_equal(
vec_ptype_abbr(foobar),
vec_ptype_abbr.default(foobar)
)
expect_equal(
vec_ptype_full(foobar),
"vctrs_bar"
)
local_methods(
vec_ptype_abbr.vctrs_bar = function(...) "bar_abbr",
vec_ptype_full.vctrs_bar = function(...) "bar_full"
)
expect_equal(
vec_ptype_abbr(foobar),
"bar_abbr"
)
expect_equal(
vec_ptype_full(foobar),
"bar_full"
)
})
test_that("data.frames have good default abbr and full methods", {
expect_snapshot({
df <- foobar(data.frame(x = 1, y = "", z = TRUE))
vec_ptype_abbr(df)
vec_ptype_full(df)
})
})
vctrs/tests/testthat/test-type-data-frame.R 0000644 0001762 0000144 00000044624 14511320527 020507 0 ustar ligges users
# printing ----------------------------------------------------------------
test_that("data frames print nicely", {
expect_equal(vec_ptype_abbr(mtcars), "df[,11]")
expect_snapshot(vec_ptype_show(mtcars))
expect_snapshot(vec_ptype_show(iris))
})
test_that("embedded data frames print nicely", {
df <- data.frame(x = 1:3)
df$a <- data.frame(a = 1:3, b = letters[1:3])
df$b <- list_of(1, 2, 3)
df$c <- as_list_of(split(data.frame(x = 1:3, y = letters[1:3]), 1:3))
expect_snapshot(vec_ptype_show(df))
})
# coercing ----------------------------------------------------------------
test_that("data frame only combines with other data frames or NULL", {
dt <- data.frame(x = 1)
expect_equal(vec_ptype_common(dt, NULL), vec_ptype(dt))
expect_error(vec_ptype_common(dt, 1:10), class = "vctrs_error_incompatible_type")
})
test_that("data frame takes max of individual variables", {
dt1 <- data.frame(x = FALSE, y = 1L)
dt2 <- data.frame(x = 1.5, y = 1.5)
expect_equal(vec_ptype_common(dt1, dt2), vec_ptype_common(dt2))
})
test_that("data frame combines variables", {
dt1 <- data.frame(x = 1)
dt2 <- data.frame(y = 1)
dt3 <- max(dt1, dt2)
expect_equal(
vec_ptype_common(dt1, dt2),
vec_ptype_common(data.frame(x = double(), y = double()))
)
})
test_that("empty data frame still has names", {
df <- data.frame()
out <- vec_ptype_common(df, df)
expect_equal(names(out), character())
})
test_that("combining data frames with foreign classes uses fallback", {
foo <- foobar(data.frame())
df <- data.frame()
expect_identical(vec_ptype_common(foo, foo, foo), foo)
expect_identical(vec_ptype_common(foo, foo, df, foo), df)
expect_identical(vec_ptype2(foo, df), data.frame())
expect_identical(vec_ptype2(df, foo), data.frame())
expect_identical(vec_ptype_common(foo, df), df)
expect_identical(vec_ptype_common(df, foo), df)
cnds <- list()
withCallingHandlers(
warning = function(cnd) {
cnds <<- append(cnds, list(cnd))
invokeRestart("muffleWarning")
},
expect_identical(
vec_ptype_common(foo, df, foo, foo),
df
)
)
# There are no longer any warnings
expect_length(cnds, 0)
expect_equal(
vec_cbind(foobar(data.frame(x = 1)), data.frame(y = 2)),
data.frame(x = 1, y = 2)
)
expect_equal(
vec_rbind(foo, data.frame(), foo),
df
)
})
# casting -----------------------------------------------------------------
test_that("safe casts work as expected", {
df <- data.frame(x = 1, y = 0)
expect_equal(vec_cast(NULL, df), NULL)
expect_equal(vec_cast(df, df), df)
expect_equal(vec_cast(data.frame(x = TRUE, y = FALSE), df), df)
})
test_that("warn about lossy coercions", {
df1 <- data.frame(x = factor("foo"), y = 1)
df2 <- data.frame(x = factor("bar"))
expect_lossy(vec_cast(df1, df1[1]), df1[1], x = df1, to = df1[1])
expect_lossy(
vec_cast(df1[1], df2),
data.frame(x = factor(NA, levels = "bar")),
x = factor("foo"),
to = factor("bar")
)
out <-
allow_lossy_cast(
allow_lossy_cast(
vec_cast(df1, df2),
factor("foo"), factor("bar")
),
df1, df2
)
expect_identical(out, data.frame(x = factor(NA, levels = "bar")))
})
test_that("invalid cast generates error", {
expect_error(vec_cast(1L, data.frame()), class = "vctrs_error_incompatible_type")
})
test_that("column order matches type", {
df1 <- data.frame(x = 1, y = "a")
df2 <- data.frame(x = TRUE, z = 3)
df3 <- vec_cast(df2, vec_ptype_common(df1, df2))
expect_named(df3, c("x", "y", "z"))
})
test_that("restore generates correct row/col names", {
df1 <- data.frame(x = NA, y = 1:4, z = 1:4)
df1$x <- data.frame(a = 1:4, b = 1:4)
df2 <- vec_restore(lapply(df1[1:3], vec_slice, 1:2), df1)
expect_named(df2, c("x", "y", "z"))
expect_equal(.row_names_info(df2), -2)
})
test_that("restore keeps automatic row/col names", {
df1 <- data.frame(x = NA, y = 1:4, z = 1:4)
df1$x <- data.frame(a = 1:4, b = 1:4)
df2 <- vec_restore(df1, df1)
expect_named(df2, c("x", "y", "z"))
expect_equal(.row_names_info(df2), -4)
})
test_that("cast to empty data frame preserves number of rows", {
out <- vec_cast(new_data_frame(n = 10L), new_data_frame())
expect_equal(nrow(out), 10L)
})
test_that("can cast unspecified to data frame", {
df <- data.frame(x = 1, y = 2L)
expect_identical(vec_cast(unspecified(3), df), vec_init(df, 3))
})
test_that("cannot cast list to data frame", {
df <- data.frame(x = 1, y = 2L)
expect_error(vec_cast(list(df, df), df), class = "vctrs_error_incompatible_type")
})
test_that("can restore lists with empty names", {
expect_identical(vec_restore(list(), data.frame()), data.frame())
})
test_that("can restore subclasses of data frames", {
expect_identical(vec_restore(list(), subclass(data.frame())), subclass(data.frame()))
local_methods(
vec_restore.vctrs_foobar = function(x, to, ..., i) "dispatched"
)
expect_identical(vec_restore(list(), subclass(data.frame())), "dispatched")
})
test_that("df_cast() checks for names", {
x <- new_data_frame(list(1))
y <- new_data_frame(list(2))
expect_error(vec_cast_common(x, y), "must have names")
})
test_that("casting to and from data frame preserves row names", {
out <- vec_cast(mtcars, unrownames(mtcars))
expect_identical(row.names(out), row.names(mtcars))
out <- vec_cast(out, unrownames(mtcars))
expect_identical(row.names(out), row.names(mtcars))
})
test_that("df_cast() evaluates arg lazily", {
expect_silent(df_cast(data_frame(), data_frame(), x_arg = print("oof")))
expect_silent(df_cast(data_frame(), data_frame(), to_arg = print("oof")))
})
# df_ptype2 ---------------------------------------------------------------
test_that("df_ptype2() evaluates arg lazily", {
expect_silent(df_ptype2(data_frame(), data_frame(), x_arg = print("oof")))
expect_silent(df_ptype2(data_frame(), data_frame(), y_arg = print("oof")))
})
# new_data_frame ----------------------------------------------------------
test_that("can construct an empty data frame", {
expect_identical(new_data_frame(), data.frame())
})
test_that("can validly set the number of rows when there are no columns", {
expect <- structure(
list(),
class = "data.frame",
row.names = .set_row_names(2L),
names = character()
)
expect_identical(new_data_frame(n = 2L), expect)
})
test_that("can add additional classes", {
expect_s3_class(new_data_frame(class = "foobar"), "foobar")
expect_s3_class(new_data_frame(class = c("foo", "bar")), c("foo", "bar"))
})
test_that("can add additional attributes", {
expect <- data.frame()
attr(expect, "foo") <- "bar"
attr(expect, "a") <- "b"
expect_identical(new_data_frame(foo = "bar", a = "b"), expect)
})
test_that("size is pulled from first column if not supplied", {
x <- new_data_frame(list(x = 1:5, y = 1:6))
expect_identical(.row_names_info(x, type = 1), -5L)
})
test_that("can construct a data frame without column names", {
expect_named(new_data_frame(list(1, 2)), NULL)
})
test_that("the names on an empty data frame are an empty character vector", {
expect_identical(names(new_data_frame()), character())
})
test_that("class attribute", {
expect_identical(
class(new_data_frame(list(a = 1))),
"data.frame"
)
expect_identical(
class(new_data_frame(list(a = 1), class = "tbl_df")),
c("tbl_df", "data.frame")
)
expect_identical(
class(new_data_frame(list(a = 1), class = c("tbl_df", "tbl", "data.frame"))),
c("tbl_df", "tbl", "data.frame", "data.frame")
)
expect_identical(
class(new_data_frame(list(a = 1), class = "foo_frame")),
c("foo_frame", "data.frame")
)
expect_identical(
class(exec(new_data_frame, list(a = 1), !!!attributes(new_data_frame(list(), class = "tbl_df")))),
c("tbl_df", "data.frame", "data.frame")
)
expect_identical(
class(exec(new_data_frame, list(a = 1), !!!attributes(new_data_frame(list(b = 1), class = "tbl_df")))),
c("tbl_df", "data.frame", "data.frame")
)
})
test_that("attributes with special names are merged", {
expect_identical(
names(new_data_frame(list(a = 1))),
"a"
)
expect_identical(
names(new_data_frame(list(a = 1), names = "name")),
"name"
)
expect_identical(
names(new_data_frame(list(1), names = "name")),
"name"
)
expect_identical(
attr(new_data_frame(list()), "row.names"),
integer()
)
expect_identical(
.row_names_info(new_data_frame(list(), n = 3L)),
-3L
)
expect_identical(
.row_names_info(new_data_frame(list(), n = 3L, row.names = 1:3)),
3L
)
expect_identical(
.row_names_info(new_data_frame(list(), n = 3L, row.names = c(NA, -3L))),
-3L
)
expect_identical(
attr(new_data_frame(list(), n = 1L, row.names = "rowname"), "row.names"),
"rowname"
)
})
test_that("n and row.names (#894)", {
# Can omit n if row.names attribute is given
expect_identical(
row.names(new_data_frame(list(), row.names = "rowname")),
"rowname"
)
expect_identical(
attr(new_data_frame(list(), row.names = 2L), "row.names"),
2L
)
expect_identical(
row.names(new_data_frame(list(), row.names = chr())),
chr()
)
})
test_that("`row.names` completely overrides `n` and the implied size of `x`, even if incompatible (tidyverse/dplyr#6596)", {
row_names <- c(NA, -3L)
df <- new_data_frame(list(), n = 2L, row.names = row_names)
expect_identical(.row_names_info(df, type = 0L), row_names)
df <- new_data_frame(list(x = 1:2), row.names = row_names)
expect_identical(.row_names_info(df, type = 0L), row_names)
})
test_that("ALTREP `row.names` are not materialized by `new_data_frame()` (tidyverse/dplyr#6596)", {
skip_if(getRversion() <= "3.5.0")
# We are careful in `new_data_frame()` to not call the `Dataptr()` or
# `Length()` ALTREP methods, both of which would materialize our lazy
# character here
row_names <- new_lazy_character(~ c("a", "b"))
x <- new_data_frame(list(), row.names = row_names)
expect_false(lazy_character_is_materialized(.row_names_info(x, type = 0L)))
x <- new_data_frame(list(x = 1:2), row.names = row_names)
expect_false(lazy_character_is_materialized(.row_names_info(x, type = 0L)))
x <- new_data_frame(list(), n = 2L, row.names = row_names)
expect_false(lazy_character_is_materialized(.row_names_info(x, type = 0L)))
})
test_that("`x` must be a list", {
expect_snapshot((expect_error(
new_data_frame(1),
"`x` must be a list"
)))
})
test_that("if supplied, `n` must be an integer of size 1", {
expect_snapshot({
(expect_error(new_data_frame(n = c(1L, 2L)), "must be an integer of size 1"))
(expect_error(new_data_frame(n = "x"), "must be an integer of size 1"))
})
})
test_that("if supplied, `n` can't be negative or missing (#1477)", {
expect_snapshot({
(expect_error(new_data_frame(n = -1L)))
(expect_error(new_data_frame(n = NA_integer_)))
})
})
test_that("`class` must be a character vector", {
expect_snapshot((expect_error(
new_data_frame(class = 1),
"must be NULL or a character vector"
)))
})
test_that("flatten info is computed", {
df_flatten_info <- function(x) {
.Call(ffi_df_flatten_info, x)
}
expect_identical(df_flatten_info(mtcars), list(FALSE, ncol(mtcars)))
df <- tibble(x = 1, y = tibble(x = 2, y = tibble(x = 3), z = 4), z = 5)
expect_identical(df_flatten_info(df), list(TRUE, 5L))
})
test_that("can flatten data frames", {
df_flatten <- function(x) {
.Call(ffi_df_flatten, x)
}
expect_identical(df_flatten(mtcars), mtcars)
df <- tibble(x = 1, y = tibble(x = 2, y = tibble(x = 3), z = 4), z = 5)
expect_identical(df_flatten(df), new_data_frame(list(x = 1, x = 2, x = 3, z = 4, z = 5)))
})
test_that("can flatten data frames with rcrd columns (#1318)", {
col <- new_rcrd(list(a = 1))
df <- data_frame(col = col, y = 1)
expect_identical(vec_proxy_equal(df), data_frame(col = 1, y = 1))
col <- new_rcrd(list(a = 1, b = 2))
df <- data_frame(col = col, y = 1)
expect_identical(vec_proxy_equal(df), data_frame(a = 1, b = 2, y = 1))
})
test_that("new_data_frame() zaps existing attributes", {
struct <- structure(list(), foo = 1)
expect_identical(
attributes(new_data_frame(struct)),
attributes(new_data_frame(list())),
)
expect_identical(
attributes(new_data_frame(struct, bar = 2)),
attributes(new_data_frame(list(), bar = 2)),
)
})
# data_frame --------------------------------------------------------------
test_that("data_frame() and df_list() report error context", {
expect_snapshot({
(expect_error(data_frame(a = 1, a = 1)))
(expect_error(data_frame(a = 1, a = 1, .error_call = call("foo"))))
(expect_error(data_frame(a = 1:2, b = int())))
(expect_error(data_frame(a = 1:2, b = int(), .error_call = call("foo"))))
(expect_error(df_list(a = 1, a = 1)))
(expect_error(df_list(a = 1, a = 1, .error_call = call("foo"))))
(expect_error(df_list(a = 1:2, b = int())))
(expect_error(df_list(a = 1:2, b = int(), .error_call = call("foo"))))
})
})
test_that("can construct data frames with empty input", {
expect_identical(data_frame(), new_data_frame())
expect_named(data_frame(), character())
})
test_that("input is tidy recycled", {
expect_identical(
data_frame(x = 1, y = 1:3),
data_frame(x = c(1, 1, 1), y = 1:3)
)
expect_identical(
data_frame(x = 1, y = integer()),
data_frame(x = double(), y = integer())
)
expect_snapshot({
expect_error(data_frame(1:2, 1:3), class = "vctrs_error_incompatible_size")
})
})
test_that("dots are dynamic", {
list_2_data_frame <- function(x) data_frame(!!!x)
expect_identical(
list_2_data_frame(list(x = 1, y = 2)),
data_frame(x = 1, y = 2)
)
})
test_that("unnamed input is auto named with empty strings", {
expect_named(data_frame(1, 2, .name_repair = "minimal"), c("", ""))
})
test_that("unnamed data frames are auto unpacked", {
expect_identical(
data_frame(w = 1, data_frame(x = 2, y = 3), z = 4),
data_frame(w = 1, x = 2, y = 3, z = 4)
)
})
test_that("named data frames are not unpacked", {
df_col <- data_frame(x = 2, y = 3)
df <- data_frame(w = 1, col = data_frame(x = 2, y = 3), z = 4)
expect_identical(df$col, df_col)
})
test_that("unpacked data frames without names are caught", {
df_col <- new_data_frame(list(1))
expect_error(data_frame(df_col), "corrupt data frame")
})
test_that("unpacking in `df_list()` can be disabled with `.unpack = FALSE`", {
out <- df_list(
w = 1,
data_frame(x = 2, y = 3),
z = 4,
.unpack = FALSE,
.name_repair = "minimal"
)
expect <- list(
w = 1,
data_frame(x = 2, y = 3),
z = 4
)
expect_identical(out, expect)
})
test_that("`.unpack` is validated", {
expect_snapshot(error = TRUE, {
df_list(.unpack = 1)
})
expect_snapshot(error = TRUE, {
df_list(.unpack = c(TRUE, FALSE))
})
})
test_that("`NULL` inputs are dropped", {
expect_identical(data_frame(NULL, x = 1, NULL), data_frame(x = 1))
})
test_that("`NULL` inputs are dropped before name repair", {
expect_identical(
data_frame(x = NULL, x = 1, .name_repair = "check_unique"),
data_frame(x = 1)
)
})
test_that("`.size` can force a desired size", {
df <- data_frame(x = 1, .size = 5)
expect_identical(df$x, rep(1, 5))
expect_size(data_frame(.size = 5), 5L)
})
test_that("`.name_repair` repairs names", {
expect_message(res <- data_frame(x = 1, x = 1, .name_repair = "unique"))
expect_named(res, c("x...1", "x...2"))
})
test_that("`.name_repair` happens after auto-naming with empty strings", {
expect_message(res <- data_frame(1, 2, .name_repair = "unique"))
expect_named(res, c("...1", "...2"))
})
test_that("`.name_repair` happens after splicing", {
expect_message(res <- data_frame(x = 1, data_frame(x = 2), .name_repair = "unique"))
expect_named(res, c("x...1", "x...2"))
})
test_that("`.name_repair` can be quiet", {
local_name_repair_verbose()
expect_snapshot({
dfl_unique <- df_list(1, 2, .name_repair = "unique_quiet")
dfl_universal <- df_list("if" = 1, "in" = 2, .name_repair = "universal_quiet")
df_unique <- data_frame(1, 2, .name_repair = "unique_quiet")
df_universal <- data_frame("if" = 1, "in" = 2, .name_repair = "universal_quiet")
})
expect_named(dfl_unique, c("...1", "...2"))
expect_named(dfl_universal, c(".if", ".in"))
expect_named(df_unique, c("...1", "...2"))
expect_named(df_universal, c(".if", ".in"))
})
# fallback ----------------------------------------------------------------
test_that("data frame fallback handles column types (#999)", {
df1 <- foobar(data.frame(x = 1))
df2 <- foobar(data.frame(x = 1, y = 2))
df3 <- foobar(data.frame(x = "", y = 2))
common <- foobar(data.frame(x = dbl(), y = dbl()))
expect_identical(vec_ptype2(df1, df2), common)
expect_identical(vec_ptype2(df2, df1), common)
exp <- foobar(data_frame(x = 1, y = na_dbl))
expect_identical(vec_cast(df1, df2), exp)
expect_identical(vec_cast(set_tibble(df1), set_tibble(df2)), set_tibble(exp))
expect_snapshot({
local_error_call(call("my_function"))
(expect_error(
vec_ptype2(df1, df3),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_ptype2(df3, df1),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_cast(df2, df1),
class = "vctrs_error_incompatible_type"
))
})
expect_identical(
vec_rbind(df1, df2),
foobar(data.frame(x = c(1, 1), y = c(NA, 2)))
)
# Attributes are not restored
df1_attrib <- foobar(df1, foo = "foo")
df2_attrib <- foobar(df2, bar = "bar")
exp <- data.frame(x = c(1, 1), y = c(NA, 2))
expect_equal(
vec_rbind(df1_attrib, df2_attrib),
exp
)
out <- with_methods(
`[.vctrs_foobar` = function(x, i, ...) {
new_data_frame(
NextMethod(),
dispatched = TRUE,
class = "vctrs_foobar"
)
},
vec_rbind(df1_attrib, df2_attrib)
)
expect_identical(out, exp)
})
test_that("falls back to tibble for tibble subclasses (#1025)", {
foo <- foobar(tibble::as_tibble(mtcars))
expect_s3_class(vec_rbind(foo, mtcars), "tbl_df")
expect_s3_class(vec_rbind(foo, mtcars, mtcars), "tbl_df")
expect_s3_class(vec_rbind(foo, mtcars, foobar(mtcars)), "tbl_df")
})
test_that("fallback is recursive", {
df <- mtcars[1:3, 1, drop = FALSE]
foo <- new_data_frame(list(x = foobar(df, foo = TRUE)))
bar <- new_data_frame(list(x = foobar(df, bar = TRUE)))
baz <- new_data_frame(list(y = 1:3, x = foobar(df, bar = TRUE)))
exp <- new_data_frame(list(x = vec_rbind(df, df)))
expect_equal(vec_rbind(foo, bar), exp)
exp <- new_data_frame(list(x = vec_rbind(df, df), y = c(NA, NA, NA, 1:3)))
expect_equal(vec_rbind(foo, baz), exp)
})
vctrs/tests/testthat/test-type-table.R 0000644 0001762 0000144 00000017764 14520724751 017611 0 ustar ligges users
# Print -------------------------------------------------------------------
test_that("ptype print methods are descriptive", {
tab1 <- new_table()
tab2 <- new_table(dim = c(0L, 1L, 2L, 1L))
expect_equal(vec_ptype_abbr(tab1), "table[1d]")
expect_equal(vec_ptype_abbr(tab2), "table[,1,2,1]")
expect_equal(vec_ptype_full(tab1), "table[1d]")
expect_equal(vec_ptype_full(tab2), "table[,1,2,1]")
})
# Coercion ----------------------------------------------------------------
test_that("can find a common type among tables with identical dimensions", {
tab1 <- new_table()
tab2 <- new_table(1:2, dim = c(1L, 2L, 1L))
expect_identical(vec_ptype2(tab1, tab1), new_table())
expect_identical(vec_ptype2(tab2, tab2), new_table(dim = c(0L, 2L, 1L)))
})
test_that("size is not considered in the ptype", {
x <- new_table(1:2, dim = 2L)
y <- new_table(1:3, dim = 3L)
expect_identical(vec_ptype2(x, y), new_table())
})
test_that("vec_ptype2() can broadcast table shapes", {
x <- new_table(dim = c(0L, 1L))
y <- new_table(dim = c(0L, 2L))
expect_identical(vec_ptype2(x, y), new_table(dim = c(0L, 2L)))
x <- new_table(dim = c(0L, 1L, 3L))
y <- new_table(dim = c(0L, 2L, 1L))
expect_identical(vec_ptype2(x, y), new_table(dim = c(0L, 2L, 3L)))
})
test_that("vec_ptype2() never propagates dimnames", {
x <- new_table(dim = c(0L, 1L), dimnames = list(character(), "x1"))
y <- new_table(dim = c(0L, 2L), dimnames = list(character(), c("y1", "y2")))
expect_null(dimnames(vec_ptype2(x, x)))
expect_null(dimnames(vec_ptype2(x, y)))
})
test_that("implicit axes are broadcast", {
x <- new_table(dim = c(0L, 2L))
y <- new_table(dim = c(0L, 1L, 3L))
expect_identical(vec_ptype2(x, y), new_table(dim = c(0L, 2L, 3L)))
})
test_that("errors on non-broadcastable dimensions", {
x <- new_table(dim = c(0L, 2L))
y <- new_table(dim = c(0L, 3L))
expect_error(vec_ptype2(x, y), class = "vctrs_error_incompatible_type")
})
test_that("vec_ptype2() errors on non-tables", {
expect_error(vec_ptype2(new_table(), 1), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(new_table(), 1L), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(new_table(), "1"), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(1, new_table()), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(1L, new_table()), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2("1", new_table()), class = "vctrs_error_incompatible_type")
})
test_that("common types have symmetry when mixed with unspecified input", {
x <- new_table()
expect_identical(vec_ptype2(x, NA), new_table())
expect_identical(vec_ptype2(NA, x), new_table())
x <- new_table(dim = c(0L, 2L))
expect_identical(vec_ptype2(x, NA), new_table(dim = c(0L, 2L)))
expect_identical(vec_ptype2(NA, x), new_table(dim = c(0L, 2L)))
})
test_that("`table` delegates coercion", {
expect_identical(
vec_ptype2(new_table(1), new_table(FALSE)),
new_table(double())
)
expect_error(
vec_ptype2(new_table(1), new_table("")),
class = "vctrs_error_incompatible_type"
)
})
# Casting -----------------------------------------------------------------
test_that("can cast to an identically shaped table", {
x <- new_table(1:5, dim = 5L)
y <- new_table(1:8, dim = c(2L, 2L, 2L))
expect_identical(vec_cast(x, x), x)
expect_identical(vec_cast(y, y), y)
})
test_that("vec_cast() can broadcast table shapes", {
# We test only the dim here and not the class because on R 3.2
# the `[.table` method did not exist and `shape_broadcast()`
# gives back a matrix, not a table.
x <- new_table(dim = c(0L, 1L))
y <- new_table(dim = c(0L, 2L))
expect_identical(dim(vec_cast(x, y)), c(0L, 2L))
x <- new_table(dim = c(0L, 1L, 1L))
y <- new_table(dim = c(0L, 2L, 3L))
expect_identical(dim(vec_cast(x, y)), c(0L, 2L, 3L))
})
test_that("cannot decrease axis length", {
x <- new_table(dim = c(0L, 3L))
y <- new_table(dim = c(0L, 1L))
expect_error(vec_cast(x, y), "Non-recyclable", class = "vctrs_error_incompatible_type")
})
test_that("cannot decrease dimensionality", {
x <- new_table(dim = c(0L, 1L, 1L))
y <- new_table(dim = c(0L, 1L))
expect_snapshot({
(expect_error(vec_cast(x, y), class = "vctrs_error_incompatible_type"))
})
})
test_that("vec_cast() errors on non-tables", {
expect_error(vec_cast(new_table(), 1), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(new_table(), 1L), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(new_table(), "1"), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(1, new_table()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(1L, new_table()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast("1", new_table()), class = "vctrs_error_incompatible_type")
})
test_that("can cast from, but not to, unspecified", {
x <- new_table()
expect_error(vec_cast(x, NA), class = "vctrs_error_incompatible_type")
expect_identical(vec_cast(NA, x), new_table(NA_integer_, dim = 1L))
x <- new_table(dim = c(0L, 2L))
expect_error(vec_cast(x, NA), class = "vctrs_error_incompatible_type")
expect_identical(vec_cast(NA, x), new_table(c(NA_integer_, NA_integer_), dim = c(1L, 2L)))
})
test_that("`table` delegates casting", {
expect_identical(
vec_cast(new_table(1), new_table(FALSE)),
new_table(TRUE)
)
expect_error(
vec_cast(new_table(1), new_table("")),
class = "vctrs_error_incompatible_type"
)
})
# Misc --------------------------------------------------------------------
test_that("`new_table()` validates input", {
expect_error(new_table(1L, 1), "`dim` must be an integer vector")
expect_error(new_table(1:2, 1L), "must match the length of `x`")
})
test_that("ptype is correct", {
tab1 <- new_table(1L, dim = 1L)
tab2 <- new_table(1:2, dim = c(1L, 2L, 1L))
expect_identical(vec_ptype(tab1), new_table())
expect_identical(vec_ptype(tab2), new_table(dim = c(0L, 2L, 1L)))
})
test_that("can use a table in `vec_c()`", {
expect_identical(vec_c(new_table()), new_table())
expect_identical(vec_c(new_table(), new_table()), new_table())
x <- new_table(1:5, 5L)
y <- new_table(1:4, dim = c(2L, 2L))
expect_identical(vec_c(x, x), new_table(c(1:5, 1:5), dim = 10L))
expect_identical(vec_c(y, y), new_table(c(1:2, 1:2, 3:4, 3:4), dim = c(4L, 2L)))
expect_identical(vec_c(x, y), new_table(c(1:5, 1:2, 1:5, 3:4), dim = c(7L, 2L)))
})
test_that("names of the first dimension are kept in `vec_c()`", {
x <- new_table(1:4, c(2L, 2L))
dimnames(x) <- list(c("r1", "r2"), c("c1", "c2"))
xx <- vec_c(x, x)
expect_identical(dimnames(xx), list(c("r1", "r2", "r1", "r2"), NULL))
})
test_that("can use a table in `list_unchop()`", {
x <- new_table(1:4, dim = c(2L, 2L))
expect_identical(list_unchop(list(x)), x)
expect_identical(list_unchop(list(x, x), indices = list(1:2, 4:3)), vec_slice(x, c(1:2, 2:1)))
})
test_that("can concatenate tables", {
x <- table(1:2)
out <- vec_c(x, x)
exp <- new_table(rep(1L, 4), dimnames = list(c("1", "2", "1", "2")))
expect_identical(out, exp)
out <- vec_rbind(x, x)
exp <- data_frame(`1` = new_table(c(1L, 1L)), `2` = new_table(c(1L, 1L)))
expect_identical(out, exp)
y <- table(list(1:2, 3:4))
# FIXME
out <- vec_c(y, y)
exp <- new_table(
matrix(int(1, 0, 1, 0, 0, 1, 0, 1), nrow = 4),
dim = c(4L, 2L),
dimnames = list(c("1", "2", "1", "2"), NULL)
)
expect_identical(out, exp)
out <- vec_rbind(y, y)
exp <- new_data_frame(list(
`3` = int(1, 0, 1, 0),
`4` = int(0, 1, 0, 1)
),
row.names = c("1...1", "2...2", "1...3", "2...4")
)
expect_identical(out, exp)
skip("FIXME: dimnames of matrices are not properly concatenated")
})
test_that("can concatenate tables of type double (#1190)", {
x <- table(c(1, 2)) / 2
out <- vec_c(x, x)
exp <- new_table(c(0.5, 0.5, 0.5, 0.5), dimnames = list(c("1", "2", "1", "2")))
expect_identical(out, exp)
out <- vec_rbind(x, x)
exp <- data_frame(`1` = new_table(c(0.5, 0.5)), `2` = new_table(c(0.5, 0.5)))
expect_identical(out, exp)
})
vctrs/tests/testthat/test-recycle.R 0000644 0001762 0000144 00000012535 14315060310 017142 0 ustar ligges users test_that("vec_recycle_common() reports error context", {
my_function <- function(...) vec_recycle_common(...)
expect_snapshot({
(expect_error(my_function(this_arg = 1:2, that_arg = int())))
(expect_error(my_function(this_arg = 1:2, that_arg = int(), .size = 2)))
(expect_error(my_function(this_arg = 1:2, that_arg = int(), .arg = "my_arg")))
(expect_error(my_function(this_arg = 1:2, that_arg = int(), .size = 2, .arg = "my_arg")))
})
})
# vec_recycle() -------------------------------------------------------------
test_that("vec_recycle recycles size 1 to any other size", {
x <- 1
x0 <- numeric()
x2 <- c(x, x)
expect_equal(vec_recycle(x, 1), x)
expect_equal(vec_recycle(x, 0), x0)
expect_equal(vec_recycle(x, 2), x2)
})
test_that("vec_recycle(): incompatible lengths get error messages", {
x2 <- c(1, 2)
expect_snapshot({
(expect_error(vec_recycle(x2, 1), class = "vctrs_error_recycle_incompatible_size"))
})
expect_error(vec_recycle(x2, 0), class = "vctrs_error_recycle_incompatible_size")
expect_error(vec_recycle(x2, 3), class = "vctrs_error_recycle_incompatible_size")
})
test_that("can recycle arrays", {
x <- matrix(1:2, 1)
x2 <- matrix(1:2, 2, 2, byrow = TRUE)
x0 <- matrix(integer(), 0, 2)
expect_equal(vec_recycle(x, 1), x)
expect_equal(vec_recycle(x, 0), x0)
expect_equal(vec_recycle(x, 2), x2)
# List arrays
data <- c(list(1), list(2))
x <- matrix(data, 1)
x2 <- matrix(data, 2, 2, byrow = TRUE)
x0 <- matrix(list(), 0, 2)
expect_equal(vec_recycle(x, 1), x)
expect_equal(vec_recycle(x, 0), x0)
expect_equal(vec_recycle(x, 2), x2)
})
test_that("vec_recycle() evaluates x_arg lazily", {
expect_silent(vec_recycle(1L, 1L, x_arg = print("oof")))
})
# Empty -------------------------------------------------------------------
test_that("empty input returns empty list", {
expect_equal(vec_recycle_common(), list())
})
# Vectors -----------------------------------------------------------------
test_that("NULL is idempotent", {
expect_equal(vec_recycle_common(NULL, NULL), list(NULL, NULL))
expect_equal(vec_recycle_common(1:5, NULL), list(1:5, NULL))
expect_equal(vec_recycle_common(NULL, 1:5), list(NULL, 1:5))
})
test_that("equal lengths returned as is", {
x <- 1:3
expect_equal(vec_recycle_common(x, x), list(x, x))
expect_equal(vec_recycle_common(x[1], x[1]), list(x[1], x[1]))
expect_equal(vec_recycle_common(x[0], x[0]), list(x[0], x[0]))
})
test_that("vec_recycle_common recycles size 1 to any other size", {
x1 <- 1
x3 <- rep(1, 3)
x0 <- numeric()
expect_equal(vec_recycle_common(x1, x3), list(x3, x3))
expect_equal(vec_recycle_common(x3, x1), list(x3, x3))
expect_equal(vec_recycle_common(x1, x0), list(x0, x0))
})
test_that("vec_recycle_common(): incompatible lengths get error messages", {
expect_snapshot({
(expect_error(vec_recycle_common(1:2, 1:3), class = "vctrs_error_incompatible_size"))
})
expect_error(vec_recycle_common(1:3, 1:2), class = "vctrs_error_incompatible_size")
expect_error(vec_recycle_common(numeric(), 1:2), class = "vctrs_error_incompatible_size")
})
# Matrices ----------------------------------------------------------------
test_that("can vec_recycle_common matrices", {
x <- matrix(nrow = 4, ncol = 4)
x1 <- x[1, , drop = FALSE]
expect_equal(vec_recycle_common(x, x), list(x, x))
expect_equal(vec_recycle_common(x1, x), list(x, x))
})
test_that("recycling matrices respects incompatible sizes", {
x <- matrix(nrow = 4, ncol = 4)
x2 <- x[1:2, , drop = FALSE]
x0 <- x[0, , drop = FALSE]
expect_snapshot({
(expect_error(vec_recycle_common(x2, x), class = "vctrs_error_incompatible_size"))
})
expect_error(vec_recycle_common(x0, x), class = "vctrs_error_incompatible_size")
})
test_that("can vec_recycle_common data frames", {
x <- data.frame(a = rep(1, 3), b = rep(2, 3))
x1 <- vec_slice(x, 1L)
expect_equal(vec_recycle_common(x, x), list(x, x))
expect_equal(vec_recycle_common(x1, x), list(x, x))
})
test_that("recycling data frames respects incompatible sizes", {
x <- data.frame(a = rep(1, 3), b = rep(2, 3))
x2 <- vec_slice(x, 1:2)
x0 <- vec_slice(x, integer())
expect_snapshot({
(expect_error(vec_recycle_common(x2, x), class = "vctrs_error_incompatible_size"))
})
expect_error(vec_recycle_common(x0, x), class = "vctrs_error_incompatible_size")
})
test_that("can vec_recycle_common matrix and data frame", {
mt <- matrix(nrow = 2, ncol = 2)
df <- data.frame(x = c(1, 1), y = c(2, 2))
expect_equal(
vec_recycle_common(vec_slice(mt, 1L), df),
list(mt, df)
)
expect_equal(
vec_recycle_common(mt, vec_slice(df, 1L)),
list(mt, df)
)
})
test_that("recycling data frames with matrices respects incompatible sizes", {
mt <- matrix(nrow = 2, ncol = 2)
df <- data.frame(x = c(1, 1), y = c(2, 2))
expect_error(
vec_recycle_common(vec_slice(mt, integer()), df),
class = "vctrs_error_incompatible_size"
)
expect_error(
vec_recycle_common(mt, vec_slice(df, 0L)),
class = "vctrs_error_incompatible_size"
)
})
test_that("recycling to size 1 has informative error", {
expect_snapshot({
(expect_error(vec_recycle(1:2, 1), class = "vctrs_error_recycle_incompatible_size"))
})
})
test_that("incompatible recycling size has informative error", {
expect_snapshot(error = TRUE, vec_recycle(1:2, 4))
expect_snapshot(error = TRUE, vec_recycle(1:2, 4, x_arg = "foo"))
})
vctrs/tests/testthat/test-type-list-of.R 0000644 0001762 0000144 00000014754 14373202700 020062 0 ustar ligges users test_that("list_of inherits from list", {
x1 <- list_of(1, 1)
expect_s3_class(x1, "list")
})
test_that("list_of works like list", {
x1 <- list_of(1, 1)
expect_type(x1, "list")
expect_s3_class(x1, "vctrs_list_of")
expect_equal(attr(x1, "ptype"), double())
x2 <- list_of(1, 1, .ptype = integer())
expect_equal(attr(x1, "ptype"), integer())
x3 <- as_list_of(list(1, 1))
expect_equal(x3, x1)
x4 <- list_of(a = 1, b = 2)
expect_equal(x4$b, 2)
expect_error(x4$c, "Invalid index", fixed = TRUE)
})
test_that("list_of errors if it can't find common type", {
expect_error(list_of(1, "a"), class = "vctrs_error_incompatible_type")
expect_error(list_of(), "find common type")
})
test_that("can use as_list_of to change type", {
x1 <- list_of(1)
expect_equal(as_list_of(x1), x1)
x2 <- as_list_of(x1, .ptype = integer())
expect_identical(x2[[1]], 1L)
})
test_that("is_list_of as expected", {
expect_false(is_list_of(list(1)))
expect_true(is_list_of(list_of(1)))
})
test_that("print method gives human friendly output", {
skip_on_cran() # Depends on tibble
expect_snapshot(list_of(1, 2:3))
expect_snapshot(tibble::tibble(x = list_of(1, 2:3)))
})
test_that("str method is reasonably correct", {
x <- list_of(1, 2:3)
expect_snapshot(str(x))
expect_snapshot(str(list(list(x, y = 2:1))))
expect_snapshot(str(x[0]))
expect_snapshot(str(list(list(x[0], y = 2:1))))
})
test_that("constructor requires list input", {
expect_error(new_list_of(1), "must be a list")
expect_error(new_list_of(mtcars), "must be a list")
})
test_that("constructor requires size 0 ptype", {
expect_error(new_list_of(ptype = 1), "must have size 0")
})
test_that("can combine a mix of named and unnamed list-ofs (#784)", {
a <- new_list_of(list(x = 1L), ptype = integer())
b <- new_list_of(list(2L), ptype = integer())
expect <- new_list_of(list(x = 1L, 2L), ptype = integer())
expect_identical(vec_c(a, b), expect)
})
# Subsetting --------------------------------------------------------------
test_that("[ preserves type", {
x <- list_of(1)
expect_equal(x[1], x)
})
test_that("[<-, [[<- and $<- coerce their input", {
x <- list_of(x = 1, y = 1, z = 1, w = 1)
x[1] <- list(FALSE)
expect_identical(x, list_of(x = 0, y = 1, z = 1, w = 1))
x[[2]] <- FALSE
expect_identical(x, list_of(x = 0, y = 0, z = 1, w = 1))
x$z <- FALSE
expect_identical(x, list_of(x = 0, y = 0, z = 0, w = 1))
x[3:4] <- c(TRUE, FALSE)
expect_identical(x, list_of(x = 0, y = 0, z = 1, w = 0))
x[[2]] <- NULL
expect_equal(x, list_of(x = 0, y = NULL, z = 1, w = 0))
expect_error(x[[2]] <- list(20), class = "vctrs_error_incompatible_type")
expect_error(x$y <- list(20), class = "vctrs_error_incompatible_type")
x[3:4] <- list(NULL)
expect_equal(x, list_of(x = 0, y = NULL, z = NULL, w = NULL))
expect_equal(is.na(x), c(FALSE, TRUE, TRUE, TRUE))
})
test_that("assingment can increase size of vector", {
x <- list_of(x = 1)
x[[2]] <- 2
x$z <- 3
x[4:5] <- c(4,5)
expect_length(x, 5)
})
# Type system -------------------------------------------------------------
test_that("list_of() are vectors", {
expect_true(obj_is_vector(list_of(1)))
expect_true(vec_is(list_of(1)))
})
test_that("list coercions are symmetric and unchanging", {
types <- list(
list(),
list_of(.ptype = integer()),
list_of(.ptype = double()),
list_of(.ptype = character())
)
mat <- maxtype_mat(types)
expect_true(isSymmetric(mat))
local_options(width = 200)
expect_snapshot(print(mat))
})
test_that("max, list_of> is list_of>", {
r_int <- list_of(.ptype = integer())
r_dbl <- list_of(.ptype = double())
expect_equal(vec_ptype_common(r_int, r_int), r_int)
expect_equal(vec_ptype_common(r_int, r_dbl), r_int)
})
test_that("can cast to self type", {
x <- list_of(1)
expect_identical(vec_cast(x, x), x)
})
test_that("can cast between different list_of types", {
x <- list_of(1, 2)
to <- list_of(.ptype = integer())
expect_identical(vec_cast(x, to), list_of(1L, 2L))
})
test_that("list_of casting retains outer names", {
x <- list_of(x = 1, 2, z = 3)
to <- list_of(.ptype = integer())
expect_named(vec_cast(x, to), c("x", "", "z"))
})
test_that("safe casts work as expected", {
x <- list_of(1)
expect_equal(vec_cast(NULL, x), NULL)
expect_equal(vec_cast(NA, x), list_of(NULL, .ptype = double()))
expect_identical(vec_cast(list(1), x), list_of(1))
expect_identical(vec_cast(list(TRUE), x), list_of(1))
expect_identical(vec_cast(x, list()), list(1))
expect_identical(vec_cast(x, list()), list(1))
expect_error(
vec_cast(list_of(1), list_of("")),
class = "vctrs_error_incompatible_type"
)
# These used to be allowed
expect_error(vec_cast(1L, x), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(1, x), class = "vctrs_error_incompatible_type")
})
test_that("error call is passed to inner cast methods", {
fn1 <- function() vec_cast(list_of(1), list_of(""))
fn2 <- function() vec_cast(list(1), list_of(""))
expect_snapshot({
(expect_error(fn1()))
(expect_error(fn2()))
})
})
test_that("lossy casts generate warning (no longer the case)", {
# This used to be a lossy cast warning
expect_error(
vec_cast(list(c(1.5, 1), 1L), to = list_of(1L)),
class = "vctrs_error_incompatible_type"
)
})
test_that("invalid casts generate error", {
expect_error(vec_cast(factor("a"), list_of(1)), class = "vctrs_error_incompatible_type")
})
test_that("list_of() has as.character() method (tidyverse/tidyr#654)", {
exp <- rep(paste0("<", vec_ptype_abbr(mtcars), ">"), 2)
expect_identical(as.character(list_of(mtcars, mtcars)), exp)
})
test_that("vec_ptype2(>, NA) is symmetric (#687)", {
lof <- list_of(1, 2, 3)
expect_identical(vec_ptype2(lof, NA), vec_ptype(lof))
expect_identical(vec_ptype2(NA, lof), vec_ptype(lof))
})
test_that("list_of() coerces to list() and list_of() (#1701)", {
expect_equal(vec_ptype_common(list_of(1), list()), list())
expect_equal(vec_cast_common(list_of(1), list()), list(list(1), list()))
expect_equal(vec_ptype_common(list_of(1), list("")), list())
expect_equal(vec_cast_common(list_of(1), list("")), list(list(1), list("")))
expect_equal(
vec_ptype_common(list_of(1), list_of("")),
list()
)
expect_equal(
vec_ptype_common(list_of(1), list(), list_of("")),
list()
)
})
test_that("can concatenate list and list-of (#1161)", {
expect_equal(
vec_c(list(1), list_of(2)),
list(1, 2)
)
expect_equal(
vec_c(list(""), list_of(2)),
list("", 2)
)
})
vctrs/tests/testthat/test-type-integer64.R 0000644 0001762 0000144 00000016672 14402367170 020323 0 ustar ligges users
test_that("casting of integer64 works", {
x <- bit64::as.integer64(1:10)
expect_equal(vec_cast(x, bit64::integer64()), x)
expect_equal(vec_cast(x, integer()), 1:10)
expect_equal(vec_cast(1:10, bit64::integer64()), x)
expect_equal(vec_cast(x, double()), as.double(x))
expect_equal(vec_cast(as.numeric(1:10), bit64::integer64()), x)
expect_equal(vec_cast(x, logical()), rep(TRUE, 10L))
expect_equal(vec_cast(c(TRUE, FALSE), bit64::integer64()), bit64::as.integer64(c(1, 0)))
expect_equal(vec_cast(NA, bit64::integer64()), bit64::as.integer64(NA))
expect_equal(vec_cast(unspecified(2), bit64::integer64()), bit64::as.integer64(c(NA, NA)))
expect_error(vec_cast(x, factor()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(factor(), x), class = "vctrs_error_incompatible_type")
# These used to be allowed
expect_error(vec_cast(x, character()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(as.character(1:10), bit64::integer64()), class = "vctrs_error_incompatible_type")
})
test_that("vec_ptype2 for integer64 works", {
x <- bit64::as.integer64(1:10)
expect_equal(vec_ptype2(x, x), bit64::integer64())
expect_equal(vec_ptype2(x, 1L), bit64::integer64())
expect_equal(vec_ptype2(1L, x), bit64::integer64())
expect_equal(vec_ptype2(x, TRUE), bit64::integer64())
expect_equal(vec_ptype2(TRUE, x), bit64::integer64())
expect_equal(vec_ptype2(x, NA), bit64::integer64())
expect_equal(vec_ptype2(NA, x), bit64::integer64())
expect_equal(vec_ptype2(unspecified(), x), bit64::integer64())
expect_equal(vec_ptype2(x, unspecified()), bit64::integer64())
expect_error(vec_ptype2(x, 1), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(1, x), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(x, ""), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2("", x), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(data.frame(), x), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(x, data.frame()), class = "vctrs_error_incompatible_type")
})
test_that("vec_ptype_abbr.integer64", {
expect_equal(vec_ptype_abbr(bit64::as.integer64(1:10)), "int64")
expect_equal(vec_ptype_full(bit64::as.integer64(1:10)), "integer64")
})
test_that("can sort integer64", {
x <- bit64::as.integer64(c(-1, -3, -2, 1))
expect_identical(vec_order(x), int(2, 3, 1, 4))
expect_identical(x[vec_order(x)], bit64::as.integer64(c(-3, -2, -1, 1)))
})
test_that("can slice integer64 objects of all dimensions", {
x <- bit64::as.integer64(1:8)
expect <- bit64::as.integer64(c(1, 3))
expect_identical(vec_slice(x, c(1, 3)), expect)
dim(x) <- c(4, 2)
expect <- bit64::as.integer64(c(1, 3, 5, 7))
dim(expect) <- c(2, 2)
expect_identical(vec_slice(x, c(1, 3)), expect)
dim(x) <- c(2, 2, 2)
expect <- bit64::as.integer64(c(2, 4, 6, 8))
dim(expect) <- c(1, 2, 2)
expect_identical(vec_slice(x, 2), expect)
})
test_that("can slice integer64 objects with `NA_integer_`", {
idx <- c(NA_integer_, 1)
x <- bit64::as.integer64(1:8)
expect <- bit64::as.integer64(c(NA, 1))
expect_identical(vec_slice(x, idx), expect)
dim(x) <- c(4, 2)
expect <- bit64::as.integer64(c(NA, 1, NA, 5))
dim(expect) <- c(2, 2)
expect_identical(vec_slice(x, idx), expect)
dim(x) <- c(2, 2, 2)
expect <- bit64::as.integer64(c(NA, 1, NA, 3, NA, 5, NA, 7))
dim(expect) <- c(2, 2, 2)
expect_identical(vec_slice(x, idx), expect)
})
test_that("can init integer64 objects", {
idx <- c(NA_integer_, NA_integer_)
x <- bit64::as.integer64(1:8)
expect_identical(vec_init(x, 2), vec_slice(x, idx))
dim(x) <- c(4, 2)
expect_identical(vec_init(x, 2), vec_slice(x, idx))
dim(x) <- c(2, 2, 2)
expect_identical(vec_init(x, 2), vec_slice(x, idx))
})
test_that("can chop integer64 objects with `NA_integer_` indices", {
idx <- list(NA_integer_, 1)
x <- bit64::as.integer64(1:8)
expect <- list(
bit64::as.integer64(NA),
bit64::as.integer64(1)
)
expect_identical(vec_chop(x, indices = idx), expect)
dim(x) <- c(4, 2)
expect <- list(
bit64::as.integer64(c(NA, NA)),
bit64::as.integer64(c(1, 5))
)
dim(expect[[1]]) <- c(1, 2)
dim(expect[[2]]) <- c(1, 2)
expect_identical(vec_chop(x, indices = idx), expect)
dim(x) <- c(2, 2, 2)
expect <- list(
bit64::as.integer64(c(NA, NA, NA, NA)),
bit64::as.integer64(c(1, 3, 5, 7))
)
dim(expect[[1]]) <- c(1, 2, 2)
dim(expect[[2]]) <- c(1, 2, 2)
expect_identical(vec_chop(x, indices = idx), expect)
})
test_that("equality proxy converts atomic input to data frames of doubles", {
x <- bit64::as.integer64(1)
expect_identical(
vec_proxy_equal(x),
data_frame(left = 2147483648, right = 1)
)
})
test_that("equality proxy works with 1-D arrays", {
x <- bit64::as.integer64(1:6)
y <- x
dim(y) <- 6
expect_identical(
vec_proxy_equal(x),
vec_proxy_equal(y)
)
})
test_that("equality proxy on >=2-D input converts to data frame and proxies each column", {
x <- bit64::as.integer64(1:8)
dim(x) <- c(2, 2, 2)
proxy1 <- integer64_proxy(x[1:2, 1, 1])
proxy2 <- integer64_proxy(x[1:2, 2, 1])
proxy3 <- integer64_proxy(x[1:2, 1, 2])
proxy4 <- integer64_proxy(x[1:2, 2, 2])
expect_identical(
vec_proxy_equal(x),
vec_cbind(proxy1, proxy2, proxy3, proxy4, .name_repair = "minimal")
)
})
test_that("can detect missing values with integer64 (#1304)", {
x <- bit64::as.integer64(c(NA, NA, 2, NA, 2, 2))
expect_identical(vec_detect_missing(x), c(TRUE, TRUE, FALSE, TRUE, FALSE, FALSE))
dim(x) <- c(3, 2)
expect_identical(vec_detect_missing(x), c(TRUE, FALSE, FALSE))
})
test_that("can fill missing values with integer64", {
x <- bit64::as.integer64(c(NA, NA, 2, NA, 2, 2))
expect <- bit64::as.integer64(c(NA, NA, 2, 2, 2, 2))
expect_identical(vec_fill_missing(x, "down"), expect)
dim(x) <- c(3, 2)
expect <- bit64::as.integer64(c(NA, NA, 2, 2, 2, 2))
dim(expect) <- c(3, 2)
expect_identical(vec_fill_missing(x, "up"), expect)
})
test_that("can compare values with integer64", {
x <- bit64::as.integer64(c(1, NA, 2))
y <- bit64::as.integer64(c(0, 2, 3))
expect_identical(vec_compare(x, y), c(1L, NA, -1L))
x <- bit64::as.integer64(1:8)
y <- bit64::as.integer64(c(1, 2, 1, 5, 1, 5, 1, 5))
dim(x) <- c(2, 2, 2)
dim(y) <- c(2, 2, 2)
expect_identical(vec_compare(x, y), c(1L, -1L))
})
test_that("integer64 <-> data frame works as expected", {
x <- bit64::as.integer64(c(-2, -1, 0, 1))
proxy <- integer64_proxy(x)
expect_identical(proxy$left, c(2147483647, 2147483647, 2147483648, 2147483648))
expect_identical(proxy$right, c(4294967294, 4294967295, 0, 1))
expect_identical(integer64_restore(proxy), x)
x <- bit64::as.integer64("9223372036854775807") + -1:0
proxy <- integer64_proxy(x)
expect_identical(proxy$left, c(4294967295, 4294967295))
expect_identical(proxy$right, c(4294967294, 4294967295))
expect_identical(integer64_restore(proxy), x)
x <- bit64::as.integer64("-9223372036854775807") + 0:1
proxy <- integer64_proxy(x)
expect_identical(proxy$left, c(0, 0))
expect_identical(proxy$right, c(1, 2))
expect_identical(integer64_restore(proxy), x)
x <- bit64::as.integer64(NA)
proxy <- integer64_proxy(x)
expect_identical(proxy$left, NA_real_)
expect_identical(proxy$right, NA_real_)
expect_identical(integer64_restore(proxy), x)
})
test_that("`integer64_proxy()` doesn't allow arrays", {
x <- bit64::as.integer64(1:6)
dim(x) <- c(3, 2)
expect_error(integer64_proxy(x), "should not have a `dim` attribute")
})
vctrs/tests/testthat/test-type-data-table.R 0000644 0001762 0000144 00000003420 14405105465 020475 0 ustar ligges users # Never run on CRAN, even if they have data.table, because we don't regularly
# check these on CI and we don't want a change in data.table to force a CRAN
# failure for vctrs.
skip_on_cran()
# Avoids adding `data.table` to Suggests.
# These tests are only run on the devs' machines.
testthat_import_from("data.table", "data.table")
test_that("common type of data.table and data.frame is data.table", {
expect_identical(
vec_ptype2(data.table(x = TRUE), data.table(y = 2)),
data.table(x = lgl(), y = dbl())
)
expect_identical(
vec_ptype2(data.table(x = TRUE), data.frame(y = 2)),
data.table(x = lgl(), y = dbl())
)
expect_identical(
vec_ptype2(data.frame(y = 2), data.table(x = TRUE)),
data.table(y = dbl(), x = lgl())
)
expect_identical(
vec_cast(data.table(y = 2), data.table(x = TRUE, y = 1L)),
data.table(x = NA, y = 2L)
)
expect_identical(
vec_cast(data.frame(y = 2), data.table(x = TRUE, y = 1L)),
data.table(x = NA, y = 2L)
)
expect_identical(
vec_cast(data.table(y = 2), data.frame(x = TRUE, y = 1L)),
data.frame(x = NA, y = 2L)
)
})
test_that("data.table and tibble do not have a common type", {
expect_equal(
vec_ptype_common(data.table(x = TRUE), tibble(y = 2)),
tibble(x = lgl(), y = dbl())
)
expect_equal(
vec_ptype_common(tibble(y = 2), data.table(x = TRUE)),
tibble(y = dbl(), x = lgl())
)
expect_identical(
vec_cast(data.table(y = 2), tibble(x = TRUE, y = 1L)),
tibble(x = lgl(NA), y = 2L)
)
expect_identical(
vec_cast(tibble(y = 2), data.table(x = TRUE, y = 1L)),
data_frame(x = lgl(NA), y = 2L)
)
})
test_that("data table has formatting methods", {
expect_snapshot({
dt <- data.table(x = 1, y = 2, z = 3)
vec_ptype_abbr(dt)
vec_ptype_full(dt)
})
})
vctrs/tests/testthat/test-rank.R 0000644 0001762 0000144 00000012527 14511320527 016457 0 ustar ligges users test_that("can rank with different types of `ties`", {
x <- c(2L, 5L, 1L, 1L, 2L)
expect_identical(vec_rank(x, ties = "min"), rank(x, ties.method = "min"))
expect_identical(vec_rank(x, ties = "max"), rank(x, ties.method = "max"))
expect_identical(vec_rank(x, ties = "sequential"), rank(x, ties.method = "first"))
expect_identical(vec_rank(x, ties = "dense"), c(2L, 3L, 1L, 1L, 2L))
})
test_that("can rank in descending order", {
x <- c(2L, 5L, 1L, 1L, 2L)
expect_identical(vec_rank(x, ties = "min", direction = "desc"), rank(-x, ties.method = "min"))
expect_identical(vec_rank(x, ties = "max", direction = "desc"), rank(-x, ties.method = "max"))
expect_identical(vec_rank(x, ties = "sequential", direction = "desc"), rank(-x, ties.method = "first"))
expect_identical(vec_rank(x, ties = "dense", direction = "desc"), c(2L, 1L, 3L, 3L, 2L))
})
test_that("can rank incomplete values with `NA`", {
x <- c(2, NA, 4, NaN, 4, 2, NA)
expect_identical(vec_rank(x, ties = "min", incomplete = "na"), rank(x, ties.method = "min", na.last = "keep"))
expect_identical(vec_rank(x, ties = "max", incomplete = "na"), rank(x, ties.method = "max", na.last = "keep"))
expect_identical(vec_rank(x, ties = "sequential", incomplete = "na"), rank(x, ties.method = "first", na.last = "keep"))
expect_identical(vec_rank(x, ties = "dense", incomplete = "na"), c(1L, NA, 2L, NA, 2L, 1L, NA))
# NaN are treated as missing, regardless of whether or not they are distinct from NA_real_
expect_identical(
vec_rank(x, ties = "min", incomplete = "na", nan_distinct = TRUE),
vec_rank(x, ties = "min", incomplete = "na", nan_distinct = FALSE)
)
})
test_that("works correctly when `incomplete = 'na'` with no missing values", {
x <- c(1, 2, 1, 5, 2)
expect_identical(vec_rank(x, incomplete = "na"), rank(x, ties.method = "min"))
})
test_that("when ranking incomplete values, all NA (or NaN) values get the same rank", {
# this is in contrast to rank(), which treats all NA (NaN) as different
x <- c(1, NA, 3, NaN, NA, 1, NaN)
expect_identical(vec_rank(x, na_value = "largest"), c(1L, 4L, 3L, 4L, 4L, 1L, 4L))
expect_identical(vec_rank(x, na_value = "smallest"), c(5L, 1L, 7L, 1L, 1L, 5L, 1L))
# If distinct, NaN are always ranked between real numbers and NA_real_
expect_identical(vec_rank(x, na_value = "largest", nan_distinct = TRUE), c(1L, 6L, 3L, 4L, 6L, 1L, 4L))
expect_identical(vec_rank(x, na_value = "smallest", nan_distinct = TRUE), c(5L, 1L, 7L, 3L, 1L, 5L, 3L))
})
test_that("ranks character vectors in the C locale", {
x <- c("B", "b", "a")
expect_identical(vec_rank(x), c(1L, 3L, 2L))
})
test_that("works with data frames", {
df <- data_frame(
x = c(1, 2, 1, 2, 2),
y = c(2, 2, 1, 2, 5)
)
expect_identical(vec_rank(df, ties = "min"), c(2L, 3L, 1L, 3L, 5L))
expect_identical(vec_rank(df, ties = "sequential"), c(2L, 3L, 1L, 4L, 5L))
})
test_that("works with data frames with 0 columns and >0 rows (#1863)", {
# All rows are treated as being from the same group
df <- data_frame(.size = 5)
expect_identical(vec_rank(df, ties = "min"), c(1L, 1L, 1L, 1L, 1L))
expect_identical(vec_rank(df, ties = "sequential"), c(1L, 2L, 3L, 4L, 5L))
expect_identical(vec_rank(df, ties = "sequential", direction = "desc"), c(1L, 2L, 3L, 4L, 5L))
})
test_that("works with data frames with 0 columns and 0 rows (#1863)", {
df <- data_frame(.size = 0)
expect_identical(vec_rank(df, ties = "min"), integer())
expect_identical(vec_rank(df, ties = "sequential"), integer())
})
test_that("can control the direction per column", {
df <- data_frame(
x = c(1, 2, 1, 2, 2),
y = c(2, 2, 1, 2, 5)
)
df2 <- df
df2$y <- -df2$y
expect_identical(
vec_rank(df, direction = c("asc", "desc")),
vec_rank(df2, direction = "asc")
)
})
test_that("incompleteness is respected in data frames and rcrds", {
df <- data_frame(
x = c(1, NA, NA, 1),
y = c(NA, NA, 1, 1)
)
expect_identical(vec_rank(df, incomplete = "na"), c(NA, NA, NA, 1L))
expect_identical(vec_rank(df, incomplete = "na", direction = "desc"), c(NA, NA, NA, 1L))
x <- new_rcrd(list(
x = c(1, 1, NA, NA, 1),
y = c(1, NA, 1, NA, 1)
))
expect_identical(vec_rank(x, incomplete = "na"), c(1L, NA, NA, NA, 1L))
})
test_that("can control `na_value` per column", {
df <- data_frame(
x = c(1, 1, NA, NA, NA),
y = c(3, NA, NA, 2, 1)
)
expect_identical(
vec_rank(df, na_value = c("largest", "smallest")),
c(2L, 1L, 3L, 5L, 4L)
)
expect_identical(
vec_rank(df, na_value = c("largest", "smallest"), direction = "desc"),
c(4L, 5L, 3L, 1L, 2L)
)
# But `incomplete = "na"` overrules it
expect_identical(
vec_rank(df, na_value = c("largest", "smallest"), incomplete = "na"),
c(1L, NA, NA, NA, NA)
)
expect_identical(
vec_rank(df, na_value = c("largest", "smallest"), incomplete = "na", direction = "desc"),
c(1L, NA, NA, NA, NA)
)
})
test_that("`x` must be a vector", {
expect_error(vec_rank(identity), class = "vctrs_error_scalar_type")
})
test_that("`ties` is validated", {
expect_snapshot(error = TRUE, vec_rank(1, ties = "foo"))
expect_snapshot(error = TRUE, vec_rank(1, ties = 1))
})
test_that("`incomplete` is validated", {
expect_snapshot(error = TRUE, vec_rank(1, incomplete = NA))
expect_snapshot(error = TRUE, vec_rank(1, incomplete = c(TRUE, FALSE)))
expect_snapshot(error = TRUE, vec_rank(1, incomplete = "foo"))
})
vctrs/tests/testthat/test-group.R 0000644 0001762 0000144 00000013405 14276722575 016675 0 ustar ligges users
# group id ----------------------------------------------------------------
test_that("vec_group_id detects groups in order of appearance", {
x <- c(2, 4, 2, 1, 4)
expect <- structure(c(1L, 2L, 1L, 3L, 2L), n = 3L)
expect_equal(vec_group_id(x), expect)
})
test_that("vec_group_id works for size 0 input", {
expect <- structure(integer(), n = 0L)
expect_equal(vec_group_id(NULL), expect)
expect_equal(vec_group_id(numeric()), expect)
})
test_that("vec_group_id works on base S3 objects", {
x <- factor(c("x", "y", "x"))
expect <- structure(c(1L, 2L, 1L), n = 2L)
expect_equal(vec_group_id(x), expect)
x <- new_date(c(0, 1, 0))
expect <- structure(c(1L, 2L, 1L), n = 2L)
expect_equal(vec_group_id(x), expect)
})
test_that("vec_group_id works row wise on data frames", {
df <- data.frame(x = c(1, 2, 1, 1), y = c(2, 3, 2, 3))
expect <- structure(c(1L, 2L, 1L, 3L), n = 3L)
expect_equal(vec_group_id(df), expect)
})
test_that("vec_group_id works row wise on arrays", {
x <- array(c(1, 1, 1, 2, 4, 2), c(3, 2))
expect <- structure(c(1L, 2L, 1L), n = 2L)
expect_equal(vec_group_id(x), expect)
})
test_that("vec_group_id works with different encodings", {
expect <- structure(c(1L, 1L, 1L), n = 1L)
expect_equal(vec_group_id(encodings()), expect)
})
test_that("vec_group_id takes the equality proxy", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1, 1), c(1, 1, 1, 2))
# Compares on only the first field
expect <- structure(c(1L, 2L, 1L, 1L), n = 2L)
expect_equal(vec_group_id(x), expect)
})
test_that("vec_group_id takes the equality proxy recursively", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1, 1), 1:4)
df <- data_frame(x = x)
expect <- structure(c(1L, 2L, 1L, 1L), n = 2L)
expect_equal(vec_group_id(df), expect)
})
# group rle ---------------------------------------------------------------
test_that("vec_group_rle returns a `vctrs_group_rle` object", {
expect_s3_class(vec_group_rle(1), "vctrs_group_rle")
})
test_that("vec_group_rle works with size 0 input", {
expect <- new_group_rle(integer(), integer(), 0L)
expect_equal(vec_group_rle(integer()), expect)
expect_equal(vec_group_rle(NULL), expect)
})
test_that("vec_group_rle detects groups in order of appearance", {
x <- c(2, 2, 3, 1, 1)
expect <- new_group_rle(1:3, c(2L, 1L, 2L), 3L)
expect_equal(vec_group_rle(x), expect)
})
test_that("vec_group_rle can refer to groups it has already seen", {
x <- c(2, 3, 2)
expect <- new_group_rle(c(1L, 2L, 1L), rep(1L, 3), 2L)
expect_equal(vec_group_rle(x), expect)
})
test_that("vec_group_rle works on base S3 objects", {
expect <- new_group_rle(c(1L, 2L, 1L, 3L), c(1L, 2L, 1L, 1L), 3L)
x <- factor(c("x", "y", "y", "x", "z"))
expect_equal(vec_group_rle(x), expect)
x <- new_date(c(0, 1, 1, 0, 2))
expect_equal(vec_group_rle(x), expect)
})
test_that("vec_group_rle takes the equality proxy", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1, 1), c(1, 1, 1, 2))
# Compares on only the first field
expect <- new_group_rle(c(1L, 2L, 1L), c(1L, 1L, 2L), 2L)
expect_equal(vec_group_rle(x), expect)
})
test_that("vec_group_rle works row wise on data frames", {
df <- data.frame(x = c(1, 1, 2, 1), y = c(2, 2, 3, 2))
expect <- new_group_rle(c(1L, 2L, 1L), c(2L, 1L, 1L), 2L)
expect_equal(vec_group_rle(df), expect)
})
test_that("vec_group_rle takes the equality proxy recursively", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1, 1), 1:4)
df <- data_frame(x = x)
expect <- new_group_rle(c(1L, 2L, 1L), c(1L, 1L, 2L), 2L)
expect_equal(vec_group_rle(df), expect)
})
test_that("can access fields", {
x <- vec_group_rle(c(1, 1, 2))
expect_equal(fields(x), c("group", "length"))
expect_identical(field(x, "group"), c(1L, 2L))
expect_identical(field(x, "length"), c(2L, 1L))
})
test_that("can access number of groups", {
x <- vec_group_rle(c(1, 1, 2))
expect_identical(attr(x, "n"), 2L)
})
test_that("print method is useful", {
x <- new_group_rle(c(1L, 2L, 1L), c(3L, 2L, 1L), 2L)
expect_snapshot(x)
})
# group loc --------------------------------------------------------------
test_that("can locate unique groups of an empty vector", {
out <- vec_group_loc(integer())
expect_s3_class(out, "data.frame")
expect_equal(out$key, integer())
expect_equal(out$loc, list())
})
test_that("can locate unique groups of a data frame", {
df <- data_frame(x = c(1, 1, 1, 2, 2), y = c("a", "a", "b", "a", "b"))
out <- vec_group_loc(df)
expect_equal(nrow(out), 4L)
expect_equal(out$key, vec_unique(df))
})
test_that("can locate unique groups of a data frame with a list column", {
df <- data_frame(x = list(1:2, 1:2, "a", 5.5, "a"))
out <- vec_group_loc(df)
expect_equal(nrow(out), 3L)
expect_equal(out$key, vec_unique(df))
})
test_that("`x` must be a vector", {
expect_error(vec_group_loc(environment()), class = "vctrs_error_scalar_type")
})
test_that("`key` column retains full type information", {
x <- factor(letters[c(1, 2, 1)], levels = letters[1:3])
out <- vec_group_loc(x)
expect_equal(levels(out$key), levels(x))
})
test_that("vec_group_loc takes the equality proxy", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1), 1:3)
expect_equal(vec_group_loc(x)$key, x[1:2])
expect_equal(vec_group_loc(x)$loc, list(c(1L, 3L), 2L))
x <- as.POSIXlt(new_datetime(c(1, 2, 1)))
expect_equal(vec_group_loc(x)$key, x[1:2])
expect_equal(vec_group_loc(x)$loc, list(c(1L, 3L), 2L))
})
test_that("vec_group_loc takes the equality proxy recursively", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1, 1), 1:4)
df <- data_frame(x = x)
expect <- data_frame(key = vec_slice(df, c(1, 2)), loc = list(c(1L, 3L, 4L), 2L))
expect_equal(vec_group_loc(df), expect)
})
test_that("vec_group_loc works with different encodings", {
encs <- encodings()
expect_identical(nrow(vec_group_loc(encs)), 1L)
})
vctrs/tests/testthat/test-error-call.R 0000644 0001762 0000144 00000013045 14376223321 017565 0 ustar ligges users test_that("failing common type reports correct error call", {
my_function <- function() vec_ptype2(2, chr())
expect_snapshot((expect_error(my_function())))
})
test_that("failing cast reports correct error call", {
my_function <- function() vec_cast(2, chr())
expect_snapshot((expect_error(my_function())))
df1 <- data_frame(x = TRUE, y = TRUE)
df2 <- data_frame(y = "1")
my_function <- function(lhs, rhs) vec_cast(lhs, rhs)
expect_snapshot((expect_error(my_function(df1, df2))))
df1 <- data_frame(y = TRUE)
df2 <- data_frame(y = "1")
expect_snapshot((expect_error(my_function(df1, df2))))
})
test_that("lossy cast reports correct error call", {
my_function <- function() vec_cast(2, lgl())
expect_snapshot((expect_error(my_function())))
})
test_that("failing common size reports correct error call", {
my_function <- function() vec_recycle(1:2, 10)
expect_snapshot((expect_error(my_function())))
# FIXME
my_function <- function() vec_size_common(1:2, 1:10)
expect_snapshot((expect_error(my_function())))
})
test_that("unsupported error reports correct error call", {
x <- new_vctr(1:2)
my_function <- function() dim(x) <- 1:2
expect_snapshot((expect_error(my_function())))
my_function <- function() median(x)
expect_snapshot((expect_error(my_function())))
})
test_that("scalar error reports correct error call", {
my_function <- function() obj_check_vector(foobar())
expect_snapshot((expect_error(my_function())))
})
test_that("size error reports correct error call", {
my_function <- function() vec_check_size(1:2, size = 1)
expect_snapshot((expect_error(my_function())))
})
test_that("bare casts report correct error call", {
my_function <- function() vec_cast(1.5, int())
expect_snapshot((expect_error(my_function())))
my_function <- function() vec_cast(1.5, lgl())
expect_snapshot((expect_error(my_function())))
my_function <- function() vec_cast(2L, lgl())
expect_snapshot((expect_error(my_function())))
# Passing call to `shape_broadcast()`
my_function <- function() vec_cast(matrix(TRUE), dbl())
expect_snapshot((expect_error(my_function())))
})
test_that("base S3 casts report correct error call", {
my_function <- function() vec_cast("a", factor("b"))
expect_snapshot((expect_error(my_function())))
})
test_that("names validation reports correct error call", {
my_function <- function() vec_as_names(c("x", "", "y"), repair = "check_unique")
expect_snapshot((expect_error(my_function())))
my_function <- function() vec_as_names(c("x", "x"), repair = "check_unique", repair_arg = "repair")
expect_snapshot((expect_error(my_function())))
my_function <- function() vec_as_names("...", repair = "check_unique", repair_arg = "repair")
expect_snapshot((expect_error(my_function())))
})
test_that("subscript validation reports correct error calls", {
my_function <- function() vctrs::num_as_location(1, 1L, missing = "bogus")
expect_snapshot((expect_error(my_function())))
my_function <- function() vctrs::vec_as_location(10, 2)
expect_snapshot((expect_error(my_function())))
my_function <- function(my_arg) vec_as_location(my_arg, 2)
expect_snapshot((expect_error(my_function(1.5))))
my_function <- function(my_arg) vctrs::vec_as_subscript(my_arg)
expect_snapshot((expect_error(my_function(1.5))))
my_function <- function(my_arg) vctrs::vec_as_location(my_arg, 2)
expect_snapshot((expect_error(my_function(list()))))
my_function <- function(my_arg) vec_as_location(1, my_arg)
expect_snapshot((expect_error(my_function(1.5))))
my_function <- function(my_arg) vec_as_location(my_arg, 1, missing = "error")
expect_snapshot((expect_error(my_function(NA))))
})
test_that("`vec_ptype()` reports correct error call", {
my_function <- function(my_arg) vec_ptype(my_arg)
expect_snapshot({
(expect_error(my_function(env())))
(expect_error(my_function(foobar(list()))))
})
})
test_that("`vec_slice()` uses `error_call`", {
my_function <- function(x, i) vec_slice(x, i, error_call = current_env())
expect_snapshot({
(expect_error(my_function(env(), 1)))
(expect_error(my_function(1, 2)))
})
})
test_that("vec_slice() reports self in error context", {
expect_snapshot({
(expect_error(vec_slice(foobar(list()), 1)))
(expect_error(vec_slice(list(), env())))
})
})
test_that("list_sizes() reports error context", {
expect_snapshot({
(expect_error(list_sizes(foobar(list()))))
(expect_error(list_sizes(list(env()))))
(expect_error(list_sizes(list(1, 2, env()))))
(expect_error(list_sizes(list(1, 2, foo = env()))))
})
})
test_that("vec_size() reports error context", {
expect_snapshot({
(expect_error(vec_size(env())))
})
})
test_that("vec_cast_common() reports error context", {
my_function <- function(...) vec_cast_common(...)
expect_snapshot((expect_error(my_function(my_arg = 1.5, .to = int()))))
expect_snapshot((expect_error(my_function(my_arg = 1.5, .to = int(), .arg = "my_arg"))))
expect_snapshot((expect_error(my_function(this_arg = 1, that_arg = "foo", .arg = "my_arg"))))
expect_snapshot((expect_error(my_function(1, "foo", .arg = "my_arg"))))
x <- data.frame(x = "a")
y <- data.frame(x = 1, y = 2)
expect_snapshot((expect_error(my_function(this_arg = x, that_arg = y))))
})
test_that("vec_ptype_common() reports error context", {
my_function <- function(...) vec_ptype_common(...)
expect_snapshot((expect_error(my_function(this_arg = 1, that_arg = "foo"))))
expect_snapshot((expect_error(my_function(this_arg = 1, that_arg = "foo", .arg = "my_arg"))))
expect_snapshot((expect_error(my_function(1, "foo", .arg = "my_arg"))))
})
vctrs/tests/testthat/test-c.R 0000644 0001762 0000144 00000050070 14437364137 015755 0 ustar ligges users local_name_repair_quiet()
test_that("zero length input returns NULL", {
expect_equal(vec_c(), NULL)
expect_equal(vec_c(NULL), NULL)
expect_equal(vec_c(NULL,), NULL)
expect_equal(vec_c(NULL, NULL), NULL)
})
test_that("NULL is idempotent", {
expect_equal(vec_c(NULL, 1L), 1L)
expect_equal(vec_c(1L, NULL), 1L)
})
test_that("NA is idempotent", {
expect_equal(vec_c(NA, 1L), c(NA, 1L))
expect_equal(vec_c(NA, "x"), c(NA, "x"))
expect_equal(vec_c(NA, factor("x")), factor(c(NA, "x")))
expect_equal(vec_c(NA, new_date(0)), new_date(c(NA, 0)))
expect_equal(vec_c(NA, new_datetime(0)), new_datetime(c(NA, 0)))
expect_equal(vec_c(NA, new_duration(0)), new_duration(c(NA, 0)))
})
test_that("NA is logical if no other types intervene", {
expect_equal(vec_c(logical()), logical())
expect_equal(vec_c(NA), NA)
expect_equal(vec_c(NA, NA), c(NA, NA))
})
test_that("different types are coerced to common", {
expect_equal(vec_c(TRUE, 1L, 1), c(1, 1, 1))
expect_equal(vec_c(TRUE, 2:4), 1:4)
})
test_that("specified .ptypes do not allow more casts", {
expect_error(
vec_c(TRUE, .ptype = character()),
class = "vctrs_error_incompatible_type"
)
})
test_that("common type failure uses error call and error arg (#1641, #1692)", {
expect_snapshot(error = TRUE, {
vec_c("x", 1, .error_call = call("foo"), .error_arg = "arg")
})
expect_snapshot(error = TRUE, {
vec_c("x", .ptype = integer(), .error_call = call("foo"), .error_arg = "arg")
})
})
test_that("common type failure uses positional errors", {
expect_snapshot({
# Looking for `..1` and `a`
(expect_error(vec_c(1, a = "x", 2)))
# Directed cast should also produce positional errors (#1690)
(expect_error(vec_c(1, a = "x", 2, .ptype = double(), .error_arg = "arg")))
# Lossy cast
(expect_error(vec_c(1, a = 2.5, .ptype = integer())))
})
})
test_that("combines outer an inner names", {
expect_equal(vec_c(x = 1), c(x = 1))
expect_equal(vec_c(c(x = 1)), c(x = 1))
expect_equal(vec_c(c(x = 1:2)), c(x1 = 1, x2 = 2))
expect_error(vec_c(y = c(x = 1)), "Please supply")
})
test_that("can bind data.frame columns", {
df <- data.frame(x = NA, y = 1:2)
df$x <- data.frame(a = 1:2)
expected <- data.frame(x = NA, y = c(1:2, 1:2))
expected$x <- data.frame(a = c(1:2, 1:2))
expect_equal(vec_c(df, df), expected)
})
test_that("vec_c() handles matrices", {
m <- matrix(1:4, nrow = 2)
dimnames(m) <- list(c("foo", "bar"), c("baz", "quux"))
# FIXME: `vec_ptype_common(m, m)` doesn't return dimension names
exp <- matrix(c(1:2, 1:2, 3:4, 3:4), nrow = 4)
rownames(exp) <- c("foo", "bar", "foo", "bar")
expect_identical(vec_c(m, m), exp)
expect_error(vec_c(outer = m), "Please supply")
})
test_that("vec_c() includes index in argument tag", {
df1 <- tibble(x = tibble(y = tibble(z = 1)))
df2 <- tibble(x = tibble(y = tibble(z = "a")))
expect_snapshot(error = TRUE, vec_c(df1, df2))
expect_snapshot(error = TRUE, vec_c(df1, df1, df2))
expect_snapshot(error = TRUE, vec_c(foo = df1, bar = df2))
})
test_that("vec_c() handles record classes", {
local_rational_class()
out <- vec_c(rational(1, 2), 1L, NA)
expect_true(vec_is(out, rational(1, 2)))
expect_size(out, 3)
expect_identical(vec_proxy(out), data.frame(n = c(1L, 1L, NA), d = c(2L, 1L, NA)))
})
test_that("can mix named and unnamed vectors (#271)", {
expect_identical(vec_c(c(a = 1), 2), c(a = 1, 2))
expect_identical(vec_c(0, c(a = 1), 2, b = 3), c(0, a = 1, 2, b =3))
})
test_that("preserves names when inputs are cast to a common type (#1690)", {
expect_named(vec_c(c(a = 1), .ptype = integer()), "a")
expect_named(vec_c(foo = c(a = 1), .ptype = integer(), .name_spec = "{outer}_{inner}"), "foo_a")
})
test_that("vec_c() repairs names", {
local_name_repair_quiet()
# Default minimal repair
expect_named(vec_c(a = 1, a = 2, `_` = 3), c("a", "a", "_"))
out <- vec_c(!!!set_names(1, NA))
expect_named(out, "")
expect_named(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "unique"), c("a...1", "a...2", "_"))
expect_error(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique")
expect_named(vec_c(a = 1, a = 2, `_` = 3, .name_repair = "universal"), c("a...1", "a...2", "._"))
expect_named(vec_c(a = 1, a = 2, .name_repair = ~ toupper(.)), c("A", "A"))
})
test_that("vec_c() can repair names quietly", {
local_name_repair_verbose()
expect_snapshot({
res_unique <- vec_c(x = TRUE, x = 0, .name_repair = "unique_quiet")
res_universal <- vec_c("if" = TRUE, "in" = 0, .name_repair = "universal_quiet")
})
expect_named(res_unique, c("x...1", "x...2"))
expect_named(res_universal, c(".if", ".in"))
})
test_that("vec_c() doesn't use outer names for data frames (#524)", {
x <- data.frame(inner = 1)
expect_equal(vec_c(outer = x), x)
a <- data.frame(x = 1L)
b <- data.frame(x = 2L)
expect_equal(vec_c(foo = a, bar = b), data.frame(x = 1:2))
})
test_that("vec_c() preserves row names and inner names", {
x <- data.frame(a = 1, row.names = "r1")
y <- data.frame(a = 2, row.names = "r2")
expect_equal(rownames(vec_c(x, y)), c("r1", "r2"))
expect_equal(rownames(vec_c(x, x)), c("r1...1", "r1...2"))
vec_x <- set_names(1:3, letters[1:3])
vec_y <- c(FOO = 4L)
oo_x <- set_names(as.POSIXlt(c("2020-01-01", "2020-01-02", "2020-01-03")), letters[1:3])
oo_y <- as.POSIXlt(c(FOO = "2020-01-04"))
df_x <- new_data_frame(list(x = 1:3), row.names = letters[1:3])
df_y <- new_data_frame(list(x = 4L), row.names = "d")
mat_x <- matrix(1:3, 3, dimnames = list(letters[1:3]))
mat_y <- matrix(4L, 1, dimnames = list("d"))
nested_x <- new_data_frame(
list(df = df_x, mat = mat_x, vec = vec_x, oo = oo_x),
row.names = c("foo", "bar", "baz")
)
nested_y <- new_data_frame(
list(df = df_y, mat = mat_y, vec = vec_y, oo = oo_y),
row.names = c("quux")
)
nested_out <- vec_c(nested_x, nested_y)
expect_identical(row.names(nested_out), c("foo", "bar", "baz", "quux"))
expect_identical(row.names(nested_out$df), c("a", "b", "c", "d"))
expect_identical(row.names(nested_out$mat), c("a", "b", "c", "d"))
expect_identical(names(nested_out$vec), c("a", "b", "c", "FOO"))
expect_identical(names(nested_out$oo), c("a", "b", "c", "FOO"))
})
test_that("vec_c() outer names work with proxied objects", {
x <- as.POSIXlt(new_datetime(0))
exp <- set_names(x, "outer")
expect_equal(vec_c(outer = x), exp)
named_x <- set_names(x, "inner")
exp <- set_names(named_x, "outer_inner")
expect_error(vec_c(outer = named_x), "Please supply")
expect_equal(vec_c(outer = named_x, .name_spec = "{outer}_{inner}"), exp)
xs <- as.POSIXlt(new_datetime(c(0, 1)))
exp <- set_names(xs, c("outer_1", "outer_2"))
expect_error(vec_c(outer = xs), "Please supply")
expect_equal(vec_c(outer = xs, .name_spec = "{outer}_{inner}"), exp)
})
test_that("vec_c() works with simple homogeneous foreign S3 classes", {
expect_identical(vec_c(foobar(1), foobar(2)), vec_c(foobar(c(1, 2))))
expect_identical(vec_c(NULL, foobar(1), foobar(2)), vec_c(foobar(c(1, 2))))
})
test_that("vec_c() works with simple homogeneous foreign S4 classes", {
joe1 <- .Counts(c(1L, 2L), name = "Joe")
joe2 <- .Counts(3L, name = "Joe")
expect_identical(vec_c(joe1, joe2), .Counts(1:3, name = "Joe"))
})
test_that("vec_c() fails with complex foreign S3 classes", {
expect_snapshot({
x <- structure(foobar(1), attr_foo = "foo")
y <- structure(foobar(2), attr_bar = "bar")
(expect_error(vec_c(x, y), class = "vctrs_error_incompatible_type"))
(expect_error(vec_c(x, y, .error_call = call("foo"), .error_arg = "arg"), class = "vctrs_error_incompatible_type"))
})
})
test_that("vec_c() fails with complex foreign S4 classes", {
expect_snapshot({
joe <- .Counts(c(1L, 2L), name = "Joe")
jane <- .Counts(3L, name = "Jane")
(expect_error(vec_c(joe, jane), class = "vctrs_error_incompatible_type"))
(expect_error(vec_c(joe, jane, .error_call = call("foo"), .error_arg = "arg"), class = "vctrs_error_incompatible_type"))
})
})
test_that("vec_c() falls back to c() if S3 method is available", {
# Check off-by-one error
expect_error(
vec_c(foobar(1), "", foobar(2)),
class = "vctrs_error_incompatible_type"
)
# Fallback when the class implements `c()`
method <- function(...) rep_along(list(...), "dispatched")
local_methods(
c.vctrs_foobar = method
)
expect_identical(
vec_c(foobar(1), foobar(2, class = "foo")),
c("dispatched", "dispatched")
)
expect_identical(
vec_c(NULL, foobar(1), NULL, foobar(2, class = "foo")),
c("dispatched", "dispatched")
)
# Registered fallback
s3_register("base::c", "vctrs_c_fallback", method)
expect_identical(
vec_c(
structure(1, class = "vctrs_c_fallback"),
structure(2, class = "vctrs_c_fallback")
),
c("dispatched", "dispatched")
)
# Don't fallback for S3 lists which are treated as scalars by default
expect_error(
vec_c(foobar(list(1)), foobar(list(2))),
class = "vctrs_error_scalar_type"
)
})
test_that("c() fallback is consistent", {
dispatched <- function(x) structure(x, class = "dispatched")
c_method <- function(...) dispatched(NextMethod())
out <- with_methods(
vec_ptype2.vctrs_foobaz.vctrs_foobaz = function(...) foobaz(df_ptype2(...)),
vec_cast.vctrs_foobaz.vctrs_foobaz = function(...) foobaz(df_cast(...)),
c.vctrs_foobar = c_method,
list(
direct = vec_c(foobar(1L), foobar(2L)),
df = vec_c(data_frame(x = foobar(1L)), data_frame(x = foobar(2L))),
tib = vec_c(tibble(x = foobar(1L)), tibble(x = foobar(2L))),
foreign_df = vec_c(foobaz(data_frame(x = foobar(1L))), foobaz(data_frame(x = foobar(2L))))
)
)
expect_equal(out$direct, dispatched(1:2))
expect_equal(out$df$x, dispatched(1:2))
expect_equal(out$tib$x, dispatched(1:2))
expect_equal(out$foreign_df$x, dispatched(1:2))
# Hard case: generic record vectors
my_rec_record <- function(x) {
new_rcrd(list(x = x), class = "my_rec_record")
}
out <- with_methods(
c.vctrs_foobar = c_method,
vec_ptype2.my_rec_record.my_rec_record = function(x, y, ...) {
my_rec_record(vec_ptype2(field(x, "x"), field(y, "x"), ...))
},
vec_cast.my_rec_record.my_rec_record = function(x, to, ...) {
x
},
vec_c(
data_frame(x = my_rec_record(foobar(1L))),
data_frame(x = my_rec_record(foobar(2L)))
)
)
expect_equal(field(out$x, "x"), dispatched(1:2))
})
test_that("vec_c() falls back to c() if S4 method is available", {
joe1 <- .Counts(c(1L, 2L), name = "Joe")
joe2 <- .Counts(3L, name = "Joe")
c_counts <- function(x, ...) {
xs <- list(x, ...)
xs_data <- lapply(xs, function(x) x@.Data)
new_data <- do.call(c, xs_data)
.Counts(new_data, name = x@name)
}
local_s4_method("c", methods::signature(x = "vctrs_Counts"), c_counts)
expect_identical(
vec_c(joe1, joe2),
.Counts(c(1L, 2L, 3L), name = "Joe")
)
expect_identical(
vec_c(NULL, joe1, joe2),
.Counts(c(1L, 2L, 3L), name = "Joe")
)
})
test_that("vec_c() fallback doesn't support `name_spec` or `ptype`", {
expect_snapshot({
(expect_error(
with_c_foobar(vec_c(foobar(1), foobar(2), .name_spec = "{outer}_{inner}")),
"name specification"
))
# Used to be an error about `ptype`
(expect_error(
with_c_foobar(vec_c(foobar(1), foobar(2), .ptype = "")),
class = "vctrs_error_incompatible_type"
))
# Uses error call (#1641)
(expect_error(
with_c_foobar(vec_c(
foobar(1), foobar(2),
.error_call = call("foo"),
.name_spec = "{outer}_{inner}"
))
))
})
})
test_that("vec_c() doesn't fall back when ptype2 is implemented", {
new_quux <- function(x) structure(x, class = "vctrs_quux")
with_methods(
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) new_quux(int()),
vec_cast.vctrs_quux.vctrs_foobar = function(x, to, ...) new_quux(x),
vec_restore.vctrs_quux = function(x, ...) new_quux(x),
c.vctrs_foobar = function(...) foobar(NextMethod()),
{
expect_s3_class(c(foobar(1:3), foobar(4L)), "vctrs_foobar")
expect_s3_class(vec_c(foobar(1:3), foobar(4L)), "vctrs_quux")
}
)
})
test_that("vec_c() falls back even when ptype is supplied", {
expect_foobar(vec_c(foobar(1), foobar(2), .ptype = foobar(dbl())))
with_methods(
c.vctrs_foobar = function(...) quux(NextMethod()),
{
expect_quux(vec_c(foobar(1), foobar(2), .ptype = foobar(dbl())))
expect_quux(vec_c(foobar(1, foo = TRUE), foobar(2, bar = TRUE), .ptype = foobar(dbl())))
}
)
})
test_that("vec_implements_ptype2() is FALSE for scalars", {
expect_false(vec_implements_ptype2(quote(foo)))
})
test_that("vec_implements_ptype2() and vec_c() fallback are compatible with old registration", {
foo <- structure(NA, class = "vctrs_implements_ptype2_false")
expect_false(vec_implements_ptype2(foo))
vec_ptype2.vctrs_implements_ptype2_true <- function(...) NULL
s3_register(
"vctrs::vec_ptype2",
"vctrs_implements_ptype2_true",
vec_ptype2.vctrs_implements_ptype2_true
)
bar <- structure(NA, class = "vctrs_implements_ptype2_true")
expect_true(vec_implements_ptype2(bar))
local_methods(
`c.vctrs_implements_ptype2_true` = function(...) stop("never called")
)
expect_identical(vec_c(bar), bar)
})
test_that("can ignore names in `vec_c()` by providing a `zap()` name-spec (#232)", {
expect_error(vec_c(a = c(b = 1:2)))
expect_identical(vec_c(a = c(b = 1:2), b = 3L, .name_spec = zap()), 1:3)
expect_snapshot({
(expect_error(
vec_c(a = c(b = letters), b = 1, .name_spec = zap()),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("can concatenate subclasses of `vctrs_vctr` which don't have ptype2 methods", {
x <- new_vctr(1, class = "vctrs_foo")
expect_identical(vec_c(x, x), new_vctr(c(1, 1), class = "vctrs_foo"))
})
test_that("base c() fallback handles unspecified chunks", {
local_methods(
c.vctrs_foobar = function(...) {
x <- NextMethod()
# Should not be passed any unspecified chunks
if (anyNA(x)) {
abort("tilt")
}
foobar(x)
},
`[.vctrs_foobar` = function(x, i, ...) {
# Return a quux to detect dispatch
quux(NextMethod())
}
)
out <- vec_c(foobar(1:2), rep(NA, 2))
expect_identical(out, quux(c(1:2, NA, NA)))
out <- vec_c(rep(NA, 2), foobar(1:2), NA)
expect_identical(out, quux(c(NA, NA, 1:2, NA)))
})
test_that("can zap outer names from a name-spec (#1215)", {
zap_outer_spec <- function(outer, inner) if (is_character(inner)) inner
expect_null(
names(vec_c(a = 1:2, .name_spec = zap_outer_spec))
)
expect_identical(
names(vec_c(a = 1:2, c(foo = 3L), .name_spec = zap_outer_spec)),
c("", "", "foo")
)
expect_null(
names(list_unchop(list(a = 1:2), indices = list(1:2), name_spec = zap_outer_spec))
)
expect_identical(
names(list_unchop(list(a = 1:2, c(foo = 3L)), indices = list(1:2, 3), name_spec = zap_outer_spec)),
c("", "", "foo")
)
})
test_that("named empty vectors force named output (#1263)", {
x <- set_names(int(), chr())
expect_named(vec_c(x), chr())
expect_named(vec_c(x, x), chr())
expect_named(vec_c(x, 1L), "")
expect_named(vec_c(x, 1), "")
expect_named(list_unchop(list(x), indices = list(int())), chr())
expect_named(list_unchop(list(x, x), indices = list(int(), int())), chr())
expect_named(list_unchop(list(x, 1L), indices = list(int(), 1)), "")
expect_named(list_unchop(list(x, 1), indices = list(int(), 1)), "")
})
# Golden tests -------------------------------------------------------
test_that("concatenation performs expected allocations", {
vec_c_list <- function(x, ptype = NULL) {
vec_c(!!!x, .ptype = ptype)
}
expect_snapshot({
ints <- rep(list(1L), 1e2)
dbls <- rep(list(1), 1e2)
# Extra allocations from `list2()`, see r-lib/rlang#937
"# `vec_c()` "
"Integers"
with_memory_prof(vec_c_list(ints))
"Doubles"
with_memory_prof(vec_c_list(dbls))
"Integers to integer"
with_memory_prof(vec_c_list(ints, ptype = int()))
"Doubles to integer"
with_memory_prof(vec_c_list(dbls, ptype = int()))
"# `list_unchop()` "
"Integers"
with_memory_prof(list_unchop(ints))
"Doubles"
with_memory_prof(list_unchop(dbls))
"Integers to integer"
with_memory_prof(list_unchop(ints, ptype = int()))
"Doubles to integer"
with_memory_prof(list_unchop(dbls, ptype = int()))
"# Concatenation with names"
"Named integers"
ints <- rep(list(set_names(1:3, letters[1:3])), 1e2)
with_memory_prof(list_unchop(ints))
"Named matrices"
mat <- matrix(1:4, 2, dimnames = list(c("foo", "bar")))
mats <- rep(list(mat), 1e2)
with_memory_prof(list_unchop(mats))
"Data frame with named columns"
df <- data_frame(
x = set_names(as.list(1:2), c("a", "b")),
y = set_names(1:2, c("A", "B")),
z = data_frame(Z = set_names(1:2, c("Za", "Zb")))
)
dfs <- rep(list(df), 1e2)
with_memory_prof(list_unchop(dfs))
"Data frame with rownames (non-repaired, non-recursive case)"
df <- data_frame(x = 1:2)
dfs <- rep(list(df), 1e2)
dfs <- map2(dfs, seq_along(dfs), set_rownames_recursively)
with_memory_prof(list_unchop(dfs))
"Data frame with rownames (repaired, non-recursive case)"
dfs <- map(dfs, set_rownames_recursively)
with_memory_prof(list_unchop(dfs))
"Data frame with rownames (non-repaired, recursive case) (#1217)"
df <- data_frame(
x = 1:2,
y = data_frame(x = 1:2)
)
dfs <- rep(list(df), 1e2)
dfs <- map2(dfs, seq_along(dfs), set_rownames_recursively)
with_memory_prof(list_unchop(dfs))
"Data frame with rownames (repaired, recursive case) (#1217)"
dfs <- map(dfs, set_rownames_recursively)
with_memory_prof(list_unchop(dfs))
"list-ofs (#1496)"
make_list_of <- function(n) {
df <- tibble::tibble(
x = new_list_of(vec_chop(1:n), ptype = integer())
)
vec_chop(df)
}
with_memory_prof(list_unchop(make_list_of(1e3)))
with_memory_prof(list_unchop(make_list_of(2e3)))
with_memory_prof(list_unchop(make_list_of(4e3)))
})
})
test_that("can dispatch many times", {
# This caused a crash when counters were not correctly protected
foo <- structure(
list(x.sorted = numeric(0), tp = numeric(0), fp = numeric(0)),
row.names = integer(0),
class = c("vctrs_foobar", "tbl_df", "tbl", "data.frame")
)
x <- lapply(1:200, function(...) foo)
expect_error(NA, object = vctrs::list_unchop(x))
})
test_that("dots splicing clones as appropriate", {
x <- list(a = 1)
vctrs::vec_cbind(!!!x)
expect_equal(x, list(a = 1))
x <- list(a = 1)
vctrs::vec_rbind(!!!x)
expect_equal(x, list(a = 1))
x <- list(a = 1)
vctrs::vec_c(!!!x)
expect_equal(x, list(a = 1))
x <- list(a = 1)
vctrs::vec_cbind(!!!x, 2)
expect_equal(x, list(a = 1))
x <- list(a = 1)
vctrs::vec_rbind(!!!x, 2)
expect_equal(x, list(a = 1))
x <- list(a = 1)
vctrs::vec_c(!!!x, 2)
expect_equal(x, list(a = 1))
})
test_that("can combine records wrapped in data frames", {
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) {
data_frame(x = unclass(x), y = seq_along(x))
},
vec_restore.vctrs_foobar = function(x, to, ...) {
foobar(x$x)
}
)
x <- foobar(1:2)
y <- foobar(3:4)
expect_equal(
vec_c(x, y),
foobar(1:4)
)
expect_equal(
list_unchop(list(x, y), indices = list(1:2, 3:4)),
foobar(1:4)
)
expect_equal(
vec_rbind(data_frame(x = x), data_frame(x = y)),
data_frame(x = foobar(1:4))
)
})
test_that("fallback works with subclasses of `vctrs_vctr`", {
# Used to fail because of interaction between common class fallback
# for `base::c()` and the `c()` method for `vctrs_vctr` that called
# back into `vec_c()`.
# Reprex for failure in the ricu package
x <- new_rcrd(list(a = 1), class = "vctrs_foobar")
expect_equal(
vec_c(x, x, .name_spec = "{inner}"),
new_rcrd(list(a = c(1, 1)), class = "vctrs_foobar")
)
# Reprex for failure in the groupr package
x <- new_rcrd(list(a = 1), class = "vctrs_foobar")
df <- data_frame(x = x)
expect_equal(
vec_rbind(df, data.frame()),
df
)
expect_equal(
vec_cast_common(df, data.frame()),
list(df, data_frame(x = x[0]))
)
})
vctrs/tests/testthat/test-missing.R 0000644 0001762 0000144 00000012455 14315060310 017166 0 ustar ligges users # ------------------------------------------------------------------------------
# vec_detect_missing()
test_that("can detect different types of NA", {
expect_true(vec_detect_missing(NA))
expect_true(vec_detect_missing(NA_integer_))
expect_true(vec_detect_missing(NA_real_))
expect_true(vec_detect_missing(NA_complex_))
expect_true(vec_detect_missing(complex(real = NA, imaginary = 1)))
expect_true(vec_detect_missing(NaN))
expect_true(vec_detect_missing(NA_character_))
expect_true(vec_detect_missing(list(NULL)))
})
test_that("can detect different types of NA in data frames", {
# using multiple columns to prevent proxy unwrapping
expect_true(vec_detect_missing(data.frame(x = NA, y = NA)))
expect_true(vec_detect_missing(data.frame(x = NA_integer_, y = NA_integer_)))
expect_true(vec_detect_missing(data.frame(x = NA_real_, y = NaN)))
expect_true(vec_detect_missing(data.frame(x = NA_complex_, y = NA_complex_)))
expect_true(vec_detect_missing(data.frame(x = complex(real = NA, imaginary = 1), y = complex(real = 1, imaginary = NA))))
expect_true(vec_detect_missing(data.frame(x = NA_character_, y = NA_character_)))
expect_true(vec_detect_missing(new_data_frame(list(x = list(NULL), y = list(NULL)))))
})
test_that("raw vectors can never be NA", {
expect_false(vec_detect_missing(raw(1)))
expect_false(vec_detect_missing(data.frame(x = raw(1), y = raw(1))))
})
test_that("vectorised over rows of a data frame", {
df <- data.frame(x = c(1, 1, NA, NA), y = c(1, NA, 1, NA))
expect_equal(vec_detect_missing(df), c(FALSE, FALSE, FALSE, TRUE))
})
test_that("works recursively with data frame columns", {
df <- data.frame(x = c(1, 1, NA, NA))
df$df <- data.frame(y = c(NA, 1, 1, NA), z = c(1, NA, 1, NA))
expect_equal(vec_detect_missing(df), c(FALSE, FALSE, FALSE, TRUE))
})
test_that("0 row, N col data frame always returns `logical()` (#1585)", {
expect_identical(vec_detect_missing(data_frame()), logical())
expect_identical(vec_detect_missing(data_frame(x = integer(), y = double())), logical())
})
test_that(">0 row, 0 col data frame always returns `TRUE` for each row (#1585)", {
# `vec_detect_missing()` returns `TRUE` for each row because it (in theory) does
# `all()` on each row, and since there are 0 columns we get
# `all(logical()) == TRUE` for each row.
expect_identical(
vec_detect_missing(data_frame(.size = 2L)),
c(TRUE, TRUE)
)
})
test_that("works with `NULL` input (#1494)", {
expect_identical(vec_detect_missing(NULL), logical())
})
# ------------------------------------------------------------------------------
# vec_any_missing()
test_that("can check for any missing with all base vector types", {
expect_false(vec_any_missing(TRUE))
expect_false(vec_any_missing(1L))
expect_false(vec_any_missing(1))
expect_false(vec_any_missing(complex(real = 1, imaginary = 1)))
expect_false(vec_any_missing("1"))
expect_false(vec_any_missing(list(1)))
expect_true(vec_any_missing(c(TRUE, NA)))
expect_true(vec_any_missing(c(1L, NA_integer_)))
expect_true(vec_any_missing(c(1, NA_real_)))
expect_true(vec_any_missing(complex(real = c(1, NA), imaginary = c(1, NA))))
expect_true(vec_any_missing(c("1", NA_character_)))
expect_true(vec_any_missing(list(1, NULL)))
})
test_that("raw vectors can never be missing", {
expect_false(vec_any_missing(raw(1)))
expect_false(vec_any_missing(data.frame(x = raw(1), y = raw(1))))
})
test_that("works with empty vectors", {
# Like `any(logical())`
expect_false(vec_any_missing(integer()))
})
test_that("correctly detects complex missingness", {
expect_false(vec_any_missing(complex(real = 1, imaginary = 1)))
expect_true(vec_any_missing(complex(real = 1, imaginary = NA)))
expect_true(vec_any_missing(complex(real = NA, imaginary = 1)))
expect_true(vec_any_missing(complex(real = NA, imaginary = NA)))
})
test_that("treats NaN as missing", {
expect_true(vec_any_missing(NaN))
})
test_that("works with `NULL` input", {
expect_false(vec_any_missing(NULL))
})
test_that("entire row of a data frame must be missing", {
df <- data.frame(x = c(1, 1, NA, NA), y = c(1, NA, 1, NA))
expect_true(vec_any_missing(df))
expect_false(vec_any_missing(df[-4,]))
})
test_that("works recursively with data frame columns", {
df <- data.frame(x = c(1, 1, NA, NA))
df$df <- data.frame(y = c(NA, 1, 1, NA), z = c(1, NA, 1, NA))
expect_true(vec_any_missing(df))
expect_false(vec_any_missing(df[-4,]))
})
test_that("0 row, N col data frame always returns `FALSE` (#1585)", {
df <- data_frame()
expect_false(vec_any_missing(df))
expect_false(vec_any_missing(data_frame(x = integer(), y = double())))
# This is consistent with `vec_detect_missing()` returning `logical()` for 0 row
# data frames. Then `any(logical()) == FALSE` to get `vec_any_missing()`.
expect_identical(
vec_any_missing(df),
any(vec_detect_missing(df))
)
})
test_that(">0 row, 0 col data frame always returns `TRUE` (#1585)", {
df <- data_frame(.size = 2L)
expect_true(vec_any_missing(df))
# This is consistent with `vec_detect_missing()` returning `TRUE` for each row
# because it (in theory) does `all()` on each row, and since there are 0
# columns we get `all(logical()) == TRUE` for each row.
# Then `any(c(TRUE, TRUE)) == TRUE` to get `vec_any_missing()`.
expect_identical(
vec_any_missing(df),
any(vec_detect_missing(df))
)
})
vctrs/tests/testthat/test-bind.R 0000644 0001762 0000144 00000107246 14375224663 016457 0 ustar ligges users local_name_repair_quiet()
# rows --------------------------------------------------------------------
test_that("empty inputs return an empty data frame", {
expect_equal(vec_rbind(), data_frame())
expect_equal(vec_rbind(NULL, NULL), data_frame())
})
test_that("vec_rbind(): NULL is idempotent", {
df <- data_frame(x = 1)
expect_equal(vec_rbind(df, NULL), df)
})
test_that("vec_rbind() output is tibble if any input is tibble", {
df <- data_frame(x = 1)
dt <- tibble::tibble(x = 1)
expect_s3_class(vec_rbind(dt), "tbl_df")
expect_s3_class(vec_rbind(dt, df), "tbl_df")
expect_s3_class(vec_rbind(df, dt), "tbl_df")
})
test_that("type of column is common type of individual columns", {
x_int <- data_frame(x = 1L)
x_dbl <- data_frame(x = 2.5)
expect_equal(vec_rbind(x_int, x_int), data_frame(x = c(1L, 1L)))
expect_equal(vec_rbind(x_int, x_dbl), data_frame(x = c(1, 2.5)))
})
test_that("incompatible columns throws common type error", {
x_int <- data_frame(x = 1L)
x_chr <- data_frame(x = "a")
expect_snapshot({
(expect_error(
vec_rbind(x_int, x_chr),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_rbind(x_int, x_chr, .error_call = call("foo")),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_rbind(x_int, x_chr, .ptype = x_chr, .error_call = call("foo")),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("result contains union of columns", {
expect_named(
vec_rbind(
data_frame(x = 1),
data_frame(y = 1)
),
c("x" , "y")
)
expect_named(
vec_rbind(
data_frame(y = 1, x = 1),
data_frame(y = 1, z = 2)
),
c("y", "x", "z")
)
})
test_that("all inputs coerced to data frames", {
expect_equal(
vec_rbind(data_frame(x = 1L), c(x = 1.5)),
data_frame(x = c(1, 1.5))
)
})
test_that("names are supplied if needed", {
local_name_repair_verbose()
expect_snapshot(out <- vec_rbind(data_frame(...1 = 1), 1))
expect_equal(out, data_frame(...1 = c(1, 1)))
})
test_that("matrix becomes data frame and has names properly repaired", {
x <- matrix(1:4, nrow = 2)
expect_equal(vec_rbind(x), data.frame(...1 = 1:2, ...2 = 3:4))
})
test_that("can bind data.frame columns", {
df <- data.frame(x = NA, y = 1:2)
df$x <- data.frame(a = 1:2)
expected <- data.frame(x = NA, y = c(1:2, 1:2))
expected$x <- data.frame(a = c(1:2, 1:2))
expect_equal(vec_rbind(df, df), expected)
})
test_that("can rbind unspecified vectors", {
expect_identical(vec_rbind(NA), data_frame(...1 = NA))
expect_identical(vec_rbind(NA, NA), data_frame(...1 = lgl(NA, NA)))
df <- data.frame(x = 1)
expect_identical(vec_rbind(NA, df), data.frame(x = c(NA, 1)))
expect_identical(vec_rbind(df, NA), data.frame(x = c(1, NA)))
expect_identical(vec_rbind(NA, df, NA), data.frame(x = c(NA, 1, NA)))
expect_identical(vec_rbind(c(x = NA), data.frame(x = 1)), data.frame(x = c(NA, 1)))
expect_identical(vec_rbind(c(y = NA), df), data.frame(y = c(NA, NA), x = c(NA, 1)))
out <- suppressMessages(vec_rbind(c(x = NA, x = NA), df))
exp <- data.frame(x...1 = c(NA, NA), x...2 = c(NA, NA), x = c(NA, 1))
expect_identical(out, exp)
})
test_that("as_df_row() tidies the names of unspecified vectors", {
expect_identical(as_df_row(c(NA, NA)), c(NA, NA))
expect_identical(as_df_row(unspecified(2)), unspecified(2))
expect_identical(as_df_row(c(a = NA, a = NA), quiet = TRUE), data.frame(a...1 = NA, a...2 = NA))
expect_identical(as_df_row(c(a = TRUE, a = TRUE), quiet = TRUE), data.frame(a...1 = TRUE, a...2 = TRUE))
})
test_that("can rbind spliced lists", {
data <- list(c(a = 1, b = 2), c(a = TRUE, b = FALSE))
expect_identical(vec_rbind(!!!data), data_frame(a = c(1, 1), b = c(2, 0)))
})
test_that("can rbind list columns", {
out <- vec_rbind(data_frame(x = list(1, 2)), data_frame(x = list(3)))
expect_identical(out, data_frame(x = list(1, 2, 3)))
})
test_that("can rbind lists", {
out <- vec_rbind(list(x = 1:2))
expect_identical(out, data_frame(x = list(c(1L, 2L))))
out <- vec_rbind(list(x = 1:2, y = 3L))
expect_identical(out, data_frame(x = list(c(1L, 2L)), y = list(3L)))
out <- vec_rbind(list(x = 1, y = 2), list(y = "string"))
expect_identical(out, data_frame(x = list(1, NULL), y = list(2, "string")))
})
test_that("can rbind factors", {
fctr <- factor(c("a", "b"))
expect_equal(vec_rbind(fctr), data_frame(...1 = fctr[1], ...2 = fctr[2]))
fctr_named <- set_names(fctr)
expect_equal(vec_rbind(fctr_named), data_frame(a = fctr[1], b = fctr[2]))
})
test_that("can rbind dates", {
date <- new_date(c(0, 1))
expect_equal(vec_rbind(date), data_frame(...1 = date[1], ...2 = date[2]))
date_named <- set_names(date, c("a", "b"))
expect_equal(vec_rbind(date_named), data_frame(a = date[1], b = date[2]))
})
test_that("can rbind POSIXlt objects into POSIXct objects", {
datetime <- as.POSIXlt(new_datetime(0))
expect_s3_class(vec_rbind(datetime, datetime)[[1]], "POSIXct")
datetime_named <- set_names(datetime, "col")
expect_named(vec_rbind(datetime_named, datetime_named), "col")
})
test_that("can rbind table objects (#913)", {
x <- new_table(1:4, c(2L, 2L))
y <- x
colnames <- c("c1", "c2")
rownames <- c("r1", "r2", "r3", "r4")
dimnames(x) <- list(rownames[1:2], colnames)
dimnames(y) <- list(rownames[3:4], colnames)
expect <- data.frame(c1 = c(1:2, 1:2), c2 = c(3:4, 3:4), row.names = rownames)
expect_identical(vec_rbind(x, y), expect)
})
test_that("can rbind missing vectors", {
expect_identical(vec_rbind(c(x = na_int)), data_frame(x = na_int))
expect_identical(vec_rbind(c(x = na_int), c(x = na_int)), data_frame(x = int(na_int, na_int)))
})
test_that("vec_rbind() respects size invariants (#286)", {
expect_identical(vec_rbind(), new_data_frame(n = 0L))
expect_identical(vec_rbind(int(), int()), new_data_frame(n = 2L))
expect_identical(vec_rbind(c(x = int()), c(x = TRUE)), new_data_frame(list(x = lgl(NA, TRUE))))
expect_identical(vec_rbind(int(), new_data_frame(n = 2L), int()), new_data_frame(n = 4L))
})
test_that("can repair names in `vec_rbind()` (#229)", {
expect_snapshot({
(expect_error(vec_rbind(.name_repair = "none"), "can't be `\"none\"`"))
(expect_error(vec_rbind(.name_repair = "minimal"), "can't be `\"minimal\"`"))
(expect_error(vec_rbind(list(a = 1, a = 2), .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique"))
})
expect_named(vec_rbind(list(a = 1, a = 2), .name_repair = "unique"), c("a...1", "a...2"))
expect_named(vec_rbind(list(`_` = 1)), "_")
expect_named(vec_rbind(list(`_` = 1), .name_repair = "universal"), c("._"))
expect_named(vec_rbind(list(a = 1, a = 2), .name_repair = ~ toupper(.)), c("A", "A"))
})
test_that("can repair names quietly", {
local_name_repair_verbose()
expect_snapshot({
res_unique <- vec_rbind(c(x = 1, x = 2), c(x = 3, x = 4), .name_repair = "unique_quiet")
res_universal <- vec_rbind(c("if" = 1, "in" = 2), c("if" = 3, "for" = 4), .name_repair = "universal_quiet")
})
expect_named(res_unique, c("x...1", "x...2"))
expect_named(res_universal, c(".if", ".in", ".for"))
})
test_that("can construct an id column", {
df <- data.frame(x = 1)
expect_named(vec_rbind(df, df, .names_to = "id"), c("id", "x"))
expect_equal(vec_rbind(df, df, .names_to = "id")$id, c(1L, 2L))
expect_equal(vec_rbind(a = df, b = df, .names_to = "id")$id, c("a", "b"))
expect_equal(vec_rbind(a = df, df, .names_to = "id")$id, c("a", ""))
})
test_that("vec_rbind() fails with arrays of dimensionality > 3", {
expect_snapshot({
(expect_error(vec_rbind(array(NA, c(1, 1, 1)))))
(expect_error(vec_rbind(array(NA, c(1, 1, 1)), .error_call = call("foo"))))
})
})
test_that("row names are preserved by vec_rbind()", {
df1 <- mtcars[1:3, ]
df2 <- mtcars[4:5, ]
expect_identical(vec_rbind(df1, df2), mtcars[1:5, ])
row.names(df2) <- NULL
out <- mtcars[1:5, ]
row.names(out) <- c(row.names(df1), "...4", "...5")
expect_identical(vec_rbind(df1, df2), out)
})
test_that("can assign row names in vec_rbind()", {
df1 <- mtcars[1:3, ]
df2 <- mtcars[4:5, ]
expect_snapshot({
(expect_error(
vec_rbind(
foo = df1,
df2,
.names_to = NULL
),
"specification"
))
})
# Combination
out <- vec_rbind(
foo = df1,
df2,
.names_to = NULL,
.name_spec = "{outer}_{inner}"
)
exp <- mtcars[1:5, ]
row.names(exp) <- c(paste0("foo_", row.names(df1)), row.names(df2))
expect_identical(out, exp)
out <- vec_rbind(foo = df1, df2, .names_to = "id")
exp <- mtcars[1:5, ]
exp <- vec_cbind(id = c(rep("foo", 3), rep("", 2)), exp)
expect_identical(out, exp)
# Sequence
out <- vec_rbind(
foo = unrownames(df1),
df2,
bar = unrownames(mtcars[6, ]),
.names_to = NULL,
.name_spec = "{outer}_{inner}"
)
exp <- mtcars[1:6, ]
row.names(exp) <- c(paste0("foo_", 1:3), row.names(df2), "bar")
expect_identical(out, exp)
out <- vec_rbind(
foo = unrownames(df1),
df2,
bar = unrownames(mtcars[6, ]),
.names_to = "id"
)
exp <- mtcars[1:6, ]
exp <- vec_cbind(id = c(rep("foo", 3), rep("", 2), "bar"), exp)
row.names(exp) <- c(paste0("...", 1:3), row.names(df2), "...6")
expect_identical(out, exp)
})
test_that("vec_rbind() takes the proxy and restores", {
df <- foobar(data.frame(x = 1))
# This data frame subclass has an identity proxy and the restore
# method falls back to a bare data frame if `$x` has any missing values.
# In `vec_rbind()`, the `vec_init()` call will create a bare data frame,
# but at the end it is `vec_restore()`d to the right class.
local_methods(
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) {
x
},
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) {
x
},
vec_proxy.vctrs_foobar = function(x, ...) {
x
},
vec_restore.vctrs_foobar = function(x, to, ...) {
if (any(is.na(x$x))) {
new_data_frame(x)
} else {
vec_restore_default(x, to)
}
}
)
expect_identical(
vec_rbind(df, df),
foobar(data.frame(x = c(1, 1)))
)
})
test_that("vec_rbind() proxies before initializing", {
df <- foobar(data.frame(x = 1))
# This data frame subclass doesn't allow `NA`s in columns.
# If initialization happened before proxying, it would try to
# create `NA` rows with `vec_init()`.
local_methods(
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) {
x
},
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) {
x
},
vec_proxy.vctrs_foobar = function(x, ...) {
new_data_frame(x)
},
vec_restore.vctrs_foobar = function(x, to, ...) {
if (any(is.na(x$x))) {
abort("`x` can't have NA values.")
}
vec_restore_default(x, to)
}
)
expect_identical(
vec_rbind(df, df),
foobar(data.frame(x = c(1, 1)))
)
})
test_that("vec_rbind() requires a data frame proxy for data frame ptypes", {
df <- foobar(data.frame(x = 1))
local_methods(
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) x,
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) x,
vec_proxy.vctrs_foobar = function(x, ...) 1
)
expect_error(
vec_rbind(df, df),
"Can't fill a data frame that doesn't have a data frame proxy"
)
})
test_that("monitoring: name repair while rbinding doesn't modify in place", {
df <- new_data_frame(list(x = 1, x = 1))
expect <- new_data_frame(list(x = 1, x = 1))
# Name repair occurs
expect_named(vec_rbind(df), c("x...1", "x...2"))
# No changes to `df`
expect_identical(df, expect)
})
test_that("performance: Row binding with S3 columns doesn't duplicate on every assignment (#1151)", {
skip_if_not_testing_performance()
x <- as.Date("2000-01-01")
x <- rep(x, 100)
df <- data.frame(x = x)
lst <- rep_len(list(df), 10000)
expect_time_lt(vec_rbind(!!!lst), 5)
})
test_that("performance: Row binding with df-cols doesn't duplicate on every assignment (#1122)", {
skip_if_not_testing_performance()
df_col <- new_data_frame(list(x = 1:1000))
df <- new_data_frame(list(y = df_col))
lst <- rep_len(list(df), 10000)
expect_time_lt(vec_rbind(!!!lst), 5)
})
# cols --------------------------------------------------------------------
test_that("vec_cbind() reports error context", {
expect_snapshot({
(expect_error(vec_cbind(foobar(list()))))
(expect_error(vec_cbind(foobar(list()), .error_call = call("foo"))))
(expect_error(vec_cbind(a = 1:2, b = int())))
(expect_error(vec_cbind(a = 1:2, b = int(), .error_call = call("foo"))))
})
})
test_that("empty inputs give data frame", {
expect_equal(vec_cbind(), data_frame())
expect_equal(vec_cbind(NULL), data_frame())
expect_equal(vec_cbind(data.frame(a = 1), NULL), data_frame(a = 1))
})
test_that("number of rows is preserved with zero column data frames (#1281)", {
df <- new_data_frame(n = 2L)
expect_size(vec_cbind(df, df), 2L)
})
test_that("vec_cbind(): NULL is idempotent", {
df <- data_frame(x = 1)
expect_equal(vec_cbind(df, NULL), df)
})
test_that("outer names are respected", {
expect_named(vec_cbind(x = 1, y = 4), c("x", "y"))
expect_named(vec_cbind(a = data.frame(x = 1)), "a")
})
test_that("inner names are respected", {
expect_named(vec_cbind(data_frame(x = 1), data_frame(y = 1)), c("x", "y"))
})
test_that("nameless vectors get tidy defaults", {
expect_named(vec_cbind(1:2, 1), c("...1", "...2"))
})
test_that("matrix becomes data frame", {
x <- matrix(1:4, nrow = 2)
expect_equal(vec_cbind(x), data.frame(...1 = 1:2, ...2 = 3:4))
# Packed if named
expect_equal(vec_cbind(x = x), data_frame(x = x))
})
test_that("duplicate names are de-deduplicated", {
local_name_repair_verbose()
expect_snapshot({
(expect_named(vec_cbind(x = 1, x = 1), c("x...1", "x...2")))
(expect_named(vec_cbind(data.frame(x = 1), data.frame(x = 1)), c("x...1", "x...2")))
})
})
test_that("rows recycled to longest", {
df <- data.frame(x = 1:3)
expect_dim(vec_cbind(df), c(3, 1))
expect_dim(vec_cbind(df, NULL), c(3, 1))
expect_dim(vec_cbind(df, y = 1), c(3, 2))
expect_dim(vec_cbind(data.frame(x = 1), y = 1:3), c(3, 2))
expect_dim(
vec_cbind(
data.frame(a = 1, b = 2),
y = 1:3
),
c(3, 3)
)
})
test_that("vec_cbind() output is tibble if any input is tibble", {
df <- data.frame(x = 1)
dt <- tibble::tibble(y = 2)
expect_s3_class(vec_cbind(dt), "tbl_df")
expect_s3_class(vec_cbind(df, dt), "tbl_df")
expect_s3_class(vec_cbind(dt, df), "tbl_df")
})
test_that("can override default .nrow", {
expect_dim(vec_cbind(x = 1, .size = 3), c(3, 1))
})
test_that("can repair names in `vec_cbind()` (#227)", {
expect_snapshot({
(expect_error(vec_cbind(a = 1, a = 2, .name_repair = "none"), "can't be `\"none\"`"))
(expect_error(vec_cbind(a = 1, a = 2, .name_repair = "check_unique"), class = "vctrs_error_names_must_be_unique"))
})
expect_named(vec_cbind(a = 1, a = 2, .name_repair = "unique"), c("a...1", "a...2"))
expect_named(vec_cbind(`_` = 1, .name_repair = "universal"), "._")
expect_named(vec_cbind(a = 1, a = 2, .name_repair = "minimal"), c("a", "a"))
expect_named(vec_cbind(a = 1, a = 2, .name_repair = toupper), c("A", "A"))
})
test_that("can repair names quietly", {
local_name_repair_verbose()
expect_snapshot({
res_unique <- vec_cbind(x = 1, x = 2, .name_repair = "unique_quiet")
res_universal <- vec_cbind("if" = 1, "in" = 2, .name_repair = "universal_quiet")
})
expect_named(res_unique, c("x...1", "x...2"))
expect_named(res_universal, c(".if", ".in"))
})
test_that("can supply `.names_to` to `vec_rbind()` (#229)", {
expect_snapshot({
(expect_error(vec_rbind(.names_to = letters)))
(expect_error(vec_rbind(.names_to = 10)))
(expect_error(vec_rbind(.names_to = letters, .error_call = call("foo"))))
})
x <- data_frame(foo = 1:2, bar = 3:4)
y <- data_frame(foo = 5L, bar = 6L)
expect_identical(
vec_rbind(a = x, b = y, .names_to = "quux"),
data_frame(quux = c("a", "a", "b"), foo = c(1L, 2L, 5L), bar = c(3L, 4L, 6L))
)
expect_identical(
vec_rbind(a = x, b = y, .names_to = "foo"),
data_frame(foo = c("a", "a", "b"), bar = c(3L, 4L, 6L))
)
# No names
expect_identical(
vec_rbind(x, y, .names_to = "quux"),
data_frame(quux = c(1L, 1L, 2L), foo = c(1L, 2L, 5L), bar = c(3L, 4L, 6L))
)
expect_identical(
vec_rbind(x, y, .names_to = "foo"),
data_frame(foo = c(1L, 1L, 2L), bar = c(3L, 4L, 6L))
)
# Partial names
expect_identical(vec_rbind(x, b = y, .names_to = "quux")$quux, c("", "", "b"))
})
test_that("can supply existing `.names_to`", {
x <- data.frame(a = 1, id = TRUE)
expect_identical(
vec_rbind(foo = x, bar = c(a = 2), .names_to = "id"),
data_frame(a = c(1, 2), id = c("foo", "bar"))
)
y <- data.frame(id = TRUE, a = 1)
expect_identical(
vec_rbind(foo = y, bar = c(a = 2), .names_to = "id"),
data_frame(id = c("foo", "bar"), a = c(1, 2))
)
})
test_that("vec_cbind() returns visibly (#452)", {
# Shouldn't be needed once `check_unique` is implemented in C
expect_visible(vctrs::vec_cbind(x = 1, .name_repair = "check_unique"))
})
test_that("vec_cbind() packs named data frames (#446)", {
expect_identical(vec_cbind(data_frame(y = 1:3)), data_frame(y = 1:3))
expect_identical(vec_cbind(x = data_frame(y = 1:3)), data_frame(x = data_frame(y = 1:3)))
})
test_that("vec_cbind() packs 1d arrays", {
a <- array(1:2)
expect_identical(vec_cbind(a), data_frame(...1 = 1:2))
expect_identical(vec_cbind(x = a), data_frame(x = a))
})
test_that("vec_cbind() packs named matrices", {
m <- matrix(1:4, 2)
expect_identical(vec_cbind(m), data_frame(...1 = 1:2, ...2 = 3:4))
expect_identical(vec_cbind(x = m), data_frame(x = m))
})
test_that("vec_cbind() never packs named vectors", {
expect_identical(vec_cbind(1:2), data_frame(...1 = 1:2))
expect_identical(vec_cbind(x = 1:2), data_frame(x = 1:2))
})
test_that("names are repaired late if unpacked", {
df <- data_frame(b = 2, b = 3, .name_repair = "minimal")
out1 <- vec_cbind(a = 1, df)
out2 <- vec_cbind(a = 1, as.matrix(df))
out3 <- vec_cbind(a = 1, matrix(1:2, nrow = 1))
expect_named(out1, c("a", "b...2", "b...3"))
expect_named(out2, c("a", "b...2", "b...3"))
expect_named(out3, c("a", "...2", "...3"))
})
test_that("names are not repaired if packed", {
df <- data_frame(b = 2, b = 3, .name_repair = "minimal")
out1 <- vec_cbind(a = 1, packed = df)
out2 <- vec_cbind(a = 1, packed = as.matrix(df))
out3 <- vec_cbind(a = 1, packed = matrix(1:2, nrow = 1))
expect_named(out1, c("a", "packed"))
expect_named(out2, c("a", "packed"))
expect_named(out3, c("a", "packed"))
expect_named(out1$packed, c("b", "b"))
expect_identical(colnames(out2$packed), c("b", "b"))
expect_identical(colnames(out3$packed), NULL)
})
test_that("vec_cbind() fails with arrays of dimensionality > 3", {
a <- array(NA, c(1, 1, 1))
expect_snapshot({
(expect_error(vec_cbind(a)))
(expect_error(vec_cbind(a, .error_call = call("foo"))))
(expect_error(vec_cbind(x = a)))
})
})
test_that("monitoring: name repair while cbinding doesn't modify in place", {
df <- new_data_frame(list(x = 1, x = 1))
expect <- new_data_frame(list(x = 1, x = 1))
# Name repair occurs
expect_named(vec_cbind(df), c("x...1", "x...2"))
# No changes to `df`
expect_identical(df, expect)
})
test_that("vec_rbind() consistently handles unnamed outputs", {
# Name repair of columns is a little weird but unclear we can do better
expect_identical(
vec_rbind(1, 2, .names_to = NULL),
data.frame(...1 = c(1, 2))
)
expect_identical(
vec_rbind(1, 2, ...10 = 3, .names_to = NULL),
data.frame(...1 = c(1, 2, 3), row.names = c("...1", "...2", "...3"))
)
expect_identical(
vec_rbind(a = 1, b = 2, .names_to = NULL),
data.frame(...1 = c(1, 2), row.names = c("a", "b"))
)
expect_identical(
vec_rbind(c(a = 1), c(b = 2), .names_to = NULL),
data.frame(a = c(1, NA), b = c(NA, 2))
)
})
test_that("vec_rbind() ignores named inputs by default (#966)", {
expect_identical(
vec_rbind(foo = c(a = 1)),
data.frame(a = 1)
)
expect_identical(
vec_rbind(foo = c(a = 1), .names_to = NULL),
data.frame(a = 1, row.names = "foo")
)
})
test_that("vec_cbind() consistently handles unnamed outputs", {
expect_identical(
vec_cbind(1, 2),
data.frame(...1 = 1, ...2 = 2)
)
expect_identical(
vec_cbind(1, 2, ...10 = 3),
data.frame(...1 = 1, ...2 = 2, ...3 = 3)
)
expect_identical(
vec_cbind(a = 1, b = 2),
data.frame(a = 1, b = 2)
)
expect_identical(
vec_cbind(c(a = 1), c(b = 2)),
new_data_frame(list(...1 = c(a = 1), ...2 = c(b = 2)))
)
})
test_that("vec_rbind() name repair messages are useful", {
local_name_repair_verbose()
expect_snapshot({
vec_rbind(1, 2)
vec_rbind(1, 2, .names_to = NULL)
vec_rbind(1, 2, ...10 = 3)
vec_rbind(1, 2, ...10 = 3, .names_to = NULL)
vec_rbind(a = 1, b = 2)
vec_rbind(a = 1, b = 2, .names_to = NULL)
vec_rbind(c(a = 1), c(b = 2))
vec_rbind(c(a = 1), c(b = 2), .names_to = NULL)
})
})
test_that("vec_rbind() is silent when assigning duplicate row names of df-cols", {
df <- new_data_frame(list(x = mtcars[1:3, 1, drop = FALSE]))
expect_snapshot(vec_rbind(df, df))
expect_snapshot(vec_rbind(mtcars[1:4, ], mtcars[1:3, ]))
})
test_that("vec_cbind() name repair messages are useful", {
local_name_repair_verbose()
expect_snapshot({
vec_cbind(1, 2)
vec_cbind(1, 2, ...10 = 3)
vec_cbind(a = 1, b = 2)
vec_cbind(c(a = 1), c(b = 2))
})
})
test_that("cbind() deals with row names", {
expect_identical(
vec_cbind(mtcars[1:3], foo = 1),
cbind(mtcars[1:3], foo = 1)
)
expect_identical(
vec_cbind(mtcars[1:3], mtcars[4]),
cbind(mtcars[1:3], mtcars[4])
)
out <- vec_cbind(
mtcars[1, 1, drop = FALSE],
unrownames(mtcars[1:3, 2, drop = FALSE])
)
exp <- mtcars[1:3, c(1, 2)]
exp[[1]] <- exp[[1, 1]]
row.names(exp) <- paste0(c("Mazda RX4..."), 1:3)
expect_identical(out, exp)
})
test_that("prefer row names of first named input (#1058)", {
df0 <- unrownames(mtcars[1:5, 1:3])
df1 <- mtcars[1:5, 4:6]
df2 <- mtcars[5:1, 7:9]
expect_identical(
row.names(vec_cbind(df0, df1, df2)),
row.names(df1)
)
expect_identical(
row.names(vec_cbind(df0, df2, df1)),
row.names(df2)
)
})
test_that("can rbind data frames with matrix columns (#625)", {
df <- tibble(x = 1:2, y = matrix(1:4, nrow = 2))
expect_identical(vec_rbind(df, df), vec_slice(df, c(1, 2, 1, 2)))
})
test_that("rbind repairs names of data frames (#704)", {
df <- data_frame(x = 1, x = 2, .name_repair = "minimal")
df_repaired <- data_frame(x...1 = 1, x...2 = 2)
expect_identical(vec_rbind(df), df_repaired)
expect_identical(vec_rbind(df, df), vec_rbind(df_repaired, df_repaired))
expect_snapshot({
(expect_error(
vec_rbind(df, df, .name_repair = "check_unique"),
class = "vctrs_error_names_must_be_unique"
))
(expect_error(
vec_rbind(df, df, .name_repair = "check_unique", .error_call = call("foo")),
class = "vctrs_error_names_must_be_unique"
))
})
})
test_that("vec_rbind() works with simple homogeneous foreign S3 classes", {
expect_identical(
vec_rbind(set_names(foobar(1), "x"), set_names(foobar(2), "x")),
data_frame(x = foobar(c(1, 2)))
)
})
test_that("vec_rbind() works with simple homogeneous foreign S4 classes", {
skip_if_cant_set_names_on_s4()
joe1 <- .Counts(1L, name = "Joe")
joe2 <- .Counts(2L, name = "Joe")
expect_identical(
vec_rbind(set_names(joe1, "x"), set_names(joe2, "x")),
data_frame(x = .Counts(1:2, name = "Joe"))
)
})
test_that("vec_rbind() fails with complex foreign S3 classes", {
expect_snapshot({
x <- structure(foobar(1), attr_foo = "foo")
y <- structure(foobar(2), attr_bar = "bar")
(expect_error(
vec_rbind(set_names(x, "x"), set_names(y, "x")),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("vec_rbind() fails with complex foreign S4 classes", {
skip_if_cant_set_names_on_s4()
expect_snapshot({
joe <- .Counts(1L, name = "Joe")
jane <- .Counts(2L, name = "Jane")
(expect_error(vec_rbind(set_names(joe, "x"), set_names(jane, "y")), class = "vctrs_error_incompatible_type"))
})
})
test_that("vec_rbind() falls back to c() if S3 method is available", {
x <- foobar(1, foo = 1)
y <- foobar(2, bar = 2)
x_df <- data_frame(x = x)
y_df <- data_frame(x = y)
expect_error(vec_rbind(x_df, y_df), class = "vctrs_error_incompatible_type")
expect_error(vec_c(x_df, y_df), class = "vctrs_error_incompatible_type")
expect_error(list_unchop(list(x_df, y_df), indices = list(1, 2)), class = "vctrs_error_incompatible_type")
with_c_method <- function(expr) {
with_methods(
c.vctrs_foobar = function(...) quux(NextMethod()),
expr
)
}
out <- with_c_method(vec_rbind(x_df, y_df))
exp <- data_frame(x = quux(c(1, 2)))
expect_identical(out, exp)
expect_identical(with_c_method(vec_c(x_df, y_df)), exp)
expect_identical(
with_c_method(list_unchop(list(x_df, y_df), indices = list(1, 2))),
exp
)
# Fallback is used with data frame subclasses, with or without
# ptype2 method
foo_df <- foobaz(x_df)
bar_df <- foobaz(y_df)
out <- with_c_method(vec_rbind(foo_df, bar_df))
exp <- foobaz(data_frame(x = quux(c(1, 2))))
expect_identical(out, exp)
expect_identical(with_c_method(vec_c(foo_df, bar_df)), exp)
expect_identical(
with_c_method(list_unchop(list(foo_df, bar_df), indices = list(1, 2))),
exp
)
with_hybrid_methods <- function(expr, cast = TRUE) {
methods <- list(
c.vctrs_foobar = function(...) quux(NextMethod()),
vec_ptype2.vctrs_foobaz.vctrs_foobaz = function(...) foobaz(df_ptype2(...)),
vec_cast.vctrs_foobaz.vctrs_foobaz = if (cast) function(...) foobaz(df_cast(...))
)
with_methods(expr, !!!compact(methods))
}
expect_equal(
with_hybrid_methods(
cast = FALSE,
vec_rbind(foo_df, bar_df)
),
foobaz(data_frame(x = quux(c(1, 2))))
)
# Falls back to data frame because there is no ptype2/cast methods
out <- with_hybrid_methods(vec_rbind(foo_df, bar_df))
exp <- foobaz(data_frame(x = quux(c(1, 2))))
expect_identical(out, exp)
expect_identical(with_hybrid_methods(vec_c(foo_df, bar_df)), exp)
expect_identical(
with_hybrid_methods(list_unchop(list(foo_df, bar_df), indices = list(1, 2))),
exp
)
wrapper_x_df <- data_frame(x = x_df)
wrapper_y_df <- data_frame(x = y_df)
out <- with_c_method(vec_rbind(wrapper_x_df, wrapper_y_df))
exp <- data_frame(x = data_frame(x = quux(c(1, 2))))
expect_identical(out, exp)
expect_identical(with_c_method(vec_c(wrapper_x_df, wrapper_y_df)), exp)
expect_identical(
with_c_method(list_unchop(list(wrapper_x_df, wrapper_y_df), indices = list(1, 2))),
exp
)
})
test_that("c() fallback works with unspecified columns", {
local_methods(
c.vctrs_foobar = function(...) foobar(NextMethod()),
`[.vctrs_foobar` = function(x, i, ...) foobar(NextMethod(), dispatched = TRUE)
)
out <- vec_rbind(
data_frame(x = foobar(1)),
data_frame(y = foobar(2))
)
expect_identical(out, data_frame(
x = foobar(c(1, NA), dispatched = TRUE),
y = foobar(c(NA, 2), dispatched = TRUE)
))
})
test_that("c() fallback works with vctrs-powered data frame subclass", {
local_methods(
c.vctrs_quux = function(...) quux(vec_paste0(NextMethod(), "-c")),
`[.vctrs_quux` = function(x, i, ...) quux(vec_paste0(NextMethod(), "-["))
)
local_foobar_df_methods()
### Joint case
df1 <- foobar(data_frame(x = quux(1:3)))
df2 <- data_frame(x = quux(4:5))
out <- vctrs::vec_rbind(df1, df2)
exp <- foobar(data_frame(x = quux(paste0(1:5, "-c"))))
expect_identical(out, exp)
out <- vctrs::vec_rbind(df2, df1)
exp <- foobar(data_frame(x = quux(paste0(c(4:5, 1:3), "-c"))))
expect_identical(out, exp)
### Disjoint case
df1 <- foobar(data_frame(x = quux(1:3)))
df2 <- data.frame(y = 4:5)
out <- vctrs::vec_rbind(df1, df2)
exp <- foobar(data_frame(
x = quux(c(paste0(1:3, "-c-["), paste0(c(NA, NA), "-["))),
y = c(rep(NA, 3), 4:5)
))
expect_identical(out, exp)
out <- vctrs::vec_rbind(df2, df1)
exp <- foobar(data_frame(
y = c(4:5, rep(NA, 3)),
x = quux(c(paste0(c(NA, NA), "-["), paste0(1:3, "-c-[")))
))
expect_identical(out, exp)
})
test_that("vec_rbind() falls back to c() if S3 method is available for S4 class", {
joe <- data_frame(x = .Counts(c(1L, 2L), name = "Joe"))
jane <- data_frame(x = .Counts(3L, name = "Jane"))
expect_error(vec_rbind(joe, jane), class = "vctrs_error_incompatible_type")
out <- with_methods(
c.vctrs_Counts = function(...) .Counts(NextMethod(), name = "dispatched"),
vec_rbind(joe, jane)
)
expect_identical(out$x, .Counts(1:3, name = "dispatched"))
})
test_that("rbind supports names and inner names (#689)", {
out <- vec_rbind(
data_frame(x = list(a = 1, b = 2)),
data_frame(x = list(3)),
data_frame(x = list(d = 4))
)
expect_identical(out$x, list(a = 1, b = 2, 3, d = 4))
vec_x <- set_names(1:3, letters[1:3])
vec_y <- c(FOO = 4L)
oo_x <- set_names(as.POSIXlt(c("2020-01-01", "2020-01-02", "2020-01-03")), letters[1:3])
oo_y <- c(FOO = as.POSIXlt(c("2020-01-04")))
df_x <- new_data_frame(list(x = 1:3), row.names = letters[1:3])
df_y <- new_data_frame(list(x = 4L), row.names = "d")
mat_x <- matrix(1:3, 3, dimnames = list(letters[1:3]))
mat_y <- matrix(4L, 1, dimnames = list("d"))
nested_x <- new_data_frame(
list(df = df_x, mat = mat_x, vec = vec_x, oo = oo_x),
row.names = c("foo", "bar", "baz")
)
nested_y <- new_data_frame(
list(df = df_y, mat = mat_y, vec = vec_y, oo = oo_y),
row.names = c("quux")
)
nested_out <- vec_rbind(nested_x, nested_y)
expect_identical(row.names(nested_out), c("foo", "bar", "baz", "quux"))
expect_identical(row.names(nested_out$df), c("a", "b", "c", "d"))
expect_identical(row.names(nested_out$mat), c("a", "b", "c", "d"))
expect_identical(names(nested_out$vec), c("a", "b", "c", "FOO"))
expect_identical(names(nested_out$oo), c("a", "b", "c", "FOO"))
})
test_that("vec_rbind() doesn't fall back to c() with proxied classes (#1119)", {
foobar_rcrd <- function(x, y) new_rcrd(list(x = x, y = y), class = "vctrs_foobar")
x <- foobar_rcrd(x = 1:2, y = 3:4)
out <- vec_rbind(x, x)
exp <- data_frame(
...1 = foobar_rcrd(x = c(1L, 1L), y = c(3L, 3L)),
...2 = foobar_rcrd(x = c(2L, 2L), y = c(4L, 4L))
)
expect_identical(out, exp)
out <- vec_rbind(data_frame(x = x), data_frame(x = x))
exp <- data_frame(
x = foobar_rcrd(x = c(1L, 2L, 1L, 2L), y = c(3L, 4L, 3L, 4L))
)
expect_identical(out, exp)
})
test_that("vec_rbind() fallback works with tibbles", {
x <- foobar("foo")
df <- data_frame(x = x)
tib <- tibble(x = x)
local_methods(c.vctrs_foobar = function(...) quux(NextMethod()))
exp <- tibble(x = quux(c("foo", "foo")))
expect_identical(vec_rbind(tib, tib), exp)
expect_identical(vec_rbind(df, tib), exp)
expect_identical(vec_rbind(tib, df), exp)
})
test_that("vec_rbind() zaps names when name-spec is zap() and names-to is NULL", {
expect_identical(
vec_rbind(foo = c(x = 1), .names_to = NULL, .name_spec = zap()),
data.frame(x = 1)
)
})
test_that("can't zap names when `.names_to` is supplied", {
expect_identical(
vec_rbind(foo = c(x = 1), .names_to = zap(), .name_spec = zap()),
data.frame(x = 1)
)
expect_snapshot({
(expect_error(
vec_rbind(foo = c(x = 1), .names_to = "id", .name_spec = zap())
))
(expect_error(
vec_rbind(foo = c(x = 1), .names_to = "id", .name_spec = zap(), .error_call = call("foo"))
))
})
})
test_that("can zap outer names from a name-spec (#1215)", {
zap_outer_spec <- function(outer, inner) if (is_character(inner)) inner
df <- data.frame(x = 1:2)
df_named <- data.frame(x = 3L, row.names = "foo")
expect_null(
vec_names(vec_rbind(a = df, .names_to = NULL, .name_spec = zap_outer_spec))
)
expect_identical(
vec_names(vec_rbind(a = df, df_named, .name_spec = zap_outer_spec)),
c("...1", "...2", "foo")
)
})
test_that("column names are treated consistently in vec_rbind()", {
exp <- data.frame(a = c(1L, 1L), b = c(2L, 2L))
x <- c(a = 1L, b = 2L)
expect_identical(vec_rbind(x, x), exp)
x <- array(1:2, dimnames = list(c("a", "b")))
expect_identical(vec_rbind(x, x), exp)
x <- matrix(1:2, nrow = 1, dimnames = list(NULL, c("a", "b")))
expect_identical(vec_rbind(x, x), exp)
x <- array(1:6, c(1, 2, 1), dimnames = list(NULL, c("a", "b"), NULL))
expect_error(vec_rbind(x, x), "Can't bind arrays")
})
test_that("can repair names of row-binded vectors (#1567)", {
local_name_repair_verbose()
expect_silent(
expect_named(
vec_rbind(
x = 1:3,
y = 4:6,
.name_repair = function(x) c("a", "a", "a")
),
c("a", "a", "a")
)
)
})
test_that("can repair names of row-binded matrices", {
local_name_repair_verbose()
expect_silent({
expect_named(
vec_rbind(
x = matrix(1:3, 1),
y = matrix(4:6, 1),
.name_repair = function(x) c("a", "a", "a")
),
c("a", "a", "a")
)
expect_named(
vec_rbind(
x = matrix(1:3, 1),
y = 4:6,
.name_repair = function(x) c("a", "a", "a")
),
c("a", "a", "a")
)
})
})
test_that("vec_rbind() only restores one time", {
restored <- list()
local_methods(
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) x,
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) x,
vec_proxy.vctrs_foobar = function(x, ...) x,
vec_restore.vctrs_foobar = function(x, to, ...) {
# Ignore proxying and restoration of ptypes
if (length(x)) {
restored <<- c(restored, list(x))
}
foobar(x)
}
)
df <- data_frame(x = foobar(1:3))
vec_rbind(df, df)
expect_equal(restored, list(
rep(na_int, 6), # From `vec_init()`
foobar(c(1:3, 1:3)) # Final restoration
))
})
test_that("vec_rbind() applies `base::c()` fallback to df-cols (#1462, #1640)", {
x <- structure(1, class = "myclass")
df <- tibble(a = tibble(x = x))
df <- vec_rbind(df, df)
expect_equal(df$a$x, structure(c(1, 1), class = "myclass"))
})
# Golden tests -------------------------------------------------------
test_that("row-binding performs expected allocations", {
vec_rbind_list <- function(x) {
vec_rbind(!!!x)
}
expect_snapshot({
ints <- rep(list(1L), 1e2)
named_ints <- rep(list(set_names(1:3, letters[1:3])), 1e2)
"Integers as rows"
suppressMessages(with_memory_prof(vec_rbind_list(ints)))
suppressMessages(with_memory_prof(vec_rbind_list(named_ints)))
"Data frame with named columns"
df <- data_frame(
x = set_names(as.list(1:2), c("a", "b")),
y = set_names(1:2, c("A", "B")),
z = data_frame(Z = set_names(1:2, c("Za", "Zb")))
)
dfs <- rep(list(df), 1e2)
with_memory_prof(vec_rbind_list(dfs))
"Data frame with rownames (non-repaired, non-recursive case)"
df <- data_frame(x = 1:2)
dfs <- rep(list(df), 1e2)
dfs <- map2(dfs, seq_along(dfs), set_rownames_recursively)
with_memory_prof(vec_rbind_list(dfs))
"Data frame with rownames (repaired, non-recursive case)"
dfs <- map(dfs, set_rownames_recursively)
with_memory_prof(vec_rbind_list(dfs))
"Data frame with rownames (non-repaired, recursive case) (#1217)"
df <- data_frame(
x = 1:2,
y = data_frame(x = 1:2)
)
dfs <- rep(list(df), 1e2)
dfs <- map2(dfs, seq_along(dfs), set_rownames_recursively)
with_memory_prof(vec_rbind_list(dfs))
"Data frame with rownames (repaired, recursive case) (#1217)"
dfs <- map(dfs, set_rownames_recursively)
with_memory_prof(vec_rbind_list(dfs))
})
})
test_that("`.names_to` is assigned after restoration (#1648)", {
df <- data_frame(x = factor("foo"))
expect_equal(
vec_rbind(name = df, .names_to = "x"),
data_frame(x = "name")
)
# This used to fail with:
#> Error in `vctrs::vec_rbind()`:
#> ! adding class "factor" to an invalid object
})
vctrs/tests/testthat/test-type-dplyr.R 0000644 0001762 0000144 00000011525 14362266120 017634 0 ustar ligges users
# `grouped_df` -------------------------------------------------------
bare_mtcars <- unrownames(mtcars)
test_that("grouped-df is proxied and restored", {
gdf <- dplyr::group_by(bare_mtcars, cyl)
expect_identical(vec_proxy(gdf), gdf)
expect_identical(vec_restore(bare_mtcars, gdf), gdf)
expect_identical(vec_ptype(gdf), gdf[0, ])
gdf <- dplyr::group_by(bare_mtcars, cyl, am, vs)
expect_identical(gdf[0, ], vec_ptype(gdf))
out <- vec_ptype(dplyr::group_by(bare_mtcars, cyl, .drop = FALSE))
expect_drop(out, FALSE)
})
test_that("can take the common type of grouped tibbles and tibbles", {
gdf <- dplyr::group_by(bare_mtcars, cyl)
expect_identical(vec_ptype2(gdf, data.frame()), vec_ptype(gdf))
expect_identical(vec_ptype2(data.frame(), gdf), vec_ptype(gdf))
expect_identical(vec_ptype2(gdf, tibble()), vec_ptype(gdf))
expect_identical(vec_ptype2(tibble(), gdf), vec_ptype(gdf))
gdf_nodrop <- dplyr::group_by(bare_mtcars, cyl, .drop = FALSE)
expect_drop(vec_ptype2(gdf, gdf_nodrop), FALSE)
expect_drop(vec_ptype2(gdf_nodrop, gdf), FALSE)
expect_drop(vec_ptype2(gdf_nodrop, bare_mtcars), FALSE)
expect_drop(vec_ptype2(bare_mtcars, gdf_nodrop), FALSE)
})
test_that("the common type of grouped tibbles includes the union of grouping variables", {
gdf1 <- dplyr::group_by(bare_mtcars, cyl)
gdf2 <- dplyr::group_by(bare_mtcars, am, vs)
expect_identical(
vec_ptype2(gdf1, gdf2),
vec_ptype(dplyr::group_by(bare_mtcars, cyl, am, vs))
)
})
test_that("can cast to and from `grouped_df`", {
gdf <- dplyr::group_by(unrownames(bare_mtcars), cyl)
input <- bare_mtcars[10]
cast_gdf <- dplyr::group_by(vec_cast(bare_mtcars[10], bare_mtcars), cyl)
expect_error(
vec_cast(input, dplyr::group_by(bare_mtcars["cyl"], cyl)),
class = "vctrs_error_cast_lossy"
)
expect_identical(
vec_cast(input, gdf),
cast_gdf
)
expect_identical(
vec_cast(gdf, bare_mtcars),
unrownames(bare_mtcars)
)
expect_identical(
vec_cast(tibble::as_tibble(input), gdf),
unrownames(cast_gdf)
)
tib <- tibble::as_tibble(bare_mtcars)
expect_identical(
unrownames(vec_cast(gdf, tib)),
tib
)
})
test_that("casting to `grouped_df` doesn't require grouping variables", {
expect_identical(
vec_cast(bare_mtcars[10], dplyr::group_by(bare_mtcars, cyl)),
dplyr::group_by(vec_cast(bare_mtcars[10], bare_mtcars), cyl)
)
})
test_that("casting to `grouped_df` handles `drop`", {
gdf_nodrop <- dplyr::group_by(bare_mtcars, cyl, .drop = FALSE)
expect_identical(vec_cast(bare_mtcars, gdf_nodrop), gdf_nodrop)
})
test_that("can cbind grouped data frames", {
gdf <- dplyr::group_by(bare_mtcars[-10], cyl)
df <- unrownames(bare_mtcars)[10]
expect_identical(
unrownames(vec_cbind(gdf, df)),
tibble::as_tibble(bare_mtcars)[c(1:9, 11, 10)]
)
gdf1 <- dplyr::group_by(bare_mtcars[2], cyl)
gdf2 <- dplyr::group_by(bare_mtcars[8:9], vs, am)
expect_identical(
unrownames(vec_cbind(gdf1, gdf2)),
tibble::as_tibble(bare_mtcars)[c(2, 8, 9)]
)
})
# `rowwise` ----------------------------------------------------------
test_that("rowwise can be proxied and restored", {
rww <- dplyr::rowwise(unrownames(bare_mtcars))
expect_identical(vec_proxy(rww), rww)
expect_identical(vec_restore(unrownames(bare_mtcars), rww), rww)
expect_identical(vec_ptype(rww), rww[0, ])
})
test_that("can take the common type of rowwise tibbles and tibbles", {
rww <- dplyr::rowwise(bare_mtcars)
expect_identical(vec_ptype2(rww, data.frame()), vec_ptype(rww))
expect_identical(vec_ptype2(data.frame(), rww), vec_ptype(rww))
expect_identical(vec_ptype2(rww, tibble()), vec_ptype(rww))
expect_identical(vec_ptype2(tibble(), rww), vec_ptype(rww))
})
test_that("can cast to and from `rowwise_df`", {
rww <- unrownames(dplyr::rowwise(bare_mtcars))
input <- bare_mtcars[10]
cast_rww <- dplyr::rowwise(vec_cast(bare_mtcars[10], bare_mtcars))
expect_error(
vec_cast(input, dplyr::rowwise(bare_mtcars["cyl"])),
class = "vctrs_error_cast_lossy"
)
expect_identical(
vec_cast(input, rww),
cast_rww
)
expect_identical(
vec_cast(rww, bare_mtcars),
unrownames(bare_mtcars)
)
expect_identical(
vec_cast(tibble::as_tibble(input), rww),
unrownames(cast_rww)
)
tib <- tibble::as_tibble(bare_mtcars)
expect_identical(
unrownames(vec_cast(rww, tib)),
tib
)
})
test_that("can cbind rowwise data frames", {
df <- unrownames(bare_mtcars)
rww <- dplyr::rowwise(df[-2])
gdf <- dplyr::group_by(df[2], cyl)
exp <- dplyr::rowwise(df[c(1, 3:11, 2)])
expect_identical(vec_cbind(rww, df[2]), exp)
# Suboptimal
expect_identical(vec_cbind(rww, gdf), exp)
})
test_that("common type between rowwise and grouped data frames is a bare df", {
out <- vec_ptype_common(dplyr::rowwise(bare_mtcars), dplyr::group_by(bare_mtcars, cyl))
expect_identical(out, tibble::as_tibble(bare_mtcars[0, ]))
})
vctrs/tests/testthat/helper-conditions.R 0000644 0001762 0000144 00000003677 14315060310 020174 0 ustar ligges users
with_subscript_data <- function(expr,
subscript_arg,
subscript_elt = NULL,
subscript_action = NULL) {
local_options(rlang_force_unhandled_error = TRUE)
tryCatch(
expr,
vctrs_error_subscript = function(cnd) {
cnd$subscript_arg <- subscript_arg
cnd$subscript_elt <- subscript_elt
cnd$subscript_action <- subscript_action
cnd_signal(cnd)
}
)
}
with_tibble_cols <- function(expr) {
with_subscript_data(
expr,
subscript_arg = quote(foo(bar)),
subscript_elt = "column",
subscript_action = "rename"
)
}
with_tibble_rows <- function(expr) {
with_subscript_data(
expr,
subscript_arg = quote(foo(bar)),
subscript_elt = "row",
subscript_action = "remove"
)
}
with_dm_tables <- function(expr) {
with_subscript_data(
expr,
subscript_arg = quote(foo(bar)),
subscript_elt = "table",
subscript_action = "extract"
)
}
with_tidyselect_select <- function(expr) {
with_subscript_data(
expr,
subscript_arg = quote(foo(bar)),
subscript_elt = "column",
subscript_action = "select"
)
}
with_tidyselect_relocate <- function(expr) {
with_subscript_data(
expr,
subscript_arg = quote(foo(bar)),
subscript_elt = "column",
subscript_action = "relocate"
)
}
my_vec_rep <- function(my_x, my_times) {
vec_rep(
my_x,
my_times,
error_call = current_env(),
x_arg = "my_x",
times_arg = "my_times"
)
}
my_vec_rep_each <- function(my_x, my_times) {
vec_rep_each(
my_x,
my_times,
error_call = current_env(),
x_arg = "my_x",
times_arg = "my_times"
)
}
my_vec_as_names <- function(my_names,
...,
my_repair = "minimal",
my_quiet = FALSE) {
vec_as_names(
my_names,
repair = my_repair,
repair_arg = "my_repair",
quiet = my_quiet
)
}
vctrs/tests/testthat/helper-type-dplyr.R 0000644 0001762 0000144 00000000234 14276722575 020146 0 ustar ligges users
expect_drop <- function(x, value) {
drop <- dplyr::group_by_drop_default(x)
if (value) {
expect_true(drop)
} else {
expect_false(drop)
}
}
vctrs/tests/testthat/test-type-misc.R 0000644 0001762 0000144 00000017003 14405105465 017434 0 ustar ligges users
test_that("`numeric_version` is a vector (#723)", {
x <- numeric_version("0.1.0")
y <- numeric_version("0.2.0")
z <- c(x, y)
expect_true(vec_is(x))
expect_true(vec_equal(x, x))
expect_false(vec_equal(x, y))
expect_identical(vec_equal(y, z), c(FALSE, TRUE))
expect_identical(vec_unique(z), z)
expect_identical(vec_unique(c(y, z, x)), z[2:1])
})
test_that("`numeric_version` falls back to base methods", {
x <- utils::packageVersion("rlang")
y <- utils::packageVersion("vctrs")
z <- c(x, y)
# `z` is a `list-of`-like type but slicing 1 element returns the
# atomic type. To implement this in vctrs we'd need to provide a way
# of customising the "wrapper" type for size > 1 vectors.
expect_identical(vec_slice(z, 1:2), z)
expect_identical(vec_slice(z, 1), x)
expect_identical(vec_slice(z, 2), y)
expect_identical(vec_c(x, y), z)
})
test_that("`numeric_version` has an equality, comparison, and order proxy", {
numeric_row <- function(...) {
out <- list2(...)
out <- map(out, as.integer)
names(out) <- paste0("...", seq_len(8L))
new_data_frame(out, n = 1L)
}
x <- numeric_version(c("1.2-3", "1.21.1", "3", "2.21.0.9000", "0.5.01"))
expect <- vec_rbind(
numeric_row(1, 2, 3, 0, 0, 0, 0, 0),
numeric_row(1, 21, 1, 0, 0, 0, 0, 0),
numeric_row(3, 0, 0, 0, 0, 0, 0, 0),
numeric_row(2, 21, 0, 9000, 0, 0, 0, 0),
numeric_row(0, 5, 1, 0, 0, 0, 0, 0)
)
expect_identical(vec_proxy_equal(x), expect)
expect_identical(vec_proxy_compare(x), expect)
expect_identical(vec_proxy_order(x), expect)
})
test_that("`numeric_version` proxy works with empty vectors", {
x <- numeric_version(character())
expect <- vec_rep(list(integer()), times = 8L)
names(expect) <- paste0("...", seq_len(8L))
expect <- new_data_frame(expect, n = 0L)
expect_identical(vec_proxy_equal(x), expect)
})
test_that("`numeric_version` proxy handles pseudo-`NA`", {
numeric_row <- function(...) {
out <- list2(...)
out <- map(out, as.integer)
names(out) <- paste0("...", seq_len(8L))
new_data_frame(out, n = 1L)
}
x <- numeric_version(c("1_1", "1.2", NA), strict = FALSE)
expect <- vec_rbind(
numeric_row(NA, NA, NA, NA, NA, NA, NA, NA),
numeric_row(1, 2, 0, 0, 0, 0, 0, 0),
numeric_row(NA, NA, NA, NA, NA, NA, NA, NA)
)
expect_identical(vec_proxy_equal(x), expect)
expect_identical(vec_proxy_compare(x), expect)
expect_identical(vec_proxy_order(x), expect)
})
test_that("`numeric_version` works with functions using the equality proxy", {
x <- numeric_version(c("1.2-3", "1.21.1", "1_1", "0.5", "1.3"), strict = FALSE)
y <- numeric_version(c("1.21.1", "1.21.1", "1_2", "0.05", "1_3"), strict = FALSE)
expect_identical(vec_unique(x), x)
expect_identical(vec_unique(y), y[c(1, 3, 4)])
expect_identical(vec_detect_missing(y), c(FALSE, FALSE, TRUE, FALSE, TRUE))
expect_identical(vec_equal(x, y), c(FALSE, TRUE, NA, TRUE, NA))
expect_identical(vec_equal(x, y, na_equal = TRUE), c(FALSE, TRUE, TRUE, TRUE, FALSE))
})
test_that("`numeric_version` works with functions using the comparison proxy", {
x <- numeric_version(c("1.2-3", "1.21.1", "1_1", "0.5", "1.3"), strict = FALSE)
y <- numeric_version(c("1.21.1", "1.21.1", "1_2", "0.05", "1_3"), strict = FALSE)
expect_identical(vec_compare(x, y), c(-1L, 0L, NA, 0L, NA))
expect_identical(vec_compare(x, y, na_equal = TRUE), c(-1L, 0L, 0L, 0L, 1L))
# Specifically related to base R taking a joint proxy in `Ops.numeric_version`
x <- numeric_version("3.3")
y <- numeric_version("3.21")
# `.encode_numeric_version(x) < .encode_numeric_version(y)` == FALSE
# `x < y` == TRUE
expect_identical(vec_compare(x, y), -1L)
})
test_that("`numeric_version` works with functions using the order proxy (tidyverse/dplyr#6680)", {
x <- numeric_version(c("1.2-3", "1.21.1", "1_1", "0.5", "1.30"), strict = FALSE)
y <- numeric_version(c("1.21.1", "1.21.1", "1_2", "0.05", "1_3"), strict = FALSE)
expect_identical(vec_order(y), c(4L, 1L, 2L, 3L, 5L))
expect_identical(vec_order_radix(y), c(4L, 1L, 2L, 3L, 5L))
expect_identical(vec_order(y, na_value = "smallest"), c(3L, 5L, 4L, 1L, 2L))
expect_identical(vec_order_radix(y, na_value = "smallest"), c(3L, 5L, 4L, 1L, 2L))
expect_identical(
vec_locate_matches(x, y),
data_frame(
needles = c(1L, 2L, 2L, 3L, 3L, 4L, 5L),
haystack = c(NA, 1L, 2L, 3L, 5L, 4L, NA)
)
)
expect_identical(
vec_locate_matches(x, y, condition = "<"),
data_frame(
needles = c(1L, 1L, 2L, 3L, 4L, 4L, 5L),
haystack = c(1L, 2L, NA, NA, 1L, 2L, NA)
)
)
})
test_that("`numeric_version` proxy can handle at most 8 components", {
x <- numeric_version("1.2.3.4.5.6.7.8")
expect_silent(vec_proxy_equal(x))
x <- numeric_version("1.2.3.4.5.6.7.8.9")
expect_snapshot(error = TRUE, {
vec_proxy_equal(x)
})
})
test_that("`numeric_version` can compare against components with 8 components", {
x <- numeric_version("2.3.4.5.6.7.8.9")
y <- c(x, numeric_version(c("1.1", "11.2", "2.1")))
expect_identical(vec_compare(x, y), c(0L, 1L, -1L, 1L))
})
test_that("`package_version` and `R_system_version` use the `numeric_version` proxy", {
x <- numeric_version("1.5.6")
y <- package_version("1.5.6")
z <- R_system_version("1.5.6")
expect_identical(vec_proxy_equal(y), vec_proxy_equal(x))
expect_identical(vec_proxy_equal(z), vec_proxy_equal(x))
})
test_that("can slice `ts` vectors", {
x <- ts(1:3)
expect_identical(vec_ptype(x), x[0])
expect_identical(vec_slice(x, 2), x[2])
})
test_that("can concatenate `ts` vectors", {
x <- ts(1:3)
expect_identical(vec_c(x, x), c(x, x))
df <- data_frame(x = x)
expect_identical(vec_rbind(df, df), data_frame(x = c(x, x)))
})
test_that("`omit` class is numeric (#1160)", {
x <- c(NA, 1:3, NA)
omit <- attr(na.omit(x), "na.action")
expect_identical(vec_ptype_common(omit, omit), structure(int(), class = "omit"))
expect_identical(vec_ptype_common(1.5, omit), dbl())
expect_identical(vec_ptype_common(omit, 1L), int())
expect_identical(vec_cast_common(omit, omit), list(omit, omit))
expect_identical(vec_cast_common(omit, 1L), list(unstructure(omit), 1L))
expect_identical(vec_cast_common(1.5, omit), list(1.5, unstructure(as.double(omit))))
expect_error(vec_cast(1L, omit), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(1.0, omit), class = "vctrs_error_incompatible_type")
expect_identical(vec_slice(omit, 1), structure(1L, class = "omit"))
expect_identical(vec_c(omit, omit), structure(c(1L, 5L, 1L, 5L), class = "omit"))
expect_identical(vec_c(omit, omit, 10L), c(1L, 5L, 1L, 5L, 10L))
expect_identical(vec_slice(x, omit), x[omit])
})
test_that("`exclude` class is numeric (#1160)", {
x <- c(NA, 1:3, NA)
exc <- attr(na.exclude(x), "na.action")
expect_identical(vec_ptype_common(exc, exc), structure(int(), class = "exclude"))
expect_identical(vec_ptype_common(1.5, exc), dbl())
expect_identical(vec_ptype_common(exc, 1L), int())
expect_identical(vec_cast_common(exc, exc), list(exc, exc))
expect_identical(vec_cast_common(exc, 1L), list(unstructure(exc), 1L))
expect_identical(vec_cast_common(1.5, exc), list(1.5, unstructure(as.double(exc))))
expect_error(vec_cast(1L, exc), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(1.0, exc), class = "vctrs_error_incompatible_type")
expect_identical(vec_slice(exc, 1), structure(1L, class = "exclude"))
expect_identical(vec_c(exc, exc), structure(c(1L, 5L, 1L, 5L), class = "exclude"))
expect_identical(vec_c(exc, exc, 10L), c(1L, 5L, 1L, 5L, 10L))
expect_identical(vec_slice(x, exc), x[exc])
})
vctrs/tests/testthat/helper-types.R 0000644 0001762 0000144 00000004050 14276722575 017201 0 ustar ligges users # Don't call tibble::tibble() to avoid catch-22, because tibble now uses vctrs
bare_tibble <- structure(data.frame(), class = c("tbl_df", "tbl", "data.frame"))
base_empty_types <- list(
null = NULL,
logical = lgl(),
integer = int(),
double = dbl(),
complex = cpl(),
character = chr(),
raw = bytes(),
list = list(),
dataframe = data.frame()
)
base_s3_empty_types <- list(
bare_factor = new_factor(),
bare_ordered = new_ordered(),
bare_date = new_date(),
bare_posixct = new_datetime(tzone = "UTC"),
bare_posixlt = as.POSIXlt(new_datetime(tzone = "UTC")),
bare_tibble = bare_tibble
)
proxied_empty_types <- list(
double = new_hidden(),
dataframe = bare_tibble,
dataframe = structure(data.frame(), class = c("vctrs_foobar", "data.frame"))
)
empty_types <- c(
base_empty_types,
proxied_empty_types,
# Non proxied type
scalar = foobar(list()),
scalar = function() NULL
)
atomics <- list(TRUE, 1L, 1.0, 1i, "foo", bytes(1))
vectors <- c(atomics, list(list()))
records <- list(
df = data.frame(x = 1),
rcrd = new_rcrd(list(x = 1)),
posixlt = as.POSIXlt("2020-01-01")
)
tuple <- function(x = integer(), y = integer()) {
fields <- vec_recycle_common(
x = vec_cast(x, integer()),
y = vec_cast(y, integer())
)
new_rcrd(fields, class = "vctrs_tuple")
}
tuple_methods <- list(
format.vctrs_tuple = function(x, ...) {
paste0("(", field(x, "x"), ",", field(x, "y"), ")")
},
vec_ptype2.vctrs_tuple.vctrs_tuple = function(x, y, ...) x,
vec_cast.vctrs_tuple.vctrs_tuple = function(x, to, ...) x
)
local_tuple_methods <- function(frame = caller_env()) {
local_methods(.frame = frame, !!!tuple_methods)
}
set_tuple_methods <- function(env = global_env()) {
env_bind(env, !!!tuple_methods)
}
local_comparable_tuple <- function(frame = caller_env()) {
local_tuple_methods(frame = frame)
# Compare only on first field
local_methods(
.frame = frame,
vec_proxy_equal.vctrs_tuple = function(x, ...) field(x, "x")
)
}
c_na <- function(...) {
x <- c(...)
names(x)[names(x) == ""] <- NA_character_
x
}
vctrs/tests/testthat/test-arith.R 0000644 0001762 0000144 00000001466 14276722575 016654 0 ustar ligges users
test_that("logical/integer/numeric works", {
expect_equal(vec_arith("+", TRUE, TRUE), 2L)
expect_equal(vec_arith("+", TRUE, 1L), 2L)
expect_equal(vec_arith("+", TRUE, 1), 2)
expect_equal(vec_arith("+", 1L, TRUE), 2L)
expect_equal(vec_arith("+", 1L, 1L), 2L)
expect_equal(vec_arith("+", 1L, 1), 2)
expect_equal(vec_arith("+", 1, TRUE), 2L)
expect_equal(vec_arith("+", 1, 1L), 2L)
expect_equal(vec_arith("+", 1, 1), 2)
})
test_that("default is error", {
f <- new_vctr(1:10, class = "foo")
expect_error(vec_arith("+", f, 1), class = "vctrs_error_incompatible_op")
expect_error(vec_arith("+", TRUE, f), class = "vctrs_error_incompatible_op")
expect_error(vec_arith("+", 1L, f), class = "vctrs_error_incompatible_op")
expect_error(vec_arith("+", 1, f), class = "vctrs_error_incompatible_op")
})
vctrs/tests/testthat/test-type-asis.R 0000644 0001762 0000144 00000006276 14315060310 017437 0 ustar ligges users # ------------------------------------------------------------------------------
# Printing
test_that("I() wraps contents", {
f <- factor()
expect_equal(vec_ptype_abbr(I(f)), "I")
expect_equal(vec_ptype_full(I(f)), "I>")
})
test_that("AsIs class stripped from I()", {
df <- data.frame(x = 1, y = 1:2)
class(df) <- c("myclass", "data.frame")
expect_equal(vec_ptype_full(I(df)), "I>")
expect_equal(vec_ptype_full(I(df[1])), "I>")
expect_equal(vec_ptype_full(I(df[0])), "I>")
})
# ------------------------------------------------------------------------------
# Proxy / restore
test_that("can slice AsIs class", {
df <- data.frame(x = I(1:3), y = I(list(4, 5, 6)))
expect_identical(vec_slice(df, 2:3), unrownames(df[2:3, ]))
})
test_that("equality proxy is forwarded correctly for atomic types (#1557)", {
# We don't define any equality proxies for base atomic types, but we can fake it
local_methods(vec_proxy_equal.integer = function(x, ...) "dispatched")
asis <- I(1L)
expect_identical(vec_proxy_equal(asis), "dispatched")
})
test_that("comparison proxy is forwarded correctly for atomic types (#1557)", {
# vec_proxy_compare.raw() exists
x <- raw()
asis <- I(x)
expect_identical(vec_proxy_compare(asis), vec_proxy_compare(x))
expect_identical(vec_proxy_compare(asis), integer())
})
test_that("order proxy is forwarded correctly for atomic types (#1557)", {
# vec_proxy_order.list() exists
x <- list(2, 1, 2)
asis <- I(x)
expect_identical(vec_proxy_order(asis), vec_proxy_order(x))
expect_identical(vec_proxy_order(asis), c(1L, 2L, 1L))
})
# ------------------------------------------------------------------------------
# Coercion
test_that("can take the common type of identical AsIs objects", {
expect_identical(vec_ptype2(I(1), I(1)), I(numeric()))
})
test_that("AsIs objects throw ptype2 errors with their underlying types", {
expect_snapshot({
(expect_error(vec_ptype2(I(1), I("x")), class = "vctrs_error_incompatible_type"))
})
})
test_that("AsIs always wraps the common type", {
expect_identical(vec_ptype2(I(1L), 1), I(numeric()))
expect_identical(vec_ptype2(1, I(1L)), I(numeric()))
})
# ------------------------------------------------------------------------------
# Casting
test_that("can cast one AsIs to another AsIs", {
expect_identical(vec_cast(I(1), I(1)), I(1))
expect_identical(vec_cast(I(1), I(1L)), I(1L))
})
test_that("AsIs objects throw cast errors with their underlying types", {
expect_snapshot({
(expect_error(vec_cast(I(1), I(factor("x"))), class = "vctrs_error_incompatible_type"))
})
})
test_that("casting from an AsIs drops the AsIs class", {
expect_identical(vec_cast(I(1), 1), 1)
})
test_that("casting to an AsIs adds the AsIs class", {
expect_identical(vec_cast(1, I(1)), I(1))
})
# ------------------------------------------------------------------------------
# Misc
test_that("can `vec_c()` with only AsIs objects", {
expect_identical(vec_c(I(1), I(2)), I(c(1, 2)))
expect_identical(vec_c(I(1), I(2L)), I(c(1, 2)))
})
test_that("can `vec_c()` with AsIs objects mixed with other types", {
expect_identical(vec_c(I(1L), 1), I(c(1, 1)))
})
vctrs/tests/testthat/test-cast.R 0000644 0001762 0000144 00000023303 14377212620 016454 0 ustar ligges users
test_that("Casting to named argument mentions 'match type '", {
expect_snapshot(error = TRUE, vec_cast(1, "", x_arg = "foo", to_arg = "bar"))
expect_snapshot(error = TRUE, vec_cast(1, "", x_arg = "foo"))
})
# vec_cast() ---------------------------------------------------------------
test_that("new classes are uncoercible by default", {
x <- structure(1:10, class = "vctrs_nonexistant")
expect_error(vec_cast(1, x), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(x, 1), class = "vctrs_error_incompatible_type")
})
test_that("casting requires vectors", {
expect_error(vec_cast(NULL, quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_cast(NA, quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_cast(list(), quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_cast(quote(name), NULL), class = "vctrs_error_scalar_type")
expect_error(vec_cast(quote(name), NA), class = "vctrs_error_scalar_type")
expect_error(vec_cast(quote(name), list()), class = "vctrs_error_scalar_type")
expect_error(vec_cast(quote(name), quote(name)), class = "vctrs_error_scalar_type")
})
test_that("casting between `NULL` and partial types is allowed", {
expect_identical(vec_cast(NULL, partial_factor()), NULL)
expect_identical(vec_cast(partial_factor(), NULL), partial_factor())
})
test_that("dimensionality matches output" ,{
x1 <- matrix(TRUE, nrow = 1, ncol = 1)
x2 <- matrix(1, nrow = 0, ncol = 2)
expect_dim(vec_cast(x1, x2), c(1, 2))
expect_dim(vec_cast(TRUE, x2), c(1, 2))
x <- matrix(1, nrow = 2, ncol = 2)
expect_error(vec_cast(x, logical()), class = "vctrs_error_incompatible_type")
})
test_that("empty input to vec_cast_common() returns list()", {
expect_equal(vec_cast_common(), list())
expect_equal(vec_cast_common(NULL, NULL), list(NULL, NULL))
})
test_that("identical structures can be cast to each other", {
expect_identical(vec_cast(foobar("foo"), foobar("bar")), foobar("foo"))
})
test_that("cast common preserves names", {
expect_identical(vec_cast_common(foo = 1, bar = 2L), list(foo = 1, bar = 2))
})
test_that("cast errors create helpful messages (#57, #225)", {
# Lossy cast
expect_snapshot(error = TRUE, vec_cast(1.5, 10L))
# Incompatible cast
expect_snapshot(error = TRUE, vec_cast(factor("foo"), 10))
# Nested data frames - Lossy cast
expect_snapshot(error = TRUE, {
x <- tibble(a = tibble(b = 1.5))
y <- tibble(a = tibble(b = 10L))
vec_cast(x, y)
})
# Nested data frames - Incompatible cast
expect_snapshot(error = TRUE, {
x <- tibble(a = tibble(b = factor("foo")))
y <- tibble(a = tibble(b = 10))
vec_cast(x, y)
})
# Nested data frames - Common cast error
expect_snapshot(error = TRUE, {
x <- tibble(a = tibble(b = factor("foo")))
y <- tibble(a = tibble(b = 10))
vec_cast_common(x, y)
})
})
test_that("unspecified can be cast to shaped vectors", {
x <- matrix(letters[1:4], 2)
expect_identical(vec_cast(NA, x), matrix(chr(NA, NA), 1))
x <- foobar(c(1:4))
dim(x) <- c(2, 2)
out <- vec_cast(NA, x)
exp <- foobar(int(c(NA, NA)))
dim(exp) <- c(1, 2)
expect_identical(out, exp)
})
test_that("vec_cast() falls back to base class even when casting to non-base type", {
expect_equal(vec_cast(foobar(mtcars), mtcars), mtcars)
expect_equal(vec_cast(mtcars, foobar(mtcars)), mtcars)
})
test_that("vec_cast() only attempts to fall back if `to` is a data frame (#1568)", {
expect_snapshot({
(expect_error(
vec_cast(foobar(mtcars), 1),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("vec_cast() evaluates x_arg and to_arg lazily", {
expect_silent(vec_cast(TRUE, logical(), x_arg = print("oof")))
expect_silent(vec_cast(TRUE, logical(), to_arg = print("oof")))
})
# Conditions --------------------------------------------------------------
test_that("can suppress cast errors selectively", {
f <- function() vec_cast(factor("a"), to = factor("b"))
expect_error(regexp = NA, allow_lossy_cast(f()))
expect_error(regexp = NA, allow_lossy_cast(f(), x_ptype = factor("a")))
expect_error(regexp = NA, allow_lossy_cast(f(), to_ptype = factor("b")))
expect_error(regexp = NA, allow_lossy_cast(f(), x_ptype = factor("a"), to_ptype = factor("b")))
expect_error(allow_lossy_cast(f(), x_ptype = factor("c")), class = "vctrs_error_cast_lossy")
expect_error(allow_lossy_cast(f(), x_ptype = factor("b"), to_ptype = factor("a")), class = "vctrs_error_cast_lossy")
expect_error(allow_lossy_cast(f(), x_ptype = factor("a"), to_ptype = factor("c")), class = "vctrs_error_cast_lossy")
})
test_that("can signal deprecation warnings for lossy casts", {
local_options(lifecycle_verbosity = "warning")
lossy_cast <- function() {
maybe_lossy_cast(
TRUE,
factor("foo"),
factor("bar"),
lossy = TRUE,
.deprecation = TRUE,
x_arg = "x",
to_arg = "to"
)
}
expect_snapshot({
(expect_warning(expect_true(lossy_cast())))
})
expect_warning(regexp = NA, expect_true(allow_lossy_cast(lossy_cast())))
expect_warning(regexp = NA, expect_true(allow_lossy_cast(lossy_cast(), factor("foo"), factor("bar"))))
expect_warning(expect_true(allow_lossy_cast(lossy_cast(), factor("bar"), double())))
})
# vec_cast_common() -------------------------------------------------------
test_that("vec_ptype_common() optionally falls back to base class", {
x <- foobar(NA, foo = 1)
y <- foobaz(NA, bar = 2)
x_df <- data_frame(x = x)
y_df <- data_frame(x = y)
expect_error(
vec_ptype_common_opts(x, y, .opts = full_fallback_opts()),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_ptype_common_opts(x_df, y_df, .opts = full_fallback_opts()),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast_common_opts(x, y, .opts = full_fallback_opts()),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast_common_opts(x_df, y_df, .opts = full_fallback_opts()),
class = "vctrs_error_incompatible_type"
)
class(y) <- c("foo", class(x))
y_df <- data_frame(x = y)
common_sentinel <- vec_ptype_common_opts(x, y, .opts = full_fallback_opts())
expect_true(is_common_class_fallback(common_sentinel))
expect_identical(fallback_class(common_sentinel), "vctrs_foobar")
common_sentinel <- vec_ptype_common_opts(x_df, y_df, .opts = full_fallback_opts())
expect_true(is_common_class_fallback(common_sentinel$x))
expect_identical(fallback_class(common_sentinel$x), "vctrs_foobar")
common <- vec_cast_common_opts(x = x, y = y, .opts = full_fallback_opts())
expect_identical(common, list(x = x, y = y))
common <- vec_cast_common_opts(x = x_df, y = y_df, .opts = full_fallback_opts())
expect_identical(common, list(x = x_df, y = y_df))
})
test_that("vec_ptype_common_fallback() collects common type", {
x <- foobar(1, foo = 1, class = c("quux", "baz"))
y <- foobar(2, bar = 2, class = "baz")
x_df <- data_frame(x = x)
y_df <- data_frame(x = y)
out <- vec_ptype_common_fallback(x, y)
expect_identical(typeof(out), "double")
expect_true(is_common_class_fallback(out))
expect_identical(fallback_class(out), c("baz", "vctrs_foobar"))
out <- vec_ptype_common_fallback(x_df, y_df)
expect_identical(typeof(out$x), "double")
expect_true(is_common_class_fallback(out$x))
expect_identical(fallback_class(out$x), c("baz", "vctrs_foobar"))
# Different base types can't fall back to common class
z <- foobar(3L, baz = 3)
expect_error(
vec_ptype_common_fallback(x, z),
class = "vctrs_error_incompatible_type"
)
z_df <- data_frame(x = z)
expect_error(
vec_ptype_common_fallback(x_df, z_df),
class = "vctrs_error_incompatible_type"
)
})
test_that("fallback sentinel is returned with unspecified inputs", {
fallback <- vec_ptype_common_fallback(foobar(1), foobar(1))
expect_identical(vec_ptype_common_fallback(NA, foobar(1)), fallback)
expect_identical(vec_ptype_common_fallback(foobar(1), NA), fallback)
})
test_that("vec_ptype_common() supports subclasses of list", {
x <- structure(list(1), class = c("vctrs_foo", "list"))
y <- structure(list(2), class = c("bar", "vctrs_foo", "list"))
expect_error(vec_c(x, y), class = "vctrs_error_incompatible_type")
out <- with_methods(
c.vctrs_foo = function(...) quux(NextMethod()),
vec_c(x, y)
)
expect_identical(out, quux(list(1, 2)))
})
test_that("vec_cast_common_fallback() works with tibbles", {
x <- foobar("foo")
df <- data_frame(x = x)
tib <- tibble(x = x)
exp <- list(tib, tib)
expect_identical(vec_cast_common_fallback(tib, tib), exp)
expect_identical(vec_cast_common_fallback(tib, df), exp)
expect_identical(vec_cast_common_fallback(df, tib), exp)
})
test_that("can call `vec_cast()` from C (#1666)", {
fn <- inject(function(x, i) .Call(!!ffi_exp_vec_cast, x, i))
environment(fn) <- ns_env("utils")
x <- array(1, dim = c(1, 1))
y <- array(2, dim = c(2, 2))
expect_equal(fn(x, y), vec_cast(x, y))
})
test_that("df-fallback for cast is not sensitive to attributes order", {
x <- structure(
list(col = ""),
class = c("vctrs_foobar", "tbl_df", "tbl", "data.frame"),
row.names = c(NA, -1L),
foo = "foo",
bar = "bar"
)
ptype <- structure(
list(col = character(0)),
foo = "foo",
bar = "bar",
row.names = integer(0),
class = c("vctrs_foobar", "tbl_df", "tbl", "data.frame")
)
expect_identical(vec_cast(x, ptype), x)
})
test_that("bare-type fallback for df-cast works", {
# NOTE: Not sure why this was necessary. The cubble and yamlet
# packages fail without this.
local_methods(
c.vctrs_foobaz = function(...) quux(NextMethod())
)
df <- data_frame(x = 1, y = foobaz("foo"))
gdf <- dplyr::new_grouped_df(
df,
data_frame(x = 1, .rows = list(1L)),
class = "vctrs_foobar"
)
expect_error(vec_rbind(gdf, gdf), NA)
})
vctrs/tests/testthat/helper-s4.R 0000644 0001762 0000144 00000003406 14276722575 016367 0 ustar ligges users
.rando <- setClass(
"vctrs_rando",
contains = "numeric",
slots = list(.Data = "numeric")
)
rando <- function(n = 0) {
.rando(as.numeric(seq_len(n)))
}
as_rando <- function(x) {
rando(length(x))
}
setMethod("[", "vctrs_rando", function(x, i, j, ..., drop = TRUE) {
new_n <- length(vec_as_location(i, length(x@.Data), names(x@.Data)))
rando(new_n)
})
.Counts <- methods::setClass(
"vctrs_Counts",
contains = "integer",
slots = c(name = "character")
)
local_c_counts <- function(frame = caller_env()) {
c_counts <- function(x, ...) {
xs <- list(x, ...)
xs_data <- lapply(xs, function(x) x@.Data)
new_data <- do.call(c, xs_data)
.Counts(new_data, name = "Dispatched")
}
local_s4_method(
frame = frame,
"c",
methods::signature(x = "vctrs_Counts"),
c_counts
)
}
local_s4_method <- function(generic, signature, method, frame = caller_env()) {
methods::setMethod(generic, signature, method)
exit_expr <- call2(methods::removeMethod, generic, signature, where = topenv(frame))
local_exit(exit_expr, frame = frame)
}
with_s4_method <- function(generic, signature, method, expr) {
local_s4_method(generic, signature, method)
expr
}
local_exit <- function(expr, frame = caller_env()) {
# We are at top-level when only one frame refers to the global environment
if (is_reference(frame, global_env())) {
is_global_frame <- sys.parents() == 0
if (sum(is_global_frame) == 1) {
abort("Can't add an exit event at top-level")
}
}
# Inline everything so the call will succeed in any environment
expr <- call2(on.exit, expr, add = TRUE)
eval_bare(expr, frame)
invisible(expr)
}
skip_if_cant_set_names_on_s4 <- function() {
skip_if(getRversion() < "3.5.0", message = "Can't set names on S4 objects")
}
vctrs/tests/testthat/test-set.R 0000644 0001762 0000144 00000031773 14511320527 016323 0 ustar ligges users # vec_set_intersect -------------------------------------------------------
test_that("retains names of `x` elements", {
x <- c(a = 1, b = 4, c = 1, d = 4, e = 2)
y <- c(w = 3, x = 2, y = 1, z = 2)
expect_identical(
vec_set_intersect(x, y),
c(a = 1, e = 2)
)
})
test_that("returns elements in order they first appear in `x`", {
expect_identical(vec_set_intersect(c(3, 1, 2, 3), c(2, 3)), c(3, 2))
})
test_that("returns unique elements", {
expect_identical(vec_set_intersect(c(1, 2, 1), c(2, 2, 1)), c(1, 2))
})
test_that("works with character vectors of different encodings", {
encs <- encodings()
# Always returns UTF-8
expect_identical(vec_set_intersect(encs$utf8, encs$latin1), encs$utf8)
expect_identical(vec_set_intersect(encs$latin1, encs$utf8), encs$utf8)
})
test_that("has consistency with `NA` values", {
expect_identical(vec_set_intersect(c(NA_real_, 1), NA_real_), NA_real_)
expect_identical(vec_set_intersect(c(1, NA_real_), NA_real_), NA_real_)
expect_identical(vec_set_intersect(c(NA_real_, NaN), NaN), NaN)
expect_identical(vec_set_intersect(c(NaN, NA_real_), NaN), NaN)
})
test_that("works with complex missing values", {
na <- complex(
real = c(NA_real_, NA_real_, NaN, NaN),
imaginary = c(NA_real_, NaN, NA_real_, NaN)
)
expect_identical(vec_set_intersect(na, na), na)
expect_identical(vec_set_intersect(na, na[2]), na[2])
})
test_that("works correctly with unspecified logical vectors", {
expect_identical(vec_set_intersect(NA, NA), NA)
})
test_that("returns a vector of the common type", {
expect_identical(vec_set_intersect(1L, c(2, 1)), 1)
})
test_that("works with data frames", {
x <- data_frame(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
)
y <- data_frame(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
)
expect_identical(vec_set_intersect(x, y), vec_slice(x, c(2, 4)))
expect_identical(vec_set_intersect(y, x), vec_slice(y, c(1, 3)))
})
test_that("works with rcrds", {
x <- new_rcrd(list(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
))
y <- new_rcrd(list(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
))
expect_identical(vec_set_intersect(x, y), vec_slice(x, c(2, 4)))
expect_identical(vec_set_intersect(y, x), vec_slice(y, c(1, 3)))
})
# vec_set_difference ------------------------------------------------------
test_that("retains names of `x` elements", {
x <- c(a = 1, b = 4, c = 1, d = 4, e = 5)
y <- c(w = 3, x = 2, y = 1, z = 2)
expect_identical(
vec_set_difference(x, y),
c(b = 4, e = 5)
)
})
test_that("returns elements in order they first appear in `x`", {
expect_identical(vec_set_difference(c(3, 1, 2, 3), 1), c(3, 2))
})
test_that("returns unique elements", {
expect_identical(vec_set_difference(c(1, 2, 1, 4), c(4, 5)), c(1, 2))
})
test_that("works with character vectors of different encodings", {
encs <- encodings()
expect_identical(vec_set_difference(encs$utf8, encs$latin1), character())
expect_identical(vec_set_difference(encs$latin1, encs$utf8), character())
})
test_that("has consistency with `NA` values", {
expect_identical(vec_set_difference(c(NA_real_, 1), NA_real_), 1)
expect_identical(vec_set_difference(c(1, NA_real_), NA_real_), 1)
expect_identical(vec_set_difference(c(NA_real_, NaN), NaN), NA_real_)
expect_identical(vec_set_difference(c(NaN, NA_real_), NaN), NA_real_)
})
test_that("works with complex missing values", {
na <- complex(
real = c(NA_real_, NA_real_, NaN, NaN),
imaginary = c(NA_real_, NaN, NA_real_, NaN)
)
expect_identical(vec_set_difference(na, na), complex())
expect_identical(vec_set_difference(na, na[2]), na[c(1, 3, 4)])
})
test_that("works correctly with unspecified logical vectors", {
expect_identical(vec_set_difference(NA, NA), logical())
})
test_that("returns a vector of the common type", {
expect_identical(vec_set_difference(c(3L, 1L), c(2, 1)), 3)
})
test_that("works with data frames", {
x <- data_frame(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
)
y <- data_frame(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
)
expect_identical(vec_set_difference(x, y), vec_slice(x, 1))
expect_identical(vec_set_difference(y, x), vec_slice(y, c(2, 4)))
})
test_that("works with rcrds", {
x <- new_rcrd(list(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
))
y <- new_rcrd(list(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
))
expect_identical(vec_set_difference(x, y), vec_slice(x, 1))
expect_identical(vec_set_difference(y, x), vec_slice(y, c(2, 4)))
})
# vec_set_union -----------------------------------------------------------
test_that("retains names of `x` and `y` elements", {
x <- c(a = 1, b = 4, c = 1, d = 4, e = 5)
y <- c(w = 3, x = 2, y = 1, z = 2)
expect_identical(
vec_set_union(x, y),
c(a = 1, b = 4, e = 5, w = 3, x = 2)
)
})
test_that("does minimal name repair on duplicate names", {
x <- c(a = 1)
y <- c(a = 2)
expect_named(vec_set_union(x, y), c("a", "a"))
})
test_that("returns elements in order they first appear in `x` and `y`", {
expect_identical(vec_set_union(c(3, 1, 2, 3), c(4, 2, 5, 4)), c(3, 1, 2, 4, 5))
})
test_that("returns unique elements", {
expect_identical(vec_set_union(c(1, 2, 1, 4), c(4, 5, 5)), c(1, 2, 4, 5))
})
test_that("works with character vectors of different encodings", {
encs <- encodings()
# Always returns UTF-8
expect_identical(vec_set_union(encs$utf8, encs$latin1), encs$utf8)
expect_identical(vec_set_union(encs$latin1, encs$utf8), encs$utf8)
})
test_that("has consistency with `NA` values", {
expect_identical(vec_set_union(c(NA_real_, 1), NA_real_), c(NA_real_, 1))
expect_identical(vec_set_union(c(1, NA_real_), NA_real_), c(1, NA_real_))
expect_identical(vec_set_union(NA_real_, NaN), c(NA_real_, NaN))
expect_identical(vec_set_union(NaN, NA_real_), c(NaN, NA_real_))
})
test_that("works with complex missing values", {
na <- complex(
real = c(NA_real_, NA_real_, NaN, NaN),
imaginary = c(NA_real_, NaN, NA_real_, NaN)
)
expect_identical(vec_set_union(na, na), na)
expect_identical(vec_set_union(na[-2], na), na[c(1, 3, 4, 2)])
})
test_that("works correctly with unspecified logical vectors", {
expect_identical(vec_set_union(NA, NA), NA)
})
test_that("returns a vector of the common type", {
expect_identical(vec_set_union(c(3L, 1L), c(2, 1)), c(3, 1, 2))
})
test_that("works with data frames", {
x <- data_frame(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
)
y <- data_frame(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
)
expect_identical(vec_set_union(x, y), vec_c(vec_slice(x, c(1, 2, 4)), vec_slice(y, c(2, 4))))
expect_identical(vec_set_union(y, x), vec_c(vec_slice(y, c(1, 2, 3, 4)), vec_slice(x, 1)))
})
test_that("works with rcrds", {
x <- new_rcrd(list(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
))
y <- new_rcrd(list(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
))
expect_identical(vec_set_union(x, y), vec_c(vec_slice(x, c(1, 2, 4)), vec_slice(y, c(2, 4))))
expect_identical(vec_set_union(y, x), vec_c(vec_slice(y, c(1, 2, 3, 4)), vec_slice(x, 1)))
})
# vec_set_symmetric_difference --------------------------------------------
test_that("retains names of `x` and `y` elements", {
x <- c(a = 1, b = 4, c = 1, d = 4, e = 5)
y <- c(w = 3, x = 2, y = 1, z = 2)
expect_identical(
vec_set_symmetric_difference(x, y),
c(b = 4, e = 5, w = 3, x = 2)
)
})
test_that("returns elements in order they first appear in `x` and `y`", {
expect_identical(vec_set_symmetric_difference(c(3, 1, 2, 3), c(4, 2, 5, 4)), c(3, 1, 4, 5))
})
test_that("returns unique elements", {
expect_identical(vec_set_symmetric_difference(c(1, 2, 1, 4), c(4, 5, 5)), c(1, 2, 5))
})
test_that("works with character vectors of different encodings", {
encs <- encodings()
# Always returns UTF-8
expect_identical(vec_set_symmetric_difference(encs$utf8, encs$latin1), character())
expect_identical(vec_set_symmetric_difference(encs$latin1, encs$utf8), character())
})
test_that("has consistency with `NA` values", {
expect_identical(vec_set_symmetric_difference(c(NA_real_, 1), NA_real_), 1)
expect_identical(vec_set_symmetric_difference(c(1, NA_real_), NA_real_), 1)
expect_identical(vec_set_symmetric_difference(c(NaN, 1), NaN), 1)
expect_identical(vec_set_symmetric_difference(c(1, NaN), NaN), 1)
expect_identical(vec_set_symmetric_difference(NA_real_, NaN), c(NA_real_, NaN))
expect_identical(vec_set_symmetric_difference(NaN, NA_real_), c(NaN, NA_real_))
})
test_that("works with complex missing values", {
na <- complex(
real = c(NA_real_, NA_real_, NaN, NaN),
imaginary = c(NA_real_, NaN, NA_real_, NaN)
)
expect_identical(vec_set_symmetric_difference(na, na), complex())
expect_identical(vec_set_symmetric_difference(na[-2], na[-4]), na[c(4, 2)])
})
test_that("works correctly with unspecified logical vectors", {
expect_identical(vec_set_symmetric_difference(NA, NA), logical())
})
test_that("returns a vector of the common type", {
expect_identical(vec_set_symmetric_difference(c(3L, 1L), c(2, 1)), c(3, 2))
})
test_that("works with data frames", {
x <- data_frame(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
)
y <- data_frame(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
)
expect_identical(
vec_set_symmetric_difference(x, y),
vec_c(vec_slice(x, 1), vec_slice(y, c(2, 4)))
)
expect_identical(
vec_set_symmetric_difference(y, x),
vec_c(vec_slice(y, c(2, 4)), vec_slice(x, 1))
)
})
test_that("works with rcrds", {
x <- new_rcrd(list(
a = c(1, 2, 1, 1),
b = c("a", "b", "a", "d")
))
y <- new_rcrd(list(
a = c(2, 3, 1, 2),
b = c("b", "b", "d", "d")
))
expect_identical(
vec_set_symmetric_difference(x, y),
vec_c(vec_slice(x, 1), vec_slice(y, c(2, 4)))
)
expect_identical(
vec_set_symmetric_difference(y, x),
vec_c(vec_slice(y, c(2, 4)), vec_slice(x, 1))
)
})
# common ------------------------------------------------------------------
test_that("works with package version columns of data frames (#1837)", {
package_frame <- function(x) {
data_frame(version = package_version(x))
}
x <- package_frame(c("4.0", "2.0"))
y <- package_frame(c("1.0", "3.0" ,"4.0"))
expect_identical(vec_set_intersect(x, y), package_frame("4.0"))
expect_identical(vec_set_difference(x, y), package_frame("2.0"))
expect_identical(vec_set_union(x, y), package_frame(c("4.0", "2.0", "1.0", "3.0")))
expect_identical(vec_set_symmetric_difference(x, y), package_frame(c("2.0", "1.0", "3.0")))
})
test_that("errors nicely if common type can't be taken", {
expect_snapshot(error = TRUE, {
vec_set_intersect(1, "x")
})
expect_snapshot(error = TRUE, {
vec_set_difference(1, "x")
})
expect_snapshot(error = TRUE, {
vec_set_union(1, "x")
})
expect_snapshot(error = TRUE, {
vec_set_symmetric_difference(1, "x")
})
})
test_that("dots must be empty", {
expect_snapshot(error = TRUE, {
vec_set_intersect(1, 2, 3)
})
expect_snapshot(error = TRUE, {
vec_set_difference(1, 2, 3)
})
expect_snapshot(error = TRUE, {
vec_set_union(1, 2, 3)
})
expect_snapshot(error = TRUE, {
vec_set_symmetric_difference(1, 2, 3)
})
})
test_that("`ptype` is respected", {
expect_identical(vec_set_intersect(1, 1, ptype = integer()), 1L)
expect_identical(vec_set_difference(1, 1, ptype = integer()), integer())
expect_identical(vec_set_union(1, 2, ptype = integer()), c(1L, 2L))
expect_identical(vec_set_symmetric_difference(1, 2, ptype = integer()), c(1L, 2L))
expect_snapshot(error = TRUE, {
vec_set_intersect(1, 1.5, ptype = integer())
})
expect_snapshot(error = TRUE, {
vec_set_difference(1, 1.5, ptype = integer())
})
expect_snapshot(error = TRUE, {
vec_set_union(1, 1.5, ptype = integer())
})
expect_snapshot(error = TRUE, {
vec_set_symmetric_difference(1, 1.5, ptype = integer())
})
})
test_that("`x_arg` and `y_arg` can be adjusted", {
expect_snapshot(error = TRUE, {
vec_set_intersect(1, "2", x_arg = "foo", y_arg = "bar")
})
expect_snapshot(error = TRUE, {
vec_set_difference(1, "2", x_arg = "foo", y_arg = "bar")
})
expect_snapshot(error = TRUE, {
vec_set_union(1, "2", x_arg = "foo", y_arg = "bar")
})
expect_snapshot(error = TRUE, {
vec_set_symmetric_difference(1, "2", x_arg = "foo", y_arg = "bar")
})
expect_snapshot(error = TRUE, {
vec_set_intersect(1, "2", x_arg = "", y_arg = "")
})
})
test_that("`error_call` can be adjusted", {
my_set_intersect <- function() {
vec_set_intersect(1, "x", error_call = current_env())
}
my_set_difference <- function() {
vec_set_difference(1, "x", error_call = current_env())
}
my_set_union <- function() {
vec_set_union(1, "x", error_call = current_env())
}
my_set_symmetric_difference <- function() {
vec_set_symmetric_difference(1, "x", error_call = current_env())
}
expect_snapshot(error = TRUE, {
my_set_intersect()
})
expect_snapshot(error = TRUE, {
my_set_difference()
})
expect_snapshot(error = TRUE, {
my_set_union()
})
expect_snapshot(error = TRUE, {
my_set_symmetric_difference()
})
})
vctrs/tests/testthat/test-split.R 0000644 0001762 0000144 00000002250 14276722575 016670 0 ustar ligges users
test_that("can split empty vector", {
out <- vec_split(integer(), character())
expect_s3_class(out, "data.frame")
expect_equal(out$key, character())
expect_equal(out$val, list())
})
test_that("split data frame with data frame", {
df <- data.frame(x = c(1, 1, 2), y = c(1, 1, 1))
out <- vec_split(df, df)
expect_s3_class(out, "data.frame")
expect_equal(out$key, data.frame(x = c(1, 2), y = c(1, 1)))
expect_equal(out$val, list(
data.frame(x = c(1, 1), y = c(1, 1)),
data.frame(x = 2, y = 1)
))
})
test_that("x and by must be same size", {
expect_error(
vec_split(1:3, 1:2),
"same size"
)
})
test_that("split takes the equality proxy (#375)", {
local_comparable_tuple()
x <- tuple(c(1, 2, 1), 1:3)
expect_identical(nrow(vec_split(1:3, x)), 2L)
})
test_that("split works with different encodings", {
encs <- encodings()
expect_identical(nrow(vec_split(1:3, encs)), 1L)
})
test_that("`key` and `value` retain names", {
x <- c(a = 1, b = 2, c = 1, a = 1)
split <- vec_split(x, x)
expect_identical(split$key, c(a = 1, b = 2))
expect_identical(split$val[[1]], c(a = 1, c = 1, a = 1))
expect_identical(split$val[[2]], c(b = 2))
})
vctrs/tests/testthat/test-order.R 0000644 0001762 0000144 00000136402 14511320527 016636 0 ustar ligges users # ------------------------------------------------------------------------------
# vec_order_radix() - insertion
test_that("can order size zero input", {
expect_identical(vec_order_radix(integer()), integer())
})
test_that("can order integers", {
x <- c(2L, 3L, 1L, 5L)
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- 1:5
expect_identical(vec_order_radix(x), order(x))
})
test_that("orders correctly around the UINT8_MAX boundary", {
x <- 251:255
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c(1L, 3L, 1L, 3L)
expect_identical(vec_order_radix(x)[1:2], c(1L, 3L))
expect_identical(vec_order_radix(x)[3:4], c(2L, 4L))
})
test_that("`NA` order defaults to last", {
x <- c(1L, NA_integer_, 3L)
expect_identical(vec_order_radix(x), c(1L, 3L, 2L))
})
test_that("integer, small: `NA` order can be first", {
x <- c(1L, NA_integer_, 3L)
expect_identical(vec_order_radix(x, na_value = "smallest"), c(2L, 1L, 3L))
})
test_that("double: `direction` can be set to `desc`", {
x <- c(1, 5, 3)
expect_identical(vec_order_radix(x, direction = "desc"), c(2L, 3L, 1L))
x <- c(1L, .Machine$integer.max, 3L)
expect_identical(vec_order_radix(x, direction = "desc"), c(2L, 3L, 1L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(3L, NA_integer_, 1L, 2L)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("all `NA` values works", {
x <- c(NA_integer_, NA_integer_)
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order when in expected order", {
x <- c(1L, 1L, 2L, NA, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 1:5)
x <- c(NA, NA, 3L, 3L, 2L)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 1:5)
x <- c(NA, NA, 1L, 1L, 2L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 1:5)
x <- c(3L, 3L, 2L, NA, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 1:5)
})
test_that("can order when in strictly opposite of expected order (no ties)", {
x <- c(NA, 2L, 1L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 3:1)
x <- c(1L, 2L, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 3:1)
x <- c(2L, 1L, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 3:1)
x <- c(NA, 1L, 2L)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 3:1)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - counting
# To trigger counting ordering, get above the insertion order boundary and then
# have a range less than the counting order range boundary.
test_that("can order integers with counting order", {
x <- (ORDER_INSERTION_BOUNDARY + 1L):1L
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- 1:(ORDER_INSERTION_BOUNDARY + 1L)
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c(1:ORDER_INSERTION_BOUNDARY, 1L)
expect_identical(vec_order_radix(x)[1:2], c(1L, ORDER_INSERTION_BOUNDARY + 1L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(3L, NA_integer_, 1L, 2L, 1:ORDER_INSERTION_BOUNDARY)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - radix
# To trigger radix ordering, get above the insertion order boundary and then
# have a range greater than the counting order range boundary.
test_that("can order integers with radix order", {
x <- c(INT_ORDER_COUNTING_RANGE_BOUNDARY + 1L, 1:ORDER_INSERTION_BOUNDARY)
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- c(1:ORDER_INSERTION_BOUNDARY, INT_ORDER_COUNTING_RANGE_BOUNDARY + 1L)
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c(1:ORDER_INSERTION_BOUNDARY, 1L, INT_ORDER_COUNTING_RANGE_BOUNDARY + 1L)
expect_identical(vec_order_radix(x)[1:2], c(1L, ORDER_INSERTION_BOUNDARY + 1L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(3L, NA_integer_, 1L, 2L, 1:ORDER_INSERTION_BOUNDARY, INT_ORDER_COUNTING_RANGE_BOUNDARY + 1L)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("can order all 1 value", {
x <- rep(1L, ORDER_INSERTION_BOUNDARY + 1L)
expect_identical(vec_order_radix(x), base_order(x))
expect_identical(vec_order_radix(x, direction = "desc"), base_order(x, decreasing = TRUE))
})
test_that("all `NA` values works - ensures that we can compute the 'range' of all NAs", {
x <- rep(NA_integer_, ORDER_INSERTION_BOUNDARY + 1L)
expect_identical(vec_order_radix(x), base_order(x))
expect_identical(vec_order_radix(x, direction = "desc"), base_order(x, decreasing = TRUE))
})
test_that("can order with many NAs first", {
x <- c(rep(NA_integer_, ORDER_INSERTION_BOUNDARY + 1L), 2L)
expect_identical(vec_order_radix(x), base_order(x))
expect_identical(vec_order_radix(x, na_value = "smallest"), base_order(x, na.last = FALSE))
})
test_that("subtraction in counting order range computation works correctly (#1399)", {
x <- c(rep(1L, ORDER_INSERTION_BOUNDARY), -2147483647L)
expect_identical(vec_order_radix(x), base_order(x))
})
# ------------------------------------------------------------------------------
# vec_order_radix()
# Really this just goes through the integer infrastructure. Just checking that
# it is working.
test_that("can order size zero input", {
expect_identical(vec_order_radix(logical()), integer())
})
test_that("can order logicals", {
x <- c(FALSE, TRUE, FALSE)
expect_identical(vec_order_radix(x), order(x))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(TRUE, NA, FALSE)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("all `NA` values works", {
x <- c(NA, NA)
expect_identical(vec_order_radix(x), order(x))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - insertion
test_that("can order size zero input", {
expect_identical(vec_order_radix(double()), integer())
})
test_that("can order doubles", {
x <- c(2, 3, 1, 5)
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- 1:5 + 0
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c(1, 3, 1, 3)
expect_identical(vec_order_radix(x)[1:2], c(1L, 3L))
expect_identical(vec_order_radix(x)[3:4], c(2L, 4L))
})
test_that("`NA` order defaults to last", {
x <- c(1, NA_real_, 3)
expect_identical(vec_order_radix(x), c(1L, 3L, 2L))
})
test_that("double: `NA` order can be first", {
x <- c(1, NA_real_, 3)
expect_identical(vec_order_radix(x, na_value = "smallest"), c(2L, 1L, 3L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(3, NA_real_, 1, 2)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("all `NA` values works", {
x <- c(NA_real_, NA_real_)
expect_identical(vec_order_radix(x), order(x))
})
test_that("NA_real_ and NaN look identical for ordering", {
x <- c(NA_real_, NaN)
expect_identical(vec_order_radix(x, na_value = "largest"), c(1L, 2L))
expect_identical(vec_order_radix(x, na_value = "smallest"), c(1L, 2L))
})
test_that("double: -Inf / Inf order correctly", {
x <- c(0, -Inf, Inf)
expect_identical(vec_order_radix(x, direction = "asc"), c(2L, 1L, 3L))
expect_identical(vec_order_radix(x, direction = "desc"), c(3L, 1L, 2L))
})
test_that("double: -0 and 0 order identically / stably", {
x <- c(0, -0)
expect_identical(vec_order_radix(x, direction = "desc"), c(1L, 2L))
expect_identical(vec_order_radix(x, direction = "asc"), c(1L, 2L))
})
test_that("can order when in expected order", {
x <- c(1, 1, 2, NA, NaN)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 1:5)
x <- c(NA, NaN, 3, 3, 2)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 1:5)
x <- c(NA, NaN, 1, 1, 2)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 1:5)
x <- c(3, 3, 2, NA, NaN)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 1:5)
})
test_that("can order when in expected order - using distinct NaN values", {
x <- c(1, 1, 2, NaN, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest", nan_distinct = TRUE), 1:5)
x <- c(NA, NaN, 3, 3, 2)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest", nan_distinct = TRUE), 1:5)
x <- c(NA, NaN, 1, 1, 2)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest", nan_distinct = TRUE), 1:5)
x <- c(3, 3, 2, NaN, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest", nan_distinct = TRUE), 1:5)
})
test_that("can order when in strictly opposite of expected order (no ties)", {
x <- c(NA, 2, 1)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 3:1)
x <- c(1, 2, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 3:1)
x <- c(2, 1, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 3:1)
x <- c(NA, 1, 2)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 3:1)
})
test_that("can order when in strictly opposite of expected order (no ties) - using distinct NaN values", {
x <- c(NA, NaN, 2, 1)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest", nan_distinct = TRUE), 4:1)
x <- c(1, 2, NaN, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest", nan_distinct = TRUE), 4:1)
x <- c(2, 1, NaN, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest", nan_distinct = TRUE), 4:1)
x <- c(NA, NaN, 1, 2)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest", nan_distinct = TRUE), 4:1)
})
test_that("NaN is always placed next to numbers when treated as distinct", {
x <- c(1, 2, NA, NaN)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest", nan_distinct = TRUE), c(1L, 2L, 4L, 3L))
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest", nan_distinct = TRUE), c(3L, 4L, 1L, 2L))
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest", nan_distinct = TRUE), c(3L, 4L, 2L, 1L))
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest", nan_distinct = TRUE), c(2L, 1L, 4L, 3L))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - radix
# To trigger radix ordering, get above the insertion order boundary. There is
# no intermediate counting sort for doubles.
test_that("can order doubles with radix order", {
x <- (ORDER_INSERTION_BOUNDARY + 1L):1L + 0
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- 1:(ORDER_INSERTION_BOUNDARY + 1L) + 0
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c(1:ORDER_INSERTION_BOUNDARY, 1L) + 0
expect_identical(vec_order_radix(x)[1:2], c(1L, ORDER_INSERTION_BOUNDARY + 1L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c(3, NA_real_, 1, 2, 1:ORDER_INSERTION_BOUNDARY)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("all `NA` values works", {
x <- rep(NA_real_, ORDER_INSERTION_BOUNDARY + 1L)
expect_identical(vec_order_radix(x), order(x))
})
test_that("NA_real_ and NaN generally look identical for ordering", {
x <- rep(c(NA_real_, NaN), ORDER_INSERTION_BOUNDARY + 1L)
expect_identical(vec_order_radix(x, na_value = "largest"), seq_along(x))
expect_identical(vec_order_radix(x, na_value = "smallest"), seq_along(x))
})
test_that("NA_real_ and NaN can be considered distinct with `nan_distinct`", {
x <- rep(c(NA_real_, NaN), ORDER_INSERTION_BOUNDARY + 1L)
loc_nan <- seq(2L, length(x), by = 2L)
loc_na <- seq(1L, length(x), by = 2L)
expect_identical(vec_order_radix(x, na_value = "largest", nan_distinct = TRUE), c(loc_nan, loc_na))
expect_identical(vec_order_radix(x, na_value = "smallest", nan_distinct = TRUE), c(loc_na, loc_nan))
})
test_that("-Inf / Inf order correctly", {
x <- c(rep(0, ORDER_INSERTION_BOUNDARY), -Inf, Inf)
expect_identical(vec_order_radix(x, direction = "asc"), order(x, decreasing = FALSE))
expect_identical(vec_order_radix(x, direction = "desc"), order(x, decreasing = TRUE))
})
test_that("double, large: -0 and 0 order identically / stably", {
x <- c(rep(0, ORDER_INSERTION_BOUNDARY), -0)
expect_identical(vec_order_radix(x, direction = "desc"), order(x, decreasing = TRUE))
expect_identical(vec_order_radix(x, direction = "asc"), order(x, decreasing = FALSE))
})
# ------------------------------------------------------------------------------
# vec_order_radix()
test_that("can order size zero input", {
expect_identical(vec_order_radix(complex()), integer())
})
test_that("can order complex", {
x <- complex(real = c(3, 1, 2))
expect_identical(vec_order_radix(x), c(2L, 3L, 1L))
})
test_that("ordering on ties is done stably", {
x <- complex(real = c(1, 3, 1, 3))
expect_identical(vec_order_radix(x)[1:2], c(1L, 3L))
expect_identical(vec_order_radix(x)[3:4], c(2L, 4L))
})
test_that("imaginary section is used to break ties", {
x <- complex(
real = c(1L, 2L, 1L),
imaginary = c(3L, 2L, 1L)
)
expect_identical(vec_order_radix(x), c(3L, 1L, 2L))
})
test_that("can be used in a data frame", {
x <- c(1L, 1L, 1L, 2L, 1L)
y <- complex(
real = c(1L, 2L, 1L, 3L, 1L),
imaginary = c(3L, 2L, 1L, 4L, 1L)
)
z <- c(1, 2, 5, 4, 3)
# as second column
df1 <- data.frame(x = x, y = y)
# as first column
df2 <- data.frame(y = y, x = x)
# as second column with a third after it to break ties
df3 <- data.frame(x = x, y = y, z = z)
# Base R can't do radix sorting with complex
expect_identical(vec_order_radix(df1), c(3L, 5L, 1L, 2L, 4L))
expect_identical(vec_order_radix(df2), c(3L, 5L, 1L, 2L, 4L))
expect_identical(vec_order_radix(df3), c(5L, 3L, 1L, 2L, 4L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- complex(real = c(3, NA, 1.5, 2, NA), imaginary = c(1, 1, 1, 1, 2))
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
# In fixing #1403, we now align with base R
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("full gambit of tests involving missing values are working as expected (#1403)", {
x <- complex(
real = c(NaN, NA, NA, NA, NaN, NaN, 1, 1, 1, 2),
imaginary = c(NA, NA, NaN, 1, NaN, 1, NA, NaN, 1, NA)
)
df <- data_frame(a = rep(1L, length(x)), x = x)
# {number}, {NaN}, {NaN + NA}, {NA + NaN}, {NA}
expect <- c(9L, 5L, 6L, 8L, 1L, 3L, 2L, 4L, 7L, 10L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(df, direction = "asc", na_value = "largest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(df, direction = "desc", na_value = "smallest", nan_distinct = TRUE), expect)
# {NA}, {NA + NaN}, {NaN + NA}, {NaN}, {number}
expect <- c(2L, 4L, 7L, 10L, 3L, 1L, 5L, 6L, 8L, 9L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(df, direction = "asc", na_value = "smallest", nan_distinct = TRUE), expect)
expect_identical(vec_order_radix(df, direction = "desc", na_value = "largest", nan_distinct = TRUE), expect)
# {number}, {NA or NaN}
expect <- c(9L, 1:7, 8L, 10L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(df, direction = "asc", na_value = "largest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(df, direction = "desc", na_value = "smallest", nan_distinct = FALSE), expect)
# {NA or NaN}, {number}
expect <- c(1:8, 10L, 9L)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(df, direction = "asc", na_value = "smallest", nan_distinct = FALSE), expect)
expect_identical(vec_order_radix(df, direction = "desc", na_value = "largest", nan_distinct = FALSE), expect)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - insertion
test_that("can order size zero input", {
expect_identical(vec_order_radix(character()), integer())
})
test_that("can order characters", {
x <- c("xy", "x", "a", "bc")
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order sorted vector", {
x <- c("a", "b", "c")
expect_identical(vec_order_radix(x), order(x))
})
test_that("ordering on ties is done stably", {
x <- c("ab", "ba", "ab", "ba")
expect_identical(vec_order_radix(x)[1:2], c(1L, 3L))
expect_identical(vec_order_radix(x)[3:4], c(2L, 4L))
})
test_that("`NA` order defaults to last", {
x <- c("x", NA_character_, "y")
expect_identical(vec_order_radix(x), c(1L, 3L, 2L))
})
test_that("character, small: `NA` order can be first", {
x <- c("x", NA_character_, "y")
expect_identical(vec_order_radix(x, na_value = "smallest"), c(2L, 1L, 3L))
})
test_that("character, small: `direction` can be set to `desc`", {
x <- c("x", "abcde", "yz")
expect_identical(vec_order_radix(x, direction = "desc"), c(3L, 1L, 2L))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- c("aaa", NA_character_, "a", "aa")
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[order(x, na.last = TRUE, decreasing = TRUE)]
)
})
test_that("all `NA` values works", {
x <- c(NA_character_, NA_character_)
expect_identical(vec_order_radix(x), order(x))
})
test_that("can order empty string vs ASCII value 1 'Start of Header'", {
x <- c("\001", "")
expect_identical(vec_order_radix(x), c(2L, 1L))
})
test_that("can be used in a data frame", {
x <- c(1L, 4L, 1L, 3L, 1L)
y <- c("zy", "zz", "abcd", "gfa", "zy")
z <- c(1, 2, 5, 4, 3)
# as second column
df1 <- data.frame(x = x, y = y)
# as first column
df2 <- data.frame(y = y, x = x)
# as second column with a third after it to break ties
df3 <- data.frame(x = x, y = y, z = z)
expect_identical(vec_order_radix(df1), base_order(df1))
expect_identical(vec_order_radix(df2), base_order(df2))
expect_identical(vec_order_radix(df3), base_order(df3))
})
test_that("can have multiple character columns in a data frame", {
df <- data.frame(
x = c("def", "aba", "aba", "aba", "q"),
y = c("zy", "zz", "zz", "gfa", "zy"),
z = c("foo", "qux", "bar", "baz", "boo")
)
expect_identical(vec_order_radix(df), base_order(df))
})
test_that("can order with varying encodings by converting to UTF-8", {
encs <- encodings()
x <- c(encs$utf8, encs$unknown, encs$latin1, "AC")
expect_identical(vec_order_radix(x), c(4L, 1L, 2L, 3L))
expect_identical(vec_order_radix(x, direction = "desc"), c(1L, 2L, 3L, 4L))
})
test_that("can order when in expected order", {
x <- c("a", "a", "b", NA, NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 1:5)
x <- c(NA, NA, "c", "c", "b")
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 1:5)
x <- c(NA, NA, "a", "a", "b")
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 1:5)
x <- c("c", "c", "b", NA, NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 1:5)
})
test_that("can order when in strictly opposite of expected order (no ties)", {
x <- c(NA, "b", "a")
expect_identical(vec_order_radix(x, direction = "asc", na_value = "largest"), 3:1)
x <- c("a", "b", NA)
expect_identical(vec_order_radix(x, direction = "desc", na_value = "largest"), 3:1)
x <- c("b", "a", NA)
expect_identical(vec_order_radix(x, direction = "asc", na_value = "smallest"), 3:1)
x <- c(NA, "a", "b")
expect_identical(vec_order_radix(x, direction = "desc", na_value = "smallest"), 3:1)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - radix
# Have to get the number of unique strings above the ORDER_INSERTION_BOUNDARY
# to trigger radix ordering.
test_that("can order character vectors", {
x <- paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L))
expect_identical(vec_order_radix(x), base_order(x))
})
test_that("ordering on ties is done stably", {
x <- c(paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L)), "x1")
expect_identical(vec_order_radix(x)[1:2], c(1L, length(x)))
})
test_that("`NA` order defaults to last", {
x <- paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L))
x <- c(x, NA_character_, "y")
expect_identical(vec_order_radix(x)[length(x)], length(x) - 1L)
})
test_that("character, large: `NA` order can be first", {
x <- paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L))
x <- c(x, NA_character_, "y")
expect_identical(vec_order_radix(x, na_value = "smallest")[[1L]], length(x) - 1L)
})
test_that("character, large: `direction` can be set to `desc`", {
x <- paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L))
expect_identical(vec_order_radix(x, direction = "desc"), base_order(x, decreasing = TRUE))
})
test_that("all combinations of `direction` and `na_value` work", {
x <- paste0("x", seq(1L, ORDER_INSERTION_BOUNDARY + 1L))
x <- c(x, NA_character_, "x", "aa", "x1")
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "asc")],
x[base_order(x, na.last = TRUE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "asc")],
x[base_order(x, na.last = FALSE, decreasing = FALSE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "largest", direction = "desc")],
x[base_order(x, na.last = FALSE, decreasing = TRUE)]
)
expect_identical(
x[vec_order_radix(x, na_value = "smallest", direction = "desc")],
x[base_order(x, na.last = TRUE, decreasing = TRUE)]
)
})
# ------------------------------------------------------------------------------
# vec_order_radix()
test_that("list elements are ordered by first appearance", {
expect_identical(vec_order_radix(list(1:2, "a", 1:2)), c(1L, 3L, 2L))
})
test_that("missing values in lists are respected (#1401)", {
x <- list(1, NULL, 2, NULL)
expect_identical(vec_order_radix(x, na_value = "largest"), c(1L, 3L, 2L, 4L))
expect_identical(vec_order_radix(x, na_value = "smallest"), c(2L, 4L, 1L, 3L))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - insertion
test_that("data frame with no columns and no rows returns integer()", {
x <- data.frame()
expect_identical(vec_order_radix(x), integer())
})
test_that("data frame with no columns and some rows returns sequential rows", {
x <- new_data_frame(n = 5L)
expect_identical(vec_order_radix(x), 1:5)
})
test_that("can order with multiple pre-sorted keys", {
df <- data.frame(x = 1:2, y = 3:4)
expect_identical(vec_order_radix(df), 1:2)
})
test_that("first column has ordering presedence", {
df <- data.frame(x = c(3L, 2L, 1L), y = c(1L, 2L, 3L))
expect_identical(vec_order_radix(df), 3:1)
})
test_that("secondary columns break ties - integer", {
df <- data.frame(
x = c(1L, 2L, 1L),
y = c(3L, 2L, 1L)
)
expect_identical(vec_order_radix(df), c(3L, 1L, 2L))
})
test_that("secondary columns break ties - double", {
df <- data.frame(
x = c(1, 2, 1),
y = c(3, 2, 1)
)
expect_identical(vec_order_radix(df), c(3L, 1L, 2L))
})
test_that("secondary columns break ties - logical", {
df <- data.frame(
x = c(FALSE, TRUE, FALSE),
y = c(TRUE, TRUE, FALSE)
)
expect_identical(vec_order_radix(df), c(3L, 1L, 2L))
})
test_that("orders correctly when first column is already ordered but second isn't", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L),
y = c(3L, 2L, 4L, 1L)
)
expect_identical(vec_order_radix(df), c(2L, 1L, 4L, 3L))
})
test_that("orders correctly when first column is already ordered but second isn't - character", {
df <- data.frame(
x = c("a", "a", "b", "b"),
y = c("c", "b", "d", "a")
)
expect_identical(vec_order_radix(df), c(2L, 1L, 4L, 3L))
})
test_that("`direction` is recycled", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L),
y = c(3L, 2L, 4L, 1L)
)
expect_identical(vec_order_radix(df, direction = "desc"), c(3L, 4L, 1L, 2L))
})
test_that("`na_value` is recycled", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L, NA),
y = c(3L, 2L, 4L, 1L, NA)
)
expect_identical(vec_order_radix(df, na_value = "smallest"), c(5L, 2L, 1L, 4L, 3L))
})
test_that("`direction` can be a vector", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L, NA, 1L),
y = c(3L, 2L, 4L, 1L, 3L, NA)
)
expect_identical(vec_order_radix(df, direction = c("desc", "asc")), c(5L, 4L, 3L, 2L, 1L, 6L))
})
test_that("`na_value` can be a vector", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L, NA, NA),
y = c(3L, 2L, 4L, 1L, NA, 2)
)
expect_identical(vec_order_radix(df, na_value = c("smallest", "largest")), c(6L, 5L, 2L, 1L, 4L, 3L))
})
test_that("`na_value` and `direction` can both be vectors", {
df <- data.frame(
x = c(1L, 1L, 2L, 2L, NA, NA),
y = c(3L, 2L, 4L, 1L, NA, 2)
)
expect_identical(
vec_order_radix(df, direction = c("desc", "asc"), na_value = c("smallest", "largest")),
c(4:1, 6:5)
)
})
test_that("`direction` is recycled right with array columns (#1753)", {
df <- data_frame(
x = matrix(c(1, 1, 1, 3, 2, 2), ncol = 2),
y = 3:1
)
expect_identical(
vec_order_radix(df, direction = c("asc", "desc")),
c(2L, 3L, 1L)
)
expect_snapshot(error = TRUE, {
vec_order_radix(df, direction = c("asc", "desc", "desc"))
})
df <- data_frame(
x = array(c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 3, 3), dim = c(3, 2, 2)),
y = 3:1
)
expect_identical(
vec_order_radix(df, direction = c("asc", "desc")),
c(2L, 3L, 1L)
)
})
test_that("`na_value` is recycled right with array columns (#1753)", {
df <- data_frame(
x = matrix(c(1, 1, 1, 3, NA, 2), ncol = 2),
y = 3:1
)
expect_identical(
vec_order_radix(df, na_value = c("largest", "smallest")),
c(3L, 1L, 2L)
)
expect_identical(
vec_order_radix(df, na_value = c("smallest", "largest")),
c(2L, 3L, 1L)
)
expect_snapshot(error = TRUE, {
vec_order_radix(df, direction = c("smallest", "largest", "largest"))
})
df <- data_frame(
x = array(c(1, 1, 1, 2, 2, 2, 3, 3, 3, 4, NA, 3), dim = c(3, 2, 2)),
y = 3:1
)
expect_identical(
vec_order_radix(df, na_value = c("largest", "smallest")),
c(3L, 1L, 2L)
)
expect_identical(
vec_order_radix(df, na_value = c("smallest", "largest")),
c(2L, 3L, 1L)
)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - counting
test_that("can order 2+ integer column chunks with counting sort", {
half <- floor(ORDER_INSERTION_BOUNDARY / 2) + 1L
quarter_low <- floor(half / 2)
quarter_high <- ceiling(half / 2)
df <- data.frame(
x = 1L,
y = c(rep(2L, quarter_low), rep(1L, quarter_high), rep(3L, half))
)
expect_identical(vec_order_radix(df), base_order(df))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - radix
test_that("can order 2+ integer column chunks with radix sort", {
half <- floor(ORDER_INSERTION_BOUNDARY / 2) + 1L
quarter_low <- floor(half / 2)
quarter_high <- ceiling(half / 2)
df <- data.frame(
x = 1L,
y = c(rep(2L, quarter_low), rep(1L, quarter_high), rep(3L, half), INT_ORDER_COUNTING_RANGE_BOUNDARY + 1L)
)
expect_identical(vec_order_radix(df), base_order(df))
})
test_that("can order 2+ double column chunks with radix sort", {
half <- floor(ORDER_INSERTION_BOUNDARY / 2) + 1L
quarter_low <- floor(half / 2)
quarter_high <- ceiling(half / 2)
df <- data.frame(
x = 1,
y = c(rep(2, quarter_low), rep(1, quarter_high), rep(3, half), INT_ORDER_COUNTING_RANGE_BOUNDARY + 1)
)
expect_identical(vec_order_radix(df), base_order(df))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - chr_proxy_collate
test_that("`chr_proxy_collate` transforms string input", {
x <- c("b", "a", "A")
expect_identical(vec_order_radix(x, chr_proxy_collate = tolower), c(2L, 3L, 1L))
expect_identical(vec_order_radix(x, chr_proxy_collate = ~tolower(.x)), c(2L, 3L, 1L))
})
test_that("`chr_proxy_collate` works with data frame columns and is applied to all string columns", {
df <- data_frame(x = c(1, 1, 1), y = c("B", "a", "a"), z = c("a", "D", "c"))
expect_identical(vec_order_radix(df, chr_proxy_collate = tolower), c(3L, 2L, 1L))
})
test_that("`chr_proxy_collate` is validated", {
expect_error(vec_order_radix("x", chr_proxy_collate = 1), "Can't convert `chr_proxy_collate` to a function")
expect_error(vec_order_radix("x", chr_proxy_collate = ~c("y", "z")), "1, not 2")
expect_error(vec_order_radix("x", chr_proxy_collate = ~1), "character vector")
expect_error(vec_order_radix("x", chr_proxy_collate = function() {"y"}))
})
test_that("`chr_proxy_collate` can return bytes-encoded strings (like `stringi::stri_sort_key()`)", {
x <- c("A", "a", "b", "B")
# Mimic stringi::stri_sort_key(x, locale = "en")
sort_key <- function(x) {
# dput(lapply(stringi::stri_sort_key(x, locale = "en"), charToRaw))
out <- list(
as.raw(c(0x2a, 0x01, 0x05, 0x01, 0xdc)),
as.raw(c(0x2a, 0x01, 0x05, 0x01, 0x05)),
as.raw(c(0x2c, 0x01, 0x05, 0x01, 0x05)),
as.raw(c(0x2c, 0x01, 0x05, 0x01, 0xdc))
)
out <- vapply(out, FUN.VALUE = character(1), function(x) {
# Uses native encoding
x <- rawToChar(x)
Encoding(x) <- "bytes"
x
})
out
}
expect_identical(
vec_order_radix(x, chr_proxy_collate = sort_key),
c(2L, 1L, 3L, 4L)
)
})
# ------------------------------------------------------------------------------
# vec_order_radix() - error checking
test_that("`na_value` is checked", {
expect_error(vec_order_radix(1L, na_value = "x"), "\"largest\" or \"smallest\"")
expect_error(vec_order_radix(1L, na_value = c(TRUE, TRUE)), "must be a character vector")
expect_error(vec_order_radix(1L, na_value = NA_character_), "can't be missing")
})
test_that("`direction` is checked", {
expect_error(vec_order_radix(1L, direction = "x"), "must contain only")
expect_error(vec_order_radix(1L, direction = c("asc", "asc")), "single value")
expect_error(vec_order_radix(1L, direction = NA_character_), "can't be missing")
expect_error(vec_order_radix(data.frame(x = 1), direction = c("asc", "asc")), "length 1 or")
})
test_that("`x` is checked", {
expect_error(vec_order_radix(foobar()), class = "vctrs_error_scalar_type")
})
# ------------------------------------------------------------------------------
# vec_order_radix() - groups
test_that("groups can be reallocated if we exceed the max group data size", {
set.seed(123)
# The first column has all unique groups so 1 more than the default group
# data size is needed and will be reallocated on the fly
df <- data.frame(
x = sample(GROUP_DATA_SIZE_DEFAULT + 1L, replace = TRUE),
y = sample(GROUP_DATA_SIZE_DEFAULT + 1L, replace = TRUE),
z = sample(GROUP_DATA_SIZE_DEFAULT + 1L, replace = TRUE)
)
expect_identical(vec_order_radix(df), base_order(df))
})
# ------------------------------------------------------------------------------
# vec_order_radix() - comparison proxy
test_that("ordering works with rcrd types", {
x <- tuple(c(1, 2, 1), c(3, 2, 1))
expect_identical(vec_order_radix(x), c(3L, 1L, 2L))
})
test_that("data frame comparison proxies don't allow vector `direction` or `na_value`", {
x <- tuple(c(1, 2, 1), c(3, 2, 1))
expect_error(vec_order_radix(x, direction = c("desc", "asc")), "single value")
expect_error(vec_order_radix(x, na_value = c("largest", "smallest")), "single value")
})
test_that("ordering works with df-cols", {
df_col <- new_data_frame(list(y = c(2, 1, 2), z = c(3, 3, 3)))
df <- new_data_frame(list(x = c(1, 1, 1), y = df_col))
expect_identical(vec_order_radix(df), c(2L, 1L, 3L))
# Can only supply a max of 2 `direction` or `na_value` values which get internally
# expanded to 3 to match the flattened df proxy
expect_identical(vec_order_radix(df, direction = c("asc", "desc")), c(1L, 3L, 2L))
expect_error(vec_order_radix(df, direction = c("desc", "desc", "asc")), "or length equal to")
})
test_that("ordering works with df-cols with 0 cols", {
df_col <- new_data_frame(list(), n = 3L)
df <- new_data_frame(list(x = c(1, 3, 1), y = df_col, z = c(2, 1, 1)))
expect_identical(vec_order_radix(df), c(3L, 1L, 2L))
# Can supply 3 `direction` values even though the 0-col df-col gets dropped
expect_identical(vec_order_radix(df, direction = c("asc", "desc", "desc")), c(1L, 3L, 2L))
expect_error(vec_order_radix(df, direction = c("desc", "asc")), "or length equal to")
})
test_that("ordering works with rcrd cols", {
y <- tuple(c(1, 2, 1), c(3, 2, 1))
df <- new_data_frame(list(z = c(1, 1, 1), y = y))
expect_identical(vec_order_radix(df), c(3L, 1L, 2L))
# Can only supply a max of 2 `direction` values which get internally
# expanded to 3 to match the flattened df proxy
expect_identical(vec_order_radix(df, direction = c("asc", "desc")), c(2L, 1L, 3L))
expect_error(vec_order_radix(df, direction = c("desc", "desc", "asc")), "or length equal to")
})
# ------------------------------------------------------------------------------
# `vec_order_radix()` - Pre-existing tests
test_that("can request NAs sorted first", {
expect_equal(vec_order_radix(c(1, NA), direction = "asc", na_value = "largest"), 1:2)
expect_equal(vec_order_radix(c(1, NA), direction = "desc", na_value = "largest"), 2:1)
expect_equal(vec_order_radix(c(1, NA), direction = "asc", na_value = "smallest"), 2:1)
expect_equal(vec_order_radix(c(1, NA), direction = "desc", na_value = "smallest"), 1:2)
})
test_that("can sort data frames", {
df <- data.frame(x = c(1, 2, 1), y = c(1, 2, 2))
out1 <- vec_sort(df)
expect_equal(out1, data.frame(x = c(1, 1, 2), y = c(1, 2, 2)))
out2 <- vec_sort(df, direction = "desc")
expect_equal(out2, data.frame(x = c(2, 1, 1), y = c(2, 2, 1)))
})
test_that("can sort empty data frames (#356)", {
df1 <- data.frame()
expect_equal(vec_sort(df1), df1)
df2 <- data.frame(x = numeric(), y = integer())
expect_equal(vec_sort(df2), df2)
})
test_that("can order tibbles that contain non-comparable objects", {
expect_equal(vec_order_radix(data_frame(x = list(10, 2, 1))), 1:3)
})
test_that("can order matrices and arrays (#306)", {
x <- matrix(c(1, 1, 1, 1, 2, 1), ncol = 2)
expect_identical(vec_order_radix(x), c(1L, 3L, 2L))
x <- array(1:8, c(2, 2, 2))
x[2] <- 1
x[3] <- 5
expect_identical(vec_order_radix(x), 2:1)
})
test_that("can order empty data frames (#356)", {
df1 <- data.frame()
expect_equal(vec_order_radix(df1), integer())
df2 <- data.frame(x = numeric(), y = integer())
expect_equal(vec_order_radix(df2), integer())
})
test_that("can order data frames with data frame columns (#527)", {
expect_equal(
vec_order_radix(iris),
vec_order_radix(data_frame(iris = iris))
)
})
test_that("can order data frames (and subclasses) with matrix columns", {
df <- new_data_frame(n = 2L)
df$x <- new_data_frame(list(y = matrix(1:2, 2)))
expect_identical(vec_order_radix(df), 1:2)
df$x <- tibble::tibble(y = matrix(1:2, 2))
expect_identical(vec_order_radix(df), 1:2)
})
# ------------------------------------------------------------------------------
# vec_locate_sorted_groups()
test_that("`vec_locate_sorted_groups()` is working", {
x <- c(1, 3, 1, 5, 2, 5, 1)
expect <- new_data_frame(
list(
key = c(1, 2, 3, 5),
loc = list(c(1L, 3L, 7L), 5L, 2L, c(4L, 6L))
)
)
expect_identical(vec_locate_sorted_groups(x), expect)
})
test_that("`chr_proxy_collate` can result in keys being seen as identical", {
x <- c("b", "A", "a")
y <- c("b", "a", "A")
x_expect <- data_frame(key = c("A", "b"), loc = list(c(2L, 3L), 1L))
y_expect <- data_frame(key = c("a", "b"), loc = list(c(2L, 3L), 1L))
expect_identical(vec_locate_sorted_groups(x, chr_proxy_collate = tolower), x_expect)
expect_identical(vec_locate_sorted_groups(y, chr_proxy_collate = tolower), y_expect)
})
# ------------------------------------------------------------------------------
# `vec_order_info(chr_ordered = FALSE)`
test_that("can order character vectors in appearance order", {
x <- c("b", "a", "B", "B", "a")
info <- vec_order_info(x, chr_ordered = FALSE)
expect_identical(info[[1]], c(1L, 2L, 5L, 3L, 4L))
expect_identical(info[[2]], c(1L, 2L, 2L))
expect_identical(info[[3]], 2L)
})
test_that("using appearance order means `direction` has no effect", {
x <- c("b", "a", "B", "B", "a")
info1 <- vec_order_info(x, direction = "asc", chr_ordered = FALSE)
info2 <- vec_order_info(x, direction = "desc", chr_ordered = FALSE)
expect_identical(info1[[1]], info2[[1]])
expect_identical(info1[[2]], info2[[2]])
expect_identical(info1[[3]], info2[[3]])
})
test_that("appearance order works with NA - `na_value` has no effect", {
x <- c(NA, "foo", NA, "bar")
info <- vec_order_info(x, chr_ordered = FALSE)
expect_identical(info[[1]], c(1L, 3L, 2L, 4L))
expect_identical(info[[2]], c(2L, 1L, 1L))
expect_identical(info[[3]], 2L)
})
test_that("appearance order can be mixed with regular ordering", {
x <- c("b", "a", "B", "B", "a", "a")
y <- c(1, 2, 3, 4, 1, 2)
df <- data_frame(x = x, y = y)
# `y` breaks ties
info <- vec_order_info(df, chr_ordered = FALSE)
expect_identical(info[[1]], c(1L, 5L, 2L, 6L, 3L, 4L))
expect_identical(info[[2]], c(1L, 1L, 2L, 1L, 1L))
expect_identical(info[[3]], 2L)
})
# ------------------------------------------------------------------------------
# `vec_order_info(nan_distinct = FALSE)`
test_that("Indistinct NA and NaN are reported in the same group", {
x <- c(NA, NaN)
info <- vec_order_info(x, nan_distinct = FALSE)
expect_identical(info[[1]], c(1L, 2L))
expect_identical(info[[2]], 2L)
expect_identical(info[[3]], 2L)
})
# ------------------------------------------------------------------------------
# `vec_order_info()`
test_that("Zero column data frames with >0 rows work (#1863)", {
# All rows are treated as being from the same group
x <- data_frame(.size = 5)
info <- vec_order_info(x)
expect_identical(info[[1]], 1:5) # Order
expect_identical(info[[2]], 5L) # Group sizes
expect_identical(info[[3]], 5L) # Max group size
})
test_that("Zero column data frames with exactly 0 rows work (#1863)", {
# This is a particularly special case, since we don't actually push a group size
x <- data_frame(.size = 0L)
info <- vec_order_info(x)
expect_identical(info[[1]], integer())
expect_identical(info[[2]], integer())
expect_identical(info[[3]], 0L)
})
# ------------------------------------------------------------------------------
# vec_sort
test_that("can sort data frames", {
df <- data.frame(x = c(1, 2, 1), y = c(1, 2, 2))
out1 <- vec_sort(df)
expect_equal(out1, data.frame(x = c(1, 1, 2), y = c(1, 2, 2)))
out2 <- vec_sort(df, direction = "desc")
expect_equal(out2, data.frame(x = c(2, 1, 1), y = c(2, 2, 1)))
})
test_that("can sort empty data frames (#356)", {
df1 <- data.frame()
expect_equal(vec_sort(df1), df1)
df2 <- data.frame(x = numeric(), y = integer())
expect_equal(vec_sort(df2), df2)
})
# ------------------------------------------------------------------------------
# vec_order
test_that("can request NAs sorted first", {
expect_equal(vec_order(c(1, NA), direction = "asc", na_value = "largest"), 1:2)
expect_equal(vec_order(c(1, NA), direction = "desc", na_value = "largest"), 2:1)
expect_equal(vec_order(c(1, NA), direction = "asc", na_value = "smallest"), 2:1)
expect_equal(vec_order(c(1, NA), direction = "desc", na_value = "smallest"), 1:2)
})
test_that("can order complex vectors", {
x <- complex(real = c(1, 2, 2, 3, 3), imaginary = c(5, 4, 3, 2, NA))
expect_equal(vec_order(x, direction = "asc", na_value = "largest"), c(1, 3, 2, 4, 5))
expect_equal(vec_order(x, direction = "desc", na_value = "largest"), rev(c(1, 3, 2, 4, 5)))
expect_equal(vec_order(x, direction = "asc", na_value = "smallest"), c(5, 1, 3, 2, 4))
expect_equal(vec_order(x, direction = "desc", na_value = "smallest"), rev(c(5, 1, 3, 2, 4)))
})
test_that("can order tibbles that contain non-comparable objects", {
expect_equal(vec_order(data_frame(x = list(10, 2, 1))), 1:3)
})
test_that("can order matrices and arrays (#306)", {
x <- matrix(c(1, 1, 1, 1, 2, 1), ncol = 2)
expect_identical(vec_order(x), c(1L, 3L, 2L))
x <- array(1:8, c(2, 2, 2))
x[2] <- 1
x[3] <- 5
expect_identical(vec_order(x), 2:1)
})
test_that("can order zero column data frames (#356, #1499)", {
df <- data_frame()
expect_identical(vec_order(df), integer())
df <- data_frame(.size = 5L)
expect_identical(vec_order(df), 1:5)
df <- data_frame(.size = 5L)
expect_identical(vec_order(df, direction = "desc"), 1:5)
})
test_that("can order zero row data frames (#356, #1499)", {
df <- data.frame(x = numeric())
expect_identical(vec_order(df), integer())
df <- data.frame(x = numeric(), y = integer())
expect_identical(vec_order(df), integer())
df <- data.frame(x = numeric(), y = integer())
expect_identical(vec_order(df, direction = "desc"), integer())
})
test_that("can order data frames with data frame columns (#527)", {
expect_equal(
vec_order(iris),
vec_order(data_frame(iris = iris))
)
})
test_that("can order data frames (and subclasses) with matrix columns", {
df <- new_data_frame(n = 2L)
df$x <- new_data_frame(list(y = matrix(1:2, 2)))
expect_identical(vec_order(df), 1:2)
df$x <- tibble::tibble(y = matrix(1:2, 2))
expect_identical(vec_order(df), 1:2)
})
test_that("classed proxies do not affect performance (tidyverse/dplyr#5423)", {
skip_on_cran()
x <- glue::glue("{1:10000}")
expect_time_lt(vec_order(x), 0.2)
})
test_that("can order data frames that don't allow removing the column names (#1298)", {
skip_if_not_installed("withr")
local_methods(
`names<-.vctrs_foobar` = function(x, value) {
if (is.null(value)) {
abort("Cannot remove names.")
}
NextMethod()
}
)
df <- foobar(data.frame(x = 1, y = 2))
expect_silent(expect_identical(vec_order(df), 1L))
})
test_that("missing values in lists are respected (#1401)", {
x <- list(1, NULL, 2, NULL)
expect_identical(vec_order(x, na_value = "largest"), c(1L, 3L, 2L, 4L))
expect_identical(vec_order(x, na_value = "smallest"), c(2L, 4L, 1L, 3L))
})
test_that("dots must be empty (#1647)", {
expect_snapshot(error = TRUE, {
vec_order(1, 2)
})
expect_snapshot(error = TRUE, {
vec_sort(1, 2)
})
})
vctrs/tests/testthat/test-hash.R 0000644 0001762 0000144 00000011100 14276722575 016452 0 ustar ligges users
# Vectorised --------------------------------------------------------------
test_that("vec_hash() produces same hash for same values", {
x <- vec_hash(1:3)
y <- do.call(c, map(1:3, vec_hash))
expect_identical(x, y)
})
test_that("F, T, and NA hash to different values", {
x <- map(c(TRUE, FALSE, NA), vec_hash)
expect_length(unique(x), 3)
})
test_that("vec_hash of double produces different values", {
x <- vec_hash(c(1, 1, 2))
expect_true(identical(x[1:4], x[5:8]))
expect_false(identical(x[5:8], x[9:12]))
})
test_that("NA and NaN hash to different values", {
x <- vec_hash(c(NA, NaN))
expect_false(identical(x[1:4], x[5:8]))
})
test_that("same string hashes to same value", {
x <- vec_hash(c("1", "1", "2"))
expect_true(identical(x[1:4], x[5:8]))
expect_false(identical(x[5:8], x[9:12]))
})
test_that("list hashes to values of individual values", {
x <- vec_hash(list(1:3, letters))
expect_identical(x[1:4], obj_hash(1:3))
expect_identical(x[5:8], obj_hash(letters))
x <- map(list(list(1:3), list(letters)), vec_hash)
expect_identical(x[[1]], obj_hash(1:3))
expect_identical(x[[2]], obj_hash(letters))
})
test_that("hash of data frame works down rows", {
df <- data.frame(x = 1:3, y = 1:3)
x <- vec_hash(df)
expect_length(x, 4 * vec_size(df))
expect_identical(x[1:4], vec_hash(df[1, ]))
})
test_that("hashes are consistent from run to run", {
# no string, since we're currently hashing the address in string pool
df <- list(
lgl = c(TRUE, FALSE, NA),
int = 1:100,
dbl1 = as.double(1:100),
dbl2 = seq(0, 1, length = 100)
)
hash <- lapply(df, vec_hash)
# Big-endian results are byte-swapped, but otherwise equivalent.
# Swap results so that there's no need to save results twice.
if (.Platform$endian == "big") {
hash <- lapply(
hash,
function(x) {
writeBin(readBin(x, "int", 100, endian = "big"), x, endian = "little")
}
)
}
local_options(max.print = 99999)
expect_snapshot(hash)
})
test_that("can hash list of non-vectors", {
x <- list(quote(x), mean)
expect_equal(
vec_hash(x),
c(obj_hash(x[[1]]), obj_hash(x[[2]]))
)
})
test_that("can hash matrices", {
x <- matrix(c(1, 1, 1, 2, 2, 1), c(3, 2))
expect_identical(
vec_hash(x),
vec_hash(x)
)
x <- matrix(c(1, 2, 3, 4), c(2, 2))
expect_identical(
vec_hash(x),
vec_hash(x)
)
expect_false(identical(
vec_hash(x),
vec_hash(c(1, 2))
))
y <- matrix(c(1, 2, 3, 5), c(2, 2))
expect_false(identical(
vec_hash(x),
vec_hash(y)
))
})
test_that("can hash NA", {
expect_identical(
vec_hash(NA),
vec_hash(NA),
)
})
test_that("can hash 1D arrays", {
# 1D arrays are dispatched to `as.data.frame.vector()` which
# currently does not strip dimensions. This caused an infinite
# recursion.
expect_length(vec_hash(array(1:2)), 8)
expect_identical(vec_hash(array(1:2)), vec_hash(1:2))
})
test_that("can hash raw vectors", {
expect_identical(vec_hash(0:255), vec_hash(as.raw(0:255)))
})
test_that("can hash complex vectors", {
expect_identical(
vec_hash(c(1, 2) + 0i),
c(obj_hash(c(1, 0)), obj_hash(c(2, 0)))
)
})
test_that("hash treats positive and negative 0 as equivalent (#637)", {
expect_equal(vec_hash(-0), vec_hash(0))
})
test_that("can hash lists of expressions", {
expect_equal(
vec_hash(list(expression(x), expression(y))),
c(obj_hash(expression(x)), obj_hash(expression(y)))
)
})
test_that("vec_hash() uses recursive equality proxy", {
x <- new_data_frame(list(x = foobar(1:3)))
default <- vec_hash(x)
local_methods(vec_proxy_equal.vctrs_foobar = function(...) c(0, 0, 0))
overridden <- vec_hash(x)
expect_false(identical(default, overridden))
})
# Object ------------------------------------------------------------------
test_that("equal objects hash to same value", {
# just test function since they'll recurse through every other object type
f1 <- function(x, y = NULL) x + y
f2 <- function(x, y = NULL) x + y
expect_false(identical(obj_hash(f1), obj_hash(f2)))
expect_false(identical(vec_hash(data_frame(x = list(f1))), vec_hash(data_frame(x = list(f2)))))
attr(f1, "srcref") <- NULL
attr(f2, "srcref") <- NULL
expect_equal(obj_hash(f1), obj_hash(f2))
expect_equal(vec_hash(data_frame(x = list(f1))), vec_hash(data_frame(x = list(f2))))
})
test_that("expression vectors hash to the same value as lists of calls/names", {
expect_equal(
obj_hash(expression(x, y)),
obj_hash(list(as.name("x"), as.name("y")))
)
expect_equal(
obj_hash(expression(mean(), sd())),
obj_hash(list(call("mean"), call("sd")))
)
})
vctrs/tests/testthat/test-rep.R 0000644 0001762 0000144 00000012041 14363556517 016320 0 ustar ligges users # ------------------------------------------------------------------------------
# vec_rep()
test_that("`vec_rep()` can repeat vectors", {
expect_identical(vec_rep(1:2, 5), rep(1:2, 5))
expect_identical(vec_rep(list(1, "x"), 5), rep(list(1, "x"), 5))
})
test_that("`vec_rep()` repeats data frames row wise", {
x <- data.frame(x = 1:2, y = 3:4)
expect_identical(vec_rep(x, 2), vec_slice(x, c(1:2, 1:2)))
})
test_that("`vec_rep()` can repeat 0 `times`", {
expect_identical(vec_rep(1, 0), numeric())
})
test_that("`vec_rep()` can repeat 1 `time`", {
expect_identical(vec_rep(1:3, 1), 1:3)
})
test_that("`vec_rep()` can repeat `x` of size 1", {
expect_identical(vec_rep(1, 2), c(1, 1))
})
test_that("`vec_rep()` errors on long vector output", {
# Exact error message may be platform specific
expect_error(vec_rep(1:2, .Machine$integer.max), "output size must be less than")
})
test_that("`vec_rep()` validates `times`", {
expect_snapshot({
(expect_error(my_vec_rep(1, "x"), class = "vctrs_error_incompatible_type"))
(expect_error(my_vec_rep(1, c(1, 2))))
(expect_error(my_vec_rep(1, -1)))
(expect_error(my_vec_rep(1, NA_integer_)))
})
})
# ------------------------------------------------------------------------------
# vec_rep_each()
test_that("`vec_rep_each()` can repeat each element of vectors", {
expect_identical(vec_rep_each(1:2, 5), rep(1:2, each = 5))
expect_identical(vec_rep_each(list(1, "x"), 5), rep(list(1, "x"), each = 5))
})
test_that("`vec_rep_each()` `times` is vectorized", {
expect_identical(vec_rep_each(1:2, 1:2), rep(1:2, times = 1:2))
})
test_that("`vec_rep_each()` repeats data frames row wise", {
x <- data.frame(x = 1:2, y = 3:4)
expect_identical(vec_rep_each(x, c(2, 1)), vec_slice(x, c(1, 1, 2)))
})
test_that("`vec_rep_each()` can repeat 0 `times`", {
expect_identical(vec_rep_each(1:2, 0), integer())
})
test_that("`vec_rep_each()` finalizes type when repeating 0 times (#1673)", {
expect_identical(vec_rep_each(NA, 0), logical())
})
test_that("`vec_rep_each()` retains names when repeating 0 times (#1673)", {
x <- c(a = 1, b = 2)
expect_identical(vec_rep_each(x, 0), named(numeric()))
})
test_that("`vec_rep_each()` can repeat 1 `time`", {
expect_identical(vec_rep_each(1:2, 1), 1:2)
})
test_that("`vec_rep_each()` errors on long vector output", {
# Exact error message may be platform specific
expect_error(vec_rep_each(1:2, .Machine$integer.max), "output size must be less than")
})
test_that("`vec_rep_each()` validates `times`", {
expect_snapshot({
(expect_error(my_vec_rep_each(1, "x"), class = "vctrs_error_incompatible_type"))
(expect_error(my_vec_rep_each(1, -1)))
(expect_error(my_vec_rep_each(c(1, 2), c(1, -1))))
(expect_error(my_vec_rep_each(1, NA_integer_)))
(expect_error(my_vec_rep_each(c(1, 2), c(1, NA_integer_))))
})
})
test_that("`vec_rep_each()` uses recyclying errors", {
expect_snapshot({
(expect_error(my_vec_rep_each(1:2, 1:3), class = "vctrs_error_recycle_incompatible_size"))
})
})
# ------------------------------------------------------------------------------
test_that("`vec_rep()` validates `times`", {
expect_snapshot(error = TRUE, my_vec_rep(1, "x"))
expect_snapshot(error = TRUE, my_vec_rep(1, c(1, 2)))
expect_snapshot(error = TRUE, my_vec_rep(1, -1))
expect_snapshot(error = TRUE, my_vec_rep(1, NA_integer_))
})
test_that("`vec_rep_each()` validates `times`", {
expect_snapshot(error = TRUE, my_vec_rep_each(1, "x"))
expect_snapshot(error = TRUE, my_vec_rep_each(1, -1))
expect_snapshot(error = TRUE, my_vec_rep_each(c(1, 2), c(1, -1)))
expect_snapshot(error = TRUE, my_vec_rep_each(1, NA_integer_))
expect_snapshot(error = TRUE, my_vec_rep_each(c(1, 2), c(1, NA_integer_)))
})
test_that("`vec_rep_each()` uses recyclying errors", {
expect_snapshot(error = TRUE, my_vec_rep_each(1:2, 1:3))
})
# vec_unrep --------------------------------------------------------------------
test_that("can unrep a vector", {
x <- c(1, 3, 3, 1, 5, 5, 6)
expect <- data_frame(
key = c(1, 3, 1, 5, 6),
times = c(1L, 2L, 1L, 2L, 1L)
)
expect_identical(vec_unrep(x), expect)
})
test_that("can unrep a data frame", {
df <- data_frame(
x = c(1, 1, 2, 2, 2),
y = c(1, 1, 1, 1, 2)
)
expect <- data_frame(
key = vec_slice(df, c(1, 3, 5)),
times = c(2L, 2L, 1L)
)
expect_identical(vec_unrep(df), expect)
})
test_that("works with size zero input", {
expect_identical(vec_unrep(integer()), data_frame(key = integer(), times = integer()))
})
test_that("can roundtrip empty input", {
x <- integer()
compressed <- vec_unrep(x)
expect_identical(vec_rep_each(compressed$key, compressed$times), x)
x <- data_frame()
compressed <- vec_unrep(x)
expect_identical(vec_rep_each(compressed$key, compressed$times), x)
})
test_that("works with data frames with rows but no columns", {
x <- data_frame(.size = 5)
expect <- data_frame(key = data_frame(.size = 1L), times = 5L)
expect_identical(vec_unrep(x), expect)
})
test_that("errors on scalars", {
expect_snapshot(error = TRUE, {
vec_unrep(environment())
})
})
vctrs/tests/testthat/test-translate.R 0000644 0001762 0000144 00000010343 14276722575 017534 0 ustar ligges users # ------------------------------------------------------------------------------
# vec_normalize_encoding()
test_that("can translate a character vector of various encodings (#553)", {
x <- unlist(encodings(), use.names = FALSE)
results <- vec_normalize_encoding(x)
expect_equal_encoding(results, encodings()$utf8)
})
test_that("translates all encodings to UTF-8", {
encs <- encodings()
for (enc in encs) {
expect_equal_encoding(vec_normalize_encoding(enc), encodings()$utf8)
}
})
test_that("can translate a list containing character vectors with different encodings", {
results <- vec_normalize_encoding(encodings())
results <- unlist(results)
expect_equal_encoding(results, encodings()$utf8)
})
test_that("translation fails purposefully with any bytes", {
expect_error(
vec_normalize_encoding(encoding_bytes()),
"translating strings with \"bytes\" encoding"
)
})
test_that("translation fails purposefully when mixing with bytes with other encodings", {
for (enc in encodings()) {
x <- c(encoding_bytes(), enc)
expect_error(vec_normalize_encoding(x), "translating strings with \"bytes\" encoding")
}
})
test_that("attributes are kept on translation (#599)", {
encs <- encodings()
x <- c(encs$utf8, encs$latin1)
x <- structure(x, names = c("a", "b"), extra = 1)
expect_equal(attributes(vec_normalize_encoding(x)), attributes(x))
})
test_that("translation is robust against scalar types contained in lists (#633)", {
x <- list(a = z ~ y, b = z ~ z)
expect_equal(vec_normalize_encoding(x), x)
})
test_that("translation can still occur even if a scalar type is in a list", {
encs <- encodings()
x <- list(a = z ~ y, b = encs$latin1)
result <- vec_normalize_encoding(x)
expect_equal_encoding(result$b, encs$utf8)
})
test_that("translation occurs inside scalars contained in a list", {
encs <- encodings()
scalar <- structure(list(x = encs$latin1), class = "scalar_list")
lst <- list(scalar)
result <- vec_normalize_encoding(lst)
expect_equal_encoding(result[[1]]$x, encs$utf8)
})
test_that("translation treats data frames elements of lists as lists (#1233)", {
encs <- encodings()
field <- c(encs$utf8, encs$latin1)
a <- new_rcrd(list(field = field))
df <- data.frame(a = a, b = 1:2)
x <- list(df)
# Recursive proxy won't proxy list elements,
# so the rcrd column in the data frame won't get proxied
proxy <- vec_proxy_equal(x)
result <- vec_normalize_encoding(proxy)
expect_identical(result, x)
result_field <- field(result[[1]]$a, "field")
expect_field <- c(encs$utf8, encs$utf8)
expect_equal_encoding(result_field, expect_field)
})
test_that("attributes are translated", {
utf8 <- encodings()$utf8
latin1 <- encodings()$latin1
a <- structure(1, enc = utf8)
b <- structure(1, enc = latin1)
c <- structure(1, enc1 = utf8, enc2 = list(latin1), enc3 = latin1)
x <- list(a, b, c)
result <- vec_normalize_encoding(x)
a_enc <- attr(result[[1]], "enc")
b_enc <- attr(result[[2]], "enc")
c_enc1 <- attr(result[[3]], "enc1")
c_enc2 <- attr(result[[3]], "enc2")[[1]]
c_enc3 <- attr(result[[3]], "enc3")
expect_equal_encoding(a_enc, utf8)
expect_equal_encoding(b_enc, utf8)
expect_equal_encoding(c_enc1, utf8)
expect_equal_encoding(c_enc2, utf8)
expect_equal_encoding(c_enc3, utf8)
expect <- list(
structure(1, enc = utf8),
structure(1, enc1 = utf8, enc2 = list(utf8), enc3 = utf8)
)
expect_identical(vec_unique(x), expect)
})
test_that("attributes are translated recursively", {
utf8 <- encodings()$utf8
latin1 <- encodings()$latin1
nested <- structure(1, latin1 = latin1)
x <- structure(2, nested = nested, foo = 1, latin1 = latin1)
result <- vec_normalize_encoding(x)
attrib <- attributes(result)
attrib_nested <- attributes(attrib$nested)
expect_equal_encoding(attrib$latin1, utf8)
expect_equal_encoding(attrib_nested$latin1, utf8)
})
test_that("NAs aren't converted to 'NA' (#1291)", {
utf8 <- c(NA, encodings()$utf8)
latin1 <- c(NA, encodings()$latin1)
result1 <- vec_normalize_encoding(utf8)
result2 <- vec_normalize_encoding(latin1)
expect_equal_encoding(result1, utf8)
expect_equal_encoding(result2, utf8)
expect_identical(result1[[1]], NA_character_)
expect_identical(result2[[1]], NA_character_)
})
vctrs/tests/testthat/test-partial-frame.R 0000644 0001762 0000144 00000005337 14276722575 020272 0 ustar ligges users
test_that("has ok print method", {
pf <- vec_ptype2(partial_frame(x = 1L), data.frame(y = 2))
expect_snapshot(pf)
expect_equal(vec_ptype_abbr(pf), "prtl")
})
test_that("order of variables comes from data", {
pf <- partial_frame(y = 1, x = 2)
df <- data.frame(x = 1, y = 2)
expect_named(vec_ptype_common(pf, df), c("x", "y"))
expect_named(vec_ptype_common(df, pf), c("x", "y"))
})
test_that("partial variables added to end if not in data", {
pf <- partial_frame(y = 1)
df <- data.frame(x = 1)
expect_named(vec_ptype_common(pf, df), c("x", "y"))
expect_named(vec_ptype_common(df, pf), c("x", "y"))
})
test_that("can assert partial frames based on column presence", {
pf <- partial_frame(y = 1)
expect_true(vec_is(data.frame(y = 2), pf))
expect_false(vec_is(data.frame(x = 1), pf))
expect_true(vec_is(data.frame(x = 1, y = 2), pf))
expect_true(vec_is(data.frame(x = 1, y = 2, z = 3), pf))
pf <- partial_frame(y = 1, z = 3)
expect_false(vec_is(data.frame(y = 2), pf))
expect_false(vec_is(data.frame(x = 1), pf))
expect_false(vec_is(data.frame(x = 1, y = 2), pf))
expect_true(vec_is(data.frame(x = 1, y = 2, z = 3), pf))
})
test_that("can assert partial frames based on column type", {
pf <- partial_frame(y = 1)
expect_false(vec_is(data.frame(y = "2"), pf))
})
test_that("incompatible data frames are an error", {
df <- data.frame(y = 1)
expect_error(vec_ptype2(df, partial_frame(y = chr())), class = "vctrs_error_incompatible_type")
expect_error(new_partial_frame(df, data.frame(y = chr())), class = "vctrs_error_incompatible_type")
})
test_that("dispatch is symmetric with tibbles", {
# Now causes infloop with the new double-dispatch mechanism because
# of the way we call vec_ptype2() from is_same_type() for partial
# types
return(expect_true(TRUE))
left <- vec_ptype2(partial_frame(x = 1), tibble::tibble(x = 1))
right <- vec_ptype2(tibble::tibble(x = 1), partial_frame(x = 1))
expect_identical(left, right)
})
test_that("can take the common type with partial frames", {
exp <- data.frame(x = dbl(), y = chr(), a = chr())
out <- vec_ptype_common(
partial_frame(x = double(), a = character()),
data.frame(x = 1L, y = "a")
)
expect_identical(out, exp)
out <- vec_ptype_common(
data.frame(x = 1L, y = "a"),
partial_frame(x = double(), a = character())
)
expect_identical(out, data.frame(x = dbl(), y = chr(), a = chr()))
})
test_that("can rbind with a partial frame prototype", {
out <- vec_rbind(
data.frame(x = 1L, y = "a"),
data.frame(x = FALSE, z = 10),
.ptype = partial_frame(x = double(), a = character())
)
exp <- data.frame(
x = dbl(1, 0),
y = chr("a", NA),
z = dbl(NA, 10),
a = chr(NA, NA)
)
expect_identical(out, exp)
})
vctrs/tests/testthat/test-type2.R 0000644 0001762 0000144 00000026671 14362266120 016576 0 ustar ligges users
test_that("base coercions are symmetric and unchanging", {
types <- list(
logical(),
integer(),
double(),
character(),
raw(),
list()
)
mat <- maxtype_mat(types)
expect_true(isSymmetric(mat))
expect_snapshot(mat)
})
test_that("new classes are uncoercible by default", {
x <- structure(1:10, class = "vctrs_nonexistant")
expect_error(vec_ptype2(1, x), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(x, 1), class = "vctrs_error_incompatible_type")
})
test_that("vec_typeof2() returns common type", {
nms <- names(base_empty_types)
for (i in seq_along(base_empty_types)) {
this <- nms[[i]]
for (j in seq_along(base_empty_types)) {
that <- nms[[j]]
if (i <= j) {
exp <- paste0("VCTRS_TYPE2_", this, "_", that)
} else {
exp <- paste0("VCTRS_TYPE2_", that, "_", this)
}
out <- vec_typeof2(base_empty_types[[this]], base_empty_types[[that]])
expect_identical(out, exp)
}
}
})
test_that("vec_typeof2_s3() returns common type", {
all_base_empty_types <- c(base_empty_types, base_s3_empty_types)
nms_s3 <- names(base_s3_empty_types)
nms <- names(all_base_empty_types)
for (i in seq_along(all_base_empty_types)) {
this <- nms[[i]]
for (j in seq_along(all_base_empty_types)) {
that <- nms[[j]]
# Skip when we have two non s3 objects
if (!(this %in% nms_s3) & !(that %in% nms_s3)) {
next
}
if (i <= j) {
exp <- paste0("VCTRS_TYPE2_S3_", this, "_", that)
} else {
exp <- paste0("VCTRS_TYPE2_S3_", that, "_", this)
}
out <- vec_typeof2_s3(all_base_empty_types[[this]], all_base_empty_types[[that]])
expect_identical(out, exp)
}
}
})
test_that("vec_ptype2() dispatches when inputs have shape", {
expect_identical(dim(vec_ptype2(int(), matrix(nrow = 3, ncol = 4))), c(0L, 4L))
expect_identical(dim(vec_ptype2(matrix("", nrow = 3), c("", "", ""))), c(0L, 1L))
})
test_that("vec_ptype2() requires vectors", {
expect_error(vec_ptype2(NULL, quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(NA, quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(list(), quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(quote(name), NULL), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(quote(name), NA), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(quote(name), list()), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(quote(name), quote(name)), class = "vctrs_error_scalar_type")
})
test_that("vec_ptype2() with unspecified requires vectors", {
expect_error(vec_ptype2(unspecified(), quote(name)), class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(quote(name), unspecified()), class = "vctrs_error_scalar_type")
})
test_that("vec_ptype2() forwards argument tag", {
expect_error(vec_ptype2(quote(name), list(), x_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type")
expect_error(vec_ptype2(list(), quote(name), y_arg = "foo"), "`foo`", class = "vctrs_error_scalar_type")
})
test_that("stop_incompatible_type() checks for scalars", {
expect_error(stop_incompatible_type(NA, foobar(), x_arg = "x", y_arg = "y"), class = "vctrs_error_scalar_type")
expect_error(vec_ptype_common(NA, foobar()), class = "vctrs_error_scalar_type")
expect_error(vec_ptype_common(foobar(), list()), class = "vctrs_error_scalar_type")
})
test_that("vec_ptype2() methods forward args to stop_incompatible_type()", {
expect_args(new_hidden(), lgl(), x_arg = "foo", y_arg = "bar")
expect_args(lgl(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(int(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(dbl(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(chr(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(list(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(new_rcrd(list(x = NA)), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(data.frame(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(Sys.Date(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(as.difftime(1, units = "hours"), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(factor(), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(ordered(""), new_hidden(), x_arg = "foo", y_arg = "bar")
expect_args(ordered(""), factor(), x_arg = "foo", y_arg = "bar")
expect_args(bit64::as.integer64(1), new_hidden(), x_arg = "foo", y_arg = "bar")
})
test_that("vec_ptype2() data frame methods builds argument tags", {
# Bare objects
expect_snapshot(error = TRUE, {
vec_ptype2("foo", 10)
})
# Nested dataframes
expect_snapshot(error = TRUE, {
df1 <- tibble(x = tibble(y = tibble(z = 1)))
df2 <- tibble(x = tibble(y = tibble(z = "a")))
vec_ptype2(df1, df2)
})
})
test_that("stop_incompatible_type() can be called without argument tags", {
expect_error(stop_incompatible_type(1, 2, x_arg = "", y_arg = ""), " and ", class = "vctrs_error_incompatible_type")
})
test_that("vec_ptype2() returns empty prototype when other input is NULL", {
expect_identical(vec_ptype2(1:5, NULL), int())
expect_identical(vec_ptype2(NULL, 1:5), int())
})
test_that("Subclasses of data.frame dispatch to `vec_ptype2()` methods", {
local_methods(
vec_ptype2.quuxframe = function(x, y, ...) UseMethod("vec_ptype2.quuxframe"),
vec_ptype2.quuxframe.data.frame = function(x, y, ...) "dispatched!",
vec_ptype2.data.frame.quuxframe = function(x, y, ...) "dispatched!"
)
quux <- structure(data.frame(), class = c("quuxframe", "data.frame"))
expect_identical(vec_ptype2(quux, mtcars), "dispatched!")
expect_identical(vec_ptype2(mtcars, quux), "dispatched!")
quux <- structure(data.frame(), class = c("quuxframe", "tbl_df", "data.frame"))
expect_identical(vec_ptype2(quux, mtcars), "dispatched!")
expect_identical(vec_ptype2(mtcars, quux), "dispatched!")
})
test_that("Subclasses of `tbl_df` have `tbl_df` common type (#481)", {
quux <- foobar(tibble())
expect_identical(
vec_ptype_common(quux, tibble()),
tibble()
)
expect_identical(
vec_ptype_common(tibble(), quux),
tibble()
)
})
test_that("Column name encodings are handled correctly in the common type (#553)", {
encs <- encodings()
data <- list(chr())
df_utf8 <- tibble::as_tibble(set_names(data, encs$utf8))
df_unknown <- tibble::as_tibble(set_names(data, encs$unknown))
expect_identical(vec_ptype2(df_utf8, df_unknown), df_utf8)
})
test_that("vec_is_subtype() determines subtyping relationship", {
expect_true(vec_is_subtype(lgl(), int()))
expect_false(vec_is_subtype(int(), lgl()))
expect_false(vec_is_subtype(lgl(), chr()))
expect_false(vec_is_subtype(chr(), lgl()))
local_methods(
vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar"),
vec_ptype2.vctrs_foobar.logical = function(x, y, ...) logical(),
vec_ptype2.logical.vctrs_foobar = function(x, y, ...) logical()
)
expect_true(vec_is_subtype(foobar(TRUE), lgl()))
expect_false(vec_is_subtype(lgl(), foobar(TRUE)))
})
test_that("can override scalar vector error message for base scalar types", {
expect_snapshot({
(expect_error(vec_ptype2(NULL, quote(x), y_arg = "foo"), class = "vctrs_error_scalar_type"))
(expect_error(vec_ptype2(quote(x), NULL, x_arg = "foo"), class = "vctrs_error_scalar_type"))
})
})
test_that("can override scalar vector error message for S3 types", {
expect_snapshot({
(expect_error(vec_ptype2(NULL, foobar(), y_arg = "foo"), class = "vctrs_error_scalar_type"))
(expect_error(vec_ptype2(foobar(), NULL, x_arg = "foo"), class = "vctrs_error_scalar_type"))
})
})
test_that("ptype2 and cast errors when same class fallback is impossible are informative", {
expect_snapshot({
(expect_error(
vec_cast(foobar(1, bar = TRUE), foobar(2, baz = TRUE)),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_ptype2(foobar(1, bar = TRUE), foobar(2, baz = TRUE)),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("Incompatible attributes bullets are not show when methods are implemented", {
expect_snapshot({
with_foobar_cast <- function(expr ) {
with_methods(
vec_cast.vctrs_foobar = function(...) NULL,
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) vec_default_cast(x, to, ...),
expr
)
}
with_foobar_ptype2 <- function(expr ) {
with_methods(
vec_ptype2.vctrs_foobar = function(...) NULL,
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) vec_default_ptype2(x, y, ...),
expr
)
}
(expect_error(
with_foobar_cast(vec_cast(foobar(1, bar = TRUE), foobar(2, baz = TRUE))),
class = "vctrs_error_incompatible_type"
))
(expect_error(
with_foobar_ptype2(vec_ptype2(foobar(1, bar = TRUE), foobar(2, baz = TRUE))),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("attributes no longer play a role in bare data frame fallback", {
foobar_bud <- foobar(mtcars, bud = TRUE)
foobar_boo <- foobar(mtcars, boo = TRUE)
expect_equal(
vec_ptype2(foobar_bud, foobar_boo),
vec_slice(unrownames(mtcars), 0)
)
expect_equal(
vec_ptype2(foobar(mtcars), foobaz(mtcars)),
vec_slice(unrownames(mtcars), 0)
)
})
test_that("vec_ptype2() methods get prototypes", {
x <- NULL
y <- NULL
local_methods(vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) {
x <<- x
y <<- y
NULL
})
vec_ptype2(foobar(1:3), foobar(letters))
expect_identical(x, foobar(int()))
expect_identical(y, foobar(chr()))
vec_ptype2(foobar(mtcars), foobar(iris))
expect_identical(x, foobar(mtcars[0, , drop = FALSE]))
expect_identical(y, foobar(iris[0, , drop = FALSE]))
})
test_that("vec_ptype2() allows vec_ptype() to return another type", {
out <- with_methods(
vec_restore.vctrs_foobar = function(x, to, ...) unstructure(x),
vec_ptype2(foobar(1), foobar(2))
)
expect_identical(out, dbl())
})
test_that("vec_ptype2() evaluates x_arg and y_arg lazily", {
expect_silent(vec_ptype2(1L, 1L, x_arg = print("oof")))
expect_silent(vec_ptype2(1L, 1L, y_arg = print("oof")))
})
test_that("can restart ptype2 errors", {
x <- data_frame(x = ordered(c("a", "b", "c")))
y <- data_frame(x = ordered(c("A", "B", "C")))
exp <- c("a", "b", "c", "A", "B", "C")
exp <- factor(exp, exp)
expect_error(vec_rbind(x, y), class = "vctrs_error_incompatible_type")
expect_equal(
with_ordered_restart(vec_rbind(x, y)),
data_frame(x = exp)
)
z <- data_frame(x = chr())
expect_equal(
with_ordered_restart(vec_ptype_common(x, y)),
data_frame(x = exp[0])
)
expect_equal(
with_ordered_restart(vec_ptype_common(x, y, z)),
data_frame(x = chr())
)
expect_equal(
with_ordered_restart(vec_cast_common(x, y)),
list(
data_frame(x = factor(c("a", "b", "c"), levels(exp))),
data_frame(x = factor(c("A", "B", "C"), levels(exp)))
)
)
expect_equal(
with_ordered_restart(vec_cast_common(x, y, z)),
list(
data_frame(x = c("a", "b", "c")),
data_frame(x = c("A", "B", "C")),
data_frame(x = chr())
)
)
# Factor case
y <- data_frame(x = factor(c("A", "B", "C")))
expect_equal(
with_ordered_restart(vec_rbind(x, y)),
data_frame(x = exp)
)
})
test_that("subclasses of tibble are compatible", {
tib <- foobar(tibble(x = 1))
ptype <- foobar(tibble(x = dbl()))
expect_equal(vec_ptype_common(tib), ptype)
expect_equal(vec_ptype_common(tib, tib), ptype)
})
vctrs/tests/testthat/helper-cast.R 0000644 0001762 0000144 00000000347 14276722575 016774 0 ustar ligges users
expect_lossy_cast <- function(expr) {
cnd <- NULL
out <- with_handlers(
warning = calling(function(x) {
cnd <<- x
cnd_muffle(x)
}),
expr
)
expect_s3_class(cnd, "vctrs_warning_cast_lossy")
out
}
vctrs/tests/testthat/test-interval.R 0000644 0001762 0000144 00000043070 14315060310 017336 0 ustar ligges users # ------------------------------------------------------------------------------
# vec_interval_groups()
test_that("can compute groups", {
x <- data_frame(
start = c(1L, 9L, 2L, 2L, 10L),
end = c(5L, 11L, 6L, 8L, 12L)
)
expect_identical(
vec_interval_groups(x$start, x$end),
data_frame(start = c(1L, 9L), end = c(8L, 12L))
)
})
test_that("can group with size one input", {
x <- data_frame(start = 1L, end = 2L)
expect_identical(
vec_interval_groups(x$start, x$end),
x
)
})
test_that("can group with size zero input", {
x <- data_frame(start = integer(), end = integer())
expect_identical(
vec_interval_groups(x$start, x$end),
x
)
})
test_that("missing intervals are retained", {
x <- data_frame(start = NA, end = NA)
expect_identical(
vec_interval_groups(x$start, x$end),
x
)
x <- data_frame(start = c(NA, NA), end = c(NA, NA))
expect_identical(
vec_interval_groups(x$start, x$end),
x[1,]
)
x <- data_frame(start = c(3, NA, 2, NA), end = c(5, NA, 3, NA))
expect_identical(
vec_interval_groups(x$start, x$end),
data_frame(start = c(2, NA), end = c(5, NA))
)
})
test_that("missing intervals can be dropped", {
x <- data_frame(start = NA, end = NA)
expect_identical(
vec_interval_groups(x$start, x$end, missing = "drop"),
data_frame(start = logical(), end = logical())
)
x <- data_frame(start = c(NA, NA), end = c(NA, NA))
expect_identical(
vec_interval_groups(x$start, x$end, missing = "drop"),
data_frame(start = logical(), end = logical())
)
x <- data_frame(start = c(3, NA, 2, NA), end = c(5, NA, 3, NA))
expect_identical(
vec_interval_groups(x$start, x$end, missing = "drop"),
data_frame(start = 2, end = 5)
)
})
test_that("max endpoint is retained even if it isn't the last in the group", {
# 10 is max end of first group, but 5 is last value in that group
x <- data_frame(start = c(1L, 2L, 12L), end = c(10L, 5L, 15L))
expect_identical(
vec_interval_groups(x$start, x$end),
data_frame(start = c(1L, 12L), end = c(10L, 15L))
)
})
# ------------------------------------------------------------------------------
# vec_interval_locate_groups()
test_that("can locate groups", {
x <- data_frame(
start = c(1L, 9L, 2L, 2L, 10L),
end = c(5L, 11L, 6L, 8L, 12L)
)
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(
out$key,
data_frame(start = c(1L, 9L), end = c(8L, 12L))
)
expect_identical(
out$loc,
list(c(1L, 3L, 4L), c(2L, 5L))
)
})
test_that("can locate groups with size one input", {
expect_identical(
vec_interval_locate_groups(1L, 2L),
data_frame(
key = data_frame(start = 1L, end = 2L),
loc = list(1L)
)
)
})
test_that("can locate groups with size zero input", {
expect_identical(
vec_interval_locate_groups(integer(), integer()),
data_frame(
key = data_frame(start = integer(), end = integer()),
loc = list()
)
)
})
test_that("locations are ordered by both `start` and `end`", {
x <- data_frame(start = c(4L, 4L, 1L), end = c(6L, 5L, 2L))
out <- vec_interval_locate_groups(x$start, x$end)
# Ties of `start = 4` are broken by `end` values and reordered
expect_identical(
out$loc,
list(3L, c(2L, 1L))
)
# So this orders `x`
expect_identical(
vec_slice(x, unlist(out$loc)),
vec_sort(x)
)
})
test_that("missing intervals are retained", {
x <- data_frame(start = NA, end = NA)
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(
out$key,
data_frame(start = NA, end = NA)
)
expect_identical(
out$loc,
list(1L)
)
x <- data_frame(start = c(3, NA, 2, NA), end = c(5, NA, 3, NA))
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(
out$key,
data_frame(start = c(2, NA), end = c(5, NA))
)
expect_identical(
out$loc,
list(c(3L, 1L), c(2L, 4L)),
)
})
test_that("missing intervals can be dropped", {
x <- data_frame(start = NA, end = NA)
out <- vec_interval_locate_groups(x$start, x$end, missing = "drop")
expect_identical(
out$key,
data_frame(start = logical(), end = logical())
)
expect_identical(
out$loc,
list()
)
x <- data_frame(start = c(3, NA, 2, NA), end = c(5, NA, 3, NA))
out <- vec_interval_locate_groups(x$start, x$end, missing = "drop")
expect_identical(
out$key,
data_frame(start = 2, end = 5)
)
expect_identical(
out$loc,
list(c(3L, 1L)),
)
})
test_that("treats NA and NaN as equivalent with doubles", {
x <- data_frame(start = c(NA, NaN, NA, NaN), end = c(NA, NA, NaN, NaN))
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(
out$key,
data_frame(start = NA_real_, end = NaN)
)
expect_identical(
out$loc,
list(1:4),
)
out <- vec_interval_locate_groups(x$start, x$end, missing = "drop")
expect_identical(
out$key,
data_frame(start = double(), end = double())
)
expect_identical(
out$loc,
list(),
)
})
test_that("recognizes missing rows in data frames", {
start <- data_frame(year = c(2019, NA, NA, 2019, 2019), month = c(12, NA, NA, 12, 12))
end <- data_frame(year = c(2020, NA, NA, 2020, 2020), month = c(2, NA, NA, 11, 12))
x <- data_frame(start = start, end = end)
out <- vec_interval_locate_groups(x$start, x$end)
expect_start <- data_frame(year = c(2019, NA), month = c(12, NA))
expect_end <- data_frame(year = c(2020, NA), month = c(12, NA))
expect <- data_frame(start = expect_start, end = expect_end)
expect_identical(out$key, expect)
expect_identical(out$loc, list(c(1L, 4L, 5L), c(2L, 3L)))
})
test_that("works on various types", {
x <- data_frame(start = c(1.5, 2, 3.1, NA), end = c(1.7, 3.2, 4.5, NA))
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(out$key, data_frame(start = c(1.5, 2, NA), end = c(1.7, 4.5, NA)))
expect_identical(out$loc, list(1L, 2:3, 4L))
out <- vec_interval_locate_groups(x$start, x$end, missing = "drop")
expect_identical(out$key, data_frame(start = c(1.5, 2), end = c(1.7, 4.5)))
expect_identical(out$loc, list(1L, 2:3))
x <- data_frame(start = c("a", "c", "f", NA), end = c("b", "g", "h", NA))
out <- vec_interval_locate_groups(x$start, x$end)
expect_identical(out$key, data_frame(start = c("a", "c", NA), end = c("b", "h", NA)))
expect_identical(out$loc, list(1L, 2:3, 4L))
out <- vec_interval_locate_groups(x$start, x$end, missing = "drop")
expect_identical(out$key, data_frame(start = c("a", "c"), end = c("b", "h")))
expect_identical(out$loc, list(1L, 2:3))
})
test_that("can keep abutting intervals separate", {
# after
x <- data_frame(start = c(1L, 2L, 0L), end = c(2L, 3L, 2L))
out <- vec_interval_locate_groups(x$start, x$end, abutting = FALSE)
expect_identical(out$key, data_frame(start = c(0L, 2L), end = c(2L, 3L)))
expect_identical(out$loc, list(c(3L, 1L), 2L))
# before
x <- data_frame(start = c(1L, 0L), end = c(2L, 1L))
out <- vec_interval_locate_groups(x$start, x$end, abutting = FALSE)
expect_identical(out$key, data_frame(start = c(0L, 1L), end = c(1L, 2L)))
expect_identical(out$loc, list(2L, 1L))
# both
x <- data_frame(start = c(1L, 0L, 2L), end = c(2L, 1L, 3L))
out <- vec_interval_locate_groups(x$start, x$end, abutting = FALSE)
expect_identical(out$key, data_frame(start = c(0L, 1L, 2L), end = c(1L, 2L, 3L)))
expect_identical(out$loc, list(2L, 1L, 3L))
})
test_that("`missing` is validated", {
expect_snapshot((expect_error(vec_interval_locate_groups(1, 2, missing = "s"))))
expect_snapshot((expect_error(vec_interval_locate_groups(1, 2, missing = c("group", "drop")))))
})
test_that("common type is taken", {
expect_snapshot((expect_error(vec_interval_locate_groups(1, "x"))))
})
# ------------------------------------------------------------------------------
# vec_interval_complement()
test_that("computes the complement", {
x <- data_frame(
start = c(6L, 1L, 2L, 12L),
end = c(9L, 3L, 4L, 14L)
)
expect_identical(
vec_interval_complement(x$start, x$end),
data_frame(start = c(4L, 9L), end = c(6L, 12L))
)
})
test_that("treats intervals as half-open like [a, b)", {
x <- data_frame(
start = c(1L, 5L),
end = c(4L, 6L)
)
expect_identical(
vec_interval_complement(x$start, x$end),
data_frame(start = 4L, end = 5L)
)
})
test_that("`[a, b)` and `[b, c)` result in no complement values", {
x <- data_frame(
start = c(1L, 5L),
end = c(5L, 6L)
)
expect_identical(
vec_interval_complement(x$start, x$end),
data_frame(start = integer(), end = integer())
)
})
test_that("works with `lower == upper`", {
x <- data_frame(
start = c(1L, 2L, 12L, NA),
end = c(10L, 5L, 15L, NA)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 10L, upper = 10L),
data_frame(start = integer(), end = integer())
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = -1L, upper = -1L),
data_frame(start = integer(), end = integer())
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 20L, upper = 20L),
data_frame(start = integer(), end = integer())
)
})
test_that("works with `lower` before any values", {
x <- data_frame(
start = c(1L, 2L, 12L, NA),
end = c(10L, 5L, 15L, NA)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = -1L),
data_frame(start = c(-1L, 10L), end = c(1L, 12L))
)
})
test_that("works if both `lower` and `upper` are before any values", {
x <- data_frame(
start = c(2L, 1L, 12L, NA),
end = c(5L, 10L, 15L, NA)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = -5L, upper = -2L),
data_frame(start = -5L, end = -2L)
)
})
test_that("works with `upper` after any values", {
x <- data_frame(
start = c(2L, 1L, 13L, 12L, NA),
end = c(5L, 10L, 17L, 15L, NA)
)
expect_identical(
vec_interval_complement(x$start, x$end, upper = 20L),
data_frame(start = c(10L, 17L), end = c(12L, 20L))
)
})
test_that("works if both `lower` and `upper` are after any values", {
x <- data_frame(
start = c(2L, 1L, 12L, NA),
end = c(5L, 10L, 15L, NA)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 17L, upper = 19L),
data_frame(start = 17L, end = 19L)
)
})
test_that("works with only NA and `lower`", {
x <- data_frame(start = NA_integer_, end = NA_integer_)
expect_identical(vec_interval_complement(x$start, x$end, lower = 5L), data_frame(start = integer(), end = integer()))
})
test_that("works with only NA and `upper`", {
x <- data_frame(start = NA_integer_, end = NA_integer_)
expect_identical(vec_interval_complement(x$start, x$end, upper = 5L), data_frame(start = integer(), end = integer()))
})
test_that("works with only NA and both `lower` and `upper`", {
x <- data_frame(start = NA_integer_, end = NA_integer_)
expect_identical(vec_interval_complement(x$start, x$end, lower = 2L, upper = 5L), data_frame(start = 2L, end = 5L))
})
test_that("works with `lower` that is on the max set value", {
x <- data_frame(
start = c(1L, 12L),
end = c(9L, 13L)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 9L),
data_frame(start = 9L, end = 12L)
)
})
test_that("works with `upper` that is on the max set value", {
x <- data_frame(
start = c(-5L, 1L, 2L, 12L),
end = c(0L, 10L, 5L, 15L)
)
expect_identical(
vec_interval_complement(x$start, x$end, upper = 10L),
data_frame(start = 0L, end = 1L)
)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 10L, upper = 10L),
data_frame(start = integer(), end = integer())
)
})
test_that("size zero case generally returns nothing", {
expect_identical(
vec_interval_complement(integer(), integer()),
data_frame(start = integer(), end = integer())
)
expect_identical(
vec_interval_complement(integer(), integer(), lower = 5L),
data_frame(start = integer(), end = integer())
)
expect_identical(
vec_interval_complement(integer(), integer(), upper = 5L),
data_frame(start = integer(), end = integer())
)
})
test_that("size zero case with both `lower` and `upper` returns an interval", {
expect_identical(
vec_interval_complement(integer(), integer(), lower = 5L, upper = 10L),
data_frame(start = 5L, end = 10L)
)
})
test_that("size zero case with `lower == upper` doesn't return anything", {
expect_identical(
vec_interval_complement(integer(), integer(), lower = 5L, upper = 5L),
data_frame(start = integer(), end = integer())
)
})
test_that("works when `lower` is contained in an interval", {
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = 3),
data_frame(start = 5, end = 10)
)
})
test_that("works when `lower` is in a gap between intervals", {
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = 7),
data_frame(start = 7, end = 10)
)
})
test_that("works when `upper` is in a gap between intervals", {
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), upper = 7),
data_frame(start = c(-3, 5), end = c(1, 7))
)
})
test_that("works when `lower` and `upper` are in a gap between intervals", {
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = 6, upper = 7),
data_frame(start = 6, end = 7)
)
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = 7, upper = 7),
data_frame(start = double(), end = double())
)
})
test_that("works when `lower` and `upper` have an interval between them", {
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = 0, upper = 7),
data_frame(start = c(0, 5), end = c(1, 7))
)
expect_identical(
vec_interval_complement(c(-5, 1, 10), c(-3, 5, 15), lower = -6, upper = 7),
data_frame(start = c(-6, -3, 5), end = c(-5, 1, 7))
)
})
test_that("allow `lower > upper` which returns an empty interval", {
x <- data_frame(start = c(1, 2), end = c(5, 12))
expect_identical(
vec_interval_complement(x$start, x$end, lower = 10, upper = 9),
data_frame(start = double(), end = double())
)
})
test_that("complement works when `lower` and `upper` are in the same interval", {
x <- data_frame(start = 1, end = 5)
expect_identical(
vec_interval_complement(x$start, x$end, lower = 2, upper = 4),
data_frame(start = double(), end = double())
)
})
test_that("`lower` and `upper` can't contain missing values", {
expect_snapshot({
(expect_error(vec_interval_complement(1, 2, lower = NA)))
(expect_error(vec_interval_complement(1, 2, upper = NA)))
start <- data_frame(x = 1, y = 2)
end <- data_frame(x = 1, y = 3)
(expect_error(vec_interval_complement(start, end, lower = data_frame(x = 1, y = NA))))
(expect_error(vec_interval_complement(start, end, upper = data_frame(x = 1, y = NA))))
})
})
# ------------------------------------------------------------------------------
# vec_interval_locate_containers()
test_that("can locate containers", {
x <- data_frame(
start = c(1L, 9L, 2L, 2L, 10L),
end = c(5L, 12L, 6L, 8L, 12L)
)
expect_identical(
vec_interval_locate_containers(x$start, x$end),
c(1L, 4L, 2L)
)
})
test_that("can locate containers with size one input", {
x <- data_frame(start = 1L, end = 2L)
expect_identical(
vec_interval_locate_containers(x$start, x$end),
1L
)
})
test_that("can locate containers with size zero input", {
x <- data_frame(start = integer(), end = integer())
expect_identical(
vec_interval_locate_containers(x$start, x$end),
integer()
)
})
test_that("missing intervals are retained", {
x <- data_frame(start = NA, end = NA)
expect_identical(
vec_interval_locate_containers(x$start, x$end),
1L
)
x <- data_frame(start = c(NA, NA), end = c(NA, NA))
# Ties use first missing value seen
expect_identical(
vec_interval_locate_containers(x$start, x$end),
1L
)
x <- data_frame(start = c(3, NA, 2, NA), end = c(5, NA, 5, NA))
# Missing intervals at the end
expect_identical(
vec_interval_locate_containers(x$start, x$end),
c(3L, 2L)
)
})
test_that("locations order the intervals", {
x <- data_frame(start = c(4L, 4L, 1L, NA, 4L), end = c(5L, 6L, 2L, NA, 6L))
out <- vec_interval_locate_containers(x$start, x$end)
expect_identical(
out,
c(3L, 2L, 4L)
)
# This orders `x`
expect_identical(
vec_slice(x, out),
vec_sort(vec_slice(x, out))
)
})
test_that("treats NA and NaN as equivalent with doubles", {
x <- data_frame(start = c(NA, NaN, NA, NaN), end = c(NA, NA, NaN, NaN))
expect_identical(vec_interval_locate_containers(x$start, x$end), 1L)
})
test_that("recognizes missing rows in data frames", {
start <- data_frame(year = c(2019, NA, NA, 2019, 2019), month = c(12, NA, NA, 12, 12))
end <- data_frame(year = c(2020, NA, NA, 2020, 2020), month = c(2, NA, NA, 11, 12))
x <- data_frame(start = start, end = end)
expect_identical(
vec_interval_locate_containers(x$start, x$end),
c(5L, 2L)
)
})
test_that("duplicate containers return the first", {
x <- data_frame(start = c(1, 1, 2, 1, 2), end = c(2, 2, 3, 2, 3))
expect_identical(vec_interval_locate_containers(x$start, x$end), c(1L, 3L))
})
test_that("works on various types", {
x <- data_frame(start = c(1.5, 3, NA, 1.6, NA), end = c(1.7, 3.1, NA, 3.2, NA))
out <- vec_interval_locate_containers(x$start, x$end)
expect_identical(out, c(1L, 4L, 3L))
x <- data_frame(start = c("a", "a", NA, "f", NA), end = c("b", "g", NA, "h", NA))
out <- vec_interval_locate_containers(x$start, x$end)
expect_identical(out, c(2L, 4L, 3L))
})
test_that("common type is taken", {
expect_snapshot((expect_error(vec_interval_locate_containers(1, "x"))))
})
vctrs/tests/testthat/test-type-vctr.R 0000644 0001762 0000144 00000052375 14315060310 017457 0 ustar ligges users
test_that("constructor sets attributes", {
x <- new_vctr(1:4, class = "x", x = 1)
expect_equal(x, structure(1:4, class = c("x", "vctrs_vctr"), x = 1))
x <- new_vctr(1:4, class = "x", x = 1, inherit_base_type = TRUE)
expect_equal(x, structure(1:4, class = c("x", "vctrs_vctr", "integer"), x = 1))
})
test_that(".data must be a vector", {
expect_error(new_vctr(mean), "vector type")
})
test_that("attributes other than names are ignored", {
out <- new_vctr(structure(1, a = 1))
expect_null(attributes(out)$a)
})
test_that("default format method is internal", {
x <- new_vctr(1, class = "x")
expect_equal(format(x), format(x))
})
test_that("vctr class is proxied", {
expect_identical(vec_proxy(new_vctr(1:3)), new_vctr(1:3))
expect_identical(vec_proxy(new_vctr(as.list(1:3))), unclass(new_vctr(as.list(1:3))))
expect_true(vec_is(new_vctr(as.list(1:3))))
})
test_that("Can opt out of base type", {
x <- new_vctr(1, class = "x", inherit_base_type = FALSE)
expect_s3_class(x, c("x", "vctrs_vctr"), exact = TRUE)
})
test_that("base type is always set for lists", {
expect_s3_class(new_vctr(list()), "list")
})
test_that("cannot opt out of the base type with lists", {
expect_error(new_vctr(list(), inherit_base_type = FALSE), "must inherit from the base type")
})
test_that("data frames are not allowed", {
expect_error(new_vctr(mtcars), "can't be a data frame")
})
test_that("attributes must be named", {
expect_error(vec_set_attributes(1, list(1)), "must be named")
expect_error(vec_set_attributes(1, list(y = 1, 2)), "2 does not")
})
test_that("can strip all attributes without adding new ones", {
expect_equal(vec_set_attributes(structure(1, a = 1), NULL), 1)
})
test_that("`c.vctrs_vctr()` checks for default method arguments (#791)", {
expect_error(c(new_vctr(1), recursive = TRUE), "`recursive` must be")
expect_error(c(new_vctr(1), use.names = FALSE), "`use.names` must be")
})
# Cast/restore ------------------------------------------------------------
test_that("cast to NULL returns x", {
x <- new_vctr(1, class = "x")
expect_equal(vec_cast(NULL, x), NULL)
})
test_that("cast succeeds if attributes equal", {
x1 <- new_vctr(1, class = "x", a = 1, b = 2)
x2 <- new_vctr(2, class = "x", a = 1, b = 2)
expect_equal(vec_cast(x1, x2), x1)
expect_equal(vec_cast(x2, x1), x2)
})
test_that("and fails if attributes are different", {
x1 <- new_vctr(1, class = "x", a = 1, b = 2)
x2 <- new_vctr(2, class = "x", a = 2, b = 2)
expect_error(vec_cast(x1, x2), class = "vctrs_error_incompatible_type")
})
test_that("restoring to atomic vector of same type preserves attributes", {
x1 <- new_vctr(1, class = "x")
x2 <- new_vctr(2, class = "x")
expect_equal(vec_restore(2, x1), x2)
})
test_that("restoring to atomic vector of different type throws error", {
x1 <- new_vctr(1, class = "x")
expect_error(vec_restore("x", x1), class = "vctrs_error_incompatible_type")
})
test_that("base coercion methods mapped to vec_cast", {
x <- new_vctr(1, inherit_base_type = FALSE)
expect_error(as.logical(x), class = "vctrs_error_incompatible_type")
expect_error(as.integer(x), class = "vctrs_error_incompatible_type")
expect_error(as.logical(x), class = "vctrs_error_incompatible_type")
expect_error(as.double(x), class = "vctrs_error_incompatible_type")
expect_error(as.character(x), class = "vctrs_error_incompatible_type")
expect_error(as.Date(x), class = "vctrs_error_incompatible_type")
expect_error(as.POSIXct(x), class = "vctrs_error_incompatible_type")
expect_error(as.POSIXlt(x), class = "vctrs_error_incompatible_type")
expect_equal(as.list(x), list(x))
})
test_that("as.data.frame creates data frame", {
x <- new_vctr(1:3)
df <- as.data.frame(x)
expect_s3_class(df, "data.frame")
expect_equal(nrow(df), 3)
expect_named(df, "x")
})
test_that("as.data.frame on shaped vctrs doesn't bring along extra attributes", {
x <- new_vctr(1:3, foo = "bar", dim = c(3L, 1L))
df <- as.data.frame(x)
expect_null(attr(df, "foo", exact = TRUE))
})
test_that("as.data.frame2() unclasses input to avoid dispatch on as.data.frame()", {
x <- structure(1:2, dim = c(1L, 2L), dimnames = list("r1", c("c1", "c2")), class = "foo")
expect <- data.frame(c1 = 1L, c2 = 2L, row.names = "r1")
local_methods(as.data.frame.foo = function(x, ...) "dispatched!")
expect_identical(as.data.frame2(x), expect)
})
test_that("as.list() chops vectors", {
expect_identical(
as.list(new_vctr(1:3)),
list(new_vctr(1L), new_vctr(2L), new_vctr(3L))
)
x <- new_vctr(as.list(1:3))
expect_identical(as.list(x), as.list(1:3))
})
# equality + comparison + arith + math ---------------------------------------
test_that("equality functions remapped", {
x <- new_vctr(c(1, 1, NA), inherit_base_type = FALSE)
expect_error(x == 1, class = "vctrs_error_incompatible_type")
expect_error(x != 1, class = "vctrs_error_incompatible_type")
expect_equal(is.na(x), c(FALSE, FALSE, TRUE))
expect_true(anyNA(x))
expect_equal(unique(x), new_vctr(c(1, NA), inherit_base_type = FALSE))
expect_equal(duplicated(x), c(FALSE, TRUE, FALSE))
expect_true(anyDuplicated(x))
})
test_that("is.na<-() supported", {
x <- new_vctr(1:4)
is.na(x) <- c(FALSE, FALSE, TRUE, NA)
expect_identical(x, new_vctr(c(1:2, NA, 4L)))
x <- new_vctr(1:4)
is.na(x) <- TRUE
expect_identical(x, new_vctr(rep(NA_integer_, 4)))
x <- new_vctr(1:4)
is.na(x) <- c(2, 3)
expect_identical(x, new_vctr(c(1L, NA, NA, 4L)))
names <- c("a", "b", "c", "d")
x <- set_names(new_vctr(1:4), names)
is.na(x) <- c("d", "b", "b")
expect_identical(x, set_names(new_vctr(c(1L, NA, 3L, NA)), names))
x <- new_vctr(1:4)
expect_error(is.na(x) <- "x", "character names to index an unnamed vector")
expect_error(is.na(x) <- 5, class = "vctrs_error_subscript_oob")
})
test_that("comparison functions remapped", {
local_methods(
vec_proxy_compare.bizzaro = function(x, ...) -vec_data(x)
)
x1 <- new_vctr(c(1, 2), class = "bizzaro")
x2 <- new_vctr(2, class = "bizzaro")
expect_equal(order(x1), c(2L, 1L))
expect_equal(x1 < x2, c(FALSE, FALSE))
expect_equal(x1 <= x2, c(FALSE, TRUE))
expect_equal(x1 > x2, c(TRUE, FALSE))
expect_equal(x1 >= x2, c(TRUE, TRUE))
})
test_that("operators remapped", {
local_methods(
vec_arith.bizzaro = function(op, x, y) 1L
)
x <- new_vctr(c(1, 2), class = "bizzaro")
expect_equal(x + 1, 1L)
expect_equal(x - 1, 1L)
expect_equal(x * 1, 1L)
expect_equal(x / 1, 1L)
expect_equal(x ^ 1, 1L)
expect_equal(x %% 1, 1L)
expect_equal(x %/% 1, 1L)
expect_equal(x & 1, 1L)
expect_equal(x | 1, 1L)
expect_equal(!x, 1L)
expect_equal(+x, 1L)
expect_equal(-x, 1L)
})
test_that("math functions overridden", {
local_methods(
vec_math.bizzaro = function(fn, x, ...) vec_math_base(fn, 2L)
)
x <- new_vctr(c(1, NA), class = "bizzaro")
expect_equal(mean(x), 2L)
expect_equal(sum(x), 2L)
expect_equal(is.finite(x), TRUE)
expect_equal(is.infinite(x), FALSE)
expect_equal(is.nan(x), FALSE)
})
test_that("diff matches base R", {
local_methods(
vec_arith.vctrs_minus = function(op, x, y) vec_arith_base(op, x, y)
)
x1 <- cumsum(cumsum(1:10))
x2 <- new_vctr(x1, class = "vctrs_minus")
expect_equal(diff(x2), diff(x1))
expect_equal(diff(x2, lag = 2L), diff(x1, lag = 2L))
expect_equal(diff(x2, differences = 2L), diff(x1, differences = 2L))
expect_equal(diff(x2, lag = 11), x2[0L])
expect_equal(diff(x2, differences = 11), x2[0L])
})
test_that("na.omit() works and retains metadata", {
x <- new_vctr(c(a = 1, b = NA, c = 2))
result <- na.omit(x)
expect <- vec_slice(x, c(1, 3))
attr(expect, "na.action") <- structure(c(b = 2L), class = "omit")
expect_identical(result, expect)
})
test_that("na.omit() returns its input unchanged if there are no missing values", {
x <- new_vctr(c(a = 1, b = 2))
expect_identical(na.omit(x), x)
})
test_that("na.exclude() works and retains metadata", {
x <- new_vctr(c(a = 1, b = NA, c = 2))
result <- na.exclude(x)
expect <- vec_slice(x, c(1, 3))
attr(expect, "na.action") <- structure(c(b = 2L), class = "exclude")
expect_identical(result, expect)
})
test_that("na.fail() works", {
x <- new_vctr(c(a = 1, b = 2))
expect_identical(na.fail(x), x)
x <- new_vctr(c(a = 1, b = NA, c = 2))
expect_snapshot(error = TRUE, na.fail(x))
})
# names -------------------------------------------------------------------
test_that("`NA_character_` names are repaired to the empty string (#784)", {
expect_named(new_vctr(set_names(1, NA_character_)), "")
expect_named(new_vctr(set_names(1:2, c("a", NA))), c("a", ""))
})
test_that("the empty string is an allowed name (#784)", {
expect_named(new_vctr(set_names(1, "")), "")
expect_named(new_vctr(set_names(1:2, c("", "x"))), c("", "x"))
})
test_that("can not provide invalid names", {
x <- new_vctr(c(a = 1, b = 2))
expect_error(names(x) <- "x", "length")
expect_error(names(x) <- c("x", "y", "z"), "length")
expect_error(names(x) <- NULL, NA)
})
test_that("can set names to the empty string (#784)", {
x <- new_vctr(c(a = 1, b = 2))
names(x) <- c("", "")
expect_named(x, c("", ""))
names(x) <- c("", "x")
expect_named(x, c("", "x"))
})
test_that("setting names to `NA_character_` repairs to the empty string (#784)", {
x <- new_vctr(1:2)
names(x) <- c(NA_character_, NA_character_)
expect_named(x, c("", ""))
names(x) <- c("x", NA_character_)
expect_named(x, c("x", ""))
})
test_that("can use [ and [[ with names", {
local_methods(
vec_ptype2.vctrs_vctr.double = function(...) dbl(),
vec_ptype2.double.vctrs_vctr = function(...) dbl()
)
x <- new_vctr(c(a = 1, b = 2))
expect_equal(x["b"], new_vctr(c(b = 2)))
expect_equal(x[["b"]], new_vctr(2)) # [[ drops names
x[["c"]] <- 3
expect_equal(x[["c"]], new_vctr(3))
x["d"] <- 4
expect_equal(x[["d"]], new_vctr(4))
})
test_that("can use [ and [[ with names - list vctr", {
local_methods(
vec_ptype2.vctrs_vctr = function(...) list(),
vec_ptype2.list.vctrs_vctr = function(...) list()
)
y <- new_vctr(list(a = 1, b = 2))
y[["c"]] <- 3
expect_equal(y[["c"]], 3)
y["d"] <- list(4)
expect_equal(y[["d"]], 4)
})
test_that("can use [[<- to replace n-dimensional elements", {
local_methods(
vec_restore.vctrs_mtrx = function(x, to, ...) x,
vec_ptype2.double.vctrs_mtrx = function(...) dbl(),
vec_ptype2.vctrs_mtrx = function(...) dbl()
)
x <- new_vctr(rep(1, times = 4), dim = c(2, 2), class = "vctrs_mtrx")
x[[2, 2]] <- 4
expect_equal(x[[2, 2]], 4)
})
test_that("subsetting preserves attributes", {
x <- new_vctr(c(a = 1, b = 2))
attr(x, "extra") <- TRUE
y <- x[1]
expect_equal(attr(x, "extra"), TRUE)
})
test_that("$ inherits from underlying vector", {
x1 <- new_vctr(c(a = 1, b = 2))
expect_error(x1$a, "atomic vectors")
expect_error(x1$a <- 2, "atomic vectors")
x2 <- new_vctr(list(a = 1, b = 2))
expect_equal(x2$a, 1)
x2$a <- 10
expect_equal(x2$a, 10)
})
# unsupported/unimplemented operations --------------------------------------
test_that("can't touch protected attributes", {
x <- new_vctr(1:4)
expect_error(dim(x) <- c(2, 2), class = "vctrs_error_unsupported")
expect_error(dimnames(x) <- list("x"), class = "vctrs_error_unsupported")
expect_error(levels(x) <- "x", class = "vctrs_error_unsupported")
# It is expected that unimplemented `levels()` returns `NULL`
expect_null(levels(x))
# But it's ok to set names to NULL; this happens at least in vec_c
# and maybe elsewhere. We may need to back off on this level of
# strictness in the future
expect_error(names(x) <- NULL, NA)
})
test_that("summary is unimplemented", {
x <- new_vctr(1:4)
expect_error(summary(x), class = "vctrs_error_unimplemented")
})
# hidden class ------------------------------------------------------------
# We can't construct classes in test because the methods are not found
# when vctr generics call other generics. Instead we rely on a very simple
# class implemented in vctr.R
test_that("class preserved when subsetting", {
h <- new_hidden(1:4)
expect_s3_class(h, "hidden")
expect_s3_class(h[1], "hidden")
expect_s3_class(h[[1]], "hidden")
expect_s3_class(rep(h[1], 2), "hidden")
expect_s3_class(as.list(h)[[1]], "hidden")
length(h) <- 3
expect_s3_class(h, "hidden")
})
test_that("RHS cast when using subset assign", {
local_hidden()
h <- new_hidden(1)
expect_error(h[[1]] <- "x", class = "vctrs_error_incompatible_type")
expect_error(h[1] <- "x", class = "vctrs_error_incompatible_type")
h[2] <- 1
expect_equal(h, new_hidden(c(1, 1)))
h[[2]] <- 2
expect_equal(h, new_hidden(c(1, 2)))
})
test_that("c passes on to vec_c", {
local_hidden()
h <- new_hidden(1)
expect_equal(c(h), h)
expect_equal(c(h, NULL), h)
expect_equal(c(h, 1), rep(h, 2))
expect_equal(c(h, h), rep(h, 2))
})
test_that("rbind does not fail with an unclear message (#1186)", {
# In general, vec_rbind() should be preferred. In many cases rbind() does
# the right thing, this test exists to alert us if this changes in the future.
skip_on_cran()
local_hidden()
h <- new_hidden(1)
# A failure in levels() for vctrs_vctr classes was the underlying issue.
expect_null(levels(h))
df <- data_frame(h = h)
expect_equal(rbind(df), df)
expect_equal(rbind(df, NULL), df)
expect_equal(rbind(df, data_frame(h = 1)), unrownames(df[c(1, 1), , drop = FALSE]))
expect_equal(rbind(df, df), unrownames(df[c(1, 1), , drop = FALSE]))
# An example where the result differs, to alert us if the rbind() contract
# changes
expect_equal(rbind(data_frame(h = 1), df), data_frame(h = c(1, 1)))
})
test_that("summaries preserve class", {
h <- new_hidden(c(1, 2))
expect_equal(sum(h), new_hidden(3))
expect_equal(mean(h), new_hidden(1.5))
})
test_that("methods using vec_proxy_compare agree with base", {
h <- new_hidden(c(1:10))
h_na <- new_hidden(c(NA, 1:10))
expect_agree <- function(f, x, na.rm = FALSE) {
f <- enexpr(f)
expect_equal(vec_data((!!f)(x, na.rm = na.rm)), (!!f)(vec_data(x), na.rm = na.rm))
}
expect_agree(min, h)
expect_agree(max, h)
expect_agree(range, h)
expect_agree(min, h_na)
expect_agree(max, h_na)
expect_agree(range, h_na)
expect_agree(min, h_na, na.rm = TRUE)
expect_agree(max, h_na, na.rm = TRUE)
expect_agree(range, h_na, na.rm = TRUE)
})
test_that("can put in data frame", {
h <- new_hidden(1:4)
expect_named(as.data.frame(h), "h")
expect_named(data.frame(x = h), "x")
})
test_that("base coercions default to vec_cast", {
local_hidden()
h <- new_hidden(1)
expect_error(as.character(h), class = "vctrs_error_incompatible_type")
expect_error(as.integer(h), class = "vctrs_error_incompatible_type")
expect_error(generics::as.factor(h), class = "vctrs_error_incompatible_type")
expect_error(generics::as.ordered(h), class = "vctrs_error_incompatible_type")
expect_error(generics::as.difftime(h), class = "vctrs_error_incompatible_type")
expect_equal(as.logical(h), TRUE)
expect_equal(as.double(h), 1)
})
test_that("default print and str methods are useful", {
h <- new_hidden(1:4)
expect_snapshot(h)
expect_snapshot(h[0])
expect_snapshot(str(h))
})
test_that("default print method shows names", {
h <- new_hidden(c(A = 1, B = 2, C = 3))
expect_snapshot(h)
})
test_that("can't transpose", {
h <- new_hidden(1:4)
expect_error(t(h), class = "vctrs_error_unsupported")
})
test_that("shaped vctrs can be cast to data frames", {
x <- new_vctr(1:4, dim = 4)
expect_identical(as.data.frame(x), data.frame(V1 = 1:4))
x <- new_vctr(1:4, dim = c(2, 2))
expect_identical(as.data.frame(x), data.frame(V1 = 1:2, V2 = 3:4))
})
# slicing -----------------------------------------------------------------
test_that("additional subscripts are handled (#269)", {
new_2d <- function(.data, dim) {
vctrs::new_vctr(.data, dim = dim, class = "vctrs_2d")
}
x <- new_2d(c(1, 2), dim = c(2L, 1L))
expect_identical(x[1], new_2d(1, dim = c(1, 1)))
expect_identical(x[1, 1], new_2d(1, dim = c(1, 1)))
expect_identical(x[, 1], new_2d(c(1, 2), dim = c(2, 1)))
})
# summary generics --------------------------------------------------------
test_that("na.rm is forwarded to summary generics", {
x <- new_vctr(dbl(1, 2, NA))
expect_identical(mean(x, na.rm = FALSE), new_vctr(dbl(NA)))
expect_identical(mean(x, na.rm = TRUE), new_vctr(1.5))
expect_identical(min(x, na.rm = FALSE), new_vctr(dbl(NA)))
expect_identical(min(x, na.rm = TRUE), new_vctr(1))
expect_identical(max(x, na.rm = FALSE), new_vctr(dbl(NA)))
expect_identical(max(x, na.rm = TRUE), new_vctr(2))
x <- new_vctr(lgl(TRUE, NA))
expect_identical(all(x, na.rm = FALSE), lgl(NA))
expect_identical(all(x, na.rm = TRUE), TRUE)
})
test_that("Summary generics behave identically to base for empty vctrs (#88)", {
expect_warning(
expect_identical(
new_vctr(max(numeric())),
max(new_vctr(numeric()))
)
)
expect_warning(
expect_identical(
new_vctr(min(numeric())),
min(new_vctr(numeric()))
)
)
expect_identical(
new_vctr(range(1)),
range(new_vctr(1))
)
expect_identical(
new_vctr(prod(numeric())),
prod(new_vctr(numeric()))
)
expect_identical(
new_vctr(sum(numeric())),
sum(new_vctr(numeric()))
)
expect_identical(
new_vctr(cummax(numeric())),
cummax(new_vctr(numeric()))
)
expect_identical(
new_vctr(cummin(numeric())),
cummin(new_vctr(numeric()))
)
expect_identical(
new_vctr(cumprod(numeric())),
cumprod(new_vctr(numeric()))
)
expect_identical(
new_vctr(cumsum(numeric())),
cumsum(new_vctr(numeric()))
)
expect_identical(
new_vctr(mean(numeric())),
mean(new_vctr(numeric()))
)
})
test_that("generic predicates return logical vectors (#251)", {
x <- new_vctr(c(1, 2))
expect_identical(is.finite(x), c(TRUE, TRUE))
expect_identical(is.infinite(x), c(FALSE, FALSE))
expect_identical(is.nan(x), c(FALSE, FALSE))
x <- new_vctr(TRUE)
expect_identical(any(x), TRUE)
expect_identical(all(x), TRUE)
})
test_that("xtfrm() converts logical types to integer", {
expect_identical(xtfrm(new_vctr(c(TRUE, FALSE, NA), foo = "bar")), c(1L, 0L, NA))
})
test_that("xtfrm() unwraps integer and double atomic types", {
expect_identical(xtfrm(new_vctr(1:3, foo = "bar")), 1:3)
expect_identical(xtfrm(new_vctr(1:3 + 0, foo = "bar")), 1:3 + 0)
})
test_that("xtfrm() works with character subclass", {
expect_identical(xtfrm(new_vctr(chr())), int())
})
test_that("xtfrm() maintains ties when falling through to vec_rank() (#1354)", {
x <- new_vctr(c("F", "F", "M", "A", "M", "A"))
expect_identical(xtfrm(x), c(2L, 2L, 3L, 1L, 3L, 1L))
})
test_that("xtfrm() propagates NAs when falling through to vec_rank()", {
x <- new_vctr(c("F", NA))
expect_identical(xtfrm(x), c(1L, NA))
})
test_that("xtfrm() uses C locale ordering with character proxies", {
x <- new_vctr(c("A", "a", "B"))
expect_identical(xtfrm(x), c(1L, 3L, 2L))
})
test_that("xtfrm() works on rcrd types", {
x <- new_rcrd(list(x = c(1, 2, 1, NA), y = c(2, 1, 1, NA)))
expect_identical(xtfrm(x), c(2L, 3L, 1L, NA))
})
test_that("Summary generics behave as expected if na.rm = TRUE and all values are NA (#1357)", {
expect_identical(min(new_vctr(NA_real_), na.rm = TRUE), new_vctr(Inf))
expect_identical(max(new_vctr(NA_real_), na.rm = TRUE), new_vctr(-Inf))
expect_identical(range(new_vctr(NA_real_), na.rm = TRUE), new_vctr(c(Inf, -Inf)))
expect_identical(min(new_vctr(NA_integer_), na.rm = TRUE), new_vctr(NA_integer_))
expect_identical(max(new_vctr(NA_integer_), na.rm = TRUE), new_vctr(NA_integer_))
expect_identical(range(new_vctr(NA_integer_), na.rm = TRUE), new_vctr(c(NA_integer_, NA_integer_)))
expect_identical(min(new_vctr(NA_character_), na.rm = TRUE), new_vctr(NA_character_))
expect_identical(max(new_vctr(NA_character_), na.rm = TRUE), new_vctr(NA_character_))
expect_identical(range(new_vctr(NA_character_), na.rm = TRUE), new_vctr(c(NA_character_, NA_character_)))
expect_identical(min(new_vctr(NA), na.rm = TRUE), new_vctr(NA))
expect_identical(max(new_vctr(NA), na.rm = TRUE), new_vctr(NA))
expect_identical(range(new_vctr(NA), na.rm = TRUE), new_vctr(c(NA, NA)))
})
test_that("Summary generics behave as expected for empty vctrs (#1357)", {
expect_identical(min(new_vctr(numeric()), na.rm = TRUE), new_vctr(Inf))
expect_identical(max(new_vctr(numeric()), na.rm = TRUE), new_vctr(-Inf))
expect_identical(range(new_vctr(numeric()), na.rm = TRUE), new_vctr(c(Inf, -Inf)))
expect_identical(min(new_vctr(integer()), na.rm = TRUE), new_vctr(NA_integer_))
expect_identical(max(new_vctr(integer()), na.rm = TRUE), new_vctr(NA_integer_))
expect_identical(range(new_vctr(integer()), na.rm = TRUE), new_vctr(c(NA_integer_, NA_integer_)))
expect_identical(min(new_vctr(character()), na.rm = TRUE), new_vctr(NA_character_))
expect_identical(max(new_vctr(character()), na.rm = TRUE), new_vctr(NA_character_))
expect_identical(range(new_vctr(character()), na.rm = TRUE), new_vctr(c(NA_character_, NA_character_)))
expect_identical(min(new_vctr(logical()), na.rm = TRUE), new_vctr(NA))
expect_identical(max(new_vctr(logical()), na.rm = TRUE), new_vctr(NA))
expect_identical(range(new_vctr(logical()), na.rm = TRUE), new_vctr(c(NA, NA)))
})
test_that("anyNA(recursive = TRUE) works with lists (#1278)", {
x <- list_of(1:4, c(2, NA, 5))
expect_false(anyNA(x))
expect_true(anyNA(x, recursive = TRUE))
x <- new_vctr(list(1:4, list(c(2, NA, 5))))
expect_false(anyNA(x))
expect_true(anyNA(x, recursive = TRUE))
})
vctrs/tests/testthat/test-compare.R 0000644 0001762 0000144 00000021206 14376223321 017147 0 ustar ligges users
test_that("inputs must be vectors", {
expect_error(vec_compare(NULL, 1), class = "vctrs_error_scalar_type")
expect_error(vec_compare(1, NULL), class = "vctrs_error_scalar_type")
})
test_that("matches R ordering", {
expect_same <- function(x, y) {
expect_equal(vec_compare(!!x, !!y), cmp(!!x, !!y))
}
expect_same(c(NA, FALSE, TRUE), FALSE)
expect_same(c(NA, -100L, 0L, 100L), 0L)
expect_same(c(NA, -Inf, -100, 100, Inf), 0L)
expect_same(c(NA, NaN, 0), NA)
expect_same(c(NA, "a", "b", "c"), "b")
expect_same(as.raw(2:5), as.raw(4))
})
test_that("NAs equal when requested", {
expect_value <- function(x, y, val, .ptype = NULL) {
expect_equal(vec_compare(!!x, !!y, .ptype = .ptype, na_equal = TRUE), !!val)
}
expect_value(NA, NA, 0L)
expect_value(NA, FALSE, -1L)
expect_value(FALSE, NA, 1L)
expect_value(NA_integer_, NA_integer_, 0L)
expect_value(NA_integer_, 0L, -1L)
expect_value(0L, NA_integer_, 1L)
expect_value(NA_character_, NA_character_, 0L)
expect_value(NA_character_, "", -1L)
expect_value("", NA_character_, 1L)
expect_value(0, NA_real_, 1L)
expect_value(0, NaN, 1L)
expect_value(0, 0, 0L)
expect_value(NA_real_, NA_real_, 0L)
expect_value(NA_real_, NaN, 1L)
expect_value(NA_real_, 0, -1L)
expect_value(NaN, NA_real_, -1L)
expect_value(NaN, NaN, 0L)
expect_value(NaN, 0, -1L)
})
test_that("data frames are compared column by column", {
df1 <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1))
expect_equal(vec_compare(df1, df1[2, ]), c(-1, 0, 1))
expect_equal(vec_compare(df1[1], df1[2, 1, drop = FALSE]), c(0, 0, 0))
expect_equal(vec_compare(df1[2], df1[2, 2, drop = FALSE]), c(-1, 0, 1))
expect_equal(vec_compare(df1[2:1], df1[2, 2:1]), c(-1, 0, 1))
})
test_that("can compare data frames with various types of columns", {
x1 <- data_frame(x = 1, y = 2)
y1 <- data_frame(x = 2, y = 1)
x2 <- data_frame(x = "a")
y2 <- data_frame(x = "b")
x3 <- data_frame(x = FALSE)
y3 <- data_frame(x = TRUE)
x4 <- data_frame(x = 1L)
y4 <- data_frame(x = 2L)
expect_equal(vec_compare(x1, y1), -1)
expect_equal(vec_compare(x2, y2), -1)
expect_equal(vec_compare(x3, y3), -1)
expect_equal(vec_compare(x4, y4), -1)
})
test_that("can compare data frames with data frame columns", {
df1 <- data_frame(x = data_frame(a = 1))
df2 <- data_frame(x = data_frame(a = 2))
expect_equal(vec_compare(df1, df1), 0)
expect_equal(vec_compare(df1, df2), -1)
})
test_that("can compare data frames with 0 columns", {
x <- new_data_frame(n = 2L)
expect_identical(vec_compare(x, x), c(0L, 0L))
})
test_that("C code doesn't crash with bad inputs", {
df <- data.frame(x = c(1, 1, 1), y = c(-1, 0, 1))
expect_error(.Call(ffi_vec_compare, df, df[1], TRUE), "not comparable")
# Names are not checked, as `vec_cast_common()` should take care of the type.
# So if `vec_cast_common()` is not called, or is improperly specified, then
# this could result in false equality.
expect_equal(.Call(ffi_vec_compare, df, setNames(df, c("x", "z")), TRUE), c(0, 0, 0))
df1 <- new_data_frame(list(x = 1:3, y = c(1, 1, 1)))
df2 <- new_data_frame(list(y = 1:2, x = 1:2))
expect_error(.Call(ffi_vec_compare, df1, df2, TRUE), "must have the same types and lengths")
})
test_that("xtfrm.vctrs_vctr works for variety of base classes", {
df <- data.frame(x = c(NA, 1, 1), y = c(1, 2, 1))
# Internally uses `vec_rank()`, which propagates rows if not "complete"
expect_equal(xtfrm.vctrs_vctr(df), c(NA, 2, 1))
x <- c(2, 3, 1)
expect_equal(xtfrm.vctrs_vctr(x), x)
expect_equal(xtfrm.vctrs_vctr(letters[x]), x)
})
test_that("vec_proxy_order() orders list using order of appearance", {
x <- 1:2
y <- 2:4
z <- "a"
lst <- list(x, y, x, y, z)
expect_identical(vec_proxy_order(lst), c(1L, 2L, 1L, 2L, 5L))
})
test_that("vec_compare() calls vec_proxy_compare()", {
local_methods(
vec_proxy_compare.vctrs_foobar = function(x, ...) rev(x),
vec_ptype2.integer.vctrs_foobar = function(...) foobar(int()),
vec_ptype2.vctrs_foobar = function(...) foobar(int()),
vec_cast.vctrs_foobar = function(...) NULL,
vec_cast.vctrs_foobar.integer = function(x, ...) x,
)
expect_identical(vec_compare(1:3, 1:3), int(0, 0, 0))
expect_identical(vec_compare(1:3, foobar(1:3)), int(-1, 0, 1))
})
test_that("vec_proxy_compare() preserves data frames and vectors", {
df <- data_frame(x = 1:2, y = c("a", "b"))
expect_identical(vec_proxy_compare(df), df)
x <- c(NA, "a", "b", "c")
expect_identical(vec_proxy_compare(x), x)
})
test_that("vec_proxy_compare() handles data frame with a POSIXlt column", {
df <- data.frame(times = 1:5, x = 1:5)
df$times <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day"))
df2 <- df
df2$times <- vec_proxy_compare(df$times)
expect_identical(
vec_proxy_compare(df),
vec_proxy_compare(df2)
)
})
test_that("vec_proxy_compare.POSIXlt() correctly orders (#720)", {
dates <- as.POSIXlt(seq.Date(as.Date("2019-12-30"), as.Date("2020-01-03"), by = "day"))
expect_equal(vec_order(dates), 1:5)
})
test_that("vec_proxy_compare.POSIXlt() correctly orders around DST", {
# 1am in EDT
x <- as.POSIXlt("2020-11-01 01:00:00", tz = "America/New_York")
# "falls back" to 1am again, but in EST
y <- as.POSIXlt(x + 3600)
expect_equal(vec_order(c(y, x)), c(2, 1))
})
test_that("vec_proxy_compare() flattens df-cols", {
df_col <- data_frame(z = 3:4, w = 4:5)
df <- data_frame(x = 1:2, y = df_col)
expect <- data_frame(x = 1:2, z = 3:4, w = 4:5)
expect_identical(vec_proxy_compare(df), expect)
})
test_that("vec_proxy_compare() unwraps 1 col dfs", {
df <- data_frame(x = 1:2)
expect_identical(vec_proxy_compare(df), 1:2)
df_col <- data_frame(y = 1:2)
df <- data_frame(x = df_col)
expect_identical(vec_proxy_compare(df), 1:2)
})
test_that("vec_proxy_order() works on deeply nested lists", {
df_col <- data_frame(z = list("b", "a", "b"))
# Relaxed and unwrapped
df1 <- data_frame(x = df_col)
expect_identical(vec_proxy_order(df1), c(1L, 2L, 1L))
df2 <- data_frame(x = df_col, y = 1:3)
expect_identical(vec_proxy_order(df2), data_frame(x = c(1L, 2L, 1L), y = 1:3))
})
test_that("error is thrown when comparing complexes (#1655)", {
expect_snapshot({
(expect_error(vec_compare(complex(), complex())))
})
})
test_that("error is thrown when comparing lists", {
expect_error(vec_compare(list(), list()), class = "vctrs_error_unsupported")
expect_error(.Call(ffi_vec_compare, list(), list(), FALSE), "Can't compare lists")
})
test_that("error is thrown when comparing data frames with list columns", {
df <- data_frame(x = list())
expect_error(vec_compare(df, df), class = "vctrs_error_unsupported")
expect_error(.Call(ffi_vec_compare, df, df, FALSE), "Can't compare lists")
})
test_that("error is thrown when comparing scalars", {
x <- new_sclr(x = 1)
expect_error(vec_compare(x, x), class = "vctrs_error_scalar_type")
expect_error(.Call(ffi_vec_compare, x, x, FALSE), class = "vctrs_error_scalar_type")
})
test_that("`na_equal` is validated", {
expect_snapshot({
(expect_error(vec_compare(1, 1, na_equal = 1)))
(expect_error(vec_compare(1, 1, na_equal = c(TRUE, FALSE))))
})
})
test_that("can compare equal strings with different encodings", {
for (x_encoding in encodings()) {
for (y_encoding in encodings()) {
expect_equal(vec_compare(x_encoding, y_encoding), 0L)
}
}
})
test_that("can compare non-equal strings with different encodings", {
x <- "x"
y <- encodings()$latin1
expect_equal(vec_compare(x, y), -1L)
})
test_that("comparison can be determined when strings have identical encodings", {
encs <- encodings()
for (enc in encs) {
expect_equal(vec_compare(enc, enc), 0L)
}
})
test_that("comparison is known to always fail with bytes", {
enc <- encoding_bytes()
error <- "translating strings with \"bytes\" encoding"
expect_error(vec_compare(enc, enc), error)
})
test_that("comparison is known to fail when comparing bytes to other encodings", {
error <- "translating strings with \"bytes\" encoding"
for (enc in encodings()) {
expect_error(vec_compare(encoding_bytes(), enc), error)
expect_error(vec_compare(enc, encoding_bytes()), error)
}
})
test_that("can compare unspecified", {
expect_equal(vec_compare(NA, NA), NA_integer_)
expect_equal(vec_compare(NA, NA, na_equal = TRUE), 0)
expect_equal(vec_compare(c(NA, NA), unspecified(2)), c(NA_integer_, NA_integer_))
})
test_that("can't supply NA as `na_equal`", {
expect_snapshot(error = TRUE, {
vec_compare(NA, NA, na_equal = NA)
})
})
test_that("vec_compare() silently falls back to base data frame", {
expect_silent(expect_identical(
vec_compare(foobar(mtcars), foobar(tibble::as_tibble(mtcars))),
rep(0L, 32)
))
})
vctrs/tests/testthat/helper-c.R 0000644 0001762 0000144 00000000071 14315060310 016226 0 ustar ligges users class_type <- function(x) {
.Call(ffi_class_type, x)
}
vctrs/tests/testthat/test-type-tibble.R 0000644 0001762 0000144 00000006446 14362266120 017751 0 ustar ligges users test_that("tibble beats data frame", {
df <- new_data_frame()
dt <- tibble::tibble()
expect_s3_class(vec_ptype_common(dt, df), "tbl_df")
expect_s3_class(vec_ptype_common(df, dt), "tbl_df")
})
test_that("can cast tibble to df and vice versa", {
df <- new_data_frame()
tib <- tibble::tibble()
expect_identical(vec_cast(df, tib), tib)
expect_identical(vec_cast(tib, df), df)
expect_identical(vec_cast(tib, tib), tib)
})
test_that("can't cast vector to tibble", {
dt <- tibble::tibble()
v <- logical()
expect_snapshot({
local_error_call(call("my_function"))
(expect_error(vec_ptype2(v, dt), class = "vctrs_error_incompatible_type"))
(expect_error(vec_ptype2(dt, v), class = "vctrs_error_incompatible_type"))
(expect_error(vec_cast(v, dt), class = "vctrs_error_incompatible_type"))
})
})
test_that("casting to and from tibble preserves row names", {
out <- vec_cast(mtcars, tibble::as_tibble(mtcars))
expect_identical(row.names(out), row.names(mtcars))
out <- vec_cast(out, unrownames(mtcars))
expect_identical(row.names(out), row.names(mtcars))
})
test_that("no common type between list and tibble", {
dt <- tibble::tibble()
l <- list()
expect_error(vec_ptype2(l, dt), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(dt, l), class = "vctrs_error_incompatible_type")
})
test_that("vec_restore restores tibbles", {
df1 <- tibble::tibble(x = 1:4)
df2 <- vec_restore(vec_data(df1), df1)
expect_s3_class(df2, "tbl_df")
})
test_that("the type of a tibble with an unspecified column retains unspecifiedness", {
df1 <- tibble::tibble(x = 1, y = NA)
df2 <- tibble::tibble(x = 1, y = unspecified(1))
expect <- tibble::tibble(x = numeric(), y = unspecified())
expect_identical(vec_ptype(df1), expect)
expect_identical(vec_ptype(df2), expect)
})
test_that("vec_ptype_finalise() works recursively over tibbles", {
df <- tibble(x = numeric(), y = unspecified())
expect <- tibble(x = numeric(), y = logical())
expect_identical(vec_ptype_finalise(df), expect)
})
test_that("vec_ptype_finalise() can handle tibble df columns", {
df <- tibble(x = numeric(), y = tibble(z = unspecified()))
expect <- tibble(x = numeric(), y = tibble(z = logical()))
expect_identical(vec_ptype_finalise(df), expect)
})
test_that("can use ptype2 and cast with tibble that has incorrect class vector", {
tib1 <- structure(data.frame(x = 1), class = c("tbl_df", "data.frame"))
tib2 <- structure(data.frame(y = 2), class = c("tbl_df", "data.frame"))
exp <- structure(data.frame(x = dbl(), y = dbl()), class = c("tbl_df", "data.frame"))
requireNamespace("tibble")
expect_identical(
vec_ptype_common(tib1, tib2),
exp
)
expect_identical(
vec_ptype_common(tib1, data.frame(y = 2)),
tibble::new_tibble(exp, nrow = nrow(exp))
)
expect_identical(
vec_ptype_common(data.frame(x = 1), tib2),
tibble::new_tibble(exp, nrow = nrow(exp))
)
expect_identical(
vec_cast(tib1, tib1),
tib1
)
expect_snapshot({
local_error_call(call("my_function"))
(expect_error(
vec_cast(tib1, tib2),
class = "vctrs_error_cast"
))
(expect_error(
vec_cast(tib1, data.frame(y = 2)),
class = "vctrs_error_cast"
))
(expect_error(
vec_cast(data.frame(x = 1), tib2),
class = "vctrs_error_cast"
))
})
})
vctrs/tests/testthat/test-type-sf.R 0000644 0001762 0000144 00000017044 14405105465 017116 0 ustar ligges users # Never run on CRAN, even if they have sf, because we don't regularly
# check these on CI and we don't want a change in sf to force a CRAN
# failure for vctrs.
skip_on_cran()
# Avoids adding `sf` to Suggests.
# These tests are only run on the devs' machines.
testthat_import_from("sf", c(
"st_sf",
"st_sfc",
"st_point",
"st_bbox",
"st_precision",
"st_crs",
"st_linestring",
"st_as_sf",
"st_multipoint"
))
# Need recent version to work around restore bug for sfc lists and changes
# to `c.sfc()`
skip_if_not_installed("sf", "1.0-11")
test_that("sf has a ptype2 method", {
sfc1 = st_sfc(st_point(1:2), st_point(3:4))
sfc2 = st_sfc(st_linestring(matrix(1:4, 2)))
sf1 = st_sf(x = c(TRUE, FALSE), geo1 = sfc1)
sf2 = st_sf(y = "", geo2 = sfc2, x = 0, stringsAsFactors = FALSE)
out = vctrs::vec_ptype2(sf1, sf2)
exp = st_sf(
x = double(),
y = character(),
geo1 = sfc1[0],
geo2 = sfc2[0],
stringsAsFactors = FALSE
)
expect_identical(out, exp)
out = vctrs::vec_ptype2(sf1, new_data_frame(sf2))
expect_identical(out, exp)
out = vctrs::vec_ptype2(new_data_frame(sf1), sf2)
exp_rhs = st_sf(
x = double(),
y = character(),
geo1 = sfc1[0],
geo2 = sfc2[0],
stringsAsFactors = FALSE,
sf_column_name = "geo2"
)
expect_identical(out, exp_rhs)
})
test_that("sf has a cast method", {
sfc1 = st_sfc(st_point(1:2), st_point(3:4))
sfc2 = st_sfc(st_linestring(matrix(1:4, 2)))
sf1 = st_sf(x = c(TRUE, FALSE), geo1 = sfc1)
sf2 = st_sf(y = "", geo2 = sfc2, x = 0, stringsAsFactors = FALSE)
expect_error(
vctrs::vec_cast(sf1, sf2),
class = "vctrs_error_cast_lossy"
)
expect_error(
vctrs::vec_cast(sf2, sf1),
class = "vctrs_error_cast_lossy"
)
common = vec_ptype2(sf1, sf2)
out = vctrs::vec_cast(sf1, common)
exp = st_sf(
x = c(1, 0),
y = character(2)[NA],
geo1 = sfc1,
geo2 = sfc2[c(NA, NA) + 0L],
stringsAsFactors = FALSE
)
expect_identical(out, exp)
out = vctrs::vec_cast(new_data_frame(sf1), common)
expect_identical(out, exp)
out = vctrs::vec_cast(sf1, new_data_frame(common))
expect_identical(out, new_data_frame(exp))
out = vctrs::vec_cast(sf2, common)
exp = st_sf(
x = 0,
y = "",
geo1 = sfc1[NA + 0L],
geo2 = sfc2,
stringsAsFactors = FALSE
)
expect_identical(out, exp)
})
# https://github.com/r-lib/vctrs/issues/1136
test_that("can combine sf data frames", {
testthat_import_from("dplyr", "bind_rows")
sfc1 = st_sfc(st_point(1:2), st_point(3:4))
sfc2 = st_sfc(st_linestring(matrix(1:4, 2)))
sf1 = st_sf(x = c(TRUE, FALSE), geo1 = sfc1)
sf2 = st_sf(y = "", geo2 = sfc2, x = 0, stringsAsFactors = FALSE)
exp = data_frame(
x = c(1, 0, 0),
geo1 = sfc1[c(1:2, NA)],
y = c(NA, NA, ""),
geo2 = sfc2[c(NA, NA, 1)]
)
expect_identical(vctrs::vec_rbind(sf1, sf2), exp)
expect_identical(bind_rows(sf1, sf2), st_as_sf(exp))
exp = data_frame(
y = c("", NA, NA, ""),
x = c(0, 1, 0, 0),
geo2 = sfc2[c(1, NA, NA, 1)],
geo1 = sfc1[c(NA, 1:2, NA)]
)
expect_identical(vctrs::vec_rbind(sf2, sf1, sf2), exp)
expect_identical(bind_rows(sf2, sf1, sf2), st_as_sf(exp))
})
test_that("can combine sf and tibble", {
sfc1 = st_sfc(st_point(1:2), st_point(3:4))
sfc2 = st_sfc(st_linestring(matrix(1:4, 2)))
sf1 = st_sf(x = c(TRUE, FALSE), geo1 = sfc1)
sf2 = st_sf(y = "", geo2 = sfc2, x = 0, stringsAsFactors = FALSE)
out = vctrs::vec_rbind(sf2, data.frame(x = 1))
exp = data_frame(
y = c("", NA),
x = c(0, 1),
geo2 = sfc2[c(1L, NA)]
)
expect_identical(out, exp)
out = vctrs::vec_rbind(sf2, tibble::tibble(x = 1))
expect_identical(out, exp)
out = vctrs::vec_rbind(tibble::tibble(x = 1), sf2)
exp = data_frame(
x = c(1, 0),
y = c(NA, ""),
geo2 = sfc2[c(NA, 1L)]
)
expect_identical(out, exp)
})
# https://github.com/r-spatial/sf/issues/1390
test_that("can combine sfc lists", {
ls <- st_linestring(matrix(1:3, ncol = 3))
sfc <- st_sfc(ls)
expect_identical(vec_c(sfc, sfc), c(sfc, sfc))
sf <- st_as_sf(data.frame(id = 1, geometry = sfc))
# Currently returns a bare data frame because of the workaround for
# the `c()` fallback sentinels
expect_identical(vec_rbind(sf, sf), new_data_frame(rbind(sf, sf)))
expect_identical(vec_rbind(sf, sf, sf), new_data_frame(rbind(sf, sf, sf)))
})
test_that("can combine sfc lists with unspecified chunks", {
point <- st_point(1:2)
out <- vec_c(c(NA, NA), st_sfc(point), NA)
expect_identical(out, st_sfc(NA, NA, point, NA))
multipoint <- st_multipoint(matrix(1:4, 2))
x <- st_sfc(point)
y <- st_sfc(multipoint, multipoint)
out <- vec_rbind(
data_frame(x = x),
data_frame(y = y)
)
expect_identical(out, data_frame(
x = st_sfc(point, NA, NA),
y = st_sfc(NA, multipoint, multipoint)
))
})
test_that("`n_empty` attribute of `sfc` vectors is restored", {
pt1 = st_sfc(st_point(c(NA_real_, NA_real_)))
pt2 = st_sfc(st_point(0:1))
x = c(pt1, pt2)
expect_identical(attr(vctrs::vec_slice(x, 1), "n_empty"), 1L)
expect_identical(attr(vctrs::vec_slice(x, 2), "n_empty"), 0L)
combined = vctrs::vec_c(pt1, pt2, pt1)
expect_length(combined, 3)
expect_identical(attr(combined, "n_empty"), 2L)
})
test_that("bbox attributes of `sfc` vectors are restored", {
pt1 = st_sfc(st_point(c(1L, 2L)))
pt2 = st_sfc(st_point(c(10L, 20L)))
x = c(pt1, pt2)
expect_identical(st_bbox(vctrs::vec_slice(x, 1)), st_bbox(pt1))
expect_identical(st_bbox(vctrs::vec_slice(x, 2)), st_bbox(pt2))
combined = vctrs::vec_c(pt1, pt2)
expect_identical(st_bbox(x), st_bbox(combined))
})
test_that("`precision` and `crs` attributes of `sfc` vectors are restored", {
x = st_sfc(st_point(c(pi, pi)), precision = 1e-4, crs = 3857)
out = vctrs::vec_slice(x, 1)
expect_identical(st_precision(x), st_precision(out))
expect_identical(st_crs(x), st_crs(out))
})
test_that("`precision` attributes of `sfc` vectors are combined", {
x = st_sfc(st_point(c(pi, pi)), precision = 1e-4, crs = 3857)
y = st_sfc(st_point(c(0, 0)), precision = 1e-4, crs = 3857)
out = vctrs::vec_c(x, y)
expect_identical(st_precision(x), st_precision(out))
# These used to be errors before we fell back to c()
y = st_sfc(st_point(c(0, 0)), precision = 1e-2, crs = 3857)
expect_identical(vctrs::vec_c(x, y), c(x, y))
# expect_error(vctrs::vec_c(x, y), "precisions not equal")
})
test_that("`crs` attributes of `sfc` vectors must be the same", {
x = st_sfc(st_point(c(pi, pi)), precision = 1e-4, crs = 3857)
y = st_sfc(st_point(c(0, 0)), precision = 1e-4, crs = 3857)
out = vctrs::vec_c(x, y)
expect_identical(st_crs(x), st_crs(out))
# Error on different `crs` comes from sf as of 1.0-10
y = st_sfc(st_point(c(0, 0)), precision = 1e-4, crs = 4326)
expect_snapshot(error = TRUE, {
vctrs::vec_c(x, y)
})
})
test_that("`vec_locate_matches()` works with `sfc` vectors", {
x <- c(
st_sfc(st_point(c(0, 0))),
st_sfc(st_point(c(0, 1))),
st_sfc(st_point(c(2, 1))),
st_sfc(c(st_point(c(0, 1)), st_point(c(0, 1))))
)
y <- c(
st_sfc(c(st_point(c(0, 1)), st_point(c(0, 1)))),
st_sfc(st_point(c(0, 0))),
st_sfc(st_point(c(0, 3))),
st_sfc(st_point(c(0, 0))),
st_sfc(st_point(c(0, 1)))
)
out <- vec_locate_matches(x, y)
expect_identical(out$needles, c(1L, 1L, 2L, 3L, 4L))
expect_identical(out$haystack, c(2L, 4L, 5L, NA, 1L))
})
test_that("`vec_rbind()` doesn't leak common type fallbacks (#1331)", {
sf = st_sf(id = 1:2, geo = st_sfc(st_point(c(1, 1)), st_point(c(2, 2))))
expect_equal(
vec_rbind(sf, sf),
data_frame(id = rep(1:2, 2), geo = rep(sf$geo, 2))
)
expect_equal(
vec_rbind(sf, sf, .names_to = "id"),
data_frame(id = rep(1:2, each = 2), geo = rep(sf$geo, 2))
)
})
# Local Variables:
# indent-tabs-mode: t
# ess-indent-offset: 4
# tab-width: 4
# End:
vctrs/tests/testthat/test-slice.R 0000644 0001762 0000144 00000060770 14511320527 016626 0 ustar ligges users
test_that("vec_slice throws error with non-vector inputs", {
expect_error(vec_slice(environment(), 1L), class = "vctrs_error_scalar_type")
})
test_that("vec_slice throws error with non-vector subscripts", {
expect_snapshot({
(expect_error(vec_slice(1:3, Sys.Date()), class = "vctrs_error_subscript_type"))
(expect_error(vec_slice(1:3, matrix(TRUE, nrow = 1)), class = "vctrs_error_subscript_type"))
})
})
test_that("can subset base vectors", {
i <- 2:3
expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, 1))
expect_identical(vec_slice(int(1, 2, 3), i), int(2, 3))
expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, 3))
expect_identical(vec_slice(cpl(1, 2, 3), i), cpl(2, 3))
expect_identical(vec_slice(chr("1", "2", "3"), i), chr("2", "3"))
expect_identical(vec_slice(raw2(1, 2, 3), i), raw2(2, 3))
expect_identical(vec_slice(list(1, 2, 3), i), list(2, 3))
})
test_that("can subset shaped base vectors", {
i <- 2:3
mat <- as.matrix
expect_identical(vec_slice(mat(lgl(1, 0, 1)), i), mat(lgl(0, 1)))
expect_identical(vec_slice(mat(int(1, 2, 3)), i), mat(int(2, 3)))
expect_identical(vec_slice(mat(dbl(1, 2, 3)), i), mat(dbl(2, 3)))
expect_identical(vec_slice(mat(cpl(1, 2, 3)), i), mat(cpl(2, 3)))
expect_identical(vec_slice(mat(chr("1", "2", "3")), i), mat(chr("2", "3")))
expect_identical(vec_slice(mat(raw2(1, 2, 3)), i), mat(raw2(2, 3)))
expect_identical(vec_slice(mat(list(1, 2, 3)), i), mat(list(2, 3)))
})
test_that("can subset with missing indices", {
for (i in list(int(2L, NA), lgl(FALSE, TRUE, NA))) {
expect_identical(vec_slice(lgl(1, 0, 1), i), lgl(0, NA))
expect_identical(vec_slice(int(1, 2, 3), i), int(2, NA))
expect_identical(vec_slice(dbl(1, 2, 3), i), dbl(2, NA))
expect_identical(vec_slice(cpl2(1, 2, 3), i), cpl2(2, NA))
expect_identical(vec_slice(chr("1", "2", "3"), i), c("2", NA))
expect_identical(vec_slice(raw2(1, 2, 3), i), raw2(2, 0))
expect_identical(vec_slice(list(1, 2, 3), i), list(2, NULL))
}
})
test_that("can subset with a recycled NA", {
local_name_repair_quiet()
expect_identical(vec_slice(1:3, NA), int(NA, NA, NA))
expect_identical(vec_slice(new_vctr(1:3), NA), new_vctr(int(NA, NA, NA)))
rownames <- rep_len("", nrow(mtcars))
rownames <- vec_as_names(rownames, repair = "unique")
expect_identical(vec_slice(mtcars, NA), structure(mtcars[NA, ], row.names = rownames))
})
test_that("can subset with a recycled TRUE", {
expect_identical(vec_slice(1:3, TRUE), 1:3)
expect_identical(vec_slice(mtcars, TRUE), mtcars)
expect_identical(vec_slice(new_vctr(1:3), TRUE), new_vctr(1:3))
expect_identical(vec_as_location(TRUE, 2), 1:2)
})
test_that("can subset with a recycled FALSE", {
expect_identical(vec_slice(1:3, FALSE), int())
expect_identical(vec_slice(mtcars, FALSE), mtcars[NULL, ])
expect_identical(vec_slice(new_vctr(1:3), FALSE), new_vctr(integer()))
})
test_that("can't index beyond the end of a vector", {
expect_snapshot({
(expect_error(vec_slice(1:2, 3L), class = "vctrs_error_subscript_oob"))
(expect_error(vec_slice(1:2, -3L), class = "vctrs_error_subscript_oob"))
})
})
test_that("slicing non existing elements fails", {
expect_error(vec_as_location("foo", 1L, "f"), class = "vctrs_error_subscript_oob")
expect_error(vec_slice(c(f = 1), "foo"), class = "vctrs_error_subscript_oob")
})
test_that("can subset object of any dimensionality", {
x0 <- c(1, 1)
x1 <- ones(2)
x2 <- ones(2, 3)
x3 <- ones(2, 3, 4)
x4 <- ones(2, 3, 4, 5)
expect_equal(vec_slice(x0, 1L), 1)
expect_identical(vec_slice(x1, 1L), ones(1))
expect_identical(vec_slice(x2, 1L), ones(1, 3))
expect_identical(vec_slice(x3, 1L), ones(1, 3, 4))
expect_identical(vec_slice(x4, 1L), ones(1, 3, 4, 5))
})
test_that("can subset using logical subscript", {
x0 <- c(1, 1)
expect_identical(vec_slice(x0, TRUE), x0)
expect_identical(vec_slice(x0, c(TRUE, FALSE)), 1)
expect_error(
vec_slice(x0, c(TRUE, FALSE, TRUE)),
class = "vctrs_error_subscript_size"
)
expect_error(
vec_slice(x0, lgl()),
class = "vctrs_error_subscript_size"
)
expect_error(
vec_slice(mtcars, c(TRUE, FALSE)),
class = "vctrs_error_subscript_size"
)
})
test_that("can subset data frame columns", {
df <- data.frame(x = 1:2)
df$y <- data.frame(a = 2:1)
expect_equal(vec_slice(df, 1L)$y, vec_slice(df$y, 1L))
})
test_that("can subset empty data frames", {
df <- new_data_frame(n = 3L)
expect_equal(vec_size(vec_slice(df, integer())), 0)
expect_equal(vec_size(vec_slice(df, 1L)), 1)
expect_equal(vec_size(vec_slice(df, 1:3)), 3)
df$df <- df
expect_equal(vec_size(vec_slice(df, integer())), 0)
expect_equal(vec_size(vec_slice(df, 1L)), 1)
expect_equal(vec_size(vec_slice(df, 1:3)), 3)
})
test_that("ignores NA in logical subsetting", {
x <- c(NA, 1, 2)
expect_equal(vec_slice(x, x > 0), c(NA, 1, 2))
})
test_that("ignores NA in integer subsetting", {
expect_equal(vec_slice(0:2, c(NA, 2:3)), c(NA, 1, 2))
})
test_that("can't slice with missing argument", {
expect_error(vec_slice(1:3))
expect_error(vec_slice(mtcars))
expect_error(vec_slice(new_vctr(1:3)))
})
test_that("can slice with NULL argument", {
expect_identical(vec_slice(1:3, NULL), integer())
expect_identical(vec_slice(iris, NULL), iris[0, ])
expect_identical(vec_slice(new_vctr(1:3), NULL), new_vctr(integer()))
})
test_that("slicing unclassed structures preserves attributes", {
x <- structure(1:3, foo = "bar")
expect_identical(vec_slice(x, 1L), structure(1L, foo = "bar"))
})
test_that("can slice with negative indices", {
expect_identical(vec_slice(1:3, -c(1L, 3L)), 2L)
expect_identical(vec_slice(mtcars, -(1:30)), vec_slice(mtcars, 31:32))
expect_error(vec_slice(1:3, -c(1L, NA)), class = "vctrs_error_subscript_type")
expect_error(vec_slice(1:3, c(-1L, 1L)), class = "vctrs_error_subscript_type")
})
test_that("0 is ignored in negative indices", {
expect_identical(vec_slice(1:3, c(-2L, 0L)), int(1L, 3L))
expect_identical(vec_slice(1:3, c(0L, -2L)), int(1L, 3L))
})
test_that("0 is ignored in positive indices", {
expect_identical(vec_slice(1:3, 0L), int())
expect_identical(vec_slice(1:3, c(0L, 0L)), int())
expect_identical(vec_slice(1:3, c(0L, 2L, 0L)), 2L)
})
test_that("can slice with double indices", {
expect_identical(vec_slice(1:3, dbl(2, 3)), 2:3)
expect_snapshot((expect_error(vec_as_location(2^31, 3L), class = "vctrs_error_subscript_type")))
})
test_that("can slice with symbols", {
expect_identical(vec_as_location(quote(b), 26, letters), 2L)
})
test_that("can `vec_slice()` S3 objects without dispatch infloop", {
expect_identical(new_vctr(1:3)[1], new_vctr(1L))
expect_identical(new_vctr(as.list(1:3))[1], new_vctr(list(1L)))
})
test_that("can `vec_slice()` records", {
out <- vec_slice(new_rcrd(list(a = 1L, b = 2L)), rep(1, 3))
expect_size(out, 3)
out <- vec_init(new_rcrd(list(a = 1L, b = 2L)), 2)
expect_size(out, 2)
})
test_that("vec_restore() is called after proxied slicing", {
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) x,
vec_restore.vctrs_foobar = function(x, to, ...) "dispatch"
)
expect_identical(vec_slice(foobar(1:3), 2), "dispatch")
})
test_that("vec_slice() is proxied", {
local_proxy()
x <- vec_slice(new_proxy(1:3), 2:3)
expect_identical(proxy_deref(x), 2:3)
})
test_that("dimensions are preserved by vec_slice()", {
# Fallback case
x <- foobar(1:4)
dim(x) <- c(2, 2)
dimnames(x) <- list(a = c("foo", "bar"), b = c("quux", "hunoz"))
out <- vec_slice(x, 1)
exp <- foobar(
c(1L, 3L),
dim = c(1, 2),
dimnames = list(a = "foo", b = c("quux", "hunoz")
))
expect_identical(out, exp)
# Native case
attrib <- NULL
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) x,
vec_restore.vctrs_foobar = function(x, to, ...) attrib <<- attributes(x)
)
vec_slice(x, 1)
exp <- list(dim = 1:2, dimnames = list(a = "foo", b = c("quux", "hunoz")))
expect_identical(attrib, exp)
})
test_that("can slice shaped objects by name", {
x <- matrix(1:2)
expect_error(vec_slice(x, "foo"), "unnamed")
dimnames(x) <- list(c("foo", "bar"))
expect_equal(vec_slice(x, "foo"), vec_slice(x, 1L))
expect_error(vec_slice(x, "baz"), class = "vctrs_error_subscript_oob")
})
test_that("vec_slice() unclasses input before calling `vec_restore()`", {
oo <- NULL
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) x,
vec_restore.vctrs_foobar = function(x, ...) oo <<- is.object(x)
)
x <- foobar(1:4)
dim(x) <- c(2, 2)
vec_slice(x, 1)
expect_false(oo)
})
test_that("can call `vec_slice()` from `[` methods with shaped objects without infloop", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) vec_slice(x, i)
)
x <- foobar(1:4)
dim(x) <- c(2, 2)
exp <- foobar(c(1L, 3L))
dim(exp) <- c(1, 2)
expect_identical(x[1], exp)
})
test_that("vec_slice() restores attributes on shaped S3 objects correctly", {
x <- factor(c("a", "b", "c", "d", "e", "f"))
dim(x) <- c(3, 2)
expect <- factor(c("a", "c", "d", "f"), levels = levels(x))
dim(expect) <- c(2, 2)
expect_identical(vec_slice(x, c(1, 3)), expect)
})
test_that("vec_slice() falls back to `[` with S3 objects", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) "dispatched"
)
expect_identical(vec_slice(foobar(NA), 1), "dispatched")
expect_error(vec_slice(foobar(list(NA)), 1), class = "vctrs_error_scalar_type")
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) x
)
expect_identical(vec_slice(foobar(list(NA)), 1), foobar(list(NA)))
})
test_that("vec_slice() doesn't restore when attributes have already been restored", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) structure("dispatched", foo = "bar"),
vec_restore.vctrs_foobar = function(...) stop("not called")
)
expect_error(vec_slice(foobar(NA), 1), NA)
})
test_that("vec_slice() doesn't restore when `[` method intentionally dropped attributes", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) unstructure(NextMethod()),
vec_restore.vctrs_foobar = function(...) stop("not called")
)
expect_identical(vec_slice(foobar(NA), 1), NA)
})
test_that("can vec_slice() without inflooping when restore calls math generics", {
local_methods(
new_foobar = function(x) {
new_vctr(as.double(x), class = "vctrs_foobar")
},
vec_restore.vctrs_foobar = function(x, ...) {
abs(x)
sum(x)
mean(x)
is.finite(x)
is.infinite(x)
is.nan(x)
new_foobar(x)
}
)
expect_identical(new_foobar(1:10)[1:2], new_foobar(1:2))
})
test_that("vec_restore() is called after slicing data frames", {
local_methods(
vec_restore.vctrs_tabble = function(...) "dispatched"
)
df <- structure(mtcars, class = c("vctrs_tabble", "data.frame"))
expect_identical(vec_slice(df, 1), "dispatched")
})
test_that("additional subscripts are forwarded to `[`", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) vec_index(x, i, ...)
)
x <- foobar(c("foo", "bar", "quux", "hunoz"))
dim(x) <- c(2, 2)
exp <- foobar("quux")
dim(exp) <- c(1, 1)
expect_identical(x[1, 2], exp)
})
test_that("can use names to vec_slice() a named object", {
x0 <- c(a = 1, b = 2)
x1 <- c(a = 1, a = 2)
expect_identical(vec_slice(x0, letters[1]), c(a = 1))
expect_identical(vec_slice(x0, letters[2:1]), c(b = 2, a = 1))
expect_identical(vec_slice(x1, letters[1]), c(a = 1))
expect_error(vec_slice(x0, letters[3:1]), class = "vctrs_error_subscript_oob")
expect_error(vec_slice(x1, letters[2]), class = "vctrs_error_subscript_oob")
})
test_that("can't use names to vec_slice() an unnamed object", {
expect_error(
vec_slice(1:3, letters[1]),
"Can't use character names to index an unnamed vector.",
fixed = TRUE
)
expect_error(
vec_slice(1:3, letters[25:27]),
"Can't use character names to index an unnamed vector.",
fixed = TRUE
)
})
test_that("can slice with missing character indices (#244)", {
expect_identical(vec_as_location(na_chr, 2L, c("x", "")), na_int)
expect_identical(vec_slice(c(x = 1), na_chr), set_names(na_dbl, ""))
expect_identical(vec_slice(c(x = "foo"), na_chr), set_names(na_chr, ""))
})
test_that("can slice with numerics (#577)", {
expect_identical(vec_as_location(1:2, 3), 1:2)
expect_error(vec_as_location(1:2, 3.5), class = "vctrs_error_cast_lossy")
})
test_that("missing indices don't create NA names", {
x <- set_names(letters)
expect_identical(vec_slice(x, na_int), set_names(na_chr, ""))
expect_identical(vec_slice(x, int(1, NA, 3, NA)), chr(a = "a", NA, c = "c", NA))
# Preserves existing NA names
x <- set_names(1:2, c(NA, "foo"))
expect_identical(vec_slice(x, 1:2), x)
})
test_that("vec_slice() asserts vectorness (#301)", {
expect_error(vec_slice(NULL, 1), class = "vctrs_error_scalar_type")
})
test_that("slicing an unspecified logical vector returns a logical vector", {
expect_identical(vec_slice(NA, integer()), logical())
expect_identical(vec_slice(NA, c(1, 1)), c(NA, NA))
})
test_that("slicing an unspecified() object returns an unspecified()", {
expect_identical(vec_slice(unspecified(1), integer()), unspecified())
expect_identical(vec_slice(unspecified(1), c(1, 1)), unspecified(2))
})
test_that("vec_slice() works with Altrep classes with custom extract methods", {
skip_if(getRversion() < "3.5")
x <- .Call(vctrs_altrep_rle_Make, c(foo = 10L, bar = 5L))
idx <- c(9, 10, 11)
expect_equal(vec_slice(x, idx), c("foo", "foo", "bar"))
})
test_that("Unnamed vector with character subscript is caught", {
expect_snapshot(error = TRUE, vec_slice(1:3, letters[1]))
})
test_that("Negative subscripts are checked", {
expect_snapshot(error = TRUE, vec_slice(1:3, -c(1L, NA)))
expect_snapshot(error = TRUE, vec_slice(1:3, c(-1L, 1L)))
})
test_that("oob error messages are properly constructed", {
expect_snapshot(error = TRUE, vec_slice(c(bar = 1), "foo"))
# Multiple OOB indices
expect_snapshot(error = TRUE, vec_slice(letters, c(100, 1000)))
expect_snapshot(error = TRUE, vec_slice(letters, c(1, 100:103, 2, 104:110)))
expect_snapshot(error = TRUE, vec_slice(set_names(letters), c("foo", "bar")))
expect_snapshot(error = TRUE, vec_slice(set_names(letters), toupper(letters)))
})
# vec_init ----------------------------------------------------------------
test_that("na of atomic vectors is as expected", {
expect_equal(vec_init(TRUE), NA)
expect_equal(vec_init(1L), NA_integer_)
expect_equal(vec_init(1), NA_real_)
expect_equal(vec_init("x"), NA_character_)
expect_equal(vec_init(1i), NA_complex_)
})
test_that("na of factor preserves levels", {
f1 <- factor("a", levels = c("a", "b"))
f2 <- vec_init(f1)
expect_equal(levels(f1), levels(f2))
})
test_that("na of POSIXct preserves tz", {
dt1 <- as.POSIXct("2010-01-01", tz = "America/New_York")
dt2 <- vec_init(dt1)
expect_equal(attr(dt2, "tzone"), "America/New_York")
})
test_that("na of list is list(NULL)", {
expect_equal(vec_init(list()), list(NULL))
})
test_that("na of array is 1d slice", {
x1 <- array(1:12, c(2, 3, 4))
x2 <- vec_init(x1)
expect_equal(x2, array(NA_integer_, c(1, 3, 4)))
})
test_that("na of list-array is 1d slice", {
x1 <- array(as.list(1:12), c(2, 3, 4))
x2 <- vec_init(x1)
expect_equal(x2, array(list(), c(1, 3, 4)))
})
test_that("vec_init() asserts vectorness (#301)", {
expect_error(vec_init(NULL, 1L), class = "vctrs_error_scalar_type")
})
test_that("vec_init() works with Altrep classes", {
skip_if(getRversion() < "3.5")
x <- .Call(vctrs_altrep_rle_Make, c(foo = 1L, bar = 2L))
expect_equal(vec_init(x, 2), rep(NA_character_, 2))
})
test_that("vec_init() validates `n`", {
expect_snapshot({
(expect_error(vec_init(1L, 1.5)))
(expect_error(vec_init(1L, c(1, 2))))
(expect_error(vec_init(1L, -1L)))
(expect_error(vec_init(1L, NA)))
(expect_error(vec_init(1L, NA_integer_)))
})
})
# vec_slice + compact_rep -------------------------------------------------
# `i` is 1-based
test_that("names are repaired correctly with compact reps and `NA_integer_`", {
x <- list(a = 1L, b = 2L)
expect <- set_names(list(NULL, NULL), c("", ""))
expect_equal(vec_slice_rep(x, NA_integer_, 2L), expect)
})
test_that("names are recycled correctly with compact reps", {
expect_named(vec_slice_rep(c(x = 1L), 1L, 3L), c("x", "x", "x"))
})
test_that("vec_slice() with compact_reps work with Altrep classes", {
skip_if(getRversion() < "3.5")
x <- .Call(vctrs_altrep_rle_Make, c(foo = 10L, bar = 5L))
expect_equal(vec_slice_rep(x, 10L, 3L), rep("foo", 3))
})
# vec_slice + compact_seq -------------------------------------------------
# `start` is 0-based
test_that("can subset base vectors with compact seqs", {
start <- 1L
size <- 2L
increasing <- TRUE
expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(0, 1))
expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(2, 3))
expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(2, 3))
expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(2, 3))
expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("2", "3"))
expect_identical(vec_slice_seq(raw2(1, 2, 3), start, size, increasing), raw2(2, 3))
expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(2, 3))
})
test_that("can subset base vectors with decreasing compact seqs", {
start <- 2L
size <- 2L
increasing <- FALSE
expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl(1, 0))
expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int(3, 2))
expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl(3, 2))
expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl(3, 2))
expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr("3", "2"))
expect_identical(vec_slice_seq(raw2(1, 2, 3), start, size, increasing), raw2(3, 2))
expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list(3, 2))
})
test_that("can subset base vectors with size 0 compact seqs", {
start <- 1L
size <- 0L
increasing <- TRUE
expect_identical(vec_slice_seq(lgl(1, 0, 1), start, size, increasing), lgl())
expect_identical(vec_slice_seq(int(1, 2, 3), start, size, increasing), int())
expect_identical(vec_slice_seq(dbl(1, 2, 3), start, size, increasing), dbl())
expect_identical(vec_slice_seq(cpl(1, 2, 3), start, size, increasing), cpl())
expect_identical(vec_slice_seq(chr("1", "2", "3"), start, size, increasing), chr())
expect_identical(vec_slice_seq(raw2(1, 2, 3), start, size, increasing), raw2())
expect_identical(vec_slice_seq(list(1, 2, 3), start, size, increasing), list())
})
test_that("can subset shaped base vectors with compact seqs", {
start <- 1L
size <- 2L
increasing <- TRUE
mat <- as.matrix
expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(0, 1)))
expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(2, 3)))
expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(2, 3)))
expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(2, 3)))
expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("2", "3")))
expect_identical(vec_slice_seq(mat(raw2(1, 2, 3)), start, size, increasing), mat(raw2(2, 3)))
expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(2, 3)))
})
test_that("can subset shaped base vectors with decreasing compact seqs", {
start <- 2L
size <- 2L
increasing <- FALSE
mat <- as.matrix
expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl(1, 0)))
expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int(3, 2)))
expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl(3, 2)))
expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl(3, 2)))
expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr("3", "2")))
expect_identical(vec_slice_seq(mat(raw2(1, 2, 3)), start, size, increasing), mat(raw2(3, 2)))
expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list(3, 2)))
})
test_that("can subset shaped base vectors with size 0 compact seqs", {
start <- 1L
size <- 0L
increasing <- TRUE
mat <- as.matrix
expect_identical(vec_slice_seq(mat(lgl(1, 0, 1)), start, size, increasing), mat(lgl()))
expect_identical(vec_slice_seq(mat(int(1, 2, 3)), start, size, increasing), mat(int()))
expect_identical(vec_slice_seq(mat(dbl(1, 2, 3)), start, size, increasing), mat(dbl()))
expect_identical(vec_slice_seq(mat(cpl(1, 2, 3)), start, size, increasing), mat(cpl()))
expect_identical(vec_slice_seq(mat(chr("1", "2", "3")), start, size, increasing), mat(chr()))
expect_identical(vec_slice_seq(mat(raw2(1, 2, 3)), start, size, increasing), mat(raw2()))
expect_identical(vec_slice_seq(mat(list(1, 2, 3)), start, size, increasing), mat(list()))
})
test_that("can subset object of any dimensionality with compact seqs", {
x0 <- c(1, 1)
x1 <- ones(2)
x2 <- ones(2, 3)
x3 <- ones(2, 3, 4)
x4 <- ones(2, 3, 4, 5)
expect_equal(vec_slice_seq(x0, 0L, 1L), 1)
expect_identical(vec_slice_seq(x1, 0L, 1L), ones(1))
expect_identical(vec_slice_seq(x2, 0L, 1L), ones(1, 3))
expect_identical(vec_slice_seq(x3, 0L, 1L), ones(1, 3, 4))
expect_identical(vec_slice_seq(x4, 0L, 1L), ones(1, 3, 4, 5))
})
test_that("can subset data frames with compact seqs", {
df <- data_frame(x = 1:5, y = letters[1:5])
expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer()))
expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L))
expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3))
expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1))
df$df <- df
expect_equal(vec_slice_seq(df, 0L, 0L), vec_slice(df, integer()))
expect_equal(vec_slice_seq(df, 0L, 1L), vec_slice(df, 1L))
expect_equal(vec_slice_seq(df, 0L, 3L), vec_slice(df, 1:3))
expect_equal(vec_slice_seq(df, 2L, 3L, FALSE), vec_slice(df, 3:1))
})
test_that("can subset S3 objects using the fallback method with compact seqs", {
x <- factor(c("a", "b", "c", "d"))
expect_equal(vec_slice_seq(x, 0L, 0L), vec_slice(x, integer()))
expect_equal(vec_slice_seq(x, 0L, 1L), vec_slice(x, 1L))
expect_equal(vec_slice_seq(x, 2L, 2L), vec_slice(x, 3:4))
expect_equal(vec_slice_seq(x, 3L, 2L, FALSE), vec_slice(x, 4:3))
})
test_that("vec_slice() with compact_seqs work with Altrep classes", {
skip_if(getRversion() < "3.5")
x <- .Call(vctrs_altrep_rle_Make, c(foo = 2L, bar = 3L))
expect_equal(vec_slice_seq(x, 1L, 3L), c("foo", "bar", "bar"))
})
test_that("vec_slice() handles symbols and OO objects", {
expect_identical(vec_slice(c(a = 1, b = 2), quote(b)), c(b = 2))
expect_identical(vec_slice(c(a = 1, b = 2), factor("b")), c(b = 2))
expect_error(vec_slice(c(a = 1, b = 2), foobar("b")), class = "vctrs_error_subscript_type")
})
test_that("vec_init() handles names in columns", {
expect_identical(
vec_init(data_frame(x = c(a = 1, b = 2)))$x,
named(na_dbl)
)
expect_identical(
vec_init(data_frame(x = c(1, 2)))$x,
na_dbl
)
})
test_that("vec_slice() restores unrestored but named foreign classes", {
x <- foobar(c(x = 1))
expect_identical(vec_slice(x, 1), x)
expect_identical(vec_chop(x), list(x))
expect_identical(vec_chop(x, indices = list(1)), list(x))
expect_identical(vec_ptype(x), foobar(named(dbl())))
expect_identical(vec_ptype(x), foobar(named(dbl())))
expect_identical(vec_ptype_common(x, x), foobar(named(dbl())))
out <- vec_ptype_common_fallback(x, x)
expect_true(is_common_class_fallback(out))
expect_identical(fallback_class(out), "vctrs_foobar")
})
test_that("scalar type error is thrown when `vec_slice_unsafe()` is called directly (#1139)", {
x <- foobar(as.list(1:3))
expect_error(vec_slice_seq(x, 1L, 1L), class = "vctrs_error_scalar_type")
})
test_that("column sizes are checked before slicing (#552)", {
x <- structure(list(a = 1, b = 2:3), row.names = 1:2, class = "data.frame")
expect_error(
vctrs::vec_slice(x, 2),
"Column `a` (size 1) must match the data frame (size 2)",
fixed = TRUE
)
})
test_that("base_vec_rep() slices data frames with the base::rep() UI", {
df <- data_frame(x = data_frame(y = 1:2))
expect_identical(
base_vec_rep(df, length.out = 4),
vec_slice(df, c(1:2, 1:2))
)
})
test_that("vec_size_assign() slices data frames with the base::rep() UI", {
df <- data_frame(x = data_frame(y = 1:3))
expect_identical(
vec_size_assign(df, 2),
vec_slice(df, 1:2)
)
expect_identical(
vec_size_assign(df, 4),
vec_slice(df, c(1:3, NA))
)
})
vctrs/tests/testthat/helper-encoding.R 0000644 0001762 0000144 00000001374 14202760666 017621 0 ustar ligges users encodings <- function(bytes = FALSE) {
string <- "\u00B0C"
utf8 <- iconv(string, from = Encoding(string), to = "UTF-8")
unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE)
latin1 <- iconv(string, from = Encoding(string), to = "latin1")
out <- list(utf8 = utf8, unknown = unknown, latin1 = latin1)
if (bytes) {
out <- list2(!!! out, bytes = encoding_bytes())
}
out
}
encoding_bytes <- function() {
string <- "\u00B0C"
unknown <- iconv(string, from = Encoding(string), to = "", mark = FALSE)
bytes <- unknown
Encoding(bytes) <- "bytes"
bytes
}
expect_equal_encoding <- function(object, expected) {
args <- vec_recycle_common(object, expected)
expect_equal(Encoding(args[[1L]]), Encoding(args[[2L]]))
}
vctrs/tests/testthat/test-slice-chop.R 0000644 0001762 0000144 00000100622 14402367170 017550 0 ustar ligges users
test_that("vec_chop() throws error with non-vector inputs", {
expect_error(vec_chop(NULL), class = "vctrs_error_scalar_type")
expect_error(vec_chop(environment()), class = "vctrs_error_scalar_type")
})
test_that("atomics are split into a list", {
x <- 1:5
expect_equal(vec_chop(x), as.list(x))
x <- letters[1:5]
expect_equal(vec_chop(x), as.list(x))
})
test_that("atomic names are kept", {
x <- set_names(1:5)
result <- lapply(vec_chop(x), names)
expect_equal(result, as.list(names(x)))
})
test_that("base R classed objects are split into a list", {
fctr <- factor(c("a", "b"))
expect <- lapply(vec_seq_along(fctr), vec_slice, x = fctr)
expect_equal(vec_chop(fctr), expect)
date <- new_date(c(0, 1))
expect <- lapply(vec_seq_along(date), vec_slice, x = date)
expect_equal(vec_chop(date), expect)
})
test_that("base R classed object names are kept", {
fctr <- set_names(factor(c("a", "b")))
result <- lapply(vec_chop(fctr), names)
expect_equal(result, as.list(names(fctr)))
})
test_that("list elements are split", {
x <- list(1, 2)
result <- list(vec_slice(x, 1), vec_slice(x, 2))
expect_equal(vec_chop(x), result)
})
test_that("data frames are split rowwise", {
x <- data_frame(x = 1:2, y = c("a", "b"))
result <- list(vec_slice(x, 1), vec_slice(x, 2))
expect_equal(vec_chop(x), result)
})
test_that("vec_chop() keeps data frame row names", {
x <- data_frame(x = 1:2, y = c("a", "b"))
rownames(x) <- c("r1", "r2")
result <- lapply(vec_chop(x), rownames)
expect_equal(result, list("r1", "r2"))
})
test_that("vec_chop() keeps data frame row names for data frames with 0 columns (#1722)", {
x <- data_frame(.size = 3)
rownames(x) <- c("r1", "r2", "r3")
out <- lapply(vec_chop(x), rownames)
expect_identical(out, list("r1", "r2", "r3"))
out <- vec_chop(x, indices = list(c(2, NA), 3))
out <- lapply(out, rownames)
expect_identical(out, list(c("r2", "...2"), "r3"))
out <- vec_chop(x, sizes = c(1, 2, 0))
out <- lapply(out, rownames)
expect_identical(out, list("r1", c("r2", "r3"), character()))
})
test_that("data frames with 0 columns retain the right number of rows (#1722)", {
x <- data_frame(.size = 4)
one <- data_frame(.size = 1L)
expect_identical(
vec_chop(x),
list(one, one, one, one)
)
expect_identical(
vec_chop(x, indices = list(c(1, 3, 2), c(3, NA))),
list(
data_frame(.size = 3),
data_frame(.size = 2)
)
)
expect_identical(
vec_chop(x, sizes = c(3, 1, 0)),
list(
data_frame(.size = 3),
data_frame(.size = 1),
data_frame(.size = 0)
)
)
})
test_that("matrices / arrays are split rowwise", {
x <- array(1:12, c(2, 2, 2))
result <- list(vec_slice(x, 1), vec_slice(x, 2))
expect_equal(vec_chop(x), result)
})
test_that("matrix / array row names are kept", {
x <- array(1:12, c(2, 2, 2), dimnames = list(c("r1", "r2"), c("c1", "c2")))
result <- lapply(vec_chop(x), rownames)
expect_equal(result, list("r1", "r2"))
})
test_that("matrices / arrays without row names have other dimension names kept", {
x <- array(1:12, c(2, 2, 2), dimnames = list(NULL, c("c1", "c2")))
result <- lapply(vec_chop(x), colnames)
expect_equal(result, list(c("c1", "c2"), c("c1", "c2")))
})
test_that("vec_chop() doesn't restore when attributes have already been restored", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) structure("dispatched", foo = "bar"),
vec_restore.vctrs_foobar = function(...) structure("dispatched-and-restored", foo = "bar")
)
result <- vec_chop(foobar(NA))[[1]]
expect_equal(result, structure("dispatched", foo = "bar"))
result <- vec_chop(foobar(NA), indices = list(1))[[1]]
expect_equal(result, structure("dispatched", foo = "bar"))
result <- vec_chop(foobar(NA), sizes = 1)[[1]]
expect_equal(result, structure("dispatched", foo = "bar"))
})
test_that("vec_chop() does not restore when attributes have not been restored by `[`", {
local_methods(
`[.vctrs_foobar` = function(x, i, ...) "dispatched",
vec_restore.vctrs_foobar = function(...) "dispatched-and-restored"
)
result <- vec_chop(foobar(NA))[[1]]
expect_equal(result, "dispatched")
result <- vec_chop(foobar(NA), indices = list(1))[[1]]
expect_equal(result, "dispatched")
result <- vec_chop(foobar(NA), sizes = 1)[[1]]
expect_equal(result, "dispatched")
})
test_that("vec_chop() falls back to `[` for shaped objects with no proxy", {
x <- foobar(1)
dim(x) <- c(1, 1)
result <- vec_chop(x)[[1]]
expect_equal(result, x)
result <- vec_chop(x, indices = list(1))[[1]]
expect_equal(result, x)
result <- vec_chop(x, sizes = 1)[[1]]
expect_equal(result, x)
})
test_that("`indices` are validated", {
expect_snapshot(error = TRUE, {
vec_chop(1, indices = 1)
})
expect_snapshot({
(expect_error(vec_chop(1, indices = list(1.5)), class = "vctrs_error_subscript_type"))
})
expect_snapshot({
(expect_error(vec_chop(1, indices = list(2)), class = "vctrs_error_subscript_oob"))
})
})
test_that("`sizes` are validated", {
expect_snapshot(error = TRUE, {
vec_chop("a", sizes = "a")
})
expect_snapshot(error = TRUE, {
vec_chop("a", sizes = 2)
})
expect_snapshot(error = TRUE, {
vec_chop("a", sizes = -1)
})
expect_snapshot(error = TRUE, {
vec_chop("a", sizes = NA_integer_)
})
expect_snapshot(error = TRUE, {
vec_chop("a", sizes = c(1, 1))
})
})
test_that("can't use both `indices` and `sizes`", {
expect_snapshot(error = TRUE, {
vec_chop(1, indices = list(1), sizes = 1)
})
})
test_that("`sizes` allows `0`", {
expect_identical(
vec_chop(c("a", "b"), sizes = c(1, 0, 0, 1, 0)),
list("a", character(), character(), "b", character())
)
})
test_that("size 0 `indices` list is allowed", {
expect_equal(vec_chop(1, indices = list()), list())
})
test_that("individual index values of size 0 are allowed", {
expect_equal(vec_chop(1, indices = list(integer())), list(numeric()))
df <- data.frame(a = 1, b = "1")
expect_equal(vec_chop(df, indices = list(integer())), list(vec_ptype(df)))
})
test_that("individual index values of `NULL` are allowed", {
expect_equal(vec_chop(1, indices = list(NULL)), list(numeric()))
df <- data.frame(a = 1, b = "1")
expect_equal(vec_chop(df, indices = list(NULL)), list(vec_ptype(df)))
})
test_that("data frame row names are kept when `indices` or `sizes` are used", {
x <- data_frame(x = 1:2, y = c("a", "b"))
rownames(x) <- c("r1", "r2")
result <- lapply(vec_chop(x, indices = list(1, 1:2)), rownames)
expect_equal(result, list("r1", c("r1", "r2")))
result <- lapply(vec_chop(x, sizes = c(1, 0, 1)), rownames)
expect_equal(result, list("r1", character(), "r2"))
})
test_that("vec_chop(, indices/sizes =) can be equivalent to the default", {
x <- 1:5
indices <- as.list(vec_seq_along(x))
expect_equal(vec_chop(x, indices = indices), vec_chop(x))
sizes <- vec_rep(1L, times = vec_size(x))
expect_equal(vec_chop(x, sizes = sizes), vec_chop(x))
})
test_that("vec_chop(, indices/sizes =) can be equivalent to the default", {
x <- data.frame(x = 1:5)
indices <- as.list(vec_seq_along(x))
expect_equal(vec_chop(x, indices = indices), vec_chop(x))
sizes <- vec_rep(1L, times = vec_size(x))
expect_equal(vec_chop(x, sizes = sizes), vec_chop(x))
})
test_that("vec_chop(, indices/sizes =) can be equivalent to the default", {
x <- array(1:8, c(2, 2, 2))
indices <- as.list(vec_seq_along(x))
expect_equal(vec_chop(x, indices = indices), vec_chop(x))
sizes <- vec_rep(1L, times = vec_size(x))
expect_equal(vec_chop(x, sizes = sizes), vec_chop(x))
})
test_that("`indices` cannot use names", {
x <- set_names(1:3, c("a", "b", "c"))
expect_error(vec_chop(x, indices = list("a", c("b", "c"))), class = "vctrs_error_subscript_type")
x <- array(1:4, c(2, 2), dimnames = list(c("r1", "r2")))
expect_error(vec_chop(x, indices = list("r1")), class = "vctrs_error_subscript_type")
x <- data.frame(x = 1, row.names = "r1")
expect_error(vec_chop(x, indices = list("r1")), class = "vctrs_error_subscript_type")
})
test_that("fallback method with `indices` and `sizes` works", {
fctr <- factor(c("a", "b"))
indices <- list(1, c(1, 2))
sizes <- c(1, 0, 1)
expect_equal(
vec_chop(fctr, indices = indices),
map(indices, vec_slice, x = fctr)
)
expect_equal(
vec_chop(fctr, sizes = sizes),
list(vec_slice(fctr, 1), vec_slice(fctr, 0), vec_slice(fctr, 2))
)
})
test_that("vec_chop() falls back to `[` for shaped objects with no proxy when `indices` or `sizes` are provided", {
x <- foobar(1)
dim(x) <- c(1, 1)
result <- vec_chop(x, indices = list(1))[[1]]
expect_equal(result, x)
result <- vec_chop(x, sizes = 1)[[1]]
expect_equal(result, x)
})
test_that("vec_chop() with data frame proxies always uses the proxy's length info", {
local_methods(
vec_proxy.vctrs_proxy = function(x, ...) {
x <- proxy_deref(x)
new_data_frame(list(x = x$x, y = x$y))
},
vec_restore.vctrs_proxy = function(x, to, ...) {
new_proxy(list(x = x$x, y = x$y))
}
)
x <- new_proxy(list(x = 1:2, y = 3:4))
result <- vec_chop(x)
result1 <- result[[1]]
result2 <- result[[2]]
expect1 <- new_proxy(list(x = 1L, y = 3L))
expect2 <- new_proxy(list(x = 2L, y = 4L))
expect_identical(proxy_deref(result1), proxy_deref(expect1))
expect_identical(proxy_deref(result2), proxy_deref(expect2))
})
test_that("ALTREP objects always generate materialized chops (#1450)", {
skip_if(getRversion() <= "3.5.0")
x <- .Call(vctrs_altrep_rle_Make, c(foo = 10L, bar = 5L))
# `x` starts in compact form
expect_false(.Call(vctrs_altrep_rle_is_materialized, x))
result <- vec_chop(x)
# Chopping materializes `x`
expect_true(.Call(vctrs_altrep_rle_is_materialized, x))
# And chopped elements are not ALTREP vectors
expect_false(any(map_lgl(result, is_altrep)))
expect <- vec_chop(c(rep("foo", 10), rep("bar", 5)))
expect_identical(result, expect)
})
test_that("`vec_chop(x, indices)` backwards compatible behavior works", {
# No issues here
expect_identical(
vec_chop(1:2, list(1, 2)),
vec_chop(1:2, indices = list(1, 2))
)
# Errors still talk about `indices`
expect_snapshot(error = TRUE, {
vec_chop(1:2, 1)
})
expect_snapshot(error = TRUE, {
vec_chop(1, list(1), sizes = 1)
})
# These cases aren't allowed because they weren't possible previously either
expect_snapshot(error = TRUE, {
vec_chop(1, list(1), 2)
})
expect_snapshot(error = TRUE, {
vec_chop(1, list(1), indices = list(1))
})
})
# vec_chop + compact_seq --------------------------------------------------
# `start` is 0-based
test_that("can chop base vectors with compact seqs", {
start <- 1L
size <- 2L
expect_identical(vec_chop_seq(lgl(1, 0, 1), start, size), list(lgl(0, 1)))
expect_identical(vec_chop_seq(int(1, 2, 3), start, size), list(int(2, 3)))
expect_identical(vec_chop_seq(dbl(1, 2, 3), start, size), list(dbl(2, 3)))
expect_identical(vec_chop_seq(cpl(1, 2, 3), start, size), list(cpl(2, 3)))
expect_identical(vec_chop_seq(chr("1", "2", "3"), start, size), list(chr("2", "3")))
expect_identical(vec_chop_seq(raw2(1, 2, 3), start, size), list(raw2(2, 3)))
expect_identical(vec_chop_seq(list(1, 2, 3), start, size), list(list(2, 3)))
})
test_that("can chop with a decreasing compact seq", {
expect_equal(vec_chop_seq(int(1, 2, 3), 1L, 2L, FALSE), list(int(2, 1)))
})
test_that("can chop with multiple compact seqs", {
start <- c(1L, 0L)
size <- c(1L, 3L)
expect_equal(
vec_chop_seq(int(1, 2, 3), start, size),
list(int(2), int(1, 2, 3))
)
})
test_that("can chop S3 objects using the fallback method with compact seqs", {
x <- factor(c("a", "b", "c", "d"))
expect_equal(vec_chop_seq(x, 0L, 0L), list(vec_slice(x, integer())))
expect_equal(vec_chop_seq(x, 0L, 1L), list(vec_slice(x, 1L)))
expect_equal(vec_chop_seq(x, 2L, 2L), list(vec_slice(x, 3:4)))
})
test_that("data frames with 0 columns retain the right number of rows with compact seqs (#1722)", {
x <- data_frame(.size = 4)
out <- vec_chop_seq(x, starts = c(0L, 0L, 2L), sizes = c(0L, 2L, 1L))
out <- map_int(out, vec_size)
expect_identical(out, c(0L, 2L, 1L))
})
# list_unchop --------------------------------------------------------------
test_that("`x` must be a list", {
expect_snapshot(error = TRUE, {
list_unchop(1, indices = list(1))
})
expect_snapshot(error = TRUE, {
list_unchop(1, indices = list(1), error_call = call("foo"), error_arg = "arg")
})
expect_snapshot(error = TRUE, {
list_unchop(data.frame(x=1), indices = list(1))
})
})
test_that("`indices` must be a list", {
expect_snapshot(error = TRUE, {
list_unchop(list(1), indices = 1)
})
expect_snapshot(error = TRUE, {
list_unchop(list(1), indices = 1, error_call = call("foo"))
})
expect_snapshot(error = TRUE, {
list_unchop(list(1), indices = data.frame(x=1))
})
})
test_that("`indices` must be a list of integers", {
expect_error(list_unchop(list(1), indices = list("x")), class = "vctrs_error_subscript_type")
expect_error(list_unchop(list(1), indices = list(TRUE)), class = "vctrs_error_subscript_type")
expect_error(list_unchop(list(1), indices = list(quote(name))), class = "vctrs_error_subscript_type")
})
test_that("`x` and `indices` must be lists of the same size", {
expect_error(list_unchop(list(1, 2), indices = list(1)), "`x` and `indices` must be lists of the same size")
})
test_that("can unchop with an AsIs list (#1463)", {
x <- I(list(1, 2))
expect_identical(list_unchop(x), c(1, 2))
})
test_that("can unchop empty vectors", {
expect_null(list_unchop(list()))
expect_null(list_unchop(list(), indices = list()))
expect_identical(list_unchop(list(), indices = list(), ptype = numeric()), numeric())
})
test_that("can unchop a list of NULL", {
expect_null(list_unchop(list(NULL), indices = list(integer())))
expect_identical(list_unchop(list(NULL), indices = list(integer()), ptype = numeric()), numeric())
expect_identical(list_unchop(list(NULL, NULL), indices = list(integer(), integer()), ptype = numeric()), numeric())
})
test_that("NULLs are ignored when unchopped with other vectors", {
expect_identical(list_unchop(list("a", NULL, "b")), c("a", "b"))
expect_identical(list_unchop(list("a", NULL, "b"), indices = list(2, integer(), 1)), c("b", "a"))
})
test_that("can use a `NULL` element with a corresponding index", {
# FIXME: Probably not quite right, but not entirely clear what it should be:
# - Maybe `unspecified(2)`?
# - Or should `NULL`s even be allowed in `list_unchop()`?
expect_null(list_unchop(list(NULL), indices = list(1:2)))
expect_identical(
list_unchop(list(NULL), indices = list(1:2), ptype = integer()),
c(NA_integer_, NA_integer_)
)
x <- list("a", NULL, c("b", "c"))
indices <- list(3L, c(1L, 4L), c(2L, 5L))
expect_identical(list_unchop(x, indices = indices), c(NA, "b", "a", NA, "c"))
})
test_that("can unchop atomic vectors", {
expect_identical(list_unchop(list(1, 2), indices = list(2, 1)), c(2, 1))
expect_identical(list_unchop(list("a", "b"), indices = list(2, 1)), c("b", "a"))
})
test_that("can unchop lists", {
x <- list(list("a", "b"), list("c"))
indices <- list(c(2, 3), 1)
expect_identical(list_unchop(x, indices = indices), list("c", "a", "b"))
})
test_that("can unchop data frames", {
df1 <- data_frame(x = 1:2)
df2 <- data_frame(x = 3:4)
x <- list(df1, df2)
indices <- list(c(3, 1), c(2, 4))
expect <- vec_slice(vec_c(df1, df2), vec_order(vec_c(!!! indices)))
expect_identical(list_unchop(x, indices = indices), expect)
})
test_that("can unchop factors", {
fctr1 <- factor("z")
fctr2 <- factor(c("x", "y"))
x <- list(fctr1, fctr2)
indices <- list(2, c(3, 1))
# levels are in the order they are seen!
expect <- factor(c("y", "z", "x"), levels = c("z", "x", "y"))
expect_identical(list_unchop(x, indices = indices), expect)
})
test_that("can fallback when unchopping matrices", {
mat1 <- matrix(1:4, nrow = 2, ncol = 2)
mat2 <- matrix(5:10, nrow = 3, ncol = 2)
x <- list(mat1, mat2)
indices <- list(c(4, 1), c(2, 3, 5))
expect <- vec_slice(vec_c(mat1, mat2), vec_order(vec_c(!!! indices)))
expect_identical(list_unchop(x, indices = indices), expect)
expect_identical(list_unchop(x), vec_c(mat1, mat2))
})
test_that("can fallback when unchopping arrays of >2D", {
arr1 <- array(1:8, c(2, 2, 2))
arr2 <- matrix(9:10, c(1, 2))
x <- list(arr1, arr2)
indices <- list(c(3, 1), 2)
expect <- vec_slice(vec_c(arr1, arr2), vec_order(vec_c(!!! indices)))
expect_identical(list_unchop(x, indices = indices), expect)
expect_identical(list_unchop(x), vec_c(arr1, arr2))
})
test_that("can unchop with all size 0 elements and get the right ptype", {
x <- list(integer(), integer())
indices <- list(integer(), integer())
expect_identical(list_unchop(x, indices = indices), integer())
})
test_that("can unchop with some size 0 elements", {
x <- list(integer(), 1:2, integer())
indices <- list(integer(), 2:1, integer())
expect_identical(list_unchop(x, indices = indices), 2:1)
})
test_that("NULL is a valid index", {
expect_equal(list_unchop(list(1, 2), indices = list(NULL, 1)), 2)
expect_error(list_unchop(list(1, 2), indices = list(NULL, 2)), class = "vctrs_error_subscript_oob")
})
test_that("unchopping recycles elements of x to the size of the index", {
x <- list(1, 2)
indices <- list(c(3, 4, 5), c(2, 1))
expect_identical(list_unchop(x, indices = indices), c(2, 2, 1, 1, 1))
x <- list(1:2)
indices <- list(1:3)
expect_snapshot({
(expect_error(list_unchop(x, indices = indices)))
(expect_error(list_unchop(x, indices = indices, error_call = call("foo"), error_arg = "arg")))
})
})
test_that("unchopping takes the common type", {
x <- list(1, "a")
indices <- list(1, 2)
expect_snapshot({
(expect_error(list_unchop(x, indices = indices), class = "vctrs_error_incompatible_type"))
(expect_error(list_unchop(x, indices = indices, error_call = call("foo"), error_arg = "arg"), class = "vctrs_error_incompatible_type"))
})
x <- list(1, 2L)
expect_type(list_unchop(x, indices = indices), "double")
})
test_that("common type failure uses positional errors", {
expect_snapshot({
x <- list(1, a = "x", 2)
# Looking for `x[[1]]` and `x$a`
(expect_error(list_unchop(x)))
(expect_error(list_unchop(x, indices = list(2, 1, 3))))
# Directed cast should also produce directional errors (#1690)
(expect_error(list_unchop(x, ptype = double())))
(expect_error(list_unchop(x, indices = list(2, 1, 3), ptype = double())))
# Lossy cast
y <- list(1, a = 2.5)
(expect_error(list_unchop(y, ptype = integer())))
(expect_error(list_unchop(y, indices = list(2, 1), ptype = integer())))
})
})
test_that("can specify a ptype to override common type", {
indices <- list(1, 2)
x <- list(1, 2L)
expect_identical(list_unchop(x, indices = indices, ptype = integer()), c(1L, 2L))
x <- list(1.5, 2)
expect_snapshot({
(expect_error(list_unchop(x, indices = indices, ptype = integer())))
(expect_error(list_unchop(x, indices = indices, ptype = integer(), error_call = call("foo"), error_arg = "arg")))
})
})
test_that("leaving `indices = NULL` unchops sequentially", {
x <- list(1:2, 3:5, 6L)
expect_identical(list_unchop(x), 1:6)
})
test_that("outer names are kept", {
x <- list(x = 1, y = 2)
expect_named(list_unchop(x), c("x", "y"))
expect_named(list_unchop(x, indices = list(2, 1)), c("y", "x"))
})
test_that("outer names are recycled in the right order", {
x <- list(x = 1, y = 2)
expect_error(list_unchop(x, indices = list(c(1, 2), 3)), "Can't merge")
expect_named(list_unchop(x, indices = list(c(1, 3), 2), name_spec = "{outer}_{inner}"), c("x_1", "y", "x_2"))
expect_named(list_unchop(x, indices = list(c(3, 1), 2), name_spec = "{outer}_{inner}"), c("x_2", "y", "x_1"))
})
test_that("outer names can be merged with inner names", {
x <- list(x = c(a = 1), y = c(b = 2))
expect_error(list_unchop(x), "Can't merge")
expect_named(list_unchop(x, name_spec = "{outer}_{inner}"), c("x_a", "y_b"))
expect_named(list_unchop(x, indices = list(2, 1), name_spec = "{outer}_{inner}"), c("y_b", "x_a"))
})
test_that("preserves names when inputs are cast to a common type (#1689)", {
expect_named(list_unchop(list(c(a = 1)), ptype = integer()), "a")
expect_named(list_unchop(list(c(a = 1)), ptype = integer(), indices = list(1)), "a")
# With name spec
name_spec <- "{outer}_{inner}"
expect_named(list_unchop(list(foo = c(a = 1)), ptype = integer(), name_spec = name_spec), "foo_a")
expect_named(list_unchop(list(foo = c(a = 1)), ptype = integer(), name_spec = name_spec, indices = list(1)), "foo_a")
# When `x` elements are recycled, names are also recycled
x <- list(c(a = 1), c(b = 2))
indices <- list(1:2, 3:4)
expect_named(list_unchop(x, indices = indices, ptype = integer()), c("a", "a", "b", "b"))
})
test_that("not all inputs have to be named", {
x <- list(c(a = 1), 2, c(c = 3))
indices <- list(2, 1, 3)
expect_named(list_unchop(x, indices = indices), c("", "a", "c"))
})
test_that("list_unchop() keeps data frame row names", {
df1 <- data.frame(x = 1:2, row.names = c("r1", "r2"))
df2 <- data.frame(x = 3:4, row.names = c("r3", "r4"))
x <- list(df1, df2)
indices <- list(c(3, 1), c(2, 4))
result <- list_unchop(x, indices = indices)
expect <- c("r2", "r3", "r1", "r4")
expect_identical(vec_names(result), expect)
})
test_that("individual data frame columns retain vector names", {
df1 <- data_frame(x = c(a = 1, b = 2))
df2 <- data_frame(x = c(c = 3))
x <- list(df1, df2)
indices <- list(c(1, 2), 3)
result <- list_unchop(x, indices = indices)
expect_named(result$x, c("a", "b", "c"))
# Names should be identical to equivalent `vec_c()` call
expect_identical(list_unchop(x, indices = indices), vec_c(!!!x))
})
test_that("df-col row names are repaired silently", {
df1 <- data_frame(x = new_data_frame(list(a = 1), row.names = "inner"))
df2 <- data_frame(x = new_data_frame(list(a = 2), row.names = "inner"))
x <- list(df1, df2)
indices <- list(1, 2)
expect_silent({
result <- list_unchop(x, indices = indices)
})
expect_identical(vec_names(result$x), c("inner...1", "inner...2"))
})
test_that("monitoring - can technically assign to the same location twice", {
x <- list(1:2, 3L)
indices <- list(1:2, 1L)
expect_identical(list_unchop(x, indices = indices), c(3L, 2L, NA))
})
test_that("index values are validated", {
x <- list(1, 2)
indices1 <- list(4, 1)
indices2 <- list(c(1, 4), 2)
indices3 <- list(c(1, 3, 4), 2)
expect_error(list_unchop(x, indices = indices1), class = "vctrs_error_subscript_oob")
expect_error(list_unchop(x, indices = indices2), class = "vctrs_error_subscript_oob")
expect_identical(list_unchop(x, indices = indices3), c(1, 2, 1, 1))
})
test_that("name repair is respected and happens after ordering according to `indices`", {
local_name_repair_quiet()
x <- list(c(a = 1), c(a = 2))
indices <- list(2, 1)
expect_named(list_unchop(x, indices = indices), c("a", "a"))
expect_named(list_unchop(x, indices = indices, name_repair = "unique"), c("a...1", "a...2"))
})
test_that("list_unchop() can repair names quietly", {
local_name_repair_verbose()
x <- c(x = "a", x = "b", x = "c")
indices <- list(2, c(3, 1))
expect_snapshot({
res <- list_unchop(vec_chop(x, indices = indices), indices = indices, name_repair = "unique_quiet")
})
expect_named(res, c("x...1", "x...2", "x...3"))
x <- c("if" = "a", "in" = "b", "for" = "c")
indices <- list(2, c(3, 1))
expect_snapshot({
res <- list_unchop(vec_chop(x, indices = indices), indices = indices, name_repair = "universal_quiet")
})
expect_named(res, c(".if", ".in", ".for"))
})
test_that("list_unchop() errors on unsupported location values", {
expect_snapshot({
(expect_error(
list_unchop(list(1, 2), indices = list(c(1, 2), 0)),
class = "vctrs_error_subscript_type"
))
(expect_error(
list_unchop(list(1), indices = list(-1)),
class = "vctrs_error_subscript_type"
))
})
})
test_that("missing values propagate", {
expect_identical(
list_unchop(list(1, 2), indices = list(c(NA_integer_, NA_integer_), c(NA_integer_, 3))),
c(NA, NA, 2, NA)
)
})
test_that("list_unchop() works with simple homogeneous foreign S3 classes", {
expect_identical(list_unchop(list(foobar(1), foobar(2))), vec_c(foobar(c(1, 2))))
})
test_that("list_unchop() fails with complex foreign S3 classes", {
expect_snapshot({
x <- structure(foobar(1), attr_foo = "foo")
y <- structure(foobar(2), attr_bar = "bar")
(expect_error(list_unchop(list(x, y)), class = "vctrs_error_incompatible_type"))
(expect_error(list_unchop(list(x, y), error_call = call("foo"), error_arg = "arg"), class = "vctrs_error_incompatible_type"))
})
})
test_that("list_unchop() fails with complex foreign S4 classes", {
expect_snapshot({
joe <- .Counts(c(1L, 2L), name = "Joe")
jane <- .Counts(3L, name = "Jane")
(expect_error(list_unchop(list(joe, jane)), class = "vctrs_error_incompatible_type"))
(expect_error(list_unchop(list(joe, jane), error_call = call("foo"), error_arg = "arg"), class = "vctrs_error_incompatible_type"))
})
})
test_that("list_unchop() falls back to c() if S3 method is available", {
# Check off-by-one error
expect_error(
list_unchop(list(foobar(1), "", foobar(2)), indices = list(1, 2, 3)),
class = "vctrs_error_incompatible_type"
)
# Fallback when the class implements `c()`
method_foobar <- function(...) {
xs <- list(...)
xs <- map(xs, unclass)
res <- exec("c", !!!xs)
foobar(res)
}
local_methods(
c.vctrs_foobar = method_foobar
)
expect_identical(
list_unchop(list(foobar(1), foobar(2))),
foobar(c(1, 2))
)
expect_identical(
list_unchop(list(foobar(1), foobar(2)), indices = list(1, 2)),
foobar(c(1, 2))
)
expect_identical(
list_unchop(list(foobar(1), foobar(2)), indices = list(2, 1)),
foobar(c(2, 1))
)
expect_identical(
list_unchop(list(NULL, foobar(1), NULL, foobar(2))),
foobar(c(1, 2))
)
# OOB error is respected
expect_error(
list_unchop(list(foobar(1), foobar(2)), indices = list(1, 3)),
class = "vctrs_error_subscript_oob"
)
# Unassigned locations results in missing values.
# Repeated assignment uses the last assigned value.
expect_identical(
list_unchop(list(foobar(c(1, 2)), foobar(3)), indices = list(c(1, 3), 1)),
foobar(c(3, NA, 2))
)
expect_identical(
list_unchop(list(foobar(c(1, 2)), foobar(3)), indices = list(c(2, NA), NA)),
foobar(c(NA, 1, NA))
)
# Names are kept
expect_identical(
list_unchop(list(foobar(c(x = 1, y = 2)), foobar(c(x = 1))), indices = list(c(2, 1), 3)),
foobar(c(y = 2, x = 1, x = 1))
)
# Recycles to the size of index
expect_identical(
list_unchop(list(foobar(1), foobar(2)), indices = list(c(1, 3), 2)),
foobar(c(1, 2, 1))
)
expect_identical(
list_unchop(list(foobar(1), foobar(2)), indices = list(c(1, 2), integer())),
foobar(c(1, 1))
)
expect_snapshot({
(expect_error(
list_unchop(list(foobar(1), foobar(2)), indices = list(c(1, 3), integer())),
class = "vctrs_error_subscript_oob"
))
})
expect_snapshot({
x <- list(foobar(1:2))
indices <- list(1:3)
(expect_error(list_unchop(x, indices = indices)))
(expect_error(list_unchop(x, indices = indices, error_arg = "arg", error_call = call("foo"))))
})
method_vctrs_c_fallback <- function(...) {
xs <- list(...)
xs <- map(xs, unclass)
res <- exec("c", !!!xs)
structure(res, class = "vctrs_c_fallback")
}
# Registered fallback
s3_register("base::c", "vctrs_c_fallback", method_vctrs_c_fallback)
expect_identical(
list_unchop(
list(
structure(1, class = "vctrs_c_fallback"),
structure(2, class = "vctrs_c_fallback")
),
indices = list(2, 1)
),
structure(c(2, 1), class = "vctrs_c_fallback")
)
# Don't fallback for S3 lists which are treated as scalars by default
expect_error(
list_unchop(list(foobar(list(1)), foobar(list(2)))),
class = "vctrs_error_scalar_type"
)
})
test_that("list_unchop() falls back for S4 classes with a registered c() method", {
joe <- .Counts(c(1L, 2L), name = "Joe")
jane <- .Counts(3L, name = "Jane")
expect_snapshot({
(expect_error(
list_unchop(list(joe, 1, jane), indices = list(c(1, 2), 3, 4)),
class = "vctrs_error_incompatible_type"
))
})
local_c_counts()
expect_identical(
list_unchop(list(joe, jane), indices = list(c(1, 3), 2)),
.Counts(c(1L, 3L, 2L), name = "Dispatched")
)
expect_identical(
list_unchop(list(NULL, joe, jane), indices = list(integer(), c(1, 3), 2)),
.Counts(c(1L, 3L, 2L), name = "Dispatched")
)
# Unassigned locations results in missing values.
# Repeated assignment uses the last assigned value.
expect_identical(
list_unchop(list(joe, jane), indices = list(c(1, 3), 1)),
.Counts(c(3L, NA, 2L), name = "Dispatched")
)
expect_identical(
list_unchop(list(joe, jane), indices = list(c(2, NA), NA)),
.Counts(c(NA, 1L, NA), name = "Dispatched")
)
})
test_that("list_unchop() fallback doesn't support `name_spec` or `ptype`", {
expect_snapshot({
foo <- structure(foobar(1), foo = "foo")
bar <- structure(foobar(2), bar = "bar")
(expect_error(
with_c_foobar(list_unchop(list(foo, bar), name_spec = "{outer}_{inner}")),
"name specification"
))
# With error call
(expect_error(
with_c_foobar(list_unchop(list(foo, bar), name_spec = "{outer}_{inner}", error_call = call("foo"))),
"name specification"
))
# Used to be an error about `ptype`
x <- list(foobar(1))
(expect_error(
with_c_foobar(list_unchop(x, ptype = "")),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("list_unchop() supports numeric S3 indices", {
local_methods(
vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar"),
vec_ptype2.vctrs_foobar.integer = function(x, y, ...) foobar(integer()),
vec_cast.integer.vctrs_foobar = function(x, to, ...) vec_data(x)
)
expect_identical(list_unchop(list(1), indices = list(foobar(1L))), 1)
})
test_that("list_unchop() does not support non-numeric S3 indices", {
expect_snapshot({
(expect_error(
list_unchop(list(1), indices = list(factor("x"))),
class = "vctrs_error_subscript_type"
))
(expect_error(
list_unchop(list(1), indices = list(foobar(1L))),
class = "vctrs_error_subscript_type"
))
})
})
test_that("can ignore names in `list_unchop()` by providing a `zap()` name-spec (#232)", {
expect_snapshot({
(expect_error(list_unchop(list(a = c(b = 1:2)))))
(expect_error(list_unchop(list(a = c(b = 1:2)), error_call = call("foo"))))
})
expect_identical(
list_unchop(list(a = c(b = 1:2), b = 3L), name_spec = zap()),
1:3
)
expect_identical(
list_unchop(
list(a = c(foo = 1:2), b = c(bar = 3L)),
indices = list(2:1, 3),
name_spec = zap()
),
c(2L, 1L, 3L)
)
expect_snapshot({
x <- list(a = c(b = letters), b = 3L)
(expect_error(
list_unchop(x, name_spec = zap()),
class = "vctrs_error_incompatible_type"
))
x <- list(a = c(foo = 1:2), b = c(bar = ""))
(expect_error(
list_unchop(
x,
indices = list(2:1, 3),
name_spec = zap()
),
class = "vctrs_error_incompatible_type"
))
})
})
test_that("list_unchop() falls back to c() methods (#1120)", {
expect_error(
list_unchop(list(foobar(1), foobar(2, class = "foo"))),
class = "vctrs_error_incompatible_type"
)
local_methods(
c.vctrs_foobar = function(...) {
out <- NextMethod()
paste0(rep_along(out, "dispatched"), seq_along(out))
}
)
# Homogeneous subclasses
xs <- list(foobar(1), foobar(2, class = "foo"))
expect_identical(
list_unchop(xs),
c("dispatched1", "dispatched2")
)
expect_identical(
list_unchop(xs, indices = list(2, 1)),
c("dispatched2", "dispatched1")
)
# Different subclasses
xs <- list(
foobar(c(x = 1, y = 2), class = "foo"),
foobar(c(x = 1), foo = 1)
)
expect_identical(
list_unchop(xs),
c("dispatched1", "dispatched2", "dispatched3")
)
expect_identical(
list_unchop(xs, indices = list(c(2, 1), 3)),
c("dispatched2", "dispatched1", "dispatched3")
)
})
test_that("list_unchop() fails if foreign classes are not homogeneous and there is no c() method", {
xs <- list(
foobar(c(x = 1, y = 2), class = "foo"),
foobar(c(x = 1), foo = 1)
)
expect_error(
list_unchop(xs),
class = "vctrs_error_incompatible_type"
)
expect_error(
list_unchop(xs, indices = list(c(2, 1), 3)),
class = "vctrs_error_incompatible_type"
)
})
vctrs/tests/testthat/test-expand.R 0000644 0001762 0000144 00000007706 14362266120 017010 0 ustar ligges users test_that("expands the first column slowest by default", {
x <- 1:4
y <- 1:3
z <- 1:2
expect_identical(
vec_expand_grid(x = x, y = y, z = z),
data_frame(
x = vec_rep(vec_rep_each(x, times = 6), times = 1),
y = vec_rep(vec_rep_each(y, times = 2), times = 4),
z = vec_rep(vec_rep_each(z, times = 1), times = 12)
)
)
})
test_that("can expand the first column fastest with `.vary`", {
x <- 1:4
y <- 1:3
z <- 1:2
expect_identical(
vec_expand_grid(x = x, y = y, z = z, .vary = "fastest"),
data_frame(
x = vec_rep(vec_rep_each(x, times = 1), times = 6),
y = vec_rep(vec_rep_each(y, times = 4), times = 2),
z = vec_rep(vec_rep_each(z, times = 12), times = 1)
)
)
})
test_that("size 0 elements force a size 0 result", {
expect_identical(
vec_expand_grid(x = 1:3, y = integer(), z = 1:2),
data_frame(x = integer(), y = integer(), z = integer())
)
expect_identical(
vec_expand_grid(x = integer()),
data_frame(x = integer())
)
})
test_that("returns 1 row and 0 cols with no input", {
# Because `prod(integer()) == 1L`
expect_identical(vec_expand_grid(), data_frame(.size = 1L))
})
test_that("drops `NULL` values", {
expect_identical(
vec_expand_grid(NULL, NULL),
vec_expand_grid()
)
# And that happens before all names checks
expect_identical(
vec_expand_grid(x = 1:2, x = NULL, y = 1:3, NULL),
vec_expand_grid(x = 1:2, y = 1:3)
)
})
test_that("works with data frame inputs", {
x <- data_frame(a = 1:2, b = 2:3)
y <- 1:3
expect_identical(
vec_expand_grid(x = x, y = y),
data_frame(
x = vec_rep(vec_rep_each(x, times = 3), times = 1),
y = vec_rep(vec_rep_each(y, times = 1), times = 2),
)
)
})
test_that("`.name_repair` isn't affected by `.vary`", {
expect <- vec_as_names(c("a", "b", "a", "z"), repair = "unique_quiet")
expect_named(
vec_expand_grid(a = 1, b = 2, a = 3, z = 4, .vary = "slowest", .name_repair = "unique_quiet"),
expect
)
expect_named(
vec_expand_grid(a = 1, b = 2, a = 3, z = 4, .vary = "fastest", .name_repair = "unique_quiet"),
expect
)
})
test_that("can use `.name_repair`", {
expect_identical(
vec_expand_grid(a = 1:2, a = 2:3, .name_repair = "minimal"),
data_frame(a = c(1L, 1L, 2L, 2L), a = c(2L, 3L, 2L, 3L), .name_repair = "minimal")
)
})
test_that("inputs must be named", {
expect_snapshot(error = TRUE, {
vec_expand_grid(1)
})
expect_snapshot(error = TRUE, {
vec_expand_grid(x = 1, 2, y = 3)
})
})
test_that("catches duplicate names by default", {
expect_snapshot(error = TRUE, {
vec_expand_grid(a = 1, a = 2)
})
})
test_that("errors on non vectors and mentions the element name", {
expect_snapshot(error = TRUE, {
vec_expand_grid(y = environment())
})
})
test_that("can adjust the `.error_call`", {
my_expand_grid <- function() {
vec_expand_grid(x = environment(), .error_call = current_env())
}
expect_snapshot(error = TRUE, {
my_expand_grid()
})
})
test_that("errors nicely when expansion results in a size larger than `R_len_t`", {
# Windows 32-bit doesn't support long vectors of this size, and the
# intermediate `r_ssize` will be too large
skip_if(.Machine$sizeof.pointer < 8L, message = "No long vector support")
x <- seq_len((2^31 - 1) / 2)
y <- 1:3
expect_snapshot(error = TRUE, {
vec_expand_grid(x = x, y = y)
})
})
test_that("errors nicely when expansion results in a size larger than `R_xlen_t`", {
# Windows 32-bit doesn't support long vectors of this size, and the
# intermediate `r_ssize` will be too large
skip_if(.Machine$sizeof.pointer < 8L, message = "No long vector support")
x <- seq_len(2^31 - 1)
expect_snapshot(error = TRUE, transform = scrub_internal_error_line_number, {
vec_expand_grid(x = x, y = x)
})
})
test_that("validates `.vary`", {
expect_snapshot(error = TRUE, {
vec_expand_grid(.vary = 1)
})
expect_snapshot(error = TRUE, {
vec_expand_grid(.vary = "x")
})
})
vctrs/tests/testthat/test-partial-factor.R 0000644 0001762 0000144 00000002672 14276722575 020455 0 ustar ligges users
test_that("has ok print method", {
partial <- partial_factor("x")
expect_snapshot(partial)
both <- vec_ptype2(partial, factor("y"))
expect_snapshot(both)
empty <- partial_factor()
expect_snapshot(empty)
learned <- vec_ptype2(empty, factor("y"))
expect_snapshot(learned)
expect_equal(vec_ptype_abbr(partial), "prtl_fctr")
})
test_that("order of levels comes from data", {
pfctr <- partial_factor(c("y", "x"))
fctr <- factor(levels = c("x", "y"))
expect_equal(levels(vec_ptype_common(pfctr, fctr)), c("x", "y"))
expect_equal(levels(vec_ptype_common(fctr, pfctr)), c("x", "y"))
})
test_that("partial levels added to end if not in data", {
pfctr <- partial_factor("y")
fctr <- factor(levels = "x")
expect_equal(levels(vec_ptype_common(pfctr, fctr)), c("x", "y"))
expect_equal(levels(vec_ptype_common(fctr, pfctr)), c("x", "y"))
})
test_that("can assert partial factors based on level presence", {
pfctr <- partial_factor("y")
expect_true(vec_is(factor("y"), pfctr))
expect_false(vec_is(factor("x"), pfctr))
expect_true(vec_is(factor(c("x", "y")), pfctr))
pfctr <- partial_factor(c("y", "z"))
expect_false(vec_is(factor("y"), pfctr))
expect_true(vec_is(factor(c("y", "z")), pfctr))
expect_true(vec_is(factor(c("x", "y", "z")), pfctr))
})
# TODO - why is this not working?
# test_that("can assert partial factor based on factor type", {
# pfctr <- partial_factor()
# expect_false(vec_is(1, pfctr))
# })
vctrs/tests/testthat/test-type-factor.R 0000644 0001762 0000144 00000015711 14317573545 017775 0 ustar ligges users
test_that("ptype methods are descriptive", {
f <- factor()
o <- ordered(character())
expect_equal(vec_ptype_abbr(f), "fct")
expect_equal(vec_ptype_abbr(o), "ord")
expect_equal(vec_ptype_full(f), "factor<>")
expect_equal(vec_ptype_full(o), "ordered<>")
})
test_that("slicing factors uses a proxy to not go through `[.factor`", {
x <- factor("x")
y <- ordered("y")
local_methods(
`[.factor` = function(x, ...) abort("should not be called")
)
expect_identical(vec_slice(x, 1), x)
expect_identical(vec_slice(y, 1), y)
})
test_that("`vec_c()` throws the right error with subclassed factors (#1015)", {
skip("Factors now have a `c()` method")
a <- subclass(factor("a"))
b <- subclass(factor("b"))
# We used to return a subclass
expect_identical(vec_c(a, a), subclass(factor(c("a", "a"))))
# We used to fail if attributes were incoPatible
expect_error(vec_c(a, b), class = "vctrs_error_incompatible_type")
})
# Coercion ----------------------------------------------------------------
test_that("factor/character coercions are symmetric and unchanging", {
types <- list(
ordered(character()),
factor(),
character()
)
mat <- maxtype_mat(types)
expect_true(isSymmetric(mat))
local_options(width = 200)
expect_snapshot(print(mat))
})
test_that("factors level are unioned", {
# This is technically incorrect, but because of R's existing behaviour
# anything else will cause substantial friction.
fa <- factor(levels = "a")
fb <- factor(levels = "b")
expect_equal(vec_ptype_common(fa, fb), factor(levels = c("a", "b")))
expect_equal(vec_ptype_common(fb, fa), factor(levels = c("b", "a")))
})
test_that("coercion errors with factors", {
f <- factor(levels = "a")
expect_error(vec_ptype_common(f, logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype_common(logical(), f), class = "vctrs_error_incompatible_type")
})
test_that("vec_ptype2(, NA) is symmetric (#687)", {
fct <- new_factor()
expect_identical(
vec_ptype2(fct, NA),
vec_ptype2(NA, fct)
)
fct <- new_ordered()
expect_identical(
vec_ptype2(fct, NA),
vec_ptype2(NA, fct)
)
})
test_that("vec_ptype2(, NA) is symmetric (#687)", {
i64 <- bit64::integer64()
expect_identical(
vec_ptype2(i64, NA),
vec_ptype2(NA, i64)
)
})
test_that("vec_ptype2() errors with malformed factors", {
x <- structure(1, class = "factor")
y <- factor("x")
expect_error(vec_ptype2(x, y, x_arg = "z"), "`z` is a corrupt factor")
expect_error(vec_ptype2(y, x, y_arg = "z"), "`z` is a corrupt factor")
})
test_that("vec_ptype2() errors with malformed ordered factors", {
x <- structure(1, class = c("ordered", "factor"))
y <- as.ordered(factor("x"))
expect_error(vec_ptype2(x, y, x_arg = "z"), "`z` is a corrupt ordered factor")
expect_error(vec_ptype2(y, x, y_arg = "z"), "`z` is a corrupt ordered factor")
})
test_that("ordered factors with different levels are not compatible", {
expect_error(
vec_ptype2(ordered("a"), ordered("b")),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_ptype2(ordered("a"), ordered(c("a", "b"))),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast(ordered("a"), ordered("b")),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast(ordered("a"), ordered(c("a", "b"))),
class = "vctrs_error_incompatible_type"
)
})
test_that("factors and ordered factors are not compatible", {
expect_error(
vec_ptype2(factor("a"), ordered("a")),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_ptype2(ordered("a"), factor("a")),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast(factor("a"), ordered("a")),
class = "vctrs_error_incompatible_type"
)
expect_error(
vec_cast(ordered("a"), factor("a")),
class = "vctrs_error_incompatible_type"
)
})
# Casting -----------------------------------------------------------------
test_that("safe casts work as expected", {
fa <- factor("a")
fab <- factor(c("a", "b"))
expect_equal(vec_cast(NULL, fa), NULL)
expect_equal(vec_cast(fa, fa), fa)
expect_equal(vec_cast(fa, fab), fab[1])
expect_equal(vec_cast("a", fab), fab[1])
expect_equal(vec_cast("a", factor()), fa)
expect_equal(vec_cast(fa, factor()), fa)
# This used to be allowed
expect_error(vec_cast(list("a", "b"), fab), class = "vctrs_error_incompatible_type")
})
test_that("can cast to character", {
expect_equal(vec_cast(factor("X"), character()), "X")
expect_equal(vec_cast(ordered("X"), character()), "X")
})
test_that("can cast NA and unspecified to factor", {
expect_identical(vec_cast(NA, new_factor()), factor(NA))
expect_identical(vec_cast(NA, new_ordered()), ordered(NA))
expect_identical(vec_cast(unspecified(2), new_factor()), factor(c(NA, NA)))
expect_identical(vec_cast(unspecified(2), new_ordered()), ordered(c(NA, NA)))
})
test_that("lossy factor casts fail", {
fa <- factor("a")
fb <- factor("b")
expect_lossy(vec_cast(fa, fb), factor(NA, levels = "b"), x = fa, to = fb)
expect_lossy(vec_cast("a", fb), factor(NA, levels = "b"), x = chr(), to = fb)
})
test_that("invalid casts generate error", {
expect_error(vec_cast(double(), factor("a")), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(factor("a"), logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(ordered("a"), logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(logical(), factor("a")), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(logical(), ordered("a")), class = "vctrs_error_incompatible_type")
})
test_that("orderedness of factor is preserved", {
ord <- ordered(c("a", "b"), levels = c("b", "a"))
expect_equal(vec_cast("a", ord), ordered("a", levels = c("b", "a")))
})
test_that("NA are not considered lossy in factor cast (#109)", {
f <- factor(c("itsy", "bitsy", NA, "spider", "spider"))
expect_warning(vec_cast(f, f[1]), NA)
})
test_that("Casting to a factor with explicit NA levels retains them", {
f <- factor(c("x", NA), exclude = NULL)
expect_identical(vec_cast(f, f), f)
expect_identical(vec_cast(f, factor()), f)
})
test_that("characters can be cast to ordered", {
expect_identical(vec_cast("a", ordered("a")), ordered("a"))
expect_error(vec_cast(c("a", "b"), ordered("a")), class = "vctrs_error_cast_lossy")
})
# Proxy / restore ---------------------------------------------------------
test_that("subclassed factors / ordered factors can be restored (#1015)", {
x <- subclass(factor("a"))
proxy <- vec_proxy(x)
expect_identical(vec_restore(proxy, x), x)
y <- subclass(ordered("a"))
proxy <- vec_proxy(y)
expect_identical(vec_restore(proxy, y), y)
})
# Arithmetic and factor ---------------------------------------------------
test_that("factors don't support math or arthimetic", {
f <- factor("x")
expect_error(vec_math("sum", f), class = "vctrs_error_unsupported")
expect_error(vec_arith("+", f, f), class = "vctrs_error_unsupported")
})
vctrs/tests/testthat/test-subscript-loc.R 0000644 0001762 0000144 00000066675 14315060310 020323 0 ustar ligges users
test_that("vec_as_location2() returns a position", {
expect_identical(vec_as_location2(2, 2L), 2L)
expect_identical(vec_as_location2("foo", 2L, c("bar", "foo")), 2L)
expect_identical(vec_as_location2("0", 4L, as.character(-1:2)), 2L)
})
test_that("vec_as_location2() requires integer or character inputs", {
expect_snapshot({
(expect_error(vec_as_location2(TRUE, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(mtcars, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(env(), 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(foobar(), 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(2.5, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(Inf, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(-Inf, 10L), class = "vctrs_error_subscript_type"))
"Idem with custom `arg`"
(expect_error(vec_as_location2(foobar(), 10L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(2.5, 3L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(with_tibble_rows(vec_as_location2(TRUE)), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location() requires integer, character, or logical inputs", {
expect_snapshot({
(expect_error(vec_as_location(mtcars, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(env(), 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(foobar(), 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(2.5, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(list(), 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(function() NULL, 10L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(Sys.Date(), 3L), class = "vctrs_error_subscript_type"))
"Idem with custom `arg`"
(expect_error(vec_as_location(env(), 10L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(foobar(), 10L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(2.5, 3L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location2() and vec_as_location() require integer- or character-like OO inputs", {
expect_identical(vec_as_location2(factor("foo"), 2L, c("bar", "foo")), 2L)
expect_identical(vec_as_location(factor("foo"), 2L, c("bar", "foo")), 2L)
expect_error(vec_as_location2(foobar(1L), 10L), class = "vctrs_error_subscript_type")
expect_error(vec_as_location(foobar(1L), 10L), class = "vctrs_error_subscript_type")
# Define subtype of logical and integer
local_methods(
vec_ptype2.vctrs_foobar = function(x, y, ...) UseMethod("vec_ptype2.vctrs_foobar"),
vec_ptype2.vctrs_foobar.logical = function(x, y, ...) logical(),
vec_ptype2.vctrs_foobar.integer = function(x, y, ...) integer(),
vec_ptype2.logical.vctrs_foobar = function(x, y, ...) logical(),
vec_ptype2.integer.vctrs_foobar = function(x, y, ...) integer(),
vec_cast.vctrs_foobar = function(x, to, ...) UseMethod("vec_cast.vctrs_foobar"),
vec_cast.vctrs_foobar.integer = function(x, to, ...) foobar(x),
vec_cast.integer.vctrs_foobar = function(x, to, ...) vec_cast(unclass(x), int()),
vec_cast.logical.vctrs_foobar = function(x, to, ...) vec_cast(unclass(x), lgl())
)
expect_error(vec_as_location2(foobar(TRUE), 10L), class = "vctrs_error_subscript_type")
expect_identical(vec_as_location(foobar(TRUE), 10L), 1:10)
expect_identical(vec_as_location(foobar(FALSE), 10L), int())
})
test_that("vec_as_location() and variants check for OOB elements (#1605)", {
expect_snapshot({
"Numeric indexing"
(expect_error(vec_as_location(10L, 2L), class = "vctrs_error_subscript_oob"))
(expect_error(vec_as_location(-10L, 2L), class = "vctrs_error_subscript_oob"))
(expect_error(vec_as_location2(10L, 2L), class = "vctrs_error_subscript_oob"))
"Character indexing"
(expect_error(vec_as_location("foo", 1L, names = "bar"), class = "vctrs_error_subscript_oob"))
(expect_error(vec_as_location2("foo", 1L, names = "bar"), class = "vctrs_error_subscript_oob"))
(expect_error(vec_as_location2("foo", 1L, names = "bar", call = call("baz")), class = "vctrs_error_subscript_oob"))
})
expect_error(num_as_location(10L, 2L), class = "vctrs_error_subscript_oob")
expect_error(num_as_location2(10L, 2L), class = "vctrs_error_subscript_oob")
})
test_that("vec_as_location() doesn't require `n` for character indexing", {
expect_identical(vec_as_location("b", NULL, names = letters), 2L)
})
test_that("vec_as_location2() requires length 1 inputs", {
expect_snapshot({
(expect_error(vec_as_location2(1:2, 2L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(c("foo", "bar"), 2L, c("foo", "bar")), class = "vctrs_error_subscript_type"))
"Idem with custom `arg`"
(expect_error(vec_as_location2(1:2, 2L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(mtcars, 10L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(1:2, 2L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location2() requires positive integers", {
expect_snapshot({
(expect_error(vec_as_location2(0, 2L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(-1, 2L), class = "vctrs_error_subscript_type"))
"Idem with custom `arg`"
(expect_error(vec_as_location2(0, 2L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location2() fails with NA", {
expect_snapshot({
(expect_error(vec_as_location2(na_int, 2L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location2(na_chr, 1L, names = "foo"), class = "vctrs_error_subscript_type"))
"Idem with custom `arg`"
(expect_error(vec_as_location2(na_int, 2L, arg = "foo", call = call("my_function")), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location2() doesn't allow lossy casts", {
expect_error(vec_as_location2(2^31, 3L), class = "vctrs_error_subscript_type")
# Lossy casts generate missing values, which are disallowed
expect_error(allow_lossy_cast(vec_as_location2(2^31, 3L)), class = "vctrs_error_subscript_type")
})
test_that("all subscript errors inherit from `vctrs_error_subscript`", {
expect_error(vec_as_location(100, 2L), class = "vctrs_error_subscript")
expect_error(vec_as_location("foo", 2L, names = c("bar", "baz")), class = "vctrs_error_subscript")
expect_error(vec_as_location(foobar(1L), 2L), class = "vctrs_error_subscript")
expect_error(vec_as_location(1.5, 2L), class = "vctrs_error_subscript")
expect_error(vec_as_location2(TRUE, 2L), class = "vctrs_error_subscript")
expect_error(vec_as_location2(1.5, 2L), class = "vctrs_error_subscript")
})
test_that("all OOB errors inherit from `vctrs_error_subscript_oob`", {
expect_error(vec_as_location(100, 2L), class = "vctrs_error_subscript_oob")
expect_error(vec_as_location("foo", 2L, names = c("bar", "baz")), class = "vctrs_error_subscript_oob")
})
test_that("vec_as_location() preserves names if possible", {
expect_identical(vec_as_location(c(a = 1L, b = 3L), 3L), c(a = 1L, b = 3L))
expect_identical(vec_as_location(c(a = 1, b = 3), 3L), c(a = 1L, b = 3L))
expect_identical(vec_as_location(c(a = "z", b = "y"), 26L, letters), c(a = 26L, b = 25L))
expect_identical(vec_as_location(c(foo = TRUE, bar = FALSE, baz = TRUE), 3L), c(foo = 1L, baz = 3L))
expect_identical(vec_as_location(c(foo = TRUE), 3L), c(foo = 1L, foo = 2L, foo = 3L))
expect_identical(vec_as_location(c(foo = NA), 3L), c(foo = na_int, foo = na_int, foo = na_int))
# Names of negative selections are dropped
expect_identical(vec_as_location(c(a = -1L, b = -3L), 3L), 2L)
})
test_that("vec_as_location2() optionally allows missing values", {
expect_identical(vec_as_location2(NA, 2L, missing = "propagate"), na_int)
expect_error(vec_as_location2(NA, 2L, missing = "error"), class = "vctrs_error_subscript_type")
})
test_that("num_as_location2() optionally allows missing and negative locations", {
expect_identical(num_as_location2(na_dbl, 2L, missing = "propagate"), na_int)
expect_identical(num_as_location2(-1, 2L, negative = "ignore"), -1L)
expect_error(num_as_location2(-3, 2L, negative = "ignore"), class = "vctrs_error_subscript_oob")
expect_error(num_as_location2(0, 2L, negative = "ignore"), class = "vctrs_error_subscript_type")
})
test_that("num_as_location() optionally allows negative indices", {
expect_identical(num_as_location(dbl(1, -1), 2L, negative = "ignore"), int(1L, -1L))
expect_error(num_as_location(c(1, -10), 2L, negative = "ignore"), class = "vctrs_error_subscript_oob")
})
test_that("num_as_location() optionally forbids negative indices", {
expect_snapshot({
(expect_error(num_as_location(dbl(1, -1), 2L, negative = "error"), class = "vctrs_error_subscript_type"))
})
expect_error(num_as_location(c(1, -10), 2L, negative = "error"), class = "vctrs_error_subscript_type")
})
test_that("num_as_location() optionally ignores zero indices", {
expect_identical(num_as_location(c(1, 0), 2L, zero = "ignore"), c(1L, 0L))
})
test_that("num_as_location() optionally forbids zero indices", {
expect_snapshot({
(expect_error(
num_as_location(0L, 1L, zero = "error"),
class = "vctrs_error_subscript_type"
))
(expect_error(
num_as_location(c(0, 0, 0, 0, 0, 0), 1, zero = "error"),
class = "vctrs_error_subscript_type"
))
})
})
test_that("vec_as_location() handles NULL", {
expect_identical(
vec_as_location(NULL, 10),
vec_as_location(int(), 10),
)
})
test_that("vec_as_location() checks for mix of negative and missing locations", {
expect_snapshot({
(expect_error(
vec_as_location(-c(1L, NA), 30),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location(-c(1L, rep(NA, 10)), 30),
class = "vctrs_error_subscript_type"
))
})
})
test_that("vec_as_location() checks for mix of negative and positive locations", {
expect_snapshot({
(expect_error(
vec_as_location(c(-1L, 1L), 30),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location(c(-1L, rep(1L, 10)), 30),
class = "vctrs_error_subscript_type"
))
})
})
test_that("logical subscripts must match size of indexed vector", {
expect_snapshot({
(expect_error(
vec_as_location(c(TRUE, FALSE), 3),
class = "vctrs_error_subscript_size"
))
})
})
test_that("character subscripts require named vectors", {
expect_snapshot({
(expect_error(vec_as_location(letters[1], 3), "unnamed vector"))
})
})
test_that("arg is evaluated lazily (#1150)", {
expect_silent(vec_as_location(1, 1, arg = { writeLines("oof"); "boo" }))
})
test_that("arg works for complex expressions (#1150)", {
expect_error(vec_as_location(mean, 1, arg = paste0("foo", "bar")), "foobar")
})
test_that("can optionally extend beyond the end", {
expect_error(num_as_location(1:5, 3), class = "vctrs_error_subscript_oob")
expect_identical(num_as_location(1:5, 3, oob = "extend"), 1:5)
expect_identical(num_as_location(4:5, 3, oob = "extend"), 4:5)
expect_snapshot({
(expect_error(
num_as_location(3, 1, oob = "extend"),
class = "vctrs_error_subscript_oob"
))
(expect_error(
num_as_location(c(1, 3), 1, oob = "extend"),
class = "vctrs_error_subscript_oob"
))
(expect_error(
num_as_location(c(1:5, 7), 3, oob = "extend"),
class = "vctrs_error_subscript_oob"
))
(expect_error(
num_as_location(c(1:5, 7, 1), 3, oob = "extend"),
class = "vctrs_error_subscript_oob"
))
(expect_error(
class = "vctrs_error_subscript_oob",
num_as_location(c(1:5, 7, 1, 10), 3, oob = "extend")
))
})
})
test_that("can extend beyond the end consecutively but non-monotonically (#1166)", {
expect_identical(num_as_location(6:4, 3, oob = "extend"), 6:4)
expect_identical(num_as_location(c(1:5, 7, 6), 3, oob = "extend"), c(1:5, 7L, 6L))
expect_identical(num_as_location(c(1, NA, 4, 3), 2, oob = "extend"), c(1L, NA, 4L, 3L))
})
test_that("num_as_location() can optionally remove oob values (#1595)", {
expect_identical(num_as_location(c(5, 3, 2, 4), 3, oob = "remove"), c(3L, 2L))
expect_identical(num_as_location(c(-4, 5, 2, -1), 3, oob = "remove", negative = "ignore"), c(2L, -1L))
})
test_that("num_as_location() errors when inverting oob negatives unless `oob = 'remove'` (#1630)", {
expect_snapshot(error = TRUE, {
num_as_location(-4, 3, oob = "error", negative = "invert")
})
expect_snapshot(error = TRUE, {
num_as_location(c(-4, 4, 5), 3, oob = "extend", negative = "invert")
})
expect_identical(num_as_location(-4, 3, oob = "remove", negative = "invert"), c(1L, 2L, 3L))
expect_identical(num_as_location(c(-4, -2), 3, oob = "remove", negative = "invert"), c(1L, 3L))
})
test_that("num_as_location() generally drops zeros when inverting negatives (#1612)", {
expect_identical(
num_as_location(c(-3, 0, -1), n = 5L, negative = "invert", zero = "remove"),
c(2L, 4L, 5L)
)
# Trying to "ignore" and retain the zeroes in the output doesn't make sense,
# where would they be placed? Instead, think of the ignored zeros as being
# inverted as well, they just don't correspond to any location after the
# inversion so they aren't in the output.
expect_identical(
num_as_location(c(-3, 0, -1, 0), n = 5L, negative = "invert", zero = "ignore"),
c(2L, 4L, 5L)
)
})
test_that("num_as_location() errors on disallowed zeros when inverting negatives (#1612)", {
expect_snapshot(error = TRUE, {
num_as_location(c(0, -1), n = 2L, negative = "invert", zero = "error")
})
expect_snapshot(error = TRUE, {
num_as_location(c(-1, 0), n = 2L, negative = "invert", zero = "error")
})
})
test_that("num_as_location() with `oob = 'remove'` doesn't remove missings if they are being propagated", {
expect_identical(num_as_location(NA_integer_, 1, oob = "remove"), NA_integer_)
})
test_that("num_as_location() with `oob = 'remove'` doesn't remove zeros if they are being ignored", {
expect_identical(num_as_location(0, 1, oob = "remove", zero = "ignore"), 0L)
expect_identical(num_as_location(0, 0, oob = "remove", zero = "ignore"), 0L)
})
test_that("num_as_location() with `oob = 'extend'` doesn't allow ignored oob negative values (#1614)", {
# This is fine (ignored negative that is in bounds)
expect_identical(num_as_location(c(-5L, 6L), 5L, oob = "extend", negative = "ignore"), c(-5L, 6L))
expect_snapshot(error = TRUE, {
# Ignored negatives aren't allowed to extend the vector
num_as_location(-6L, 5L, oob = "extend", negative = "ignore")
})
expect_snapshot(error = TRUE, {
# Ensure error only reports negative indices
num_as_location(c(-7L, 6L), 5L, oob = "extend", negative = "ignore")
})
expect_snapshot(error = TRUE, {
num_as_location(c(-7L, NA), 5L, oob = "extend", negative = "ignore")
})
})
test_that("num_as_location() with `oob = 'error'` reports negative and positive oob values", {
expect_snapshot(error = TRUE, {
num_as_location(c(-6L, 7L), n = 5L, oob = "error", negative = "ignore")
})
})
test_that("num_as_location() with `missing = 'remove'` retains names (#1633)", {
x <- c(a = 1, b = NA, c = 2, d = NA)
expect_named(num_as_location(x, n = 2, missing = "remove"), c("a", "c"))
})
test_that("num_as_location() with `zero = 'remove'` retains names (#1633)", {
x <- c(a = 1, b = 0, c = 2, d = 0)
expect_named(num_as_location(x, n = 2, zero = "remove"), c("a", "c"))
})
test_that("num_as_location() with `oob = 'remove'` retains names (#1633)", {
x <- c(a = 1, b = 3, c = 2, d = 4)
expect_named(num_as_location(x, n = 2, oob = "remove"), c("a", "c"))
})
test_that("num_as_location() with `negative = 'invert'` drops names (#1633)", {
# The inputs don't map 1:1 to outputs
x <- c(a = -1, b = -3)
expect_named(num_as_location(x, n = 5), NULL)
})
test_that("missing values are supported in error formatters", {
expect_snapshot({
(expect_error(
num_as_location(c(1, NA, 2, 3), 1),
class = "vctrs_error_subscript_oob"
))
(expect_error(
num_as_location(c(1, NA, 3), 1, oob = "extend"),
class = "vctrs_error_subscript_oob"
))
})
})
test_that("can disallow missing values", {
expect_snapshot({
(expect_error(
vec_as_location(c(1, NA), 2, missing = "error"),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location(c(1, NA, 2, NA), 2, missing = "error", arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(c(1, NA, 2, NA), 2, missing = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(NA, 1, missing = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(NA, 3, missing = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(c(TRUE, NA, FALSE), 3, missing = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(NA_character_, 2, missing = "error", names = c("x", "y"))),
class = "vctrs_error_subscript_type"
))
})
})
test_that("can alter logical missing value handling (#1595)", {
x <- c(a = TRUE, b = NA, c = FALSE, d = NA)
expect_identical(
vec_as_location(x, n = 4L, missing = "propagate"),
c(a = 1L, b = NA, d = NA)
)
expect_identical(
vec_as_location(x, n = 4L, missing = "remove"),
c(a = 1L)
)
expect_snapshot(error = TRUE, {
vec_as_location(x, n = 4L, missing = "error")
})
# Specifically test size 1 case, which has its own special path
x <- c(a = NA)
expect_identical(
vec_as_location(x, n = 2L, missing = "propagate"),
c(a = NA_integer_, a = NA_integer_)
)
expect_identical(
vec_as_location(x, n = 2L, missing = "remove"),
named(integer())
)
expect_snapshot(error = TRUE, {
vec_as_location(x, n = 2L, missing = "error")
})
})
test_that("can alter character missing value handling (#1595)", {
x <- c(NA, "z", NA)
names(x) <- c("a", "b", "c")
names <- c("x", "z")
expect_identical(
vec_as_location(x, n = 2L, names = names, missing = "propagate"),
set_names(c(NA, 2L, NA), names(x))
)
expect_identical(
vec_as_location(x, n = 2L, names = names, missing = "remove"),
set_names(2L, "b")
)
expect_snapshot(error = TRUE, {
vec_as_location(x, n = 2L, names = names, missing = "error")
})
})
test_that("can alter integer missing value handling (#1595)", {
x <- c(NA, 1L, NA, 3L)
names(x) <- c("a", "b", "c", "d")
expect_identical(
vec_as_location(x, n = 4L, missing = "propagate"),
x
)
expect_identical(
vec_as_location(x, n = 4L, missing = "remove"),
c(b = 1L, d = 3L)
)
expect_snapshot(error = TRUE, {
vec_as_location(x, n = 4L, missing = "error")
})
})
test_that("can alter negative integer missing value handling (#1595)", {
x <- c(-1L, NA, NA, -3L)
expect_snapshot(error = TRUE, {
num_as_location(x, n = 4L, missing = "propagate", negative = "invert")
})
expect_identical(
num_as_location(x, n = 4L, missing = "remove", negative = "invert"),
c(2L, 4L)
)
expect_snapshot(error = TRUE, {
num_as_location(x, n = 4L, missing = "error", negative = "invert")
})
})
test_that("missing value character indices never match missing value names (#1489)", {
x <- NA_character_
names <- NA_character_
expect_identical(vec_as_location(x, n = 1L, names = names, missing = "propagate"), NA_integer_)
expect_identical(vec_as_location(x, n = 1L, names = names, missing = "remove"), integer())
})
test_that("empty string character indices never match empty string names (#1489)", {
names <- c("", "y")
expect_snapshot(error = TRUE, {
vec_as_location("", n = 2L, names = names)
})
expect_snapshot(error = TRUE, {
vec_as_location(c("", "y", ""), n = 2L, names = names)
})
})
test_that("scalar logical `FALSE` and `NA` cases don't modify a shared object (#1633)", {
x <- vec_as_location(FALSE, n = 2)
expect_identical(x, integer())
y <- vec_as_location(c(a = FALSE), n = 2)
expect_identical(y, named(integer()))
# Still unnamed
expect_identical(x, integer())
x <- vec_as_location(NA, n = 2, missing = "remove")
expect_identical(x, integer())
y <- vec_as_location(c(a = FALSE), n = 2, missing = "remove")
expect_identical(y, named(integer()))
# Still unnamed
expect_identical(x, integer())
})
test_that("can customise subscript type errors", {
expect_snapshot({
"With custom `arg`"
(expect_error(
num_as_location(-1, 2, negative = "error", arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
num_as_location2(-1, 2, negative = "error", arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location2(0, 2, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location2(na_dbl, 2, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location2(c(1, 2), 2, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location(c(TRUE, FALSE), 3, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_size"
))
(expect_error(
vec_as_location(c(-1, NA), 3, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_as_location(c(-1, 1), 3, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
(expect_error(
num_as_location(c(1, 4), 2, oob = "extend", arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_oob"
))
(expect_error(
num_as_location(0, 1, zero = "error", arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_type"
))
"With tibble columns"
(expect_error(
with_tibble_cols(num_as_location(-1, 2, negative = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(num_as_location2(-1, 2, negative = "error")),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location2(0, 2)),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location2(na_dbl, 2)),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location2(c(1, 2), 2)),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(c(TRUE, FALSE), 3)),
class = "vctrs_error_subscript_size"
))
(expect_error(
with_tibble_cols(vec_as_location(c(-1, NA), 3)),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(vec_as_location(c(-1, 1), 3)),
class = "vctrs_error_subscript_type"
))
(expect_error(
with_tibble_cols(num_as_location(c(1, 4), 2, oob = "extend")),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tibble_cols(num_as_location(0, 1, zero = "error")),
class = "vctrs_error_subscript_type"
))
})
})
test_that("can customise OOB errors", {
expect_snapshot({
(expect_error(
vec_slice(set_names(letters), "foo"),
class = "vctrs_error_subscript_oob"
))
"With custom `arg`"
(expect_error(
vec_as_location(30, length(letters), arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_oob"
))
(expect_error(
vec_as_location("foo", NULL, letters, arg = "foo", call = call("my_function")),
class = "vctrs_error_subscript_oob"
))
"With tibble columns"
(expect_error(
with_tibble_cols(vec_slice(set_names(letters), "foo")),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tibble_cols(vec_slice(set_names(letters), 30)),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tibble_cols(vec_slice(set_names(letters), -30)),
class = "vctrs_error_subscript_oob"
))
"With tibble rows"
(expect_error(
with_tibble_rows(vec_slice(set_names(letters), c("foo", "bar"))),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tibble_rows(vec_slice(set_names(letters), 1:30)),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tibble_rows(vec_slice(set_names(letters), -(1:30))),
class = "vctrs_error_subscript_oob"
))
"With tidyselect select"
(expect_error(
with_tidyselect_select(vec_slice(set_names(letters), c("foo", "bar"))),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tidyselect_select(vec_slice(set_names(letters), 30)),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tidyselect_select(vec_slice(set_names(letters), -(1:30))),
class = "vctrs_error_subscript_oob"
))
"With tidyselect relocate"
(expect_error(
with_tidyselect_relocate(vec_slice(set_names(letters), c("foo", "bar"))),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tidyselect_relocate(vec_slice(set_names(letters), 30)),
class = "vctrs_error_subscript_oob"
))
(expect_error(
with_tidyselect_relocate(vec_slice(set_names(letters), -(1:30))),
class = "vctrs_error_subscript_oob"
))
})
})
test_that("num_as_location() requires non-S3 inputs", {
expect_error(num_as_location(factor("foo"), 2), "must be a numeric vector")
})
test_that("vec_as_location() checks dimensionality", {
expect_snapshot({
(expect_error(vec_as_location(matrix(TRUE, nrow = 1), 3L), class = "vctrs_error_subscript_type"))
(expect_error(vec_as_location(array(TRUE, dim = c(1, 1, 1)), 3L), class = "vctrs_error_subscript_type"))
(expect_error(with_tibble_rows(vec_as_location(matrix(TRUE, nrow = 1), 3L)), class = "vctrs_error_subscript_type"))
})
})
test_that("vec_as_location() works with vectors of dimensionality 1", {
expect_identical(vec_as_location(array(TRUE, dim = 1), 3L), 1:3)
})
test_that("vec_as_location() UI", {
expect_snapshot(error = TRUE, vec_as_location(1, 1L, missing = "bogus"))
})
test_that("num_as_location() UI", {
expect_snapshot(error = TRUE, num_as_location(1, 1L, missing = "bogus"))
expect_snapshot(error = TRUE, num_as_location(1, 1L, negative = "bogus"))
expect_snapshot(error = TRUE, num_as_location(1, 1L, oob = "bogus"))
expect_snapshot(error = TRUE, num_as_location(1, 1L, zero = "bogus"))
})
test_that("vec_as_location2() UI", {
expect_snapshot(error = TRUE, vec_as_location2(1, 1L, missing = "bogus"))
})
test_that("vec_as_location() evaluates arg lazily", {
expect_silent(vec_as_location(1L, 1L, arg = print("oof")))
})
test_that("vec_as_location2() evaluates arg lazily", {
expect_silent(vec_as_location2(1L, 1L, arg = print("oof")))
expect_silent(vec_as_location2_result(1L, 1L, names = NULL, arg = print("oof"), missing = "error", negative = "error", call = NULL))
})
vctrs/tests/testthat/test-type-bare.R 0000644 0001762 0000144 00000041001 14511320527 017401 0 ustar ligges users
test_that("ptype2 base methods are not inherited", {
ptypes <- vec_remove(base_empty_types, c("null", "dataframe"))
for (ptype in ptypes) {
x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE)
expect_s3_class(vec_ptype2(x, x), "foobar")
expect_error(vec_ptype2(x, ptype), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(ptype, x), class = "vctrs_error_incompatible_type")
}
})
test_that("cast base methods are not inherited", {
ptypes <- vec_remove(base_empty_types, c("null", "dataframe"))
for (ptype in ptypes) {
x <- new_vctr(ptype, class = "foobar", inherit_base_type = TRUE)
expect_s3_class(vec_cast(ptype, x), "foobar")
expect_error(vec_cast(x, ptype), class = "vctrs_error_incompatible_type")
}
})
test_that("default cast allows objects with the same type", {
x <- structure(1, class = c("foo", "double"))
expect_equal(vec_cast(x, x), x)
})
# vec_shaped_ptype -------------------------------------------------------
test_that("array dimensions are preserved", {
mat1 <- matrix(lgl(), nrow = 1, ncol = 1)
mat2 <- matrix(lgl(), nrow = 2, ncol = 2)
mat3 <- matrix(lgl(), nrow = 2, ncol = 3)
expect_equal(vec_ptype2(mat1, mat1), matrix(lgl(), nrow = 0, ncol = 1))
expect_equal(vec_ptype2(mat1, mat2), matrix(lgl(), nrow = 0, ncol = 2))
expect_error(vec_ptype2(mat2, mat3), class = "vctrs_error_incompatible_type")
})
test_that("vec_shaped_ptype()", {
int <- function(...) array(NA_integer_, c(...))
expect_identical(vec_shaped_ptype(integer(), int(5), int(10)), new_shape(integer()))
expect_identical(vec_shaped_ptype(integer(), int(5, 1), int(10, 1)), new_shape(integer(), 1))
expect_identical(vec_shaped_ptype(integer(), int(5, 1, 2), int(10, 1, 2)), new_shape(integer(), 1:2))
})
test_that("vec_shaped_ptype() evaluates arg lazily", {
expect_silent(vec_shaped_ptype(integer(), int(5), int(10), x_arg = print("oof")))
expect_silent(vec_shaped_ptype(integer(), int(5), int(10), y_arg = print("oof")))
})
# vec_cast() --------------------------------------------------------------
# NULL
test_that("NULL is idempotent", {
expect_equal(vec_cast(NULL, NULL), NULL)
expect_equal(vec_cast(list(1:3), NULL), list(1:3))
})
# Logical
test_that("safe casts work as expected", {
exp <- lgl(TRUE, FALSE)
expect_equal(vec_cast(NULL, logical()), NULL)
expect_equal(vec_cast(lgl(TRUE, FALSE), logical()), exp)
expect_equal(vec_cast(int(1L, 0L), logical()), exp)
expect_equal(vec_cast(dbl(1, 0), logical()), exp)
# These used to be allowed
expect_error(vec_cast(chr("T", "F"), logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(chr("TRUE", "FALSE"), logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(chr("true", "false"), logical()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(1, 0), logical()), class = "vctrs_error_incompatible_type")
})
test_that("NA casts work as expected", {
exp <- lgl(NA)
to <- lgl()
expect_equal(vec_cast(lgl(NA), to), exp)
expect_equal(vec_cast(int(NA), to), exp)
expect_equal(vec_cast(dbl(NA), to), exp)
# These used to be allowed
expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})
test_that("Shaped NA casts work as expected", {
mat <- matrix
exp_mat <- mat(lgl(NA))
to_mat <- matrix(lgl())
expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)
# These used to be allowed
expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})
test_that("lossy casts generate warning", {
expect_lossy(vec_cast(int(2L, 1L), lgl()), lgl(TRUE, TRUE), x = int(), to = lgl())
expect_lossy(vec_cast(dbl(2, 1), lgl()), lgl(TRUE, TRUE), x = dbl(), to = lgl())
# These used to be allowed
expect_error(vec_cast(chr("x", "TRUE"), lgl()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(chr("t", "T"), lgl()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(chr("f", "F"), lgl()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(c(TRUE, FALSE), TRUE), lgl()), class = "vctrs_error_incompatible_type")
})
test_that("invalid casts generate error", {
expect_error(vec_cast(factor("a"), logical()), class = "vctrs_error_incompatible_type")
})
test_that("dimensionality matches output" ,{
x1 <- matrix(TRUE, nrow = 1, ncol = 1)
x2 <- matrix(1, nrow = 0, ncol = 2)
expect_dim(vec_cast(x1, x2), c(1, 2))
expect_dim(vec_cast(TRUE, x2), c(1, 2))
x <- matrix(1, nrow = 2, ncol = 2)
expect_error(vec_cast(x, logical()), class = "vctrs_error_incompatible_type")
})
test_that("the common type of two `NA` vectors is unspecified", {
expect_equal(vec_ptype2(NA, NA), unspecified())
})
# Integer
test_that("safe casts work as expected", {
expect_equal(vec_cast(NULL, integer()), NULL)
expect_equal(vec_cast(lgl(TRUE, FALSE), integer()), int(1L, 0L))
expect_equal(vec_cast(int(1L, 2L), integer()), int(1L, 2L))
expect_equal(vec_cast(dbl(1, 2), integer()), int(1L, 2L))
# These used to be allowed
expect_error(vec_cast(chr("1", "2"), integer()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(1L, 2L), integer()), class = "vctrs_error_incompatible_type")
})
test_that("NA casts work as expected", {
exp <- int(NA)
to <- int()
expect_equal(vec_cast(lgl(NA), to), exp)
expect_equal(vec_cast(int(NA), to), exp)
expect_equal(vec_cast(dbl(NA), to), exp)
# These used to be allowed
expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})
test_that("Shaped NA casts work as expected", {
mat <- matrix
exp_mat <- mat(int(NA))
to_mat <- matrix(int())
expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)
# These used to be allowed
expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})
test_that("lossy casts generate error", {
expect_lossy(vec_cast(c(2.5, 2), int()), int(2, 2), x = dbl(), to = int())
expect_lossy(vec_cast(c(.Machine$integer.max + 1, 1), int()), int(NA, 1L), x = dbl(), to = int())
expect_lossy(vec_cast(c(-.Machine$integer.max - 1, 1), int()), int(NA, 1L), x = dbl(), to = int())
# These used to be allowed
expect_error(vec_cast(c("2.5", "2"), int()), class = "vctrs_error_incompatible_type")
})
test_that("invalid casts generate error", {
expect_error(vec_cast(factor("a"), integer()), class = "vctrs_error_incompatible_type")
})
# Double
test_that("safe casts work as expected", {
expect_equal(vec_cast(NULL, double()), NULL)
expect_equal(vec_cast(lgl(TRUE, FALSE), double()), dbl(1, 0))
expect_equal(vec_cast(int(1, 0), double()), dbl(1, 0))
expect_equal(vec_cast(dbl(1, 1.5), double()), dbl(1, 1.5))
# These used to be allowed
expect_error(vec_cast(chr("1", "1.5"), double()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(1, 1.5), double()), class = "vctrs_error_incompatible_type")
})
test_that("NA casts work as expected", {
exp <- dbl(NA)
to <- dbl()
expect_equal(vec_cast(lgl(NA), to), exp)
expect_equal(vec_cast(int(NA), to), exp)
expect_equal(vec_cast(dbl(NA), to), exp)
# These used to be allowed
expect_error(vec_cast(chr(NA), to), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})
test_that("Shaped NA casts work as expected", {
mat <- matrix
exp_mat <- mat(dbl(NA))
to_mat <- matrix(dbl())
expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)
# These used to be allowed
expect_error(vec_cast(mat(chr(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})
test_that("invalid casts generate error", {
expect_error(vec_cast(factor("a"), double()), class = "vctrs_error_incompatible_type")
})
# Complex
test_that("safe casts to complex works", {
expect_identical(vec_cast(NULL, cpl()), NULL)
expect_identical(vec_cast(lgl(TRUE, FALSE), cpl()), cpl(1, 0))
expect_identical(vec_cast(int(1, 0), cpl()), cpl(1, 0))
expect_identical(vec_cast(dbl(1, 1.5), cpl()), cpl(1, 1.5))
# This used to be allowed
expect_error(vec_cast(list(1, 1.5), cpl()), class = "vctrs_error_incompatible_type")
})
test_that("NA casts work as expected", {
# This goes through a special path for
expect_equal(vec_cast(lgl(NA), cpl()), NA_complex_)
# TODO: Use our own cast routines here?
# It isn't great that this logical `NA` cast returns a different `NA`
# than the one above with just `lgl(NA)` (which is seen as unspecified). i.e.
# check the `Im()` slot between the two in R >=4.4.0. We can fix this with our
# own cast routines rather than using `vec_coerce_bare()`.
expect_type(vec_cast(lgl(NA, TRUE), cpl()), "complex")
expect_identical(is.na(vec_cast(lgl(NA, TRUE), cpl())), c(TRUE, FALSE))
# TODO: Use our own cast routines here?
# `as.complex(NA/NA_real_/NA_integer_)` and `Rf_CoerceVector(NA/NA_real_/NA_integer_)`
# have gone back and forth about what they return in the `Im()` slot. In some
# R versions they return `0` and in others they return `NA_real_`.
# https://stat.ethz.ch/pipermail/r-devel/2023-April/082545.html
# https://stat.ethz.ch/pipermail/r-devel/2023-September/082864.html
# expect_equal(vec_cast(int(NA), cpl()), NA_complex_)
expect_type(vec_cast(int(NA), cpl()), "complex")
expect_identical(is.na(vec_cast(int(NA), cpl())), TRUE)
# expect_equal(vec_cast(dbl(NA), cpl()), NA_complex_)
expect_type(vec_cast(dbl(NA), cpl()), "complex")
expect_identical(is.na(vec_cast(dbl(NA), cpl())), TRUE)
# This used to be allowed
expect_error(vec_cast(list(NA), cpl()), class = "vctrs_error_incompatible_type")
})
test_that("Shaped NA casts work as expected", {
mat <- matrix
exp_mat <- mat(NA_complex_)
to_mat <- matrix(cpl())
# TODO: Use our own cast routines here?
# `as.complex(NA/NA_real_/NA_integer_)` and `Rf_CoerceVector(NA/NA_real_/NA_integer_)`
# have gone back and forth about what they return in the `Im()` slot. In some
# R versions they return `0` and in others they return `NA_real_`.
# https://stat.ethz.ch/pipermail/r-devel/2023-April/082545.html
# https://stat.ethz.ch/pipermail/r-devel/2023-September/082864.html
# expect_equal(vec_cast(mat(lgl(NA)), to_mat), exp_mat)
expect_type(vec_cast(mat(lgl(NA)), to_mat), "complex")
expect_identical(is.na(vec_cast(mat(lgl(NA)), to_mat)), matrix(TRUE))
# expect_equal(vec_cast(mat(int(NA)), to_mat), exp_mat)
expect_type(vec_cast(mat(int(NA)), to_mat), "complex")
expect_identical(is.na(vec_cast(mat(int(NA)), to_mat)), matrix(TRUE))
# expect_equal(vec_cast(mat(dbl(NA)), to_mat), exp_mat)
expect_type(vec_cast(mat(dbl(NA)), to_mat), "complex")
expect_identical(is.na(vec_cast(mat(dbl(NA)), to_mat)), matrix(TRUE))
# This used to be allowed
expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})
test_that("complex is coercible to numeric types", {
expect_identical(vec_ptype2(cpl(), NULL), cpl())
expect_identical(vec_ptype2(NULL, cpl()), cpl())
expect_identical(vec_ptype2(cpl(), int()), cpl())
expect_identical(vec_ptype2(int(), cpl()), cpl())
expect_identical(vec_ptype2(cpl(), dbl()), cpl())
expect_identical(vec_ptype2(dbl(), cpl()), cpl())
expect_identical(vec_ptype2(cpl(), cpl()), cpl())
expect_identical(vec_c(0, 1i), cpl(0i, 1i))
})
test_that("complex is not coercible to logical", {
expect_error(vec_ptype2(cpl(), lgl()), class = "vctrs_error_incompatible_type")
expect_error(vec_ptype2(lgl(), cpl()), class = "vctrs_error_incompatible_type")
})
# Character
test_that("safe casts work as expected", {
expect_equal(vec_cast(NULL, character()), NULL)
expect_equal(vec_cast(NA, character()), NA_character_)
# These used to be allowed
expect_error(vec_cast(lgl(TRUE, FALSE), character()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list("x", "y"), character()), class = "vctrs_error_incompatible_type")
})
test_that("NA casts work as expected", {
exp <- chr(NA)
to <- chr()
expect_equal(vec_cast(lgl(NA), to), exp)
expect_equal(vec_cast(chr(NA), to), exp)
# These used to be allowed
expect_error(vec_cast(int(NA), to), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(dbl(NA), to), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(list(NA), to), class = "vctrs_error_incompatible_type")
})
test_that("Shaped NA casts work as expected", {
mat <- matrix
exp_mat <- mat(chr(NA))
to_mat <- matrix(chr())
expect_equal(vec_cast(mat(chr(NA)), to_mat), exp_mat)
# These used to be allowed
expect_error(vec_cast(mat(lgl(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(int(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(dbl(NA)), to_mat), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(mat(list(NA)), to_mat), class = "vctrs_error_incompatible_type")
})
test_that("difftime does not get special treatment", {
dt1 <- as.difftime(600, units = "secs")
# This used to be allowed
expect_error(vec_cast(dt1, character()), class = "vctrs_error_incompatible_type")
})
# Raw
test_that("safe casts work as expected", {
expect_equal(vec_cast(NULL, raw()), NULL)
# This used to be allowed
expect_error(vec_cast(list(raw(1)), raw()), class = "vctrs_error_incompatible_type")
})
test_that("invalid casts generate error", {
expect_error(vec_cast(raw(1), double()), class = "vctrs_error_incompatible_type")
expect_error(vec_cast(double(1), raw()), class = "vctrs_error_incompatible_type")
})
test_that("can sort raw", {
x <- as.raw(c(3, 1, 2, 4))
expect_identical(vec_order(x), int(2, 3, 1, 4))
expect_identical(x[vec_order(x)], as.raw(1:4))
})
test_that("raw has informative type summaries", {
expect_equal(vec_ptype_abbr(raw()), "raw")
expect_equal(vec_ptype_full(raw()), "raw")
})
test_that("can provide common type with raw", {
local_methods(
vec_ptype2.raw.vctrs_foobar = function(...) "dispatched-left",
vec_ptype2.vctrs_foobar = function(...) NULL,
vec_ptype2.vctrs_foobar.raw = function(...) "dispatched-right"
)
expect_identical(vec_ptype2(raw(), foobar("")), "dispatched-left")
expect_identical(vec_ptype2(foobar(""), raw()), "dispatched-right")
})
# Lists
test_that("safe casts work as expected", {
expect_equal(vec_cast(NULL, list()), NULL)
expect_equal(vec_cast(NA, list()), list(NULL))
expect_equal(vec_cast(list(1L, 2L), list()), list(1L, 2L))
# This used to be allowed
expect_error(vec_cast(1:2, list()), class = "vctrs_error_incompatible_type")
})
test_that("dimensionality matches to" ,{
x1 <- matrix(TRUE, nrow = 1, ncol = 1)
x2 <- matrix(1L, nrow = 0, ncol = 2)
expect_dim(vec_cast(x1, x2), c(1, 2))
expect_dim(vec_cast(TRUE, x2), c(1, 2))
})
test_that("data frames are cast to list row wise (#639)", {
x <- data.frame(x = 1:2, row.names = c("a", "b"))
expect <- list(data.frame(x = 1L), data.frame(x = 2L))
# This used to be allowed
expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})
test_that("data frames can be cast to shaped lists", {
to <- array(list(), dim = c(0, 2, 1))
x <- data.frame(x = 1:2, y = 3:4)
expect <- list(vec_slice(x, 1), vec_slice(x, 2))
expect <- array(expect, dim = c(2, 2, 1))
# This used to be allowed
expect_error(vec_cast(x, to), class = "vctrs_error_incompatible_type")
})
test_that("Casting atomic `NA` values to list results in a `NULL`", {
x <- c(NA, 1)
expect <- list(NULL, 1)
# This used to be allowed
expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})
test_that("Casting data frame `NA` rows to list results in a `NULL`", {
x <- data.frame(x = c(NA, NA, 1), y = c(NA, 1, 2))
expect <- list(NULL, vec_slice(x, 2), vec_slice(x, 3))
# This used to be allowed
expect_error(vec_cast(x, list()), class = "vctrs_error_incompatible_type")
})
# Unspecified
test_that("unspecified can be cast to bare methods", {
for (x in vectors[-4]) {
expect_identical(vec_cast(unspecified(3), x), vec_init(x, 3))
}
})
vctrs/tests/testthat/test-print-str.R 0000644 0001762 0000144 00000000260 14276722575 017476 0 ustar ligges users
test_that("show attributes", {
x <- structure(1:100, x = "a string", y = 1:20, z = data.frame(x = 1:3))
expect_snapshot(obj_str(x))
expect_snapshot(obj_str(mtcars))
})
vctrs/tests/testthat/helper-order.R 0000644 0001762 0000144 00000001235 14276722575 017152 0 ustar ligges users # Keep in sync with macros in `order.c`
GROUP_DATA_SIZE_DEFAULT <- 100000L
ORDER_INSERTION_BOUNDARY <- 128L
INT_ORDER_COUNTING_RANGE_BOUNDARY <- 100000L
# Force radix method for character comparisons
base_order <- function(x, na.last = TRUE, decreasing = FALSE) {
if (is.data.frame(x)) {
x <- unname(x)
} else {
x <- list(x)
}
args <- list(na.last = na.last, decreasing = decreasing)
# `method` didn't exist on R < 3.3.
# It would sometimes use radix sorting automatically.
if (getRversion() < "3.3.0") {
method <- list()
} else {
method <- list(method = "radix")
}
args <- c(x, args, method)
rlang::exec("order", !!!args)
}
vctrs/tests/testthat/test-lifecycle-deprecated.R 0000644 0001762 0000144 00000002756 14401377400 021564 0 ustar ligges users
test_that("vec_as_index() still works", {
local_options(lifecycle_verbosity = "quiet")
expect_identical(vec_as_index(-2, 10), vec_as_location(-2, 10))
expect_identical(
vec_as_index("cyl", length(mtcars), names(mtcars)),
vec_as_location("cyl", length(mtcars), names(mtcars))
)
})
test_that("vec_repeat() still works", {
local_options(lifecycle_verbosity = "quiet")
expect_identical(vec_repeat(1:2, times = 2), vec_rep(1:2, 2))
expect_identical(vec_repeat(1:2, each = 2), vec_rep_each(1:2, 2))
})
test_that("vec_unchop() is soft-deprecated", {
local_options(lifecycle_verbosity = "warning")
expect_snapshot(vec_unchop(list(1), indices = list(1)))
})
test_that("vec_unchop() still works", {
local_options(lifecycle_verbosity = "quiet")
expect_identical(
vec_unchop(list(1L, 2:3), indices = list(2, c(3, 1))),
c(3L, 1L, 2L)
)
})
test_that("vec_equal_na() is soft-deprecated", {
local_options(lifecycle_verbosity = "warning")
expect_snapshot(vec_equal_na(c(1, NA)))
})
test_that("vec_equal_na() still works", {
local_options(lifecycle_verbosity = "quiet")
expect_identical(
vec_equal_na(c(1, NA, 2, NA)),
c(FALSE, TRUE, FALSE, TRUE)
)
})
test_that("vec_is_list() still works", {
expect_false(vec_is_list(1))
expect_true(vec_is_list(list()))
})
test_that("vec_check_list() still works", {
my_check <- function(x) vec_check_list(x)
expect_snapshot(error = TRUE, {
vec_check_list(1)
})
expect_snapshot(error = TRUE, {
my_check(1)
})
})
vctrs/tests/testthat/helper-memory.R 0000644 0001762 0000144 00000000227 14276722575 017347 0 ustar ligges users maybe_shared_col <- function(x, i) {
.Call(vctrs_maybe_shared_col, x, i)
}
new_df_unshared_col <- function() {
.Call(vctrs_new_df_unshared_col)
}
vctrs/tests/testthat/helper-expectations.R 0000644 0001762 0000144 00000004726 14362266120 020536 0 ustar ligges users expect_dim <- function(x, shape) {
dim <- dim2(x)
expect_equal(dim, !!shape)
}
expect_lossy <- function(expr, result, x = NULL, to = NULL) {
expr <- enquo(expr)
expect_error(eval_tidy(expr), class = "vctrs_error_cast_lossy")
out <- allow_lossy_cast(eval_tidy(expr), x_ptype = x, to_ptype = to)
expect_identical(!!out, !!result)
}
expect_args <- function(x, y, x_arg, y_arg) {
err <- catch_cnd(vec_ptype2(x, y, x_arg = x_arg, y_arg = y_arg), classes = "vctrs_error_incompatible_type")
expect_true(!is_null(err))
expect_true(grepl(paste0("combine `", x_arg, "`"), err$message, fixed = TRUE))
expect_true(grepl(paste0("and `", y_arg, "`"), err$message, fixed = TRUE))
expect_identical(list(err$x_arg, err$y_arg), list(x_arg, y_arg))
}
# Work around deparsing of !! on old versions of R
as_label2 <- function(expr) {
expr <- duplicate(expr, shallow = FALSE)
label <- as_label(fix_bang(expr))
label <- gsub("+++", "!!!", label, fixed = TRUE)
label <- gsub("++", "!!", label, fixed = TRUE)
label
}
fix_bang <- function(expr) {
curr <- expr
while (!is_null(curr)) {
car <- node_car(curr)
if (is_triple_bang(car)) {
replace_triple_bang(car)
} else if (is_double_bang(car)) {
replace_double_bang(car)
} else if (is_call(car)) {
node_poke_car(curr, fix_bang(car))
}
curr <- node_cdr(curr)
}
expr
}
is_double_bang <- function(expr) {
is_call(expr, "!") && is_call(node_cadr(expr), "!")
}
is_triple_bang <- function(expr) {
is_double_bang(expr) && is_call(node_cadr(node_cadr(expr)), "!")
}
replace_double_bang <- function(expr) {
node_poke_car(expr, sym("+"))
node_poke_car(node_cadr(expr), sym("+"))
}
replace_triple_bang <- function(expr) {
replace_double_bang(expr)
node_poke_car(node_cadr(node_cadr(expr)), sym("+"))
}
expect_syntactic <- function(name, exp_syn_name) {
expect_identical(
syn_name <- make_syntactic(name),
exp_syn_name
)
expect_identical(syn_name, make.names(syn_name))
}
expect_error_cnd <- function(object, class, message = NULL, ..., .fixed = TRUE) {
cnd <- expect_error(object, regexp = message, class = class[[1]], fixed = .fixed)
expect_true(inherits_all(cnd, class))
exp_fields <- list2(...)
expect_true(is_empty(setdiff(!!names(exp_fields), names(cnd))))
expect_equal(cnd[names(exp_fields)], exp_fields)
}
scrub_internal_error_line_number <- function(x) {
# Because it varies by OS
sub(pattern = "at line [[:digit:]]+", replacement = "at line ", x = x)
}
vctrs/tests/testthat/helper-size.R 0000644 0001762 0000144 00000000141 14520724751 016772 0 ustar ligges users
expect_size <- function(object, n) {
expect_identical(vec_size(object), vec_cast(n, int()))
}
vctrs/tests/testthat/test-assert.R 0000644 0001762 0000144 00000035776 14404336165 017046 0 ustar ligges users
test_that("basic assert is idempotent", {
x <- new_vctr(1:4)
expect_true(vec_is(x))
expect_identical(vec_assert(x), x)
expect_identical(vec_assert(x), new_vctr(1:4))
expect_false(withVisible(vec_assert(x))$visible)
expect_true(vec_is(1:4))
expect_identical(vec_assert(1:4), 1:4)
})
test_that("asserting ptype", {
x <- new_vctr(1:4)
good <- new_vctr(integer())
expect_true(vec_is(x, good))
expect_error(vec_assert(x, good), NA)
# Is this the correct error message?
bad <- new_vctr(double())
expect_false(vec_is(x, bad))
expect_error(vec_assert(x, bad), class = "vctrs_error_assert_ptype")
})
test_that("asserting size", {
x <- new_vctr(1:4)
expect_true(vec_is(x, size = 4))
expect_error(vec_assert(x, size = 4), NA)
expect_false(vec_is(x, size = 5))
expect_error(vec_assert(x, size = 5), class = "vctrs_error_assert_size")
})
test_that("vec_assert() labels input", {
expect_error(
vec_assert(new_vctr(1:4), size = 5),
regexp = "`new_vctr\\(1:4\\)` must have",
class = "vctrs_error_assert_size"
)
expect_error(
vec_assert(new_vctr(1:4), size = 5, arg = "foobar"),
regexp = "`foobar` must have",
class = "vctrs_error_assert_size"
)
})
test_that("bare atomic vectors are vectors but not recursive", {
expect_true(obj_is_vector(TRUE))
expect_true(obj_is_vector(1L))
expect_true(obj_is_vector(1))
expect_true(obj_is_vector(1i))
expect_true(obj_is_vector("foo"))
expect_true(obj_is_vector(as.raw(1)))
})
test_that("S3 atomic vectors are vectors", {
expect_true(obj_is_vector(foobar(TRUE)))
expect_true(obj_is_vector(foobar(1L)))
expect_true(obj_is_vector(foobar(1)))
expect_true(obj_is_vector(foobar(1i)))
expect_true(obj_is_vector(foobar("foo")))
expect_true(obj_is_vector(foobar(as.raw(1))))
})
test_that("bare lists are vectors", {
expect_true(obj_is_vector(list()))
})
test_that("S3 lists are not vectors by default", {
expect_false(obj_is_vector(foobar()))
expect_false(obj_is_list(foobar()))
local_foobar_proxy()
# TODO: These seem inconsistent.
# Should we require that S3 list proxies satisfy `obj_is_list()`?
# (i.e. unclass themselves or explicitly inherit from `"list"`?)
expect_true(obj_is_vector(foobar()))
expect_false(obj_is_list(foobar()))
})
test_that("data frames and records are vectors", {
expect_true(obj_is_vector(mtcars))
expect_true(obj_is_vector(new_rcrd(list(x = 1, y = 2))))
})
test_that("non-vector base types are scalars", {
expect_identical(vec_typeof(quote(foo)), "scalar")
expect_identical(vec_typeof(pairlist("")), "scalar")
expect_identical(vec_typeof(function() NULL), "scalar")
expect_identical(vec_typeof(env()), "scalar")
expect_identical(vec_typeof(quote(foo)), "scalar")
expect_identical(vec_typeof(~foo), "scalar")
expect_identical(vec_typeof(base::`{`), "scalar")
expect_identical(vec_typeof(base::c), "scalar")
expect_identical(vec_typeof(expression()), "scalar")
expect_false(obj_is_vector(quote(foo)))
expect_false(obj_is_vector(pairlist("")))
expect_false(obj_is_vector(function() NULL))
expect_false(obj_is_vector(env()))
expect_false(obj_is_vector(~foo))
expect_false(obj_is_vector(base::`{`))
expect_false(obj_is_vector(base::c))
expect_false(obj_is_vector(expression()))
expect_false(vec_is(quote(foo)))
expect_false(vec_is(pairlist("")))
expect_false(vec_is(function() NULL))
expect_false(vec_is(env()))
expect_false(vec_is(~foo))
expect_false(vec_is(base::`{`))
expect_false(vec_is(base::c))
expect_false(vec_is(expression()))
expect_error(vec_assert(quote(foo)), class = "vctrs_error_scalar_type")
expect_error(vec_assert(pairlist("")), class = "vctrs_error_scalar_type")
expect_error(vec_assert(function() NULL), class = "vctrs_error_scalar_type")
expect_error(vec_assert(env()), class = "vctrs_error_scalar_type")
expect_error(vec_assert(~foo), class = "vctrs_error_scalar_type")
expect_error(vec_assert(base::`{`), class = "vctrs_error_scalar_type")
expect_error(vec_assert(base::c), class = "vctrs_error_scalar_type")
expect_error(vec_assert(expression()), class = "vctrs_error_scalar_type")
})
test_that("non-vector types can be proxied", {
x <- new_proxy(1:3)
expect_identical(vec_typeof(x), "scalar")
expect_false(obj_is_vector(x))
expect_false(vec_is(x))
expect_error(vec_assert(x), class = "vctrs_error_scalar_type")
local_env_proxy()
expect_identical(vec_typeof(x), "integer")
expect_true(obj_is_vector(x))
expect_true(vec_is(x))
expect_error(regexp = NA, vec_assert(x))
})
test_that("obj_check_vector() is silent on vectors", {
expect_null(obj_check_vector(1))
expect_null(obj_check_vector(data_frame()))
})
test_that("obj_check_vector() errors on scalars", {
expect_snapshot(error = TRUE, {
obj_check_vector(quote(foo))
})
expect_snapshot(error = TRUE, {
obj_check_vector(foobar())
})
})
test_that("obj_check_vector() error respects `arg` and `call`", {
my_check_vector <- function(foo) {
obj_check_vector(foo)
}
expect_snapshot(error = TRUE, {
my_check_vector(foobar())
})
})
test_that("vec_assert() uses friendly type in error messages", {
# Friendly type will be generated in rlang in the future. Upstream
# changes should not cause CRAN failures.
skip_on_cran()
expect_error(vec_assert(function() NULL), class = "vctrs_error_scalar_type")
})
test_that("vec_typeof() handles all types", {
for (i in seq_along(empty_types)) {
expect_identical(vec_typeof(!!empty_types[[i]]), !!names(empty_types)[[i]])
}
})
test_that("bare prototypes don't act as partial types", {
expect_false(vec_is(foobar(1), dbl()))
expect_error(vec_assert(foobar(1), dbl()), class = "vctrs_error_assert_ptype")
})
test_that("data frames are always classified as such even when dispatch is off", {
expect_identical(vec_typeof_bare(mtcars), "dataframe")
})
test_that("assertion is not applied on proxy", {
local_methods(
vec_proxy.vctrs_foobar = function(x, ...) unclass(x),
vec_restore.vctrs_foobar = function(x, ...) foobar(x),
`[.vctrs_foobar` = function(x, i) vec_slice(x, i)
)
x <- foobar(list())
expect_true(vec_is(x, x))
expect_false(vec_is(x, list()))
expect_error(vec_assert(x, list()), class = "vctrs_error_assert_ptype")
expect_error(vec_assert(x, x), regexp = NA)
})
test_that("attributes of unclassed vectors are asserted", {
x <- structure(FALSE, foo = "bar")
y <- structure(TRUE, foo = "bar")
expect_false(vec_is(x, FALSE))
expect_false(vec_is(FALSE, x))
expect_true(vec_is(y, x))
expect_true(vec_is(x, y))
})
test_that("unspecified is finalised before assertion", {
expect_true(vec_is(NA, TRUE))
expect_true(vec_is(data.frame(x = NA), data.frame(x = lgl())))
expect_error(regexp = NA, vec_assert(NA, TRUE))
expect_error(regexp = NA, vec_assert(data.frame(x = NA), data.frame(x = lgl())))
})
test_that("assertion failures are explained", {
local_no_stringsAsFactors()
local_options(rlang_backtrace_on_error = "none")
expect_snapshot(error = TRUE, vec_assert(lgl(), chr()))
expect_snapshot(error = TRUE, vec_assert(lgl(), factor()))
expect_snapshot(error = TRUE, vec_assert(lgl(), factor(levels = "foo")))
expect_snapshot(error = TRUE, vec_assert(factor(levels = "bar"), factor(levels = "foo")))
expect_snapshot(error = TRUE, vec_assert(factor(), chr()))
expect_snapshot(error = TRUE, vec_assert(lgl(), data.frame()))
expect_snapshot(error = TRUE, vec_assert(lgl(), data.frame(x = 1)))
expect_snapshot(error = TRUE, vec_assert(lgl(), data.frame(x = 1, y = 2)))
expect_snapshot(error = TRUE, vec_assert(data.frame(), chr()))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1), chr()))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1), data.frame(x = "foo")))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1), data.frame(x = "foo", y = 2)))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1, y = 2), chr()))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo")))
expect_snapshot(error = TRUE, vec_assert(data.frame(x = 1, y = 2), data.frame(x = "foo", y = 2)))
})
test_that("vec_assert() validates `size` (#1470)", {
expect_snapshot({
(expect_error(vec_assert(1, size = c(2, 3))))
(expect_error(vec_assert(1, size = 1.5)))
(expect_error(vec_assert(1, size = "x")))
})
})
test_that("NULL is not a vector", {
expect_false(obj_is_vector(NULL))
expect_false(vec_is(NULL))
})
test_that("names and row names do not influence type identity (#707)", {
expect_true(vec_is(c(a = TRUE), logical()))
expect_true(vec_is(TRUE, c(a = TRUE)))
expect_true(vec_is(structure(mtcars, row.names = 1:32), mtcars))
expect_true(vec_is(mtcars, structure(mtcars, row.names = 1:32)))
})
# vec_check_size --------------------------------------------------------
test_that("vec_check_size() is silent if the size is right", {
expect_null(vec_check_size(1:5, size = 5L))
expect_null(vec_check_size(data_frame(.size = 10L), size = 10L))
})
test_that("vec_check_size() errors on the wrong size", {
expect_snapshot(error = TRUE, {
vec_check_size(1:5, size = 1L)
})
expect_snapshot(error = TRUE, {
vec_check_size(1:5, size = 10L)
})
})
test_that("vec_check_size() errors on scalars", {
expect_snapshot(error = TRUE, {
vec_check_size(quote(foo), size = 1L)
})
expect_snapshot(error = TRUE, {
vec_check_size(foobar(), size = 1L)
})
})
test_that("vec_check_size() error respects `arg` and `call`", {
my_check_size <- function(foo, size) {
vec_check_size(foo, size)
}
expect_snapshot(error = TRUE, {
my_check_size(1L, size = 5L)
})
expect_snapshot(error = TRUE, {
my_check_size(foobar(), size = 5L)
})
})
test_that("vec_check_size() validates `size`", {
expect_snapshot(error = TRUE, {
vec_check_size(1, size = "x")
})
expect_snapshot(error = TRUE, {
vec_check_size(1, size = c(1L, 2L))
})
expect_snapshot(error = TRUE, {
vec_check_size(1, size = 1.5)
})
})
# obj_is_list -----------------------------------------------------------
test_that("bare lists are lists", {
expect_true(obj_is_list(list()))
})
test_that("AsIs lists are lists (#1463)", {
expect_true(obj_is_list(I(list())))
expect_true(obj_is_list(I(list_of(1))))
expect_false(obj_is_list(I(double())))
})
test_that("list_of are lists", {
expect_true(obj_is_list(new_list_of()))
})
test_that("Vectors with a non-VECSXP type are not lists", {
expect_false(obj_is_list(1))
expect_false(obj_is_list("a"))
expect_false(obj_is_list(quote(name)))
})
test_that("explicitly classed lists are lists", {
x <- structure(list(), class = "list")
expect_true(obj_is_list(x))
expect_true(obj_is_list(subclass(x)))
})
test_that("explicit inheritance must be in the base class", {
x <- structure(1:2, class = c("list", "foobar"))
expect_false(obj_is_list(x))
})
test_that("POSIXlt are not considered a list", {
expect_false(obj_is_list(as.POSIXlt(new_datetime())))
})
test_that("rcrd types are not lists", {
expect_false(obj_is_list(new_rcrd(list(x = 1))))
})
test_that("scalars are not lists", {
expect_false(obj_is_list(foobar()))
})
test_that("S3 types can't lie about their internal representation", {
x <- structure(1:2, class = c("foobar", "list"))
expect_false(obj_is_list(x))
})
test_that("data frames of all types are not lists", {
expect_false(obj_is_list(data.frame()))
expect_false(obj_is_list(subclass(data.frame())))
expect_false(obj_is_list(tibble::tibble()))
})
test_that("S3 list with non-list proxy is still a list (#1208)", {
x <- structure(list(), class = c("foobar", "list"))
local_methods(vec_proxy.foobar = function(x) 1)
# This used to be an error (#1003)
# expect_error(obj_is_list(x), "`x` inherits")
expect_true(obj_is_list(x))
})
test_that("list-rcrds with data frame proxies are considered lists (#1208)", {
x <- structure(
list(1:2, "x"),
special = c("a", "b"),
class = c("list_rcrd", "list")
)
local_methods(
vec_proxy.list_rcrd = function(x) {
special <- attr(x, "special")
data <- unstructure(x)
new_data_frame(list(data = data, special = special))
}
)
expect_true(obj_is_list(x))
})
test_that("list_all_vectors() works", {
expect_true(list_all_vectors(list(1)))
expect_true(list_all_vectors(list_of(1)))
expect_false(list_all_vectors(list(1, env())))
expect_snapshot((expect_error(list_all_vectors(env()))))
})
test_that("obj_check_list() works", {
expect_null(obj_check_list(list(1)))
expect_null(obj_check_list(list_of(1)))
expect_snapshot({
my_function <- function(my_arg) obj_check_list(my_arg)
(expect_error(my_function(env())))
})
})
test_that("obj_check_list() uses a special error when `arg` is the empty string (#1604)", {
expect_snapshot(error = TRUE, {
obj_check_list(1, arg = "")
})
})
test_that("obj_check_list() and list_check_all_vectors() work", {
expect_null(list_check_all_vectors(list()))
expect_null(list_check_all_vectors(list(1, mtcars)))
expect_snapshot({
my_function <- function(my_arg) list_check_all_vectors(my_arg)
(expect_error(my_function(env())))
(expect_error(my_function(list(1, env()))))
(expect_error(my_function(list(1, name = env()))))
(expect_error(my_function(list(1, foo = env()))))
})
})
test_that("list_all_size() works", {
expect_true(list_all_size(list(), 2))
expect_true(list_all_size(list(integer()), 0))
expect_true(list_all_size(list(NULL), 0))
expect_true(list_all_size(list(1:2, 2:3), 2))
expect_false(list_all_size(list(1:2, 1:3), 2))
expect_false(list_all_size(list(NULL, 1:2), 2))
expect_true(list_all_size(list_of(1:3, 2:4), 3))
expect_false(list_all_size(list_of(1:3, 2:4), 4))
})
test_that("list_check_all_size() works", {
expect_null(list_check_all_size(list(), 2))
expect_null(list_check_all_size(list(integer()), 0))
expect_null(list_check_all_size(list(NULL), 0))
expect_null(list_check_all_size(list(1:2, 2:3), 2))
expect_snapshot({
my_function <- function(my_arg, size) list_check_all_size(my_arg, size)
# Validates sizes
(expect_error(list_check_all_size(list(1:2, 1:3), 2)))
(expect_error(my_function(list(1:2, 1:3), 2)))
# `NULL` is not ignored
(expect_error(my_function(list(NULL, 1:2), 2)))
})
})
test_that("list_all_size() and list_check_all_size() error on scalars", {
x <- list(env())
expect_snapshot({
# Error considered internal to `list_all_size()`
(expect_error(list_all_size(x, 2)))
my_function <- function(my_arg, size) list_check_all_size(my_arg, size)
(expect_error(my_function(x, 2)))
})
})
test_that("list_all_size() and list_check_all_size() throw error using internal call on non-list input", {
expect_snapshot({
(expect_error(list_all_size(1, 2)))
# `arg` and `call` are ignored
(expect_error(list_check_all_size(1, 2, arg = "arg", call = call("foo"))))
})
})
test_that("list_all_size() and list_check_all_size() validate `size`", {
expect_snapshot({
(expect_error(list_all_size(list(), size = "x")))
(expect_error(list_check_all_size(list(), size = "x")))
})
})
test_that("informative messages when 1d array doesn't match vector", {
x <- array(1:3)
expect_snapshot((expect_error(vec_assert(x, int()))))
})
vctrs/tests/testthat/test-slice-assign.R 0000644 0001762 0000144 00000055566 14511320527 020117 0 ustar ligges users
test_that("slice-assign throws error with non-vector inputs", {
x <- environment()
expect_error(vec_slice(x, 1L) <- 1L, class = "vctrs_error_scalar_type")
})
test_that("slice-assign throws error with non-vector `value`", {
x <- 1L
expect_error(vec_slice(x, 1L) <- NULL, class = "vctrs_error_scalar_type")
expect_error(vec_slice(x, 1L) <- environment(), class = "vctrs_error_scalar_type")
})
test_that("can slice-assign NULL", {
x <- NULL
vec_slice(x, 1L) <- 1
expect_identical(x, NULL)
})
test_that("can slice-assign base vectors", {
x <- rep(FALSE, 3)
vec_slice(x, 2) <- TRUE
expect_identical(x, lgl(FALSE, TRUE, FALSE))
x <- rep(0L, 3)
vec_slice(x, 2) <- 1L
expect_identical(x, int(0L, 1L, 0L))
x <- rep(0., 3)
vec_slice(x, 2) <- 1
expect_identical(x, dbl(0, 1, 0))
x <- rep(0i, 3)
vec_slice(x, 2) <- 1i
expect_identical(x, cpl(0i, 1i, 0i))
x <- rep("", 3)
vec_slice(x, 2) <- "foo"
expect_identical(x, chr("", "foo", ""))
x <- as.raw(rep(0, 3))
vec_slice(x, 2) <- as.raw(1)
expect_identical(x, as.raw(c(0, 1, 0)))
})
test_that("can assign base vectors", {
x <- rep(FALSE, 3)
expect_identical(vec_assign(x, 2, TRUE), lgl(FALSE, TRUE, FALSE))
expect_identical(x, rep(FALSE, 3))
x <- rep(0L, 3)
expect_identical(vec_assign(x, 2, 1L), int(0L, 1L, 0L))
expect_identical(x, rep(0L, 3))
x <- rep(0., 3)
expect_identical(vec_assign(x, 2, 1), dbl(0, 1, 0))
expect_identical(x, rep(0., 3))
x <- rep(0i, 3)
expect_identical(vec_assign(x, 2, 1i), cpl(0i, 1i, 0i))
expect_identical(x, rep(0i, 3))
x <- rep("", 3)
expect_identical(vec_assign(x, 2, "foo"), chr("", "foo", ""))
expect_identical(x, rep("", 3))
x <- as.raw(rep(0, 3))
expect_identical(vec_assign(x, 2, as.raw(1)), as.raw(c(0, 1, 0)))
expect_identical(x, as.raw(rep(0, 3)))
})
test_that("can assign shaped base vectors", {
mat <- as.matrix
x <- mat(rep(FALSE, 3))
expect_identical(vec_assign(x, 2, TRUE), mat(lgl(FALSE, TRUE, FALSE)))
expect_identical(x, mat(rep(FALSE, 3)))
x <- mat(rep(0L, 3))
expect_identical(vec_assign(x, 2, 1L), mat(int(0L, 1L, 0L)))
expect_identical(x, mat(rep(0L, 3)))
x <- mat(rep(0, 3))
expect_identical(vec_assign(x, 2, 1), mat(dbl(0, 1, 0)))
expect_identical(x, mat(rep(0, 3)))
x <- mat(rep(0i, 3))
expect_identical(vec_assign(x, 2, 1i), mat(cpl(0i, 1i, 0i)))
expect_identical(x, mat(rep(0i, 3)))
x <- mat(rep("", 3))
expect_identical(vec_assign(x, 2, "foo"), mat(chr("", "foo", "")))
expect_identical(x, mat(rep("", 3)))
x <- mat(as.raw(rep(0, 3)))
expect_identical(vec_assign(x, 2, as.raw(1)), mat(as.raw(c(0, 1, 0))))
expect_identical(x, mat(as.raw(rep(0, 3))))
})
test_that("can slice-assign lists", {
x <- rep(list(NULL), 3)
vec_slice(x, 2) <- list(NA)
expect_identical(x, list(NULL, NA, NULL))
})
test_that("can slice-assign shaped lists", {
mat <- as.matrix
x <- mat(rep(list(NULL), 3))
vec_slice(x, 2) <- list(NA)
expect_identical(x, mat(list(NULL, NA, NULL)))
})
test_that("can assign lists", {
x <- rep(list(NULL), 3)
expect_identical(vec_assign(x, 2, list(NA)), list(NULL, NA, NULL))
expect_identical(x, rep(list(NULL), 3))
})
test_that("can assign shaped lists", {
mat <- as.matrix
x <- mat(rep(list(NULL), 3))
expect_identical(vec_assign(x, 2, list(NA)), mat(list(NULL, NA, NULL)))
expect_identical(x, mat(rep(list(NULL), 3)))
})
test_that("can assign object of any dimensionality", {
x1 <- ones(2)
x2 <- ones(2, 3)
x3 <- ones(2, 3, 4)
x4 <- ones(2, 3, 4, 5)
expect_identical(vec_assign(x1, 1L, 2L), array(rep(c(2, 1), 1), dim = 2))
expect_identical(vec_assign(x2, 1L, 2L), array(rep(c(2, 1), 3), dim = c(2, 3)))
expect_identical(vec_assign(x3, 1L, 2L), array(rep(c(2, 1), 12), dim = c(2, 3, 4)))
expect_identical(vec_assign(x4, 1L, 2L), array(rep(c(2, 1), 60), dim = c(2, 3, 4, 5)))
})
test_that("atomics can't be assigned in lists", {
x <- list(NULL)
expect_error(vec_slice(x, 1) <- 1, class = "vctrs_error_incompatible_type")
expect_error(vec_assign(x, 1, 2), class = "vctrs_error_incompatible_type")
expect_error(vec_slice(x, 1) <- "foo", class = "vctrs_error_incompatible_type")
expect_error(vec_assign(x, 1, "foo"), class = "vctrs_error_incompatible_type")
})
test_that("Unspecified `NA` vector can be assigned into lists", {
x <- list(1, 2)
vec_slice(x, 1) <- NA
expect_identical(x, list(NULL, 2))
})
test_that("monitoring test - unspecified() can be assigned in lists", {
x <- list(1, 2)
expect_error(vec_slice(x, 1) <- unspecified(1), NA)
expect_equal(x, list(NULL, 2))
})
test_that("can assign and slice-assign data frames", {
df <- data.frame(x = 1:2)
df$y <- data.frame(a = 2:1)
orig <- duplicate(df, shallow = FALSE)
other <- data.frame(x = 3)
other$y <- data.frame(a = 3)
exp <- data.frame(x = int(3, 2))
exp$y <- data.frame(a = int(3, 1))
expect_identical(vec_assign(df, 1, other), exp)
expect_identical(df, orig)
vec_slice(df, 1) <- other
expect_identical(df, exp)
})
test_that("can slice-assign using logical index", {
x <- c(2, 1)
vec_slice(x, TRUE) <- 3
expect_equal(x, c(3, 3))
vec_slice(x, c(TRUE, FALSE)) <- 4
expect_equal(x, c(4, 3))
expect_error(
vec_assign(x, c(TRUE, FALSE, TRUE), 5),
class = "vctrs_error_subscript_size"
)
expect_error(
vec_assign(mtcars, c(TRUE, FALSE), mtcars[1, ]),
class = "vctrs_error_subscript_size"
)
})
test_that("slice-assign ignores NA in logical subsetting", {
x <- c(NA, 1, 2)
expect_equal(`vec_slice<-`(x, x > 0, 1), c(NA, 1, 1))
expect_equal(`vec_slice<-`(x, x > 0, c(NA, 2:1)), c(NA, 2, 1))
})
test_that("slice-assign with arrays ignores NA in logical subsetting", {
mat <- as.matrix
x <- c(NA, 1, 2)
expect_equal(`vec_slice<-`(mat(x), x > 0, 1), mat(c(NA, 1, 1)))
expect_equal(`vec_slice<-`(mat(x), x > 0, c(NA, 2:1)), mat(c(NA, 2, 1)))
})
test_that("slice-assign ignores NA in integer subsetting", {
x <- 0:2
expect_equal(`vec_slice<-`(x, c(NA, 2:3), 1), c(0, 1, 1))
expect_equal(`vec_slice<-`(x, c(NA, 2:3), c(NA, 2:1)), c(0, 2, 1))
})
test_that("slice-assign with arrays ignores NA in integer subsetting", {
mat <- as.matrix
x <- mat(0:2)
expect_equal(`vec_slice<-`(x, c(NA, 2:3), 1), mat(c(0, 1, 1)))
expect_equal(`vec_slice<-`(x, c(NA, 2:3), c(NA, 2:1)), mat(c(0, 2, 1)))
})
test_that("can't modify subset with missing argument", {
x <- 1:3
expect_error(vec_slice(x, ) <- 2L)
})
test_that("can modify subset with recycled NA argument", {
x <- 1:3
vec_slice(x, NA) <- 2L
expect_identical(x, 1:3)
})
test_that("can modify subset with recycled TRUE argument", {
x <- 1:3
vec_slice(x, TRUE) <- 2L
expect_identical(x, rep(2L, 3))
})
test_that("can modify subset with recycled FALSE argument", {
x <- 1:3
vec_slice(x, FALSE) <- 2L
expect_identical(x, 1:3)
})
test_that("can modify subset with NULL argument", {
x <- 1:3
vec_slice(x, NULL) <- 2L
expect_identical(x, 1:3)
})
test_that("can slice-assign with missing indices", {
x <- 1:3
y <- 4:6
test <- c(NA, TRUE, FALSE)
vec_slice(x, test) <- vec_slice(y, test)
expect_identical(x, int(1, 5, 3))
})
test_that("slice-assign checks vectorness", {
x <- foobar(list(1))
expect_error(vec_slice(x, 1) <- 10, class = "vctrs_error_scalar_type")
})
test_that("a coercible RHS is cast to LHS before assignment (#140)", {
x <- 1:2
expect_error(vec_slice(x, 1) <- "1", class = "vctrs_error_incompatible_type")
x <- c("foo", "bar")
expect_error(vec_slice(x, 1) <- 1, class = "vctrs_error_incompatible_type")
x <- 1:2
expect_error(vec_slice(x, 1) <- 3.5, class = "vctrs_error_cast_lossy")
allow_lossy_cast(vec_slice(x, 1) <- 3.5)
expect_identical(x, int(3, 2))
x <- matrix(1:4, 2)
vec_slice(x, 1) <- matrix(c(FALSE, FALSE), 1)
expect_identical(x, matrix(int(0, 2, 0, 4), 2))
expect_error(vec_assign(x, 1, matrix(c("", ""), 1)), class = "vctrs_error_incompatible_type")
})
test_that("slice-assign takes the proxy", {
local_proxy()
x <- new_proxy(1:3)
y <- new_proxy(20:21)
vec_slice(x, 2:3) <- y
expect_identical(proxy_deref(x), int(1, 20, 21))
})
test_that("can use names to vec_slice<-() a named object", {
x0 <- c(a = 1, b = 2)
x1 <- c(a = 1, a = 2)
vec_slice(x0, "b") <- 3
expect_identical(x0, c(a = 1, b = 3))
vec_slice(x1, "a") <- 3
expect_identical(x1, c(a = 3, a = 2))
})
test_that("can't use names to vec_slice<-() an unnamed object", {
x0 <- 1:3
expect_error(
vec_slice(x0, letters[1]) <- 4L,
"Can't use character names to index an unnamed vector.",
fixed = TRUE
)
expect_error(
vec_slice(x0, letters[25:27]) <- 5L,
"Can't use character names to index an unnamed vector.",
fixed = TRUE
)
})
test_that("slice-assign falls back to `[<-` when proxy is not implemented", {
obj <- foobar(c("foo", "bar", "baz"))
expect_error(vec_slice(obj, 1:2) <- TRUE, class = "vctrs_error_incompatible_type")
vec_slice(obj, 1:2) <- foobar("quux")
vec_ptype2(foobar(""), foobar(""))
vec_cast(foobar(""), foobar(""))
#> Error: Can't cast to
local_methods(
`[<-.vctrs_foobar` = function(x, i, value) {
x <- unclass(x)
x[i] <- "dispatched"
x
},
vec_ptype2.logical.vctrs_foobar = function(...) foobar(""),
vec_ptype2.vctrs_foobar = function(...) foobar(""),
vec_cast.vctrs_foobar = function(...) NULL,
vec_cast.vctrs_foobar.logical = function(x, to, ...) foobar(rep("", length(x)))
)
obj <- foobar(c("foo", "bar", "baz"))
vec_slice(obj, 1:2) <- TRUE
expect_identical(obj, foobar(c("dispatched", "dispatched", "baz")))
})
test_that("vec_assign() can always assign unspecified values into foreign vector types", {
obj <- foobar(c("foo", "bar", "baz"))
expect <- foobar(c(NA, "bar", "baz"))
expect_identical(vec_assign(obj, 1, NA), expect)
expect_identical(vec_assign(obj, 1, unspecified(1)), expect)
})
test_that("slice-assign casts to `to` before falling back to `[<-` (#443)", {
called <- FALSE
local_methods(
vec_proxy.vctrs_proxy = proxy_deref,
vec_ptype2.vctrs_proxy = function(...) NULL,
vec_ptype2.vctrs_proxy.vctrs_foobar = function(...) new_proxy(NA),
vec_cast.vctrs_foobar = function(...) NULL,
vec_cast.vctrs_foobar.vctrs_proxy = function(x, ...) foobar(proxy_deref(x)),
`[<-.vctrs_foobar` = function(x, i, value) {
called <<- TRUE
expect_identical(value, foobar(10))
}
)
x <- foobar(1)
y <- new_proxy(10)
vec_slice(x, 1) <- y
expect_true(called)
})
test_that("index and value are sliced before falling back", {
# Work around a bug in base R `[<-`
lhs <- foobar(c(NA, 1:4))
rhs <- foobar(int(0L, 10L))
exp <- foobar(int(10L, 1:4))
expect_identical(vec_assign(lhs, c(NA, 1), rhs), exp)
})
test_that("can assign to data frame", {
x <- data_frame(x = 1:3)
y <- data_frame(x = 20)
expect_identical(vec_assign(x, 2, y), data_frame(x = int(1, 20, 3)))
})
test_that("can assign to a data frame with matrix columns (#625)", {
df <- tibble(x = 1:2, y = matrix(1:4, nrow = 2))
expect_identical(vec_assign(df, 2L, df[1,]), vec_slice(df, c(1, 1)))
})
test_that("assigning to a factor doesn't produce corrupt levels (#853)", {
x <- factor(c("a", NA), levels = c("a", "b"))
value <- factor("b", levels = "b")
res <- vec_assign(x, 2, value)
expect_identical(res, factor(c("a", "b")))
res <- vec_assign(x, 1:2, value)
expect_identical(res, factor(c("b", "b"), levels = c("a", "b")))
})
test_that("can slice-assign unspecified vectors with default type2 method", {
local_rational_class()
x <- rational(1:2, 2:3)
x[[1]] <- NA
expect_identical(x, rational(c(NA, 2L), c(NA, 3L)))
})
test_that("`vec_assign()` evaluates arg lazily", {
expect_silent(vec_assign(1L, 1L, 1L, x_arg = print("oof")))
expect_silent(vec_assign(1L, 1L, 1L, value_arg = print("oof")))
})
test_that("`vec_assign()` requires recyclable value", {
expect_snapshot({
(expect_error(
vec_assign(1:3, 1:3, 1:2),
class = "vctrs_error_recycle_incompatible_size"
))
})
})
test_that("logical subscripts must match size of indexed vector", {
expect_snapshot({
(expect_error(
vec_assign(1:2, c(TRUE, FALSE, TRUE), 5),
class = "vctrs_error_subscript_size"
))
})
expect_snapshot(
(expect_error(
vec_assign(mtcars, c(TRUE, FALSE), mtcars[1, ]),
class = "vctrs_error_subscript_size"
))
)
})
test_that("must assign existing elements", {
expect_snapshot({
(expect_error(
vec_assign(1:3, 5, 10),
class = "vctrs_error_subscript_oob"
))
(expect_error(
vec_assign(1:3, "foo", 10),
"unnamed vector"
))
(expect_error(
vec_slice(letters, -100) <- "foo",
class = "vctrs_error_subscript_oob"
))
(expect_error(
vec_assign(set_names(letters), "foo", "bar"),
class = "vctrs_error_subscript_oob"
))
})
})
test_that("must assign with proper negative locations", {
expect_snapshot({
(expect_error(
vec_assign(1:3, c(-1, 1), 1:2),
class = "vctrs_error_subscript_type"
))
(expect_error(
vec_assign(1:3, c(-1, NA), 1:2),
class = "vctrs_error_subscript_type"
))
})
})
test_that("`vec_assign()` error args can be overridden", {
expect_snapshot({
(expect_error(
vec_assign(1:2, 1L, "x", x_arg = "foo", value_arg = "bar"),
class = "vctrs_error_incompatible_type"
))
(expect_error(
vec_assign(1:2, 1L, 1:2, value_arg = "bar"),
class = "vctrs_error_recycle_incompatible_size"
))
})
})
test_that("names are not assigned by default", {
vec_x <- set_names(1:3, letters[1:3])
vec_y <- c(FOO = 4L)
vec_out <- c(a = 1L, b = 4L, c = 3L)
expect_identical(
vec_assign(vec_x, 2, vec_y),
vec_out
)
df_x <- new_data_frame(list(x = 1:3), row.names = letters[1:3])
df_y <- new_data_frame(list(x = 4L), row.names = "FOO")
df_out <- new_data_frame(list(x = c(1L, 4L, 3L)), row.names = letters[1:3])
expect_identical(
vec_assign(df_x, 2, df_y),
df_out
)
mat_x <- matrix(1:3, 3, dimnames = list(letters[1:3]))
mat_y <- matrix(4L, 1, dimnames = list("FOO"))
mat_out <- matrix(c(1L, 4L, 3L), dimnames = list(letters[1:3]))
expect_identical(
vec_assign(mat_x, 2, mat_y),
mat_out
)
nested_x <- new_data_frame(list(df = df_x, mat = mat_x, vec = vec_x), row.names = c("foo", "bar", "baz"))
nested_y <- new_data_frame(list(df = df_y, mat = mat_y, vec = vec_y), row.names = c("quux"))
nested_out <- new_data_frame(list(df = df_out, mat = mat_out, vec = vec_out), row.names = c("foo", "bar", "baz"))
expect_identical(
vec_assign(nested_x, 2, nested_y),
nested_out
)
})
test_that("can optionally assign names", {
vec_x <- set_names(1:3, letters[1:3])
vec_y <- c(FOO = 4L)
vec_out <- c(a = 1L, FOO = 4L, c = 3L)
expect_identical(
vec_assign_params(vec_x, 2, vec_y, assign_names = TRUE),
vec_out
)
df_x <- new_data_frame(list(x = 1:3), row.names = letters[1:3])
df_y <- new_data_frame(list(x = 4L), row.names = "FOO")
df_out <- new_data_frame(list(x = c(1L, 4L, 3L)), row.names = c("a", "FOO", "c"))
expect_identical(
vec_assign_params(df_x, 2, df_y, assign_names = TRUE),
df_out
)
mat_x <- matrix(1:3, 3, dimnames = list(letters[1:3]))
mat_y <- matrix(4L, 1, dimnames = list("FOO"))
mat_out <- matrix(c(1L, 4L, 3L), dimnames = list(c("a", "FOO", "c")))
expect_identical(
vec_assign_params(mat_x, 2, mat_y, assign_names = TRUE),
mat_out
)
nested_x <- new_data_frame(list(df = df_x, mat = mat_x, vec = vec_x), row.names = c("foo", "bar", "baz"))
nested_y <- new_data_frame(list(df = df_y, mat = mat_y, vec = vec_y), row.names = c("quux"))
nested_out <- new_data_frame(list(df = df_out, mat = mat_out, vec = vec_out), row.names = c("foo", "quux", "baz"))
expect_identical(
vec_assign_params(nested_x, 2, nested_y, assign_names = TRUE),
nested_out
)
})
test_that("can optionally assign names (OO case)", {
# In case upstream attributes handling changes
skip_on_cran()
# `set_names()` must be on the inside, otherwise the POSIXlt object
# gets a `balanced` attribute of `NA`
oo_x <- as_posixlt(set_names(c("2020-01-01", "2020-01-02", "2020-01-03"), letters[1:3]))
oo_y <- as_posixlt(c(FOO = "2020-01-04"))
oo_out <- as_posixlt(c(a = "2020-01-01", FOO = "2020-01-04", c = "2020-01-03"))
expect_identical(
vec_assign_params(oo_x, 2, oo_y, assign_names = TRUE),
oo_out
)
nested_x <- new_data_frame(list(oo = oo_x), row.names = c("foo", "bar", "baz"))
nested_y <- new_data_frame(list(oo = oo_y), row.names = c("quux"))
nested_out <- new_data_frame(list(oo = oo_out), row.names = c("foo", "quux", "baz"))
expect_identical(
vec_assign_params(nested_x, 2, nested_y, assign_names = TRUE),
nested_out
)
})
test_that("assignment requires that the value proxy is the same type as the output proxy", {
x <- foobar(1)
y <- foobar("a")
local_foobar_proxy()
local_methods(
vec_cast.vctrs_foobar.vctrs_foobar = function(x, to, ...) x
)
expect_error(
vec_assign(x, 1, y),
"`double` incompatible with `value` proxy of type `character`"
)
})
test_that("assignment allows a df `value`'s column to be a different type than its proxy (#1082)", {
x <- new_data_frame(list(x = foobar(1)))
y <- new_data_frame(list(x = foobar(2)))
local_methods(
# proxying foobar wraps it in a 1 col df
vec_proxy.vctrs_foobar = function(x, ...) {
attributes(x) <- NULL
new_data_frame(list(vec = x))
},
# restoring extracts the column
vec_restore.vctrs_foobar = function(x, to, ...) {
foobar(x$vec)
},
vec_ptype2.vctrs_foobar.vctrs_foobar = function(x, y, ...) x
)
expect1 <- new_data_frame(list(x = foobar(c(1, 1))))
expect2 <- new_data_frame(list(x = foobar(2)))
expect_identical(vec_rbind(x, x), expect1)
expect_identical(vec_assign(x, 1, y), expect2)
})
test_that("monitoring: assignment to a data frame with unshared columns doesn't overwrite (#986)", {
x <- new_df_unshared_col()
value <- new_data_frame(list(x = 2))
expect <- new_data_frame(list(x = 1L))
# - On R < 4.0.0, the NAMED value of the column is 0.
# - On R >= 4.0.0, the refcnt of the column is 1 from the call to
# `SET_VECTOR_ELT()` in `new_df_unshared_col()`.
expect_false(maybe_shared_col(x, 1L))
new <- vec_assign(x, 1, value)
# On R < 4.0.0, `vec_assign()` shallow duplicates `x`, which recursively
# bumps the NAMED-ness of each column of `x` to the max value of 7 by
# calling `ENSURE_NAMEDMAX()` on it. So the columns of `x` are all considered
# shared from that.
# On R >= 4.0.0, references are tracked more precisely.
# - `new_df_unshared_col()` calls `SET_VECTOR_ELT()` when setting the
# column into `x`, bumping the column's namedness to 1.
# - Then, at the start of `df_assign()`, `x` is shallow duplicated and
# assigned to `out`. This calls `ENSURE_NAMEDMAX()` on each column,
# however this does nothing on R 4.0.0. The refcnt of each column is instead
# incremented by 1 by calls to `SET_VECTOR_ELT()` in `duplicate1()`.
# So now it is at 2.
# - But then in `df_assign()` we use `SET_VECTOR_ELT()` on `out`, overwriting
# each column. This actually decrements the refcnt on the value that was
# in `out` before the column was overwritten. The column of `out` that it
# decrements the refcnt for is the same SEXP as that column in `x`, so now
# it is back to 1, and it is not considered shared.
if (getRversion() >= "4.0.0") {
expect_false(maybe_shared_col(x, 1L))
} else {
expect_true(maybe_shared_col(x, 1L))
}
# Expect no changes to `x`!
expect_identical(x, expect)
})
test_that("monitoring: assignment to atomic vectors doesn't modify by reference", {
x <- c(1, 2, 3)
expect <- c(1, 2, 3)
vec_assign(x, 2, 3)
expect_identical(x, expect)
})
# vec_assign + compact_seq -------------------------------------------------
# `start` is 0-based
test_that("can assign shaped base vectors with compact seqs", {
start <- 1L
size <- 2L
increasing <- TRUE
mat <- as.matrix
expect_identical(vec_assign_seq(mat(lgl(1, 0, 1)), NA, start, size, increasing), mat(lgl(1, NA, NA)))
expect_identical(vec_assign_seq(mat(int(1, 2, 3)), NA, start, size, increasing), mat(int(1, NA, NA)))
expect_identical(vec_assign_seq(mat(dbl(1, 2, 3)), NA, start, size, increasing), mat(dbl(1, NA, NA)))
expect_identical(vec_assign_seq(mat(cpl2(1, 2, 3)), NA, start, size, increasing), mat(cpl2(1, NA, NA)))
expect_identical(vec_assign_seq(mat(chr("1", "2", "3")), NA, start, size, increasing), mat(chr("1", NA, NA)))
expect_identical(vec_assign_seq(mat(raw2(1, 2, 3)), raw2(1), start, size, increasing), mat(raw2(1, 1, 1)))
expect_identical(vec_assign_seq(mat(list(1, 2, 3)), NA, start, size, increasing), mat(list(1, NULL, NULL)))
})
test_that("can assign shaped base vectors with decreasing compact seqs", {
start <- 2L
size <- 2L
increasing <- FALSE
mat <- as.matrix
expect_identical(vec_assign_seq(mat(lgl(1, 0, 1)), NA, start, size, increasing), mat(lgl(1, NA, NA)))
expect_identical(vec_assign_seq(mat(int(1, 2, 3)), NA, start, size, increasing), mat(int(1, NA, NA)))
expect_identical(vec_assign_seq(mat(dbl(1, 2, 3)), NA, start, size, increasing), mat(dbl(1, NA, NA)))
expect_identical(vec_assign_seq(mat(cpl2(1, 2, 3)), NA, start, size, increasing), mat(cpl2(1, NA, NA)))
expect_identical(vec_assign_seq(mat(chr("1", "2", "3")), NA, start, size, increasing), mat(chr("1", NA, NA)))
expect_identical(vec_assign_seq(mat(raw2(1, 2, 3)), raw2(1), start, size, increasing), mat(raw2(1, 1, 1)))
expect_identical(vec_assign_seq(mat(list(1, 2, 3)), NA, start, size, increasing), mat(list(1, NULL, NULL)))
})
test_that("can assign shaped base vectors with size 0 compact seqs", {
start <- 1L
size <- 0L
increasing <- TRUE
mat <- as.matrix
expect_identical(vec_assign_seq(mat(lgl(1, 0, 1)), NA, start, size, increasing), mat(mat(lgl(1, 0, 1))))
expect_identical(vec_assign_seq(mat(int(1, 2, 3)), NA, start, size, increasing), mat(int(1, 2, 3)))
expect_identical(vec_assign_seq(mat(dbl(1, 2, 3)), NA, start, size, increasing), mat(dbl(1, 2, 3)))
expect_identical(vec_assign_seq(mat(cpl(1, 2, 3)), NA, start, size, increasing), mat(cpl(1, 2, 3)))
expect_identical(vec_assign_seq(mat(chr("1", "2", "3")), NA, start, size, increasing), mat(chr("1", "2", "3")))
expect_identical(vec_assign_seq(mat(raw2(1, 2, 3)), raw2(1), start, size, increasing), mat(raw2(1, 2, 3)))
expect_identical(vec_assign_seq(mat(list(1, 2, 3)), NA, start, size, increasing), mat(list(1, 2, 3)))
})
test_that("can assign object of any dimensionality with compact seqs", {
x1 <- ones(3)
x2 <- ones(3, 4)
x3 <- ones(3, 4, 5)
x4 <- ones(3, 4, 5, 6)
start <- 0L
size <- 2L
increasing <- TRUE
mat <- as.matrix
expect_identical(vec_assign_seq(x1, 2, start, size, increasing), array(rep(c(2, 2, 1), 1), dim = 3))
expect_identical(vec_assign_seq(x2, 2, start, size, increasing), array(rep(c(2, 2, 1), 4), dim = c(3, 4)))
expect_identical(vec_assign_seq(x3, 2, start, size, increasing), array(rep(c(2, 2, 1), 20), dim = c(3, 4, 5)))
expect_identical(vec_assign_seq(x4, 2, start, size, increasing), array(rep(c(2, 2, 1), 120), dim = c(3, 4, 5, 6)))
})
vctrs/tests/testthat/_snaps/ 0000755 0001762 0000144 00000000000 14520211521 015671 5 ustar ligges users vctrs/tests/testthat/_snaps/slice-chop.md 0000644 0001762 0000144 00000033247 14532371037 020266 0 ustar ligges users # `indices` are validated
Code
vec_chop(1, indices = 1)
Condition
Error:
! `indices` must be a list of index values, or `NULL`.
---
Code
(expect_error(vec_chop(1, indices = list(1.5)), class = "vctrs_error_subscript_type")
)
Output
Error:
! Can't subset elements.
x Can't convert from
