]>
Commit | Line | Data |
---|---|---|
1d09f67e TL |
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 | |
19 | if (!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 | |
26 | if (!exists("str2lang")) { | |
27 | str2lang <- function(s) { | |
28 | parse(text = s, keep.source = FALSE)[[1]] | |
29 | } | |
30 | } | |
31 | ||
32 | oxford_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 | ||
47 | assert_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 | ||
52 | assert_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 | ||
57 | is_list_of <- function(object, class) { | |
58 | is.list(object) && all(map_lgl(object, ~ inherits(., class))) | |
59 | } | |
60 | ||
61 | empty_named_list <- function() structure(list(), .Names = character(0)) | |
62 | ||
63 | r_symbolic_constants <- c( | |
64 | "pi", "TRUE", "FALSE", "NULL", "Inf", "NA", "NaN", | |
65 | "NA_integer_", "NA_real_", "NA_complex_", "NA_character_" | |
66 | ) | |
67 | ||
68 | is_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 | ||
84 | all_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 | ||
96 | all_vars <- function(expr) { | |
97 | setdiff(all.vars(expr), r_symbolic_constants) | |
98 | } | |
99 | ||
100 | all_names <- function(expr) { | |
101 | setdiff(all.names(expr), r_symbolic_constants) | |
102 | } | |
103 | ||
104 | is_constant <- function(expr) { | |
105 | length(all_vars(expr)) == 0 | |
106 | } | |
107 | ||
108 | read_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 | ||
124 | handle_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 | ||
137 | is_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 | |
143 | attr(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 | |
157 | recycle_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 | |
190 | repeat_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 | } |