1# Licensed to the Apache Software Foundation (ASF) under one
2# or more contributor license agreements.  See the NOTICE file
3# distributed with this work for additional information
4# regarding copyright ownership.  The ASF licenses this file
5# to you under the Apache License, Version 2.0 (the
6# "License"); you may not use this file except in compliance
7# with the License.  You may obtain a copy of the License at
8#
9#   http://www.apache.org/licenses/LICENSE-2.0
10#
11# Unless required by applicable law or agreed to in writing,
12# software distributed under the License is distributed on an
13# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
14# KIND, either express or implied.  See the License for the
15# specific language governing permissions and limitations
16# under the License.
17
18# for compatibility with R versions earlier than 4.0.0
19if (!exists("deparse1")) {
20  deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) {
21    paste(deparse(expr, width.cutoff, ...), collapse = collapse)
22  }
23}
24
25# for compatibility with R versions earlier than 3.6.0
26if (!exists("str2lang")) {
27  str2lang <- function(s) {
28    parse(text = s, keep.source = FALSE)[[1]]
29  }
30}
31
32oxford_paste <- function(x, conjunction = "and", quote = TRUE) {
33  if (quote && is.character(x)) {
34    x <- paste0('"', x, '"')
35  }
36  if (length(x) < 2) {
37    return(x)
38  }
39  x[length(x)] <- paste(conjunction, x[length(x)])
40  if (length(x) > 2) {
41    return(paste(x, collapse = ", "))
42  } else {
43    return(paste(x, collapse = " "))
44  }
45}
46
47assert_is <- function(object, class) {
48  msg <- paste(substitute(object), "must be a", oxford_paste(class, "or"))
49  assert_that(inherits(object, class), msg = msg)
50}
51
52assert_is_list_of <- function(object, class) {
53  msg <- paste(substitute(object), "must be a list of", oxford_paste(class, "or"))
54  assert_that(is_list_of(object, class), msg = msg)
55}
56
57is_list_of <- function(object, class) {
58  is.list(object) && all(map_lgl(object, ~ inherits(., class)))
59}
60
61empty_named_list <- function() structure(list(), .Names = character(0))
62
63r_symbolic_constants <- c(
64  "pi", "TRUE", "FALSE", "NULL", "Inf", "NA", "NaN",
65  "NA_integer_", "NA_real_", "NA_complex_", "NA_character_"
66)
67
68is_function <- function(expr, name) {
69  # We could have a quosure here if we have an expression like `sum({{ var }})`
70  if (is_quosure(expr)) {
71    expr <- quo_get_expr(expr)
72  }
73  if (!is.call(expr)) {
74    return(FALSE)
75  } else {
76    if (deparse(expr[[1]]) == name) {
77      return(TRUE)
78    }
79    out <- lapply(expr, is_function, name)
80  }
81  any(map_lgl(out, isTRUE))
82}
83
84all_funs <- function(expr) {
85  # It is not sufficient to simply do: setdiff(all.names, all.vars)
86  # here because that would fail to return the names of functions that
87  # share names with variables.
88  # To preserve duplicates, call `all.names()` not `all_names()` here.
89  if (is_quosure(expr)) {
90    expr <- quo_get_expr(expr)
91  }
92  names <- all.names(expr)
93  names[map_lgl(names, ~ is_function(expr, .))]
94}
95
96all_vars <- function(expr) {
97  setdiff(all.vars(expr), r_symbolic_constants)
98}
99
100all_names <- function(expr) {
101  setdiff(all.names(expr), r_symbolic_constants)
102}
103
104is_constant <- function(expr) {
105  length(all_vars(expr)) == 0
106}
107
108read_compressed_error <- function(e) {
109  msg <- conditionMessage(e)
110  if (grepl(" codec ", msg)) {
111    compression <- sub(".*Support for codec '(.*)'.*", "\\1", msg)
112    e$message <- paste0(
113      msg,
114      "\nIn order to read this file, you will need to reinstall arrow with additional features enabled.",
115      "\nSet one of these environment variables before installing:",
116      sprintf("\n\n * LIBARROW_MINIMAL=false (for all optional features, including '%s')", compression),
117      sprintf("\n * ARROW_WITH_%s=ON (for just '%s')", toupper(compression), compression),
118      "\n\nSee https://arrow.apache.org/docs/r/articles/install.html for details"
119    )
120  }
121  stop(e)
122}
123
124handle_parquet_io_error <- function(e, format) {
125  msg <- conditionMessage(e)
126  if (grepl("Parquet magic bytes not found in footer", msg) && length(format) > 1 && is_character(format)) {
127    # If length(format) > 1, that means it is (almost certainly) the default/not specified value
128    # so let the user know that they should specify the actual (not parquet) format
129    abort(c(
130      msg,
131      i = "Did you mean to specify a 'format' other than the default (parquet)?"
132    ))
133  }
134  stop(e)
135}
136
137is_writable_table <- function(x) {
138  inherits(x, c("data.frame", "ArrowTabular"))
139}
140
141# This attribute is used when is_writable is passed into assert_that, and allows
142# the call to form part of the error message when is_writable is FALSE
143attr(is_writable_table, "fail") <- function(call, env) {
144  paste0(
145    deparse(call$x),
146    " must be an object of class 'data.frame', 'RecordBatch', or 'Table', not '",
147    class(env[[deparse(call$x)]])[[1]],
148    "'."
149  )
150}
151
152#' Recycle scalar values in a list of arrays
153#'
154#' @param arrays List of arrays
155#' @return List of arrays with any vector/Scalar/Array/ChunkedArray values of length 1 recycled
156#' @keywords internal
157recycle_scalars <- function(arrays) {
158  # Get lengths of items in arrays
159  arr_lens <- map_int(arrays, NROW)
160
161  is_scalar <- arr_lens == 1
162
163  if (length(arrays) > 1 && any(is_scalar) && !all(is_scalar)) {
164
165    # Recycling not supported for tibbles and data.frames
166    if (all(map_lgl(arrays, ~ inherits(.x, "data.frame")))) {
167      abort(c(
168        "All input tibbles or data.frames must have the same number of rows",
169        x = paste(
170          "Number of rows in longest and shortest inputs:",
171          oxford_paste(c(max(arr_lens), min(arr_lens)))
172        )
173      ))
174    }
175
176    max_array_len <- max(arr_lens)
177    arrays[is_scalar] <- lapply(arrays[is_scalar], repeat_value_as_array, max_array_len)
178  }
179  arrays
180}
181
182#' Take an object of length 1 and repeat it.
183#'
184#' @param object Object of length 1 to be repeated - vector, `Scalar`, `Array`, or `ChunkedArray`
185#' @param n Number of repetitions
186#'
187#' @return `Array` of length `n`
188#'
189#' @keywords internal
190repeat_value_as_array <- function(object, n) {
191  if (inherits(object, "ChunkedArray")) {
192    return(Scalar$create(object$chunks[[1]])$as_array(n))
193  }
194  return(Scalar$create(object)$as_array(n))
195}
196