SEXP R_gpg_delete(SEXP id, SEXP secret){
gpgme_key_t key;
const char * idstr = CHAR(STRING_ELT(id, 0));
bail(gpgme_get_key(ctx, idstr, &key, 0), "find key");
gpgme_error_t err = gpgme_op_delete(ctx, key, asLogical(secret));
if(gpg_err_code (err) == GPG_ERR_CONFLICT){
Rf_warningcall(R_NilValue, "Did not delete %s. Set secret = TRUE to delete private keys", idstr);
return mkString("");
}
bail(err, "delete key");
return mkString(key->subkeys->keyid);
}
/* Origin: SEXP attribute_hidden do_warning(). */
SEXP api_R_warning(SEXP args){
SEXP call, c_call;
args = CDR(args); /* get caller name */
call = CAR(args);
args = CDR(args);
if(asLogical(CAR(args))){ /* find context -> "... in: ..:" */
c_call = call;
} else{
c_call = R_NilValue;
}
args = CDR(args);
if(asLogical(CAR(args))){ /* immediate = TRUE */
immediateWarning = 1;
} else{
immediateWarning = 0;
}
args = CDR(args);
if(CAR(args) != R_NilValue){
SETCAR(args, coerceVector(CAR(args), STRSXP));
if(!isValidString(CAR(args))){
Rf_warningcall(c_call,
" [invalid string in comm.warning(.)]\n");
} else{
Rf_warningcall(c_call, "%s",
translateChar(STRING_ELT(CAR(args), 0)));
}
} else{
Rf_warningcall(c_call, "");
}
immediateWarning = 0; /* reset to internal calls */
return CAR(args);
} /* End of api_R_warning(). */
SEXP R_mongo_collection_insert_page(SEXP ptr_col, SEXP json_vec, SEXP stop_on_error){
if(!Rf_isString(json_vec) || !Rf_length(json_vec))
stop("json_vec must be character string of at least length 1");
//ordered means serial execution
bool ordered = Rf_asLogical(stop_on_error);
//create bulk operation
bson_error_t err;
bson_t *b;
bson_t reply;
mongoc_bulk_operation_t *bulk = mongoc_collection_create_bulk_operation_with_opts (r2col(ptr_col), NULL);
for(int i = 0; i < Rf_length(json_vec); i++){
b = bson_new_from_json ((uint8_t*) Rf_translateCharUTF8(Rf_asChar(STRING_ELT(json_vec, i))), -1, &err);
if(!b){
mongoc_bulk_operation_destroy (bulk);
stop(err.message);
}
mongoc_bulk_operation_insert(bulk, b);
bson_destroy (b);
b = NULL;
}
//execute bulk operation
bool success = mongoc_bulk_operation_execute (bulk, &reply, &err);
mongoc_bulk_operation_destroy (bulk);
//check for errors
if(!success){
if(ordered){
Rf_errorcall(R_NilValue, err.message);
} else {
Rf_warningcall(R_NilValue, "Not all inserts were successful: %s\n", err.message);
}
}
//get output
SEXP out = PROTECT(bson2list(&reply));
bson_destroy (&reply);
UNPROTECT(1);
return out;
}
void readkgml_sign_int(const char* filename,
vector<string> &vertices,
vector<int> &edges,
vector< vector<string> > &attr,
vector< vector<string> > &pathway_attr,
bool expand_complexes, bool verbose)
{
xmlDocPtr doc;
xmlXPathContextPtr xpathCtx = NULL;
xmlXPathObjectPtr nodes;
if(verbose) Rprintf("Processing KGML file: %s",filename);
/* Load XML document */
doc = xmlParseFile(filename);
if (doc == NULL) {
Rf_warningcall(mkChar(filename), "Unable to parse file.");
if(verbose) Rprintf(": Error.\n");
return;
}
//Check if the xml file has a KEGG DTD System.
/* Check it is a kegg pathway file */
if(doc->intSubset == NULL ||
strcmp( (char *) (doc->intSubset->name), "pathway") != 0 )
//strncmp( (char *) (doc->intSubset->SystemID), "http://www.kegg.jp/kegg/", 24) !=0)
{
Rf_warningcall(mkChar(filename), "File is not KEGG pathway file.");
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return;
}
/* Get pathway information :*/
xmlNodePtr pathway = xmlDocGetRootElement(doc);
if(!pathway || strcmp( (char *) (pathway->name), "pathway") != 0){
Rf_warningcall(mkChar(filename), "No pathways in file.");
xmlXPathFreeContext(xpathCtx);
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return;
}
vector<string> pathway_info;
const char* pathwayId = get_attr(pathway, "name");
if(!pathwayId){
Rf_warningcall(mkChar(filename), "Pathway ID not found in file. Using file name instead.");
pathwayId = filename;
}else{
pathwayId +=5; //Remove "path:" leading characters//
}
const char* pathwayTitle = get_attr(pathway, "title");
if(!pathwayTitle){
Rf_warningcall(mkChar(pathwayId), "Pathway title not found in file.");
pathwayTitle = "";
}
if(verbose) Rprintf(" \"%s\"",pathwayTitle);
/* Create xpath evaluation context */
xpathCtx = xmlXPathNewContext(doc);
if(xpathCtx == NULL) {
Rf_warningcall(mkChar(filename), "Unable to create new XPath context.");
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return;
}
/* Evaluate xpath expression */
nodes = xmlXPathEvalExpression((xmlChar *) "//relation", xpathCtx);
if(nodes == NULL || nodes->nodesetval == NULL || nodes->nodesetval->nodeNr == 0) {
Rf_warningcall(mkChar(pathwayId), "Pathway contains no Protein-protein relationships.");
xmlXPathFreeContext(xpathCtx);
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return;
}
/* Parse XML Reactions*/
xmlNodePtr curRelation;
int size = (nodes->nodesetval) ? nodes->nodesetval->nodeNr : 0;
if(verbose) Rprintf(": %d gene relations found.\n",size);
/* Looping over "relations" */
for(int i = 0; i < size; ++i) {
curRelation = nodes->nodesetval->nodeTab[i];
char* type = get_attr(curRelation, "type");
if(!type || strcmp(type, "maplink") == 0 )
continue;
// Get gene names for entry1 and entry2
vector<string> p1,p2; //Holder objects for all gene names in this "relation"
char* entry1 = get_attr(curRelation, "entry1");
char* p1_name = entry1 ? attr_by_id(entry1, "name", xpathCtx) : NULL;
if(p1_name && strcmp(p1_name, "undefined") == 0 ){
p1_name = get_group_components(entry1, xpathCtx);
}
if(!p1_name) continue;
char* entry2 = get_attr(curRelation, "entry2");
char* p2_name = entry2 ? attr_by_id(entry2, "name", xpathCtx) : NULL;
if(p2_name && strcmp(p2_name, "undefined") == 0 ){
p2_name = get_group_components(entry2, xpathCtx);
}
if(!p2_name) continue;
/* If complexes are expanded, each gene is a separate vertex.
* Otherwise, all genes participating in the relation are kept in a single vertex.
*/
if(expand_complexes){
p1 = split(p1_name, ' ');
p2 = split(p2_name, ' ');
}else{
p1.push_back(p1_name);
p2.push_back(p2_name);
}
// Check if p1, p2 are already in our stack.
vector<size_t> p1_pos, p2_pos;
for(size_t j = 0; j < p1.size(); j++){
p1_pos.push_back( elem_pos( vertices, p1[j] ) );
if(p1_pos[j] == vertices.size())
vertices.push_back(p1[j]);
}
for(size_t k = 0; k < p2.size(); k++){
p2_pos.push_back( elem_pos( vertices, p2[k] ) );
if(p2_pos[k] == vertices.size())
vertices.push_back(p2[k]);
}
/* Setting pathway attributes for all added vertices */
//making sure pathway and vertices vectors are of the same size//
for(size_t p_attr = pathway_attr.size(); p_attr < vertices.size(); p_attr++)
{ pathway_attr.push_back(vector<string>()); }
//Adding this pathway as attribute, if it's not already added//
string pid = pathwayId;
for(size_t j=0; j<p1_pos.size(); j++){
if( !elem_in_vector(pathway_attr[ p1_pos[j] ], pid ) ){
pathway_attr[ p1_pos[j] ].push_back(pathwayId);
pathway_attr[ p1_pos[j] ].push_back(pathwayTitle);
}
}
for(size_t k=0; k<p2_pos.size(); k++){
if( !elem_in_vector(pathway_attr[ p2_pos[k] ], pid ) ){
pathway_attr[ p2_pos[k] ].push_back(pathwayId);
pathway_attr[ p2_pos[k] ].push_back(pathwayTitle);
}
}
/* Edges to connect the added vertices, and their attributes */
// Relation parsing depennds on its type //
if( strcmp(type, "PPrel") == 0 || strcmp(type, "GErel") == 0 || strcmp(type, "PCrel") == 0 ){
// Add all combinatiosn from p1-> p2 as edges.
for(size_t j=0; j<p1_pos.size(); j++){
for(size_t k=0; k<p2_pos.size(); k++){
edges.push_back(p1_pos[j]); edges.push_back(p2_pos[k]);
}
}
vector<string> e_attr;
xpathCtx->node = curRelation;
xmlNodeSetPtr subtype = xmlXPathEvalExpression( (const xmlChar *) "./subtype", xpathCtx ) ->nodesetval;
int numOfattr = (subtype) ? subtype->nodeNr : 0;
for (int a = 0;a < numOfattr;a++){
xmlNodePtr sub_node = subtype->nodeTab[a];
char* subtype_name = get_attr(sub_node, "name");
if(!subtype_name)
continue;
if(strcmp(subtype_name, "compound") == 0){
char* cpd_name = attr_by_id(get_attr(sub_node, "value"), "name", xpathCtx);
e_attr.push_back(cpd_name);
}else{
e_attr.push_back(subtype_name);
}
}
// Add the same attribute for all added edges.
for(size_t l=0; l<p1_pos.size()*p2_pos.size(); l++)
attr.push_back(e_attr);
}
else if(strcmp(type, "ECrel") == 0 ){
/* ECrel indicated participation in 2 succesive reactions
* For ECrel, KGML deson't respect the direction of the relation
* Here, I will try to find whether it's entry1->entry2, or the reverse.
* Below, p1 particpates in r1, and p2 in r2, and the shared compound is cpd.
*/
char* cpd_id = get_attr(curRelation->children->next, "value");
char* cpd = attr_by_id(cpd_id, "name", xpathCtx); //Cpd name
if(!cpd) continue;
char* r1_name = attr_by_id(entry1, "reaction",xpathCtx);
xmlNodePtr r1node = r1_name ? node_by_attr_val("name", r1_name, "reaction",xpathCtx) : NULL;
if(!r1node)continue;
bool r1_rev = strcmp(get_attr(r1node, "type"), "reversible") == 0;
bool r1_cpd = false; //If R1->Cpd (compound is a product of R1).
if(!r1_rev){
xpathCtx->node = r1node;
string childXPath = ((string)"./*[@name='")+((string)cpd)+((string)"']");
xmlNodeSetPtr children = xmlXPathEvalExpression(
(const xmlChar *) childXPath.c_str(), xpathCtx ) ->nodesetval;
char* role = children && children->nodeNr >0 ? (char*)children->nodeTab[0]-> name : NULL;
if(!role) continue;
if(strcmp( role , "product") == 0)
r1_cpd = true;
else{ r1_cpd = false;}
}// !r1_rev
char* r2_name = attr_by_id(entry2, "reaction",xpathCtx);
xmlNodePtr r2node = r2_name ? node_by_attr_val("name", r2_name, "reaction",xpathCtx) : NULL;
if(!r2node)continue;
bool r2_rev = strcmp(get_attr(r2node, "type"), "reversible") == 0;
bool r2_cpd = false;
if(!r2_rev){
xpathCtx->node = r2node;
string childXPath = ((string)"./*[@name='")+((string)cpd)+((string)"']");
xmlNodeSetPtr children = xmlXPathEvalExpression(
(const xmlChar *) childXPath.c_str(), xpathCtx ) ->nodesetval;
char* role = children && children->nodeNr >0 ? (char*)children->nodeTab[0]-> name : NULL;
if(!role) continue;
if(strcmp( role , "product") == 0)
r2_cpd = true;
else{ r2_cpd = false;}
}// !r2_rev
/* the order of r1, r2 is:
* r1 -> r2 if cpd is a product of r1 and substrate of 2
* meaning r1_cpd=true, r2_cpd=false.
* The opposite is also true.
* The value of r1_cpd doesn't matter if r1 reversible.
*/
if((r1_rev || r1_cpd) && (r2_rev || !r2_cpd)){
for(size_t j=0; j<p1_pos.size(); j++){
for(size_t k=0; k<p2_pos.size(); k++){
edges.push_back(p1_pos[j]); edges.push_back(p2_pos[k]);
vector<string> e_attr; e_attr.push_back(cpd);
attr.push_back(e_attr);
}
}
}// R1->R2
if((r1_rev || !r1_cpd) && (r2_rev || r2_cpd)){
for(size_t j=0; j<p1_pos.size(); j++){
for(size_t k=0; k<p2_pos.size(); k++){
edges.push_back(p2_pos[k]); edges.push_back(p1_pos[j]);
vector<string> e_attr; e_attr.push_back(cpd);
attr.push_back(e_attr);
}
}
}// R2->R1 (order is reversed)
}// End ECrel
}// End for(relations)
}//kgml_sig_int
SEXP readkgmlfile(SEXP FILENAME, SEXP VERBOSE) {
handle_segfault_KGML();
const char *filename = CHAR(STRING_ELT(FILENAME,0));
bool verbose = LOGICAL(VERBOSE)[0];
xmlDocPtr doc;
xmlXPathContextPtr xpathCtx;
xmlXPathObjectPtr nodes;
if(verbose) Rprintf("Processing KGML file: %s",filename);
/* Load XML document */
doc = xmlParseFile(filename);
if (doc == NULL) {
Rf_warningcall(mkChar(filename), "Unable to parse file");
if(verbose) Rprintf(": Error.\n");
return(R_NilValue);
}
/* Check it is a kegg pathway file */
if(doc->intSubset == NULL ||
strcmp( (char *) (doc->intSubset->name), "pathway") != 0 )
//strncmp( (char *) (doc->intSubset->SystemID), "http://www.kegg.jp/kegg/", 24) !=0)
{
Rf_warningcall(mkChar(filename), "File is not KEGG pathway file");
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return(R_NilValue);
}
/* Get pathway information :*/
xmlNodePtr pathway = xmlDocGetRootElement(doc);
if(pathway == NULL || strcmp( (char *) (pathway->name), "pathway") != 0){
Rf_warningcall(mkChar(filename), "No pathways in file");
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return(R_NilValue);
}
const char* pathwayId = get_attr(pathway, "name");
if(!pathwayId){
Rf_warningcall(mkChar(filename), "Pathway ID not found in file. Using file name instead.");
pathwayId = filename;
}else{
pathwayId +=5; //Remove "path:" leading characters//
}
const char* pathwayTitle = get_attr(pathway, "title");
if(!pathwayTitle){
Rf_warningcall(mkChar(pathwayId), "Pathway title not found in file.");
pathwayTitle = "";
}
if(verbose) Rprintf(" \"%s\"",pathwayTitle);
/* Create xpath evaluation context */
xpathCtx = xmlXPathNewContext(doc);
if(xpathCtx == NULL) {
Rf_warningcall(mkChar(filename), "Unable to create new XPath context");
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return(R_NilValue);
}
/* Evaluate xpath expression */
nodes = xmlXPathEvalExpression((xmlChar *) "//reaction", xpathCtx);
if(nodes == NULL || nodes->nodesetval == NULL || nodes->nodesetval->nodeNr == 0) {
Rf_warningcall(mkChar(pathwayId), "Pathway contains no reactions");
xmlXPathFreeContext(xpathCtx);
xmlFreeDoc(doc);
if(verbose) Rprintf(": Error.\n");
return(R_NilValue);
}
/* Parse XML Reactions*/
xmlNodePtr curReaction;
int size;
int i;
size = (nodes->nodesetval) ? nodes->nodesetval->nodeNr : 0;
SEXP REACTIONLIST,ID;
PROTECT(REACTIONLIST = allocVector(VECSXP,size));
PROTECT(ID = allocVector(STRSXP,size));
if(verbose) Rprintf(": %d reactions found.\n",size);
char* temp; //template for string processing
for(i = 0; i < size; ++i) {
curReaction = nodes->nodesetval->nodeTab[i];
xpathCtx->node = curReaction;
const char *name = get_attr(curReaction, "name");
SET_STRING_ELT(ID,i,mkChar(name));
SEXP REACTION,REACTIONNAMES;
SEXP NAME, REVERSIBLE, REACTANTS, RSTOIC, PRODUCTS, PSTOIC, GENES, PATHWAY,
KEGG_PATHWAY, KEGG_REACTION, KEGG_GENES, NCBI_GENE;
PROTECT(REACTION = allocVector(VECSXP,13));
PROTECT(REACTIONNAMES = allocVector(STRSXP,13));
PROTECT(NAME = allocVector(STRSXP,1));
SET_STRING_ELT(NAME,0, mkChar(name));
SET_VECTOR_ELT(REACTION,0,NAME); SET_STRING_ELT(REACTIONNAMES,0,mkChar("name"));
PROTECT(REVERSIBLE = allocVector(LGLSXP,1));
LOGICAL(REVERSIBLE)[0] = strcmp(get_attr(curReaction, "type"), "irreversible") != 0;
SET_VECTOR_ELT(REACTION,1,REVERSIBLE); SET_STRING_ELT(REACTIONNAMES,1,mkChar("reversible"));
//cout << (char *) xmlGetProp(curReaction,(const xmlChar *)"type") <<endl;
xmlNodeSetPtr reactantNodes = xmlXPathEvalExpression( (const xmlChar *) "./substrate", xpathCtx)->nodesetval;
int numOfReactants = (reactantNodes) ? reactantNodes->nodeNr : 0;
PROTECT(REACTANTS = allocVector(STRSXP,numOfReactants));
PROTECT(RSTOIC = allocVector(REALSXP,numOfReactants));
for (int r = 0;r < numOfReactants;r++) {
temp = get_attr(reactantNodes->nodeTab[r], "name");
SET_STRING_ELT(REACTANTS,r,mkChar(temp+4));
REAL(RSTOIC)[r] = NA_REAL;
}
SET_VECTOR_ELT(REACTION,2,REACTANTS); SET_STRING_ELT(REACTIONNAMES,2,mkChar("reactants"));
SET_VECTOR_ELT(REACTION,3,RSTOIC);SET_STRING_ELT(REACTIONNAMES,3,mkChar("reactant.stoichiometry"));
//cout << "Reactant level :|" << endl;
xmlNodeSetPtr productNodes = xmlXPathEvalExpression( (const xmlChar *) "./product", xpathCtx ) ->nodesetval;
int numOfProducts = (productNodes) ? productNodes->nodeNr : 0;
PROTECT(PRODUCTS = allocVector(STRSXP,numOfProducts));
PROTECT(PSTOIC = allocVector(REALSXP,numOfProducts));
for (int p = 0;p < numOfProducts;p++) {
temp = get_attr(productNodes->nodeTab[p], "name");
SET_STRING_ELT(PRODUCTS,p,mkChar(temp+4));
REAL(PSTOIC)[p] = NA_REAL;
}
SET_VECTOR_ELT(REACTION,4,PRODUCTS); SET_STRING_ELT(REACTIONNAMES,4,mkChar("products"));
SET_VECTOR_ELT(REACTION,5,PSTOIC);SET_STRING_ELT(REACTIONNAMES,5,mkChar("product.stoichiometry"));
//cout << "Product level :|" << endl;
SET_VECTOR_ELT(REACTION,6,R_NilValue);SET_STRING_ELT(REACTIONNAMES,6,mkChar("kinetics"));
string geneXPath = ((string)"//entry[@type='gene' and @reaction='")+((string)name)+((string)"']");
xmlNodeSetPtr geneNodes = xmlXPathEvalExpression(
(const xmlChar *) geneXPath.c_str(), xpathCtx ) ->nodesetval;
int numOfModifiers = (geneNodes) ? geneNodes->nodeNr : 0;
vector<string> genes;
for (int m = 0;m < numOfModifiers;m++)
genes = split( get_attr(geneNodes->nodeTab[m], "name"), ' ', genes);
PROTECT(GENES = allocVector(STRSXP,genes.size()));
PROTECT(KEGG_GENES = allocVector(STRSXP,genes.size()));
PROTECT(NCBI_GENE = allocVector(STRSXP,genes.size()));
for(size_t g=0; g<genes.size(); g++){
SET_STRING_ELT(GENES,g, mkChar( genes[g].c_str() ));
SET_STRING_ELT(KEGG_GENES,g, mkChar( genes[g].c_str() ));
SET_STRING_ELT(NCBI_GENE,g, mkChar( genes[g].c_str()+4 ));
}
SET_VECTOR_ELT(REACTION,7,GENES); SET_STRING_ELT(REACTIONNAMES,7,mkChar("genes"));
PROTECT(PATHWAY = allocVector(STRSXP,1));
SET_STRING_ELT(PATHWAY,0,mkChar(pathwayTitle));
SET_VECTOR_ELT(REACTION,8,PATHWAY); SET_STRING_ELT(REACTIONNAMES,8,mkChar("pathway"));
// Set MIRIAM idnetifiers: kegg.pathway, kegg reaction, kegg.compound, kegg.genes, ncbi.gene
PROTECT(KEGG_PATHWAY = allocVector(STRSXP,1));
SET_STRING_ELT(KEGG_PATHWAY,0,mkChar(pathwayId));
SET_VECTOR_ELT(REACTION,9,KEGG_PATHWAY); SET_STRING_ELT(REACTIONNAMES,9,mkChar("miriam.kegg.pathway"));
std::vector<std::string> kegg_reaction = split(name, ' ');
PROTECT(KEGG_REACTION = allocVector(STRSXP, kegg_reaction.size() ));
for(size_t kr=0; kr<kegg_reaction.size(); kr++)
SET_STRING_ELT(KEGG_REACTION,kr, mkChar(kegg_reaction[kr].c_str() +3));
SET_VECTOR_ELT(REACTION,10,KEGG_REACTION); SET_STRING_ELT(REACTIONNAMES,10,mkChar("miriam.kegg.reaction"));
SET_VECTOR_ELT(REACTION,11,KEGG_GENES); SET_STRING_ELT(REACTIONNAMES,11,mkChar("miriam.kegg.genes"));
SET_VECTOR_ELT(REACTION,12,NCBI_GENE); SET_STRING_ELT(REACTIONNAMES,12,mkChar("miriam.ncbigene"));
setAttrib(REACTION,R_NamesSymbol,REACTIONNAMES);
SET_VECTOR_ELT(REACTIONLIST,i,REACTION);
UNPROTECT(14);
}
setAttrib(REACTIONLIST,R_NamesSymbol,ID);
UNPROTECT(2);
/* Cleanup */
xmlXPathFreeObject(nodes);
xmlXPathFreeContext(xpathCtx);
xmlFreeDoc(doc);
//cout << "RacList returns :|" << endl;
return(REACTIONLIST);
}
SEXP transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
