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#' @importFrom R6 R6Class 19#' @importFrom purrr as_mapper map map2 map_chr map_dfr map_int map_lgl keep 20#' @importFrom assertthat assert_that is.string 21#' @importFrom rlang list2 %||% is_false abort dots_n warn enquo quo_is_null enquos is_integerish quos eval_tidy new_data_mask syms env new_environment env_bind as_label set_names exec is_bare_character 22#' @importFrom tidyselect vars_select 23#' @useDynLib arrow, .registration = TRUE 24#' @keywords internal 25"_PACKAGE" 26 27#' @importFrom vctrs s3_register vec_size vec_cast 28.onLoad <- function(...) { 29 dplyr_methods <- paste0( 30 "dplyr::", 31 c( 32 "select", "filter", "collect", "summarise", "group_by", "groups", 33 "group_vars", "ungroup", "mutate", "arrange", "rename", "pull" 34 ) 35 ) 36 for (cl in c("Dataset", "ArrowTabular", "arrow_dplyr_query")) { 37 for (m in dplyr_methods) { 38 s3_register(m, cl) 39 } 40 } 41 s3_register("dplyr::tbl_vars", "arrow_dplyr_query") 42 43 for (cl in c("Array", "RecordBatch", "ChunkedArray", "Table", "Schema")) { 44 s3_register("reticulate::py_to_r", paste0("pyarrow.lib.", cl)) 45 s3_register("reticulate::r_to_py", cl) 46 } 47 48 invisible() 49} 50 51#' Is the C++ Arrow library available? 52#' 53#' You won't generally need to call these function, but they're made available 54#' for diagnostic purposes. 55#' @return `TRUE` or `FALSE` depending on whether the package was installed 56#' with the Arrow C++ library (check with `arrow_available()`) or with S3 57#' support enabled (check with `arrow_with_s3()`). 58#' @export 59#' @examples 60#' arrow_available() 61#' arrow_with_s3() 62#' @seealso If either of these are `FALSE`, see 63#' `vignette("install", package = "arrow")` for guidance on reinstalling the 64#' package. 65arrow_available <- function() { 66 .Call(`_arrow_available`) 67} 68 69#' @rdname arrow_available 70#' @export 71arrow_with_s3 <- function() { 72 .Call(`_s3_available`) 73} 74 75option_use_threads <- function() { 76 !is_false(getOption("arrow.use_threads")) 77} 78 79#' Report information on the package's capabilities 80#' 81#' This function summarizes a number of build-time configurations and run-time 82#' settings for the Arrow package. It may be useful for diagnostics. 83#' @return A list including version information, boolean "capabilities", and 84#' statistics from Arrow's memory allocator. 85#' @export 86#' @importFrom utils packageVersion 87arrow_info <- function() { 88 opts <- options() 89 out <- list( 90 version = packageVersion("arrow"), 91 libarrow = arrow_available(), 92 options = opts[grep("^arrow\\.", names(opts))] 93 ) 94 if (out$libarrow) { 95 pool <- default_memory_pool() 96 out <- c(out, list( 97 capabilities = c( 98 s3 = arrow_with_s3(), 99 vapply(tolower(names(CompressionType)[-1]), codec_is_available, logical(1)) 100 ), 101 memory_pool = list( 102 backend_name = pool$backend_name, 103 bytes_allocated = pool$bytes_allocated, 104 max_memory = pool$max_memory, 105 available_backends = supported_memory_backends() 106 ) 107 )) 108 } 109 structure(out, class = "arrow_info") 110} 111 112#' @export 113print.arrow_info <- function(x, ...) { 114 print_key_values <- function(title, vals, ...) { 115 # Make a key-value table for printing, no column names 116 df <- data.frame(vals, stringsAsFactors = FALSE, ...) 117 names(df) <- "" 118 119 cat(title, ":\n", sep = "") 120 print(df) 121 cat("\n") 122 } 123 cat("Arrow package version: ", format(x$version), "\n\n", sep = "") 124 if (x$libarrow) { 125 print_key_values("Capabilities", c( 126 x$capabilities, 127 jemalloc = "jemalloc" %in% x$memory_pool$available_backends, 128 mimalloc = "mimalloc" %in% x$memory_pool$available_backends 129 )) 130 131 if (length(x$options)) { 132 print_key_values("Arrow options()", map_chr(x$options, format)) 133 } 134 135 format_bytes <- function(b, units = "auto", digits = 2L, ...) { 136 format(structure(b, class = "object_size"), units = units, digits = digits, ...) 137 } 138 print_key_values("Memory", c( 139 Allocator = x$memory_pool$backend_name, 140 # utils:::format.object_size is not properly vectorized 141 Current = format_bytes(x$memory_pool$bytes_allocated, ...), 142 Max = format_bytes(x$memory_pool$max_memory, ...) 143 )) 144 } else { 145 cat("Arrow C++ library not available\n") 146 } 147 invisible(x) 148} 149 150option_compress_metadata <- function() { 151 !is_false(getOption("arrow.compress_metadata")) 152} 153 154#' @include enums.R 155ArrowObject <- R6Class("ArrowObject", 156 public = list( 157 initialize = function(xp) self$set_pointer(xp), 158 159 pointer = function() get(".:xp:.", envir = self), 160 `.:xp:.` = NULL, 161 set_pointer = function(xp) { 162 if (!inherits(xp, "externalptr")) { 163 stop( 164 class(self)[1], "$new() requires a pointer as input: ", 165 "did you mean $create() instead?", 166 call. = FALSE 167 ) 168 } 169 assign(".:xp:.", xp, envir = self) 170 }, 171 print = function(...) { 172 if (!is.null(self$.class_title)) { 173 # Allow subclasses to override just printing the class name first 174 class_title <- self$.class_title() 175 } else { 176 class_title <- class(self)[[1]] 177 } 178 cat(class_title, "\n", sep = "") 179 if (!is.null(self$ToString)){ 180 cat(self$ToString(), "\n", sep = "") 181 } 182 invisible(self) 183 }, 184 185 invalidate = function() { 186 assign(".:xp:.", NULL, envir = self) 187 } 188 ) 189) 190 191#' @export 192`!=.ArrowObject` <- function(lhs, rhs) !(lhs == rhs) 193 194#' @export 195`==.ArrowObject` <- function(x, y) { 196 x$Equals(y) 197} 198 199#' @export 200all.equal.ArrowObject <- function(target, current, ..., check.attributes = TRUE) { 201 target$Equals(current, check_metadata = check.attributes) 202} 203