ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
romainfrancois wants to merge 7 commits into from
Closed

ARROW-9271: [R] Preserve data frame metadata in round trip #8150

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
ec07acf
ARROW-9271: [R] Preserve data frame metadata in round trip
romainfrancois Sep 9, 2020
2b859d7
Update r/R/table.R
romainfrancois Sep 10, 2020
3ee4a84
handle removed attributes without s3 dispatch
romainfrancois Sep 10, 2020
8bb6ed2
because class and groups are kept
romainfrancois Sep 10, 2020
dfb6908
using expect_equal() instdad of expect_identical()
romainfrancois Sep 10, 2020
9908ac4
Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…
nealrichardson Sep 11, 2020
55c5ab2
ungroup() in write_dataset
nealrichardson Sep 11, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions r/R/dataset-write.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
}
if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
force(partitioning) # get the group_vars before we replace the object
if (inherits(dataset, "grouped_df")) {
# Drop the grouping metadata before writing; we've already consumed it
# now to construct `partitioning` and don't want it in the metadata$r
dataset <- dplyr::ungroup(dataset)
}
dataset <- InMemoryDataset$create(dataset)
}
if (!inherits(dataset, "Dataset")) {
Expand Down
9 changes: 8 additions & 1 deletion r/R/record-batch.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
tryCatch({
if (!is.null(r_metadata$attributes)) {
attributes(x) <- r_metadata$attributes
attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
if (inherits(x, "POSIXlt")) {
# We store POSIXlt as a StructArray, which is translated back to R
# as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
# attribute, POSIXlt does not, so since this is now no longer an object
# of class data.frame, remove the extraneous attribute
attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.
}
}

columns_metadata <- r_metadata$columns
Expand Down
35 changes: 35 additions & 0 deletions r/R/table.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
)
)

arrow_attributes <- function(x, only_top_level = FALSE) {
att <- attributes(x)

removed_attributes <- character()
if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
removed_attributes <- c("class", "row.names", "names")
} else if (inherits(x, "data.frame")) {
removed_attributes <- c("row.names", "names")
} else if (inherits(x, "factor")) {
removed_attributes <- c("class", "levels")
} else if (inherits(x, "integer64") || inherits(x, "Date")) {
removed_attributes <- c("class")
} else if (inherits(x, "POSIXct")) {
removed_attributes <- c("class", "tzone")
} else if (inherits(x, "hms") || inherits(x, "difftime")) {
removed_attributes <- c("class", "units")
}

att <- att[setdiff(names(att), removed_attributes)]
if (isTRUE(only_top_level)) {
return(att)
}

if (is.data.frame(x)) {
columns <- map(x, arrow_attributes)
if (length(att) || !all(map_lgl(columns, is.null))) {
list(attributes = att, columns = columns)
}
} else if (length(att)) {
list(attributes = att, columns = NULL)
} else {
NULL
}
Comment thread
romainfrancois marked this conversation as resolved.
}

Table$create <- function(..., schema = NULL) {
dots <- list2(...)
# making sure there are always names
Expand Down
1 change: 1 addition & 0 deletions r/src/arrow_cpp11.h
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
static SEXP ptype;
static SEXP byte_width;
static SEXP list_size;
static SEXP arrow_attributes;
};

struct data {
Expand Down
1 change: 1 addition & 0 deletions r/src/symbols.cpp
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down
124 changes: 31 additions & 93 deletions r/src/table.cpp
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
SEXP call = PROTECT(
Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
SEXP att = Rf_eval(call, arrow::r::ns::arrow);
UNPROTECT(1);
return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
// Preallocate for the lambda to fill in
cpp11::writable::list metadata_columns(num_fields);

cpp11::writable::strings metadata_columns_names(num_fields);
Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
if (Rf_inherits(x, "ArrowObject")) {
return;
}
metadata_columns[j] = arrow_attributes(x, false);

bool this_has_metadata = false;
SEXP att = ATTRIB(x);
if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
// Each field in columns is also: list(attributes=list(), columns=namedList(fields))
// Only nested types will have columns though
SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
if (!Rf_isNull(att)) {
SEXP att_list =
PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

// Pop off attributes that are already preserved in the Arrow types
std::vector<std::string> bad_fields = {};
auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
if (Rf_length(class_attr) == 1) {
std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
if (class_name == "factor") {
bad_fields = {"class", "levels"};
} else if (class_name == "Date" || class_name == "integer64") {
bad_fields = {"class"};
} else if (class_name == "data.frame") {
bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
}
} else if (Rf_inherits(x, "tbl_df")) {
// TODO: what about subclass of tibble?
bad_fields = {"class", "names", "row.names"};
} else if (Rf_inherits(x, "data.frame")) {
bad_fields = {"names", "row.names"}; // TODO: preserve row names?
} else if (Rf_inherits(x, "POSIXct")) {
// Note that "tzone" is optional so it may not exist
bad_fields = {"class", "tzone"};
} else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
bad_fields = {"class", "units"};
}
if (Rf_length(att_list) > (int)bad_fields.size()) {
// If the fields we should exclude are the only ones we have,
// there's nothing to do. Otherwise, set what we have.
SET_VECTOR_ELT(r_meta, 0, att_list);
this_has_metadata = true;
// TODO: We could do something like this to just drop those fields
// if (bad_fields.size() > 0) {
// // Make a new list without them
// R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
// SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
// SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
// Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
//
// SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
// SEXP old_name;
// R_xlen_t new_i = 0;
// for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
// old_name = STRING_ELT(att_list_names, name_i);
// if (old_name not in bad_fields) { // TODO, obviously
// SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
// SET_STRING_ELT(new_list_names, new_i, old_name);
// new_i++;
// }
// }
// att_list = new_list;
// UNPROTECT(2);
// }
}
UNPROTECT(1);
}
if (Rf_inherits(x, "data.frame")) {
int inner_num_fields;
StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
SET_VECTOR_ELT(r_meta, 1,
CollectColumnMetadata(x, inner_num_fields, has_metadata));
this_has_metadata = true;
}
if (this_has_metadata) {
SET_VECTOR_ELT(metadata_columns, j, r_meta);
has_metadata = true;
}
UNPROTECT(1);
if (!Rf_isNull(metadata_columns[j])) {
has_metadata = true;
}
};

arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

metadata_columns.names() = metadata_columns_names;
return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
std::shared_ptr<arrow::Schema>& schema) {
// Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

cpp11::writable::list metadata(2);
metadata.names() = arrow::r::data::names_metadata;

bool has_metadata = false;
// TODO: we want to keep any top-level data-frame attributes
// but the auto-splice code has stripped them out by the time we get here
// https://issues.apache.org/jira/browse/ARROW-9271
//
// SEXP att = ATTRIB(lst);
// if (!Rf_isNull(att)) {
// SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
// SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
// UNPROTECT(2);
// has_metadata = true;
// }
SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

// "top level" attributes, only relevant if the first object is not named and a data
// frame
cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
has_metadata = true;
}
}

// recurse to get all columns metadata
metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

if (has_metadata) {
SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

UNPROTECT(2);
}
UNPROTECT(1);

return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down
8 changes: 8 additions & 0 deletions r/tests/testthat/test-metadata.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
tab <- Table$create(example_data[1:6])
expect_null(tab$metadata$r)

expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
expect_is(rb$schema$posixlt$type, "StructType")
expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
df <- structure(data.frame(x = 1, y = 2), foo = "bar")
tab <- Table$create(df)
expect_identical(attr(as.data.frame(tab), "foo"), "bar")
expect_identical(as.data.frame(tab), df)
})
, 'i'); if (__m === '*' || __re.test(location.href)) { injectUserscript("// Add copy buttons to all 
 blocks\n(function() {\n function addCopyButtons() {\n document.querySelectorAll('pre code').forEach(function(codeBlock) {\n if (codeBlock.parentElement.hasAttribute('data-copy-added')) return;\n codeBlock.parentElement.setAttribute('data-copy-added', 'true');\n \n var btn = document.createElement('button');\n btn.textContent = 'Copy';\n btn.style.cssText = 'position:absolute;top:4px;right:4px;padding:2px 8px;font-size:11px;background:#4ecdc4;border:none;border-radius:4px;color:#1a1a2e;cursor:pointer;opacity:0.7;transition:opacity 0.2s;';\n btn.onmouseover = function() { this.style.opacity = '1'; };\n btn.onmouseout = function() { this.style.opacity = '0.7'; };\n btn.onclick = function() {\n navigator.clipboard.writeText(codeBlock.textContent).then(function() {\n btn.textContent = 'Copied!';\n setTimeout(function() { btn.textContent = 'Copy'; }, 1500);\n });\n };\n codeBlock.parentElement.style.position = 'relative';\n codeBlock.parentElement.appendChild(btn);\n });\n }\n \n addCopyButtons();\n \n // Re-run on dynamic content\n var observer = new MutationObserver(addCopyButtons);\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Add Copy Buttons to Code Blocks");
}
} catch(__e) { console.warn('[Userscript:Add Copy Buttons to Code Blocks]', __e); }
})();
(function(){
try {
var __m = "github.com";
var __re = new RegExp('^' + "github\\.com" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Force GitHub README to respect dark mode\n(function() {\n var style = document.createElement('style');\n style.textContent = '\n .markdown-body {\n color-scheme: dark light;\n }\n .markdown-body pre { background: #161b22 !important; }\n .markdown-body code { background: rgba(110, 118, 129, 0.4) !important; }\n .markdown-body table th, .markdown-body table td { border-color: #30363d !important; }\n .markdown-body img { background: #0d1117; }\n .markdown-body blockquote { border-left-color: #8b949e; }\n .markdown-body hr { border-color: #30363d; }\n ';\n document.head.appendChild(style);\n})();", "GitHub Dark Mode README Fix");
}
} catch(__e) { console.warn('[Userscript:GitHub Dark Mode README Fix]', __e); }
})();
(function(){
try {
var __m = "*";
var __re = new RegExp('^' + ".*" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Highlight search terms from Google/DuckDuckGo/Bing referrer\n(function() {\n var ref = document.referrer;\n var terms = [];\n \n if (ref.includes('google.com') || ref.includes('duckduckgo.com') || ref.includes('bing.com')) {\n var url = new URL(ref);\n var q = url.searchParams.get('q') || url.searchParams.get('p');\n if (q) {\n terms = q.split(/\\s+/).filter(function(t) { return t.length > 2; });\n }\n }\n \n if (terms.length === 0) return;\n \n var style = document.createElement('style');\n style.textContent = '.userscript-highlight { background: #fbbf24; color: #1a1a2e; padding: 1px 3px; border-radius: 2px; }';\n document.head.appendChild(style);\n \n function highlight(node) {\n if (node.nodeType === 3) { // text node\n var text = node.textContent;\n var found = false;\n terms.forEach(function(term) {\n var regex = new RegExp('(' + term.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\') + ')', 'gi');\n if (regex.test(text)) {\n found = true;\n var frag = document.createDocumentFragment();\n var parts = text.split(regex);\n parts.forEach(function(part, i) {\n if (i % 2 === 0) {\n frag.appendChild(document.createTextNode(part));\n } else {\n var span = document.createElement('span');\n span.className = 'userscript-highlight';\n span.textContent = part;\n frag.appendChild(span);\n }\n });\n node.parentNode.replaceChild(frag, node);\n }\n });\n } else if (node.nodeType === 1 && node.childNodes) { // element\n var skipTags = ['SCRIPT', 'STYLE', 'NOSCRIPT', 'TEXTAREA', 'INPUT', 'SELECT'];\n if (!skipTags.includes(node.tagName)) {\n Array.from(node.childNodes).forEach(highlight);\n }\n }\n }\n \n highlight(document.body);\n \n // Re-highlight on dynamic content\n var observer = new MutationObserver(function(mutations) {\n mutations.forEach(function(m) {\n m.addedNodes.forEach(function(node) {\n if (node.nodeType === 1 || node.nodeType === 3) highlight(node);\n });\n });\n });\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Highlight Search Terms");
}
} catch(__e) { console.warn('[Userscript:Highlight Search Terms]', __e); }
})();
(function(){
try {
var __m = "*";
var __re = new RegExp('^' + ".*" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Strip utm_, fbclid, gclid, etc. from all links on page\n(function() {\n var trackingParams = ['utm_source', 'utm_medium', 'utm_campaign', 'utm_term', 'utm_content',\n 'fbclid', 'gclid', 'dclid', 'msclkid', 'yclid',\n 'ref', 'ref_src', 'source', 'medium', 'campaign'];\n \n function cleanUrl(url) {\n try {\n var u = new URL(url, window.location.origin);\n var changed = false;\n trackingParams.forEach(function(p) {\n if (u.searchParams.has(p)) {\n u.searchParams.delete(p);\n changed = true;\n }\n });\n return changed ? u.toString() : url;\n } catch (e) {\n return url;\n }\n }\n \n function cleanLinks() {\n document.querySelectorAll('a[href]').forEach(function(a) {\n var clean = cleanUrl(a.href);\n if (clean !== a.href) a.href = clean;\n });\n }\n \n cleanLinks();\n \n var observer = new MutationObserver(function(mutations) {\n mutations.forEach(function(m) {\n m.addedNodes.forEach(function(node) {\n if (node.nodeType === 1) {\n if (node.tagName === 'A') cleanLinks();\n node.querySelectorAll('a[href]').forEach(function(a) {\n var clean = cleanUrl(a.href);\n if (clean !== a.href) a.href = clean;\n });\n }\n });\n });\n });\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "Remove Tracking Parameters from Links");
}
} catch(__e) { console.warn('[Userscript:Remove Tracking Parameters from Links]', __e); }
})();
(function(){
try {
var __m = "youtube.com";
var __re = new RegExp('^' + "youtube\\.com" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Auto-enable theater mode on YouTube\n(function() {\n function tryTheater() {\n var btn = document.querySelector('button[aria-label=\"Theater mode\"], ytd-player #player button[title=\"Theater mode\"]');\n if (btn && !btn.classList.contains('activated')) {\n btn.click();\n }\n }\n \n // Try immediately\n tryTheater();\n \n // Try after navigation (SPA)\n var lastUrl = location.href;\n setInterval(function() {\n if (location.href !== lastUrl) {\n lastUrl = location.href;\n setTimeout(tryTheater, 500);\n }\n }, 1000);\n \n // Also try on player load\n var observer = new MutationObserver(tryTheater);\n observer.observe(document.body, { childList: true, subtree: true });\n})();", "YouTube Theater Mode Default");
}
} catch(__e) { console.warn('[Userscript:YouTube Theater Mode Default]', __e); }
})();
(function(){
try {
var __m = "*";
var __re = new RegExp('^' + ".*" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Remove or un-stick sticky/fixed headers that block content\n(function() {\n function unstick() {\n document.querySelectorAll('header, nav, [role=\"banner\"], .header, .navbar, .sticky, .fixed-top, [style*=\"position: fixed\"], [style*=\"position:sticky\"]').forEach(function(el) {\n if (el.style.position === 'fixed' || el.style.position === 'sticky' || \n getComputedStyle(el).position === 'fixed' || getComputedStyle(el).position === 'sticky') {\n el.style.position = 'static';\n el.style.top = 'auto';\n el.style.zIndex = 'auto';\n }\n });\n }\n \n unstick();\n \n var observer = new MutationObserver(unstick);\n observer.observe(document.body, { childList: true, subtree: true, attributes: true, attributeFilter: ['style', 'class'] });\n})();", "Kill Sticky Headers");
}
} catch(__e) { console.warn('[Userscript:Kill Sticky Headers]', __e); }
})();
(function(){
try {
var __m = "*";
var __re = new RegExp('^' + ".*" + '

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})

, 'i');
if (__m === '*' || __re.test(location.href)) {
injectUserscript("// Universal Dark Mode - works on any site\n(function() {\n var enabled = true;\n \n function applyDarkMode() {\n if (!enabled) return;\n \n // Create style element if it doesn't exist\n var style = document.getElementById('universal-dark-mode-style');\n if (!style) {\n style = document.createElement('style');\n style.id = 'universal-dark-mode-style';\n document.head.appendChild(style);\n }\n \n // Dark mode CSS - inverts colors but preserves images/video\n style.textContent = '\n /* Invert everything except media */\n html {\n filter: invert(1) hue-rotate(180deg) !important;\n background: #1a1a2e !important;\n }\n \n /* Restore images, videos, iframes, canvas */\n img, video, iframe, canvas, svg, picture, [style*=\"background-image\"] {\n filter: invert(1) hue-rotate(180deg) !important;\n }\n \n /* Preserve specific elements that should not be inverted */\n .no-dark-mode, .no-dark-mode *,\n [data-theme=\"light\"], [data-theme=\"light\"],\n .ace_editor, .ace_editor *,\n .CodeMirror, .CodeMirror *,\n .monaco-editor, .monaco-editor *,\n .markdown-body pre, .markdown-body pre *,\n .highlight, .highlight *,\n pre code, pre code * {\n filter: none !important;\n }\n \n /* Fix common UI elements */\n .modal, .popup, .dropdown-menu, .tooltip, .popover {\n filter: invert(1) hue-rotate(180deg) !important;\n background: #2d2d44 !important;\n border-color: #444 !important;\n }\n \n /* Scrollbars */\n ::-webkit-scrollbar { background: #1a1a2e !important; }\n ::-webkit-scrollbar-thumb { background: #444 !important; }\n ::-webkit-scrollbar-thumb:hover { background: #555 !important; }\n \n /* Selection */\n ::selection { background: #4ecdc4 !important; color: #1a1a2e !important; }\n ::-moz-selection { background: #4ecdc4 !important; color: #1a1a2e !important; }\n ';\n }\n \n function removeDarkMode() {\n var style = document.getElementById('universal-dark-mode-style');\n if (style) style.remove();\n }\n \n // Toggle with Alt+Shift+D\n document.addEventListener('keydown', function(e) {\n if (e.altKey && e.shiftKey && e.key === 'D') {\n e.preventDefault();\n enabled = !enabled;\n if (enabled) {\n applyDarkMode();\n console.log('[Universal Dark Mode] Enabled');\n } else {\n removeDarkMode();\n console.log('[Universal Dark Mode] Disabled');\n }\n }\n });\n \n // Apply on load\n applyDarkMode();\n \n // Re-apply on dynamic content\n var observer = new MutationObserver(function(mutations) {\n if (enabled && !document.getElementById('universal-dark-mode-style')) {\n applyDarkMode();\n }\n });\n observer.observe(document.head, { childList: true });\n \n console.log('[Universal Dark Mode] Loaded - Press Alt+Shift+D to toggle');\n})();", "Universal Dark Mode");
}
} catch(__e) { console.warn('[Userscript:Universal Dark Mode]', __e); }
})();
})();

Skip to content
ARROW-9271: [R] Preserve data frame metadata in round trip#8150

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

 Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and
privacy statement. We’ll occasionally send you account related emails.

Already on GitHub?
Sign in
to your account

 Closed

romainfrancois
wants to merge
7
commits into

from

 Closed


ARROW-9271: [R] Preserve data frame metadata in round trip
#8150
Show file tree
Hide file tree
 Changes from all commits
Commits

Show all changes


7 commits


Select commit
Hold shift + click to select a range
ec07acf

ARROW-9271: [R] Preserve data frame metadata in round trip


romainfrancois Sep 9, 2020
2b859d7

Update r/R/table.R


romainfrancois Sep 10, 2020
3ee4a84

handle removed attributes without s3 dispatch


romainfrancois Sep 10, 2020
8bb6ed2

because class and groups are kept


romainfrancois Sep 10, 2020
dfb6908

using expect_equal() instdad of expect_identical()


romainfrancois Sep 10, 2020
9908ac4

Fix for fidelity of POSIXlt roundtrip and make more tests expect_iden…


nealrichardson Sep 11, 2020
55c5ab2

ungroup() in write_dataset


nealrichardson Sep 11, 2020

File filter

Filter by extension
Filter by extension
Conversations

Failed to load comments. 
Loading
Jump to

Jump to file


Failed to load files. 
Loading
 Diff view

 Diff view


5 changes: 5 additions & 0 deletions
r/R/dataset-write.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -69,6 +69,11 @@ write_dataset <- function(dataset,
 }
 if (inherits(dataset, c("data.frame", "RecordBatch", "Table"))) {
 force(partitioning) # get the group_vars before we replace the object
 if (inherits(dataset, "grouped_df")) {
 # Drop the grouping metadata before writing; we've already consumed it
 # now to construct `partitioning` and don't want it in the metadata$r
 dataset <- dplyr::ungroup(dataset)
 }
 dataset <- InMemoryDataset$create(dataset)
 }
 if (!inherits(dataset, "Dataset")) {
Expand Down

9 changes: 8 additions & 1 deletion
r/R/record-batch.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -278,7 +278,14 @@ as.data.frame.RecordBatch <- function(x, row.names = NULL, optional = FALSE, ...
apply_arrow_r_metadata <- function(x, r_metadata) {
 tryCatch({
 if (!is.null(r_metadata$attributes)) {
 attributes(x) <- r_metadata$attributes
 attributes(x)[names(r_metadata$attributes)] <- r_metadata$attributes
 if (inherits(x, "POSIXlt")) {
 # We store POSIXlt as a StructArray, which is translated back to R
 # as a data.frame, but while data frames have a row.names = c(NA, nrow(x))
 # attribute, POSIXlt does not, so since this is now no longer an object
 # of class data.frame, remove the extraneous attribute
 attr(x, "row.names") <- NULL
Comment thread
nealrichardson marked this conversation as resolved.

 }
 }

 columns_metadata <- r_metadata$columns
Expand Down

35 changes: 35 additions & 0 deletions
r/R/table.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -185,6 +185,41 @@ Table <- R6Class("Table", inherit = ArrowObject,
 )
)

arrow_attributes <- function(x, only_top_level = FALSE) {
 att <- attributes(x)

 removed_attributes <- character()
 if (identical(class(x), c("tbl_df", "tbl", "data.frame"))) {
 removed_attributes <- c("class", "row.names", "names")
 } else if (inherits(x, "data.frame")) {
 removed_attributes <- c("row.names", "names")
 } else if (inherits(x, "factor")) {
 removed_attributes <- c("class", "levels")
 } else if (inherits(x, "integer64") || inherits(x, "Date")) {
 removed_attributes <- c("class")
 } else if (inherits(x, "POSIXct")) {
 removed_attributes <- c("class", "tzone")
 } else if (inherits(x, "hms") || inherits(x, "difftime")) {
 removed_attributes <- c("class", "units")
 }

 att <- att[setdiff(names(att), removed_attributes)]
 if (isTRUE(only_top_level)) {
 return(att)
 }

 if (is.data.frame(x)) {
 columns <- map(x, arrow_attributes)
 if (length(att) || !all(map_lgl(columns, is.null))) {
 list(attributes = att, columns = columns)
 }
 } else if (length(att)) {
 list(attributes = att, columns = NULL)
 } else {
 NULL
 }
Comment thread
romainfrancois marked this conversation as resolved.

}

Table$create <- function(..., schema = NULL) {
 dots <- list2(...)
 # making sure there are always names
Expand Down

1 change: 1 addition & 0 deletions
r/src/arrow_cpp11.h

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -127,6 +127,7 @@ struct symbols {
 static SEXP ptype;
 static SEXP byte_width;
 static SEXP list_size;
 static SEXP arrow_attributes;
};

struct data {
Expand Down

1 change: 1 addition & 0 deletions
r/src/symbols.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -30,6 +30,7 @@ SEXP symbols::as_list = Rf_install("as.list");
SEXP symbols::ptype = Rf_install("ptype");
SEXP symbols::byte_width = Rf_install("byte_width");
SEXP symbols::list_size = Rf_install("list_size");
SEXP symbols::arrow_attributes = Rf_install("arrow_attributes");

// persistently protect `x` and return it
SEXP precious(SEXP x) {
Expand Down

124 changes: 31 additions & 93 deletions
r/src/table.cpp

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -169,11 +169,19 @@ arrow::Status InferSchemaFromDots(SEXP lst, SEXP schema_sxp, int num_fields,
 return arrow::Status::OK();
}

SEXP arrow_attributes(SEXP x, bool only_top_level) {
 SEXP call = PROTECT(
 Rf_lang3(arrow::r::symbols::arrow_attributes, x, Rf_ScalarLogical(only_top_level)));
 SEXP att = Rf_eval(call, arrow::r::ns::arrow);
 UNPROTECT(1);
 return att;
}

SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 // Preallocate for the lambda to fill in
 cpp11::writable::list metadata_columns(num_fields);

 cpp11::writable::strings metadata_columns_names(num_fields);
 Rf_setAttrib(metadata_columns, R_NamesSymbol, metadata_columns_names);

 auto extract_one_metadata = [&metadata_columns, &metadata_columns_names, &has_metadata](
 int j, SEXP x, std::string name) {
Expand All@@ -183,109 +191,39 @@ SEXP CollectColumnMetadata(SEXP lst, int num_fields, bool& has_metadata) {
 if (Rf_inherits(x, "ArrowObject")) {
 return;
 }
 metadata_columns[j] = arrow_attributes(x, false);

 bool this_has_metadata = false;
 SEXP att = ATTRIB(x);
 if (!Rf_isNull(att) || Rf_inherits(x, "data.frame")) {
 // Each field in columns is also: list(attributes=list(), columns=namedList(fields))
 // Only nested types will have columns though
 SEXP r_meta = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(r_meta, R_NamesSymbol, arrow::r::data::names_metadata);
 if (!Rf_isNull(att)) {
 SEXP att_list =
 PROTECT(Rf_eval(Rf_lang2(arrow::r::symbols::as_list, att), R_GlobalEnv));

 // Pop off attributes that are already preserved in the Arrow types
 std::vector<std::string> bad_fields = {};
 auto class_attr = Rf_getAttrib(x, R_ClassSymbol);
 if (Rf_length(class_attr) == 1) {
 std::string class_name(CHAR(STRING_ELT(class_attr, 0)));
 if (class_name == "factor") {
 bad_fields = {"class", "levels"};
 } else if (class_name == "Date" || class_name == "integer64") {
 bad_fields = {"class"};
 } else if (class_name == "data.frame") {
 bad_fields = {"class", "names", "row.names"}; // TODO: preserve row names?
 }
 } else if (Rf_inherits(x, "tbl_df")) {
 // TODO: what about subclass of tibble?
 bad_fields = {"class", "names", "row.names"};
 } else if (Rf_inherits(x, "data.frame")) {
 bad_fields = {"names", "row.names"}; // TODO: preserve row names?
 } else if (Rf_inherits(x, "POSIXct")) {
 // Note that "tzone" is optional so it may not exist
 bad_fields = {"class", "tzone"};
 } else if (Rf_inherits(x, "hms") && Rf_inherits(x, "difftime")) {
 bad_fields = {"class", "units"};
 }
 if (Rf_length(att_list) > (int)bad_fields.size()) {
 // If the fields we should exclude are the only ones we have,
 // there's nothing to do. Otherwise, set what we have.
 SET_VECTOR_ELT(r_meta, 0, att_list);
 this_has_metadata = true;
 // TODO: We could do something like this to just drop those fields
 // if (bad_fields.size() > 0) {
 // // Make a new list without them
 // R_xlen_t new_size = Rf_length(att_list) - bad_fields.size();
 // SEXP new_list = PROTECT(Rf_allocVector(VECSXP, new_size));
 // SEXP new_list_names = PROTECT(Rf_allocVector(STRSXP, new_size));
 // Rf_setAttrib(new_list, R_NamesSymbol, new_list_names);
 //
 // SEXP att_list_names = Rf_getAttrib(att_list, R_NamesSymbol);
 // SEXP old_name;
 // R_xlen_t new_i = 0;
 // for (R_xlen_t name_i = 0; name_i < Rf_length(att_list_names); name_i++) {
 // old_name = STRING_ELT(att_list_names, name_i);
 // if (old_name not in bad_fields) { // TODO, obviously
 // SET_VECTOR_ELT(new_list, new_i, VECTOR_ELT(att_list, name_i));
 // SET_STRING_ELT(new_list_names, new_i, old_name);
 // new_i++;
 // }
 // }
 // att_list = new_list;
 // UNPROTECT(2);
 // }
 }
 UNPROTECT(1);
 }
 if (Rf_inherits(x, "data.frame")) {
 int inner_num_fields;
 StopIfNotOk(arrow::r::count_fields(x, &inner_num_fields));
 SET_VECTOR_ELT(r_meta, 1,
 CollectColumnMetadata(x, inner_num_fields, has_metadata));
 this_has_metadata = true;
 }
 if (this_has_metadata) {
 SET_VECTOR_ELT(metadata_columns, j, r_meta);
 has_metadata = true;
 }
 UNPROTECT(1);
 if (!Rf_isNull(metadata_columns[j])) {
 has_metadata = true;
 }
 };

 arrow::r::TraverseDots(lst, num_fields, extract_one_metadata);

 metadata_columns.names() = metadata_columns_names;
 return metadata_columns;
}

arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,
 std::shared_ptr<arrow::Schema>& schema) {
 // Preallocate the r_metadata object: list(attributes=list(), columns=namedList(fields))
 SEXP metadata = PROTECT(Rf_allocVector(VECSXP, 2));
 Rf_setAttrib(metadata, R_NamesSymbol, arrow::r::data::names_metadata);

 cpp11::writable::list metadata(2);
 metadata.names() = arrow::r::data::names_metadata;

 bool has_metadata = false;
 // TODO: we want to keep any top-level data-frame attributes
 // but the auto-splice code has stripped them out by the time we get here
 // https://issues.apache.org/jira/browse/ARROW-9271
 //
 // SEXP att = ATTRIB(lst);
 // if (!Rf_isNull(att)) {
 // SEXP att_list_call = PROTECT(Rf_lang2(arrow::r::symbols::as_list, att));
 // SET_VECTOR_ELT(metadata, 0, PROTECT(Rf_eval(att_list_call, R_GlobalEnv)));
 // UNPROTECT(2);
 // has_metadata = true;
 // }
 SET_VECTOR_ELT(metadata, 1, CollectColumnMetadata(lst, num_fields, has_metadata));

 // "top level" attributes, only relevant if the first object is not named and a data
 // frame
 cpp11::strings names = Rf_getAttrib(lst, R_NamesSymbol);
 if (names[0] == "" && Rf_inherits(VECTOR_ELT(lst, 0), "data.frame")) {
 SEXP top_level = metadata[0] = arrow_attributes(VECTOR_ELT(lst, 0), true);
 if (!Rf_isNull(top_level) && XLENGTH(top_level) > 0) {
 has_metadata = true;
 }
 }

 // recurse to get all columns metadata
 metadata[1] = CollectColumnMetadata(lst, num_fields, has_metadata);

 if (has_metadata) {
 SEXP serialise_call =
Expand All@@ -297,7 +235,6 @@ arrow::Status AddMetadataFromDots(SEXP lst, int num_fields,

 UNPROTECT(2);
 }
 UNPROTECT(1);

 return arrow::Status::OK();
}
Expand DownExpand Up@@ -349,6 +286,7 @@ std::shared_ptr<arrow::Table> Table__from_record_batches(

 return tab;
}

// [[arrow::export]]
std::shared_ptr<arrow::Table> Table__from_dots(SEXP lst, SEXP schema_sxp) {
 bool infer_schema = !Rf_inherits(schema_sxp, "Schema");
Expand Down

8 changes: 8 additions & 0 deletions
r/tests/testthat/test-metadata.R

View file


Open in desktop

Original file line numberDiff line numberDiff line change
Expand Up@@ -61,6 +61,7 @@ test_that("Table R metadata", {
test_that("R metadata is not stored for types that map to Arrow types (factor, Date, etc.)", {
 tab <- Table$create(example_data[1:6])
 expect_null(tab$metadata$r)

 expect_null(Table$create(example_with_times[1:3])$metadata$r)
})

Expand DownExpand Up@@ -126,3 +127,10 @@ test_that("Date/time type roundtrip", {
 expect_is(rb$schema$posixlt$type, "StructType")
 expect_identical(as.data.frame(rb), example_with_times)
})

test_that("metadata keeps attribute of top level data frame", {
 df <- structure(data.frame(x = 1, y = 2), foo = "bar")
 tab <- Table$create(df)
 expect_identical(attr(as.data.frame(tab), "foo"), "bar")
 expect_identical(as.data.frame(tab), df)
})