This is an automated email from the ASF dual-hosted git repository.
npr pushed a commit to branch master
in repository https://gitbox.apache.org/repos/asf/arrow.git
The following commit(s) were added to refs/heads/master by this push:
new b2c77ca ARROW-7018: [R] Non-UTF-8 data in Arrow <--> R conversion
b2c77ca is described below
commit b2c77ca4db85690e51595ba14eb10e623d825b7c
Author: Neal Richardson <[email protected]>
AuthorDate: Fri Jun 26 08:19:19 2020 -0700
ARROW-7018: [R] Non-UTF-8 data in Arrow <--> R conversion
Sprinkles `Rf_translateCharUTF8` a few places. I tried to add tests for all
of the different scenarios I could think of where we could have non-UTF strings.
Also includes `$` and `[[` methods for `Schema` objects.
Closes #7527 from nealrichardson/r-utf8
Authored-by: Neal Richardson <[email protected]>
Signed-off-by: Neal Richardson <[email protected]>
---
r/NAMESPACE | 2 +
r/R/arrow-package.R | 2 +-
r/R/field.R | 2 +-
r/R/schema.R | 34 +++++++++++--
r/R/struct.R | 6 +--
r/configure.win | 12 +++--
r/src/array_from_vector.cpp | 13 +++--
r/src/array_to_vector.cpp | 7 +--
r/src/recordbatch.cpp | 4 +-
r/src/table.cpp | 2 +
r/tests/testthat/latin1.R | 74 +++++++++++++++++++++++++++++
r/tests/testthat/test-schema.R | 3 ++
r/{R/struct.R => tests/testthat/test-utf.R} | 22 +++------
13 files changed, 147 insertions(+), 36 deletions(-)
diff --git a/r/NAMESPACE b/r/NAMESPACE
index 1b97c58..dc34a36 100644
--- a/r/NAMESPACE
+++ b/r/NAMESPACE
@@ -2,6 +2,7 @@
S3method("!=",ArrowObject)
S3method("$",RecordBatch)
+S3method("$",Schema)
S3method("$",Table)
S3method("==",ArrowObject)
S3method("[",Array)
@@ -9,6 +10,7 @@ S3method("[",ChunkedArray)
S3method("[",RecordBatch)
S3method("[",Table)
S3method("[[",RecordBatch)
+S3method("[[",Schema)
S3method("[[",Table)
S3method(Ops,Array)
S3method(Ops,ChunkedArray)
diff --git a/r/R/arrow-package.R b/r/R/arrow-package.R
index 0563395..17b1bf1 100644
--- a/r/R/arrow-package.R
+++ b/r/R/arrow-package.R
@@ -71,7 +71,7 @@ ArrowObject <- R6Class("ArrowObject",
public = list(
initialize = function(xp) self$set_pointer(xp),
- pointer = function() self$`.:xp:.`,
+ pointer = function() get(".:xp:.", envir = self),
`.:xp:.` = NULL,
set_pointer = function(xp) {
if (!inherits(xp, "externalptr")) {
diff --git a/r/R/field.R b/r/R/field.R
index 7c5832c..4053a9f 100644
--- a/r/R/field.R
+++ b/r/R/field.R
@@ -57,7 +57,7 @@ Field$create <- function(name, type, metadata) {
assert_that(inherits(name, "character"), length(name) == 1L)
type <- as_type(type, name)
assert_that(missing(metadata), msg = "metadata= is currently ignored")
- shared_ptr(Field, Field__initialize(name, type, TRUE))
+ shared_ptr(Field, Field__initialize(enc2utf8(name), type, TRUE))
}
#' @param name field name
diff --git a/r/R/schema.R b/r/R/schema.R
index 79632cb..f315460 100644
--- a/r/R/schema.R
+++ b/r/R/schema.R
@@ -83,16 +83,21 @@ Schema <- R6Class("Schema",
}
),
active = list(
- names = function() Schema__field_names(self),
+ names = function() {
+ out <- Schema__field_names(self)
+ # Hack: Rcpp should set the encoding
+ Encoding(out) <- "UTF-8"
+ out
+ },
num_fields = function() Schema__num_fields(self),
fields = function() map(Schema__fields(self), shared_ptr, class = Field),
HasMetadata = function() Schema__HasMetadata(self),
- metadata = function(new) {
- if (missing(new)) {
+ metadata = function(new_metadata) {
+ if (missing(new_metadata)) {
Schema__metadata(self)
} else {
# Set the metadata
- out <- self$WithMetadata(new)
+ out <- self$WithMetadata(new_metadata)
# $WithMetadata returns a new object but we're modifying in place,
# so swap in that new C++ object pointer into our R6 object
self$set_pointer(out$pointer())
@@ -135,6 +140,27 @@ names.Schema <- function(x) x$names
#' @export
length.Schema <- function(x) x$num_fields
+#' @export
+`[[.Schema` <- function(x, i, ...) {
+ if (is.character(i)) {
+ x$GetFieldByName(i)
+ } else if (is.numeric(i)) {
+ x$field(i - 1)
+ } else {
+ stop("'i' must be character or numeric, not ", class(i), call. = FALSE)
+ }
+}
+
+#' @export
+`$.Schema` <- function(x, name, ...) {
+ assert_that(is.string(name))
+ if (name %in% ls(x)) {
+ get(name, x)
+ } else {
+ x$GetFieldByName(name)
+ }
+}
+
#' read a Schema from a stream
#'
#' @param stream a `Message`, `InputStream`, or `Buffer`
diff --git a/r/R/struct.R b/r/R/struct.R
index ab72d47..219fb28 100644
--- a/r/R/struct.R
+++ b/r/R/struct.R
@@ -24,10 +24,8 @@ StructType <- R6Class("StructType",
GetFieldIndex = function(name) StructType__GetFieldIndex(self, name)
)
)
+StructType$create <- function(...) shared_ptr(StructType,
struct_(.fields(list(...))))
#' @rdname data-type
#' @export
-struct <- function(...){
- xp <- struct_(.fields(list(...)))
- shared_ptr(StructType, xp)
-}
+struct <- StructType$create
diff --git a/r/configure.win b/r/configure.win
index 58d6445..7365772 100644
--- a/r/configure.win
+++ b/r/configure.win
@@ -34,10 +34,14 @@ if [ $? -ne 0 ]; then
fi
# Set the right flags to point to and enable arrow/parquet
-# It's possible that the version of the libarrow binary is not identical to the
-# R version, e.g. if the R build is a patch release, so find what the dir is
-# actually called:
-RWINLIB="../windows/$(ls windows/ | grep ^arrow-)"
+if [ -d "windows/arrow-$VERSION" ]; then
+ RWINLIB="../windows/arrow-$VERSION"
+else
+ # It's possible that the version of the libarrow binary is not identical to
the
+ # R version, e.g. if the R build is a patch release, so find what the dir is
+ # actually called:
+ RWINLIB="../windows/$(ls windows/ | grep ^arrow-)"
+fi
OPENSSL_LIBS="-lcrypto -lcrypt32"
PKG_CFLAGS="-I${RWINLIB}/include -DARROW_STATIC -DPARQUET_STATIC
-DARROW_DS_STATIC -DARROW_R_WITH_ARROW"
diff --git a/r/src/array_from_vector.cpp b/r/src/array_from_vector.cpp
index b9effd5..da1e02a 100644
--- a/r/src/array_from_vector.cpp
+++ b/r/src/array_from_vector.cpp
@@ -159,6 +159,9 @@ struct VectorToArrayConverter {
if (s == NA_STRING) {
RETURN_NOT_OK(binary_builder->AppendNull());
continue;
+ } else {
+ // Make sure we're ingesting UTF-8
+ s = Rf_mkCharCE(Rf_translateCharUTF8(s), CE_UTF8);
}
RETURN_NOT_OK(binary_builder->Append(CHAR(s), LENGTH(s)));
@@ -1056,7 +1059,9 @@ static inline std::shared_ptr<arrow::DataType>
InferArrowTypeFromDataFrame(SEXP
SEXP names = Rf_getAttrib(x, R_NamesSymbol);
std::vector<std::shared_ptr<arrow::Field>> fields(n);
for (R_xlen_t i = 0; i < n; i++) {
- const auto* field_name = CHAR(STRING_ELT(names, i));
+ // Make sure we're ingesting UTF-8
+ const auto* field_name =
+ CHAR(Rf_mkCharCE(Rf_translateCharUTF8(STRING_ELT(names, i)), CE_UTF8));
fields[i] = arrow::field(field_name, InferArrowType(VECTOR_ELT(x, i)));
}
return arrow::struct_(std::move(fields));
@@ -1210,11 +1215,13 @@ arrow::Status CheckCompatibleStruct(SEXP obj,
// types of the fields, because Array__from_vector will error
// when not compatible.
SEXP names = Rf_getAttrib(obj, R_NamesSymbol);
+ SEXP name_i;
for (int i = 0; i < num_fields; i++) {
- if (type->field(i)->name() != CHAR(STRING_ELT(names, i))) {
+ name_i = Rf_mkCharCE(Rf_translateCharUTF8(STRING_ELT(names, i)), CE_UTF8);
+ if (type->field(i)->name() != CHAR(name_i)) {
return Status::RError("Field name in position ", i, " (",
type->field(i)->name(),
") does not match the name of the column of the
data frame (",
- CHAR(STRING_ELT(names, i)), ")");
+ CHAR(name_i), ")");
}
}
diff --git a/r/src/array_to_vector.cpp b/r/src/array_to_vector.cpp
index 707d4ff..bdef69d 100644
--- a/r/src/array_to_vector.cpp
+++ b/r/src/array_to_vector.cpp
@@ -387,8 +387,9 @@ class Converter_Struct : public Converter {
Rcpp::CharacterVector colnames(nf);
for (int i = 0; i < nf; i++) {
out[i] = converters[i]->Allocate(n);
- colnames[i] = type->field(i)->name();
+ colnames[i] = Rcpp::String(type->field(i)->name(), CE_UTF8);
}
+
IntegerVector rn(2);
rn[0] = NA_INTEGER;
rn[1] = -n;
@@ -856,7 +857,7 @@ Rcpp::List RecordBatch__to_dataframe(const
std::shared_ptr<arrow::RecordBatch>&
std::vector<std::shared_ptr<arrow::r::Converter>> converters(nc);
for (int64_t i = 0; i < nc; i++) {
- names[i] = batch->column_name(i);
+ names[i] = Rcpp::String(batch->column_name(i), CE_UTF8);
arrays[i] = {batch->column(i)};
converters[i] = arrow::r::Converter::Make(batch->column(i)->type(),
arrays[i]);
}
@@ -879,7 +880,7 @@ Rcpp::List Table__to_dataframe(const
std::shared_ptr<arrow::Table>& table,
for (int64_t i = 0; i < nc; i++) {
converters[i] =
arrow::r::Converter::Make(table->column(i)->type(),
table->column(i)->chunks());
- names[i] = table->field(i)->name();
+ names[i] = Rcpp::String(table->field(i)->name(), CE_UTF8);
}
if (use_threads) {
diff --git a/r/src/recordbatch.cpp b/r/src/recordbatch.cpp
index 09a45d1..d0c8556 100644
--- a/r/src/recordbatch.cpp
+++ b/r/src/recordbatch.cpp
@@ -246,6 +246,7 @@ std::shared_ptr<arrow::RecordBatch>
RecordBatch__from_arrays__known_schema(
SEXP names = Rf_getAttrib(lst, R_NamesSymbol);
auto fill_array = [&arrays, &schema](int j, SEXP x, SEXP name) {
+ name = Rf_mkCharCE(Rf_translateCharUTF8(name), CE_UTF8);
if (schema->field(j)->name() != CHAR(name)) {
Rcpp::stop("field at index %d has name '%s' != '%s'", j + 1,
schema->field(j)->name(), CHAR(name));
@@ -290,7 +291,8 @@ std::shared_ptr<arrow::RecordBatch>
RecordBatch__from_arrays(SEXP schema_sxp, SE
auto fill_array = [&arrays, &arrays_names](int j, SEXP x, SEXP name) {
arrays[j] = Array__from_vector(x, R_NilValue);
- arrays_names[j] = CHAR(name);
+ // Make sure we're ingesting UTF-8
+ arrays_names[j] = CHAR(Rf_mkCharCE(Rf_translateCharUTF8(name), CE_UTF8));
};
for (R_xlen_t i = 0, j = 0; j < num_fields; i++) {
diff --git a/r/src/table.cpp b/r/src/table.cpp
index 77160bd..81e8f39 100644
--- a/r/src/table.cpp
+++ b/r/src/table.cpp
@@ -177,6 +177,8 @@ std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst,
SEXP schema_sxp) {
SEXP names = Rf_getAttrib(lst, R_NamesSymbol);
auto fill_one_column = [&columns, &fields](int j, SEXP x, SEXP name) {
+ // Make sure we're ingesting UTF-8
+ name = Rf_mkCharCE(Rf_translateCharUTF8(name), CE_UTF8);
if (Rf_inherits(x, "ChunkedArray")) {
auto chunked_array = arrow::r::extract<arrow::ChunkedArray>(x);
fields[j] = arrow::field(CHAR(name), chunked_array->type());
diff --git a/r/tests/testthat/latin1.R b/r/tests/testthat/latin1.R
new file mode 100644
index 0000000..0339cb7
--- /dev/null
+++ b/r/tests/testthat/latin1.R
@@ -0,0 +1,74 @@
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you under the Apache License, Version 2.0 (the
+# "License"); you may not use this file except in compliance
+# with the License. You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing,
+# software distributed under the License is distributed on an
+# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+# KIND, either express or implied. See the License for the
+# specific language governing permissions and limitations
+# under the License.
+
+x <- iconv("Veitingasta�ir", to = "latin1")
+df <- tibble::tibble(
+ chr = x,
+ fct = as.factor(x)
+)
+names(df) <- iconv(paste(x, names(df), sep = "_"), to = "latin1")
+df_struct <- tibble::tibble(a = df)
+
+raw_schema <- list(utf8(), dictionary(int8(), utf8()))
+names(raw_schema) <- names(df)
+
+# Confirm setup
+expect_identical(Encoding(x), "latin1")
+expect_identical(Encoding(names(df)), c("latin1", "latin1"))
+expect_identical(Encoding(df[[1]]), "latin1")
+expect_identical(Encoding(levels(df[[2]])), "latin1")
+
+# Array
+expect_identical(as.vector(Array$create(x)), x)
+# struct
+expect_identical(as.vector(Array$create(df)), df)
+
+# ChunkedArray
+expect_identical(as.vector(ChunkedArray$create(x)), x)
+# struct
+expect_identical(as.vector(ChunkedArray$create(df)), df)
+
+# Table (including field name)
+expect_identical(as.data.frame(Table$create(df)), df)
+expect_identical(as.data.frame(Table$create(df_struct)), df_struct)
+
+# RecordBatch
+expect_identical(as.data.frame(record_batch(df)), df)
+expect_identical(as.data.frame(record_batch(df_struct)), df_struct)
+
+# Schema field name
+df_schema <- do.call(schema, raw_schema)
+expect_identical(names(df_schema), names(df))
+
+df_struct_schema <- schema(a = do.call(struct, raw_schema))
+# StructType doesn't expose names (in C++)
+# expect_identical(names(df_struct_schema$a), names(df))
+
+# Create table/batch with schema
+expect_identical(as.data.frame(Table$create(df, schema = df_schema)), df)
+expect_identical(as.data.frame(Table$create(df_struct, schema =
df_struct_schema)), df_struct)
+expect_identical(as.data.frame(record_batch(df, schema = df_schema)), df)
+expect_identical(as.data.frame(record_batch(df_struct, schema =
df_struct_schema)), df_struct)
+
+# Serialization
+feather_file <- tempfile()
+write_feather(df_struct, feather_file)
+expect_identical(read_feather(feather_file), df_struct)
+
+parquet_file <- tempfile()
+write_parquet(df, parquet_file) # Parquet doesn't yet support nested types
+expect_identical(read_parquet(parquet_file), df)
diff --git a/r/tests/testthat/test-schema.R b/r/tests/testthat/test-schema.R
index 55e3a5b..d77f097 100644
--- a/r/tests/testthat/test-schema.R
+++ b/r/tests/testthat/test-schema.R
@@ -67,6 +67,9 @@ test_that("Schema $GetFieldByName", {
expect_null(schm$GetFieldByName("f"))
# TODO: schema(b = double(), b = string())$GetFieldByName("b")
# also returns NULL and probably should error bc duplicated names
+
+ expect_equal(schm$b, field("b", double()))
+ expect_equal(schm[["b"]], field("b", double()))
})
test_that("reading schema from Buffer", {
diff --git a/r/R/struct.R b/r/tests/testthat/test-utf.R
similarity index 66%
copy from r/R/struct.R
copy to r/tests/testthat/test-utf.R
index ab72d47..75a162e 100644
--- a/r/R/struct.R
+++ b/r/tests/testthat/test-utf.R
@@ -15,19 +15,11 @@
# specific language governing permissions and limitations
# under the License.
-#' @include type.R
+context("String encoding")
-StructType <- R6Class("StructType",
- inherit = NestedType,
- public = list(
- GetFieldByName = function(name) shared_ptr(Field,
StructType__GetFieldByName(self, name)),
- GetFieldIndex = function(name) StructType__GetFieldIndex(self, name)
- )
-)
-
-#' @rdname data-type
-#' @export
-struct <- function(...){
- xp <- struct_(.fields(list(...)))
- shared_ptr(StructType, xp)
-}
+test_that("We handle non-UTF strings", {
+ # Move the code with non-UTF strings to a separate file so that we don't
+ # get a parse error on *cough* certain platforms
+ skip_on_cran()
+ source("latin1.R", encoding = "latin1")
+})
