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