1# proxies -----------------------------------------------------------------
2
3#' Comparison and order proxy
4#'
5#' @description
6#' `vec_proxy_compare()` and `vec_proxy_order()` return proxy objects, i.e.
7#' an atomic vector or data frame of atomic vectors.
8#'
9#' For [`vctrs_vctr`][vctr] objects:
10#'
11#' - `vec_proxy_compare()` determines the behavior of `<`, `>`, `>=`
12#'   and `<=` (via [vec_compare()]); and [min()], [max()], [median()], and
13#'   [quantile()].
14#'
15#' - `vec_proxy_order()` determines the behavior of `order()` and `sort()`
16#'   (via `xtfrm()`).
17#'
18#' @details
19#' The default method of `vec_proxy_compare()` assumes that all classes built
20#' on top of atomic vectors or records are comparable. Internally the default
21#' calls [vec_proxy_equal()]. If your class is not comparable, you will need
22#' to provide a `vec_proxy_compare()` method that throws an error.
23#'
24#' The behavior of `vec_proxy_order()` is identical to `vec_proxy_compare()`,
25#' with the exception of lists. Lists are not comparable, as comparing
26#' elements of different types is undefined. However, to allow ordering of
27#' data frames containing list-columns, the ordering proxy of a list is
28#' generated as an integer vector that can be used to order list elements
29#' by first appearance.
30#'
31#' @param x A vector x.
32#' @inheritParams ellipsis::dots_empty
33#' @return A 1d atomic vector or a data frame.
34#'
35#' @section Dependencies:
36#' - [vec_proxy_equal()] called by default in `vec_proxy_compare()`
37#' - [vec_proxy_compare()] called by default in `vec_proxy_order()`
38#'
39#' @keywords internal
40#' @export
41#' @examples
42#' # Lists are not comparable
43#' x <- list(1:2, 1, 1:2, 3)
44#' try(vec_compare(x, x))
45#'
46#' # But lists are orderable by first appearance to allow for
47#' # ordering data frames with list-cols
48#' df <- new_data_frame(list(x = x))
49#' vec_sort(df)
50vec_proxy_compare <- function(x, ...) {
51  if (!missing(...)) {
52    # For backward compatibility with older dplyr versions
53    if (match_relax(...)) {
54      return(vec_proxy_order(x))
55    }
56    ellipsis::check_dots_empty()
57  }
58  return(.Call(vctrs_proxy_compare, x))
59  UseMethod("vec_proxy_compare")
60}
61#' @export
62vec_proxy_compare.default <- function(x, ...) {
63  stop_native_implementation("vec_proxy_compare.default")
64}
65
66match_relax <- function(..., relax = FALSE) {
67  relax
68}
69
70#' @rdname vec_proxy_compare
71#' @export
72vec_proxy_order <- function(x, ...) {
73  if (!missing(...)) {
74    ellipsis::check_dots_empty()
75  }
76  return(.Call(vctrs_proxy_order, x))
77  UseMethod("vec_proxy_order")
78}
79
80#' @export
81vec_proxy_order.default <- function(x, ...) {
82  stop_native_implementation("vec_proxy_order.default")
83}
84
85# compare -----------------------------------------------------------------
86
87#' Compare two vectors
88#'
89#' @section S3 dispatch:
90#' `vec_compare()` is not generic for performance; instead it uses
91#' [vec_proxy_compare()] to
92#'
93#' @param x,y Vectors with compatible types and lengths.
94#' @param na_equal Should `NA` values be considered equal?
95#' @param .ptype Override to optionally specify common type
96#' @return An integer vector with values -1 for `x < y`, 0 if `x == y`,
97#'    and 1 if `x > y`. If `na_equal` is `FALSE`, the result will be `NA`
98#'    if either `x` or `y` is `NA`.
99#'
100#' @section Dependencies:
101#' - [vec_cast_common()] with fallback
102#' - [vec_recycle_common()]
103#' - [vec_proxy_compare()]
104#'
105#' @export
106#' @examples
107#' vec_compare(c(TRUE, FALSE, NA), FALSE)
108#' vec_compare(c(TRUE, FALSE, NA), FALSE, na_equal = TRUE)
109#'
110#' vec_compare(1:10, 5)
111#' vec_compare(runif(10), 0.5)
112#' vec_compare(letters[1:10], "d")
113#'
114#' df <- data.frame(x = c(1, 1, 1, 2), y = c(0, 1, 2, 1))
115#' vec_compare(df, data.frame(x = 1, y = 1))
116vec_compare <- function(x, y, na_equal = FALSE, .ptype = NULL) {
117  vec_assert(x)
118  vec_assert(y)
119  vec_assert(na_equal, ptype = logical(), size = 1L)
120
121  args <- vec_recycle_common(x, y)
122  args <- vec_cast_common_params(
123    !!!args,
124    .to = .ptype,
125    .df_fallback = DF_FALLBACK_quiet
126  )
127
128  .Call(vctrs_compare, vec_proxy_compare(args[[1]]), vec_proxy_compare(args[[2]]), na_equal)
129}
130
131
132# Helpers -----------------------------------------------------------------
133
134# Used for testing
135cmp <- function(x, y) (x > y) - (x < y)
136