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