static bool EvalAllowedFunc(void) { if(AllowedFuncGlobal == NULL) error("EvalAllowedFunc: AllowedFuncGlobal == NULL"); SEXP s = eval(AllowedFuncGlobal, AllowedEnvGlobal); bool allowed; switch(TYPEOF(s)) { // be fairly permissive with return type case LGLSXP: allowed = (bool)(LOGICAL(s)[0] != 0); break; case INTSXP: allowed = INTEGER(s)[0] != 0; break; case REALSXP: allowed = (bool)(REAL(s)[0] != 0.); break; default: error("the \"allowed\" function returned a %s instead of a logical", Rf_type2char(TYPEOF(s))); allowed = FALSE; // -Wall break; } if(LENGTH(s) != 1) error("the \"allowed\" function did not return a logical of length 1"); return allowed; }
int find_offset(SEXP x, SEXP index, int i) { if (!Rf_isVector(index) || Rf_length(index) != 1) Rf_errorcall(R_NilValue, "Index %i is not a length 1 vector", i + 1); int n = Rf_length(x); if (TYPEOF(index) == INTSXP) { int val = INTEGER(index)[0]; if (val == NA_INTEGER) return -1; val--; if (val < 0 || val >= n) return -1; return val; } if (TYPEOF(index) == REALSXP) { double val = REAL(index)[0]; if (!R_finite(val)) return -1; val--; if (val < 0 || val >= n) return -1; return val; } else if (TYPEOF(index) == STRSXP) { SEXP names = Rf_getAttrib(x, R_NamesSymbol); if (names == R_NilValue) // vector doesn't have names return -1; if (STRING_ELT(index, 0) == NA_STRING) return -1; const char* val = Rf_translateCharUTF8(STRING_ELT(index, 0)); if (val[0] == '\0') // "" matches nothing return -1; for (int j = 0; j < Rf_length(names); ++j) { if (STRING_ELT(names, j) == NA_STRING) continue; const char* names_j = Rf_translateCharUTF8(STRING_ELT(names, j)); if (strcmp(names_j, val) == 0) return j; } return -1; } else { Rf_errorcall(R_NilValue, "Don't know how to index with object of type %s at level %i", Rf_type2char(TYPEOF(index)), i + 1 ); } }
SEXP extract_impl(SEXP x, SEXP index, SEXP missing) { if (!Rf_isVector(x)) { Rf_errorcall(R_NilValue, "`x` must be a vector (not a %s)", Rf_type2char(TYPEOF(x))); } if (TYPEOF(index) != VECSXP) { Rf_errorcall(R_NilValue, "`index` must be a vector (not a %s)", Rf_type2char(TYPEOF(index))); } int n = Rf_length(index); for (int i = 0; i < n; ++i) { SEXP index_i = VECTOR_ELT(index, i); int offset = find_offset(x, index_i, i); if (offset < 0) return missing; switch(TYPEOF(x)) { case NILSXP: return missing; case LGLSXP: x = Rf_ScalarLogical(LOGICAL(x)[offset]); break; case INTSXP: x = Rf_ScalarInteger(INTEGER(x)[offset]); break; case REALSXP: x = Rf_ScalarReal(REAL(x)[offset]); break; case STRSXP: x = Rf_ScalarString(STRING_ELT(x, offset)); break; case VECSXP: x = VECTOR_ELT(x, offset); break; default: Rf_errorcall(R_NilValue, "Don't know how to index object of type %s at level %i", Rf_type2char(TYPEOF(x)), i + 1 ); } } return x; }
SEXP getListElement(SEXP list, const char *str) { /* Given a R list and a character string, will return the */ /* element of the list which has the name that corresponds to the */ /* string */ SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); int i; if (names == R_NilValue) error("Attribute vectors must have names"); for (i = 0; i < length(list); i++) { if (strcmp(CHAR(STRING_ELT(names,i)), str) == 0) { if (TYPEOF(list) == VECSXP) elmt = VECTOR_ELT(list, i); else error("expecting VECSXP, got %s", Rf_type2char(TYPEOF(list))); break; } } return(elmt); }
const char* objtype(SEXP x) { return Rf_type2char(TYPEOF(x)); }
void ifaGroup::import(SEXP Rlist) { SEXP argNames; Rf_protect(argNames = Rf_getAttrib(Rlist, R_NamesSymbol)); if (Rf_length(Rlist) != Rf_length(argNames)) { mxThrow("All list elements must be named"); } std::vector<const char *> dataColNames; paramRows = -1; int pmatCols=-1; int mips = 1; int dataRows = 0; SEXP Rmean=0, Rcov=0; for (int ax=0; ax < Rf_length(Rlist); ++ax) { const char *key = R_CHAR(STRING_ELT(argNames, ax)); SEXP slotValue = VECTOR_ELT(Rlist, ax); if (strEQ(key, "spec")) { importSpec(slotValue); } else if (strEQ(key, "param")) { if (!Rf_isReal(slotValue)) mxThrow("'param' must be a numeric matrix of item parameters"); param = REAL(slotValue); getMatrixDims(slotValue, ¶mRows, &pmatCols); SEXP dimnames; Rf_protect(dimnames = Rf_getAttrib(slotValue, R_DimNamesSymbol)); if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) { SEXP names; Rf_protect(names = VECTOR_ELT(dimnames, 0)); int nlen = Rf_length(names); factorNames.resize(nlen); for (int nx=0; nx < nlen; ++nx) { factorNames[nx] = CHAR(STRING_ELT(names, nx)); } Rf_protect(names = VECTOR_ELT(dimnames, 1)); nlen = Rf_length(names); itemNames.resize(nlen); for (int nx=0; nx < nlen; ++nx) { itemNames[nx] = CHAR(STRING_ELT(names, nx)); } } } else if (strEQ(key, "mean")) { Rmean = slotValue; if (!Rf_isReal(slotValue)) mxThrow("'mean' must be a numeric vector or matrix"); mean = REAL(slotValue); } else if (strEQ(key, "cov")) { Rcov = slotValue; if (!Rf_isReal(slotValue)) mxThrow("'cov' must be a numeric matrix"); cov = REAL(slotValue); } else if (strEQ(key, "data")) { Rdata = slotValue; dataRows = Rf_length(VECTOR_ELT(Rdata, 0)); SEXP names; Rf_protect(names = Rf_getAttrib(Rdata, R_NamesSymbol)); int nlen = Rf_length(names); dataColNames.reserve(nlen); for (int nx=0; nx < nlen; ++nx) { dataColNames.push_back(CHAR(STRING_ELT(names, nx))); } Rf_protect(dataRowNames = Rf_getAttrib(Rdata, R_RowNamesSymbol)); } else if (strEQ(key, "weightColumn")) { if (Rf_length(slotValue) != 1) { mxThrow("You can only have one %s", key); } weightColumnName = CHAR(STRING_ELT(slotValue, 0)); } else if (strEQ(key, "freqColumn")) { if (Rf_length(slotValue) != 1) { mxThrow("You can only have one %s", key); } freqColumnName = CHAR(STRING_ELT(slotValue, 0)); } else if (strEQ(key, "qwidth")) { qwidth = Rf_asReal(slotValue); } else if (strEQ(key, "qpoints")) { qpoints = Rf_asInteger(slotValue); } else if (strEQ(key, "minItemsPerScore")) { mips = Rf_asInteger(slotValue); } else { // ignore } } learnMaxAbilities(); if (itemDims < (int) factorNames.size()) factorNames.resize(itemDims); if (int(factorNames.size()) < itemDims) { factorNames.reserve(itemDims); const int SMALLBUF = 24; char buf[SMALLBUF]; while (int(factorNames.size()) < itemDims) { snprintf(buf, SMALLBUF, "s%d", int(factorNames.size()) + 1); factorNames.push_back(CHAR(Rf_mkChar(buf))); } } if (Rmean) { if (Rf_isMatrix(Rmean)) { int nrow, ncol; getMatrixDims(Rmean, &nrow, &ncol); if (!(nrow * ncol == itemDims && (nrow==1 || ncol==1))) { mxThrow("mean must be a column or row matrix of length %d", itemDims); } } else { if (Rf_length(Rmean) != itemDims) { mxThrow("mean must be a vector of length %d", itemDims); } } verifyFactorNames(Rmean, "mean"); } if (Rcov) { if (Rf_isMatrix(Rcov)) { int nrow, ncol; getMatrixDims(Rcov, &nrow, &ncol); if (nrow != itemDims || ncol != itemDims) { mxThrow("cov must be %dx%d matrix", itemDims, itemDims); } } else { if (Rf_length(Rcov) != 1) { mxThrow("cov must be %dx%d matrix", itemDims, itemDims); } } verifyFactorNames(Rcov, "cov"); } setLatentDistribution(mean, cov); setMinItemsPerScore(mips); if (numItems() != pmatCols) { mxThrow("item matrix implies %d items but spec is length %d", pmatCols, numItems()); } if (Rdata) { if (itemNames.size() == 0) mxThrow("Item matrix must have colnames"); for (int ix=0; ix < numItems(); ++ix) { bool found=false; for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(itemNames[ix], dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (!Rf_isFactor(col)) { if (TYPEOF(col) == INTSXP) { mxThrow("Column '%s' is an integer but " "not an ordered factor", dataColNames[dc]); } else { mxThrow("Column '%s' is of type %s; expecting an " "ordered factor (integer)", dataColNames[dc], Rf_type2char(TYPEOF(col))); } } dataColumns.push_back(INTEGER(col)); found=true; break; } } if (!found) { mxThrow("Cannot find item '%s' in data", itemNames[ix]); } } if (weightColumnName) { for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(weightColumnName, dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (TYPEOF(col) != REALSXP) { mxThrow("Column '%s' is of type %s; expecting type numeric (double)", dataColNames[dc], Rf_type2char(TYPEOF(col))); } rowWeight = REAL(col); break; } } if (!rowWeight) { mxThrow("Cannot find weight column '%s'", weightColumnName); } } if (freqColumnName) { for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(freqColumnName, dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (TYPEOF(col) != INTSXP) { mxThrow("Column '%s' is of type %s; expecting type integer", dataColNames[dc], Rf_type2char(TYPEOF(col))); } rowFreq = INTEGER(col); break; } } if (!rowFreq) { mxThrow("Cannot find frequency column '%s'", freqColumnName); } } rowMap.reserve(dataRows); for (int rx=0; rx < dataRows; ++rx) rowMap.push_back(rx); } Eigen::Map< Eigen::ArrayXXd > Eparam(param, paramRows, numItems()); Eigen::Map< Eigen::VectorXd > meanVec(mean, itemDims); Eigen::Map< Eigen::MatrixXd > covMat(cov, itemDims, itemDims); quad.setStructure(qwidth, qpoints, Eparam, meanVec, covMat); if (paramRows < impliedParamRows) { mxThrow("At least %d rows are required in the item parameter matrix, only %d found", impliedParamRows, paramRows); } quad.refresh(meanVec, covMat); }
SEXP R_export2dataset(SEXP path, SEXP dataframe, SEXP shape, SEXP shape_info) { std::wstring dataset_name; tools::copy_to(path, dataset_name); struct _cleanup { typedef std::vector<cols_base*> c_type; std::vector<std::wstring> name; c_type c; ~_cleanup() { for (size_t i = 0, n = c.size(); i < n; i++) delete c[i]; } }cols; shape_extractor extractor; bool isShape = extractor.init(shape, shape_info) == S_OK; tools::getNames(dataframe, cols.name); R_xlen_t nlen = 0; ATLTRACE("dataframe type:%s", Rf_type2char(TYPEOF(dataframe))); if (Rf_isVectorList(dataframe)) { size_t k = tools::size(dataframe); ATLASSERT(cols.name.size() == k); cols.name.resize(k); for (size_t i = 0; i < k; i++) { nlen = std::max(nlen, tools::size(VECTOR_ELT(dataframe, i))); if (cols.name[i].empty()) cols.name[i] = L"data"; } } else { if (Rf_isNull(dataframe)) nlen = extractor.size(); else return showError<false>("unsupported datat type"), R_NilValue; } if (nlen == 0) return showError<false>("nothing to save: 0 length"), R_NilValue; if (isShape && nlen != extractor.size() ) Rf_warning("length of shape != data.frame length"); //return showError<false>("length of shape != data.frame"), R_NilValue; std::unique_ptr<arcobject::cursor> acur(arcobject::create_insert_cursor(dataset_name, extractor.geometry_info())); if (acur.get() == NULL) return showError<true>(), R_NilValue; arcobject::cursor* cur = acur.get(); for (size_t i = 0; i < cols.name.size(); i++) { ATLASSERT(!cols.name[i].empty()); SEXP it = VECTOR_ELT(dataframe, i); bool skip = false; if (isShape)//if(gt == esriGeometryPolygon || gt == esriGeometryLine) { skip = cols.name[i] == L"Shape_Area"; skip = !skip ? cols.name[i] == L"Shape_Length" : true; } if (!skip) { cols_base* item = setup_field(cur, it, cols.name[i]); if (!item) Rf_warning("unsupported data.field column type");//return showError<false>(L"unsupported data.field column type"), R_NilValue; else cols.c.push_back(item); } } if (!cur->begin()) return showError<true>(), R_NilValue; for (R_xlen_t i = 0; i < nlen; i++) { //ATLTRACE("\n"); for (const auto &c : cols.c) { if (c->pos < 0) continue; CComVariant val; c->get(i, val); if (!cur->setValue(c->pos, val)) return showError<true>("insert row value failed"), R_NilValue; } if (isShape) { if (extractor.isPoints()) cur->set_point(extractor.getPoint(i)); else cur->set_shape(extractor.getShape(i)); } if (!cur->next()) return showError<true>("insert row failed"), R_NilValue; } cur->commit(); return R_NilValue; }
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; }
Result* nth_prototype(SEXP call, const ILazySubsets& subsets, int nargs) { // has to have at least two arguments if (nargs < 2) return 0; SEXP tag = TAG(CDR(call)); if (tag != R_NilValue && tag != Rf_install("x")) { stop("the first argument of 'nth' should be either 'x' or unnamed"); } SEXP data = CADR(call); if (TYPEOF(data) == SYMSXP) { if (! subsets.count(data)) { stop("could not find variable '%s'", CHAR(PRINTNAME(data))); } data = subsets.get_variable(data); } tag = TAG(CDDR(call)); if (tag != R_NilValue && tag != Rf_install("n")) { stop("the second argument of 'first' should be either 'n' or unnamed"); } SEXP nidx = CADDR(call); if ((TYPEOF(nidx) != REALSXP && TYPEOF(nidx) != INTSXP) || LENGTH(nidx) != 1) { // we only know how to handle the case where nidx is a length one // integer or numeric. In any other case, e.g. an expression for R to evaluate // we just fallback to R evaluation (#734) return 0; } int idx = as<int>(nidx); // easy case : just a single variable: first(x,n) if (nargs == 2) { switch (TYPEOF(data)) { case INTSXP: return new Nth<INTSXP>(data, idx); case REALSXP: return new Nth<REALSXP>(data, idx); case STRSXP: return new Nth<STRSXP>(data, idx); case LGLSXP: return new Nth<LGLSXP>(data, idx); default: break; } } else { // now get `order_by` and default SEXP order_by = R_NilValue; SEXP def = R_NilValue; SEXP p = CDR(CDDR(call)); while (p != R_NilValue) { SEXP tag = TAG(p); if (tag == R_NilValue) stop("all arguments of 'first' after the first one should be named"); std::string argname = CHAR(PRINTNAME(tag)); if (argmatch("order_by", argname)) { order_by = CAR(p); } else if (argmatch("default", argname)) { def = CAR(p); } else { stop("argument to 'first' does not match either 'default' or 'order_by' "); } p = CDR(p); } // handle cases if (def == R_NilValue) { // then we know order_by is not NULL, we only handle the case where // order_by is a symbol and that symbol is in the data if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) { order_by = subsets.get_variable(order_by); switch (TYPEOF(data)) { case LGLSXP: return nth_with<LGLSXP>(data, idx, order_by); case INTSXP: return nth_with<INTSXP>(data, idx, order_by); case REALSXP: return nth_with<REALSXP>(data, idx, order_by); case STRSXP: return nth_with<STRSXP>(data, idx, order_by); default: break; } } else { return 0; } } else { if (order_by == R_NilValue) { switch (TYPEOF(data)) { case LGLSXP: return nth_noorder_default<LGLSXP>(data, idx, def); case INTSXP: return nth_noorder_default<INTSXP>(data, idx, def); case REALSXP: return nth_noorder_default<REALSXP>(data, idx, def); case STRSXP: return nth_noorder_default<STRSXP>(data, idx, def); default: break; } } else { if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) { order_by = subsets.get_variable(order_by); switch (TYPEOF(data)) { case LGLSXP: return nth_with_default<LGLSXP>(data, idx, order_by, def); case INTSXP: return nth_with_default<INTSXP>(data, idx, order_by, def); case REALSXP: return nth_with_default<REALSXP>(data, idx, order_by, def); case STRSXP: return nth_with_default<STRSXP>(data, idx, order_by, def); default: break; } } else { return 0; } } } } stop("Unsupported vector type %s", Rf_type2char(TYPEOF(data))); return 0; }
SEXP R_export2dataset(SEXP path, SEXP dataframe, SEXP shape, SEXP shape_info) { std::wstring dataset_name; tools::copy_to(path, dataset_name); struct _cleanup { typedef std::vector<cols_base*> c_type; std::vector<std::wstring> name; c_type c; //std::vector<c_type::const_iterator> shape; c_type shape; ~_cleanup() { for (size_t i = 0; i < c.size(); i++) delete c[i]; for (size_t i = 0; i < shape.size(); i++) delete shape[i]; } }cols; shape_extractor extractor; bool isShape = extractor.init(shape, shape_info) == S_OK; //SEXP sinfo = Rf_getAttrib(shape, Rf_mkChar("shape_info")); //cols.name = df.attr("names"); tools::getNames(dataframe, cols.name); //tools::vectorGeneric shape_info(sinfo); //std::string gt_type; //tools::copy_to(shape_info.at("type"), gt_type); esriGeometryType gt = extractor.type();//str2geometryType(gt_type.c_str()); R_xlen_t n = 0; ATLTRACE("dataframe type:%s", Rf_type2char(TYPEOF(dataframe))); if (Rf_isVectorList(dataframe)) { size_t k = tools::size(dataframe); cols.name.resize(k); for (size_t i = 0; i < k; i++) { n = std::max(n, tools::size(VECTOR_ELT(dataframe, (R_xlen_t)i))); if (cols.name[i].empty()) cols.name[i] = L"data"; } } else { n = tools::size(dataframe); ATLASSERT(cols.name.empty()); } if (isShape == false && n == 0) return showError<false>(L"nothing to save"), R_NilValue; if (isShape && n != extractor.size() ) return showError<false>(L"length of shape != data.frame"), R_NilValue; CComPtr<IGPUtilities> ipDEUtil; if (ipDEUtil.CoCreateInstance(CLSID_GPUtilities) != S_OK) return showError<true>(L"IDEUtilitiesImpl - CoCreateInstance has failed"), R_NilValue; HRESULT hr = 0; CComPtr<IName> ipName; if (isShape) hr = ipDEUtil->CreateFeatureClassName(CComBSTR(dataset_name.c_str()), &ipName); else hr = ipDEUtil->CreateTableName(CComBSTR(dataset_name.c_str()), &ipName); CComQIPtr<IDatasetName> ipDatasetName(ipName); CComPtr<IWorkspaceName> ipWksName; CComQIPtr<IWorkspace> ipWks; if (hr == S_OK) hr = ipDatasetName->get_WorkspaceName(&ipWksName); if (hr == S_OK) { CComPtr<IUnknown> ipUnk; hr = CComQIPtr<IName>(ipWksName)->Open(&ipUnk); ipWks = ipUnk; } if (hr != S_OK) return showError<true>(L"invalid table name"), R_NilValue; CComQIPtr<IFeatureWorkspace> ipFWKS(ipWks); ATLASSERT(ipFWKS); if (!ipFWKS) return showError<true>(L"not a FeatureWorkspace"), R_NilValue; CComBSTR bstrTableName; ipDatasetName->get_Name(&bstrTableName); CComPtr<IFieldsEdit> ipFields; hr = ipFields.CoCreateInstance(CLSID_Fields); if (hr != S_OK) return showError<true>(L"CoCreateInstance"), R_NilValue; createField(NULL, esriFieldTypeOID, ipFields); CComPtr<ISpatialReference> ipSR; if (isShape) { long pos = createField(NULL, esriFieldTypeGeometry, ipFields); CComPtr<IGeometryDef> ipGeoDef; CComPtr<IField> ipField; ipFields->get_Field(pos, &ipField); ipField->get_GeometryDef(&ipGeoDef); CComQIPtr<IGeometryDefEdit> ipGeoDefEd(ipGeoDef); ipGeoDefEd->put_GeometryType(gt); ipGeoDefEd->putref_SpatialReference(extractor.sr()); } if (cols.name.empty()) { cols.name.push_back(L"data"); cols_base* item = setup_field(ipFields, dataframe, cols.name[0].c_str()); if (!item) return showError<false>(L"unsupported datat.field column type"), NULL; cols.c.push_back(item); item->name_ref = &cols.name[0]; } else for (size_t i = 0; i < cols.name.size(); i++) { if (cols.name[i].empty()) continue; const wchar_t* str = cols.name[i].c_str(); SEXP it = VECTOR_ELT(dataframe, (R_len_t)i); cols_base* item = setup_field(ipFields, it, str); if (!item) return showError<false>(L"unsupported datat.field column type"), NULL; cols.c.push_back(item); item->name_ref = &cols.name[i]; } CComPtr<IFieldChecker> ipFieldChecker; ipFieldChecker.CoCreateInstance(CLSID_FieldChecker); if (ipFieldChecker) { ipFieldChecker->putref_ValidateWorkspace(ipWks); long error = 0; //fix fields names CComPtr<IFields> ipFixedFields; CComPtr<IEnumFieldError> ipEError; hr = ipFieldChecker->Validate(ipFields, &ipEError, &ipFixedFields); if (hr != S_OK) return showError<true>(L"validate fields failed"), NULL; if (ipFixedFields) { ipFields = ipFixedFields; for (size_t c = 0; c < cols.c.size(); c++) { CComPtr<IField> ipFixedField; ipFixedFields->get_Field(cols.c[c]->pos, &ipFixedField); _bstr_t name; ipFixedField->get_Name(name.GetAddress()); cols.c[c]->name_ref->assign(name); } } } CComPtr<IUID> ipUID; ipUID.CoCreateInstance(CLSID_UID); if (ipUID) { OLECHAR buf[256]; ::StringFromGUID2(isShape ? CLSID_Feature : CLSID_Row, buf, 256); ipUID->put_Value(CComVariant(buf)); } CComQIPtr<ITable> ipTableNew; CComBSTR keyword(L""); hr = E_FAIL; if (isShape) { CComPtr<IFeatureClass> ipFClass; hr = ipFWKS->CreateFeatureClass(bstrTableName, ipFields, ipUID, 0, esriFTSimple, CComBSTR(L"Shape"), keyword, &ipFClass); ipTableNew = ipFClass; } else { hr = ipFWKS->CreateTable(bstrTableName, ipFields, ipUID, 0, keyword, &ipTableNew); } if (hr != S_OK) { std::wstring err_txt(isShape ? L"Create FeatureClass :" : L"Create Table :"); err_txt += bstrTableName; err_txt += L" has failed"; return showError<true>(err_txt.c_str()), R_NilValue; } CComVariant oid; CComPtr<ICursor> ipCursor; CComPtr<IRowBuffer> ipRowBuffer; hr = ipTableNew->Insert(VARIANT_TRUE, &ipCursor); if (hr != S_OK) return showError<true>(L"Insert cursor failed"), R_NilValue; hr = ipTableNew->CreateRowBuffer(&ipRowBuffer); if (hr != S_OK) return showError<true>(L"Insert cursor failed"), R_NilValue; //re-map fields CComPtr<IFields> ipRealFields; ipCursor->get_Fields(&ipRealFields); for (size_t c = 0; c < cols.c.size(); c++) { ipRealFields->FindField(CComBSTR(cols.c[c]->name_ref->c_str()), &(cols.c[c]->pos)); CComPtr<IField> ipField; ipRealFields->get_Field(cols.c[c]->pos, &ipField); VARIANT_BOOL b = VARIANT_FALSE; ipField->get_IsNullable(&b); if (b == VARIANT_FALSE) { esriFieldType ft = esriFieldTypeInteger; ipField->get_Type(&ft); switch(ft) { case esriFieldTypeInteger: cols.c[c]->vNULL = 0;//std::numeric_limits<int>::min(); break; case esriFieldTypeDouble: cols.c[c]->vNULL = 0.0;//-std::numeric_limits<double>::max(); break; case esriFieldTypeString: cols.c[c]->vNULL = L""; } } } CComQIPtr<IFeatureBuffer> ipFBuffer(ipRowBuffer); for (R_len_t i = 0; i < n; i++) { //ATLTRACE("\n"); for (size_t c = 0; c < cols.c.size(); c++) { if (cols.c[c]->pos < 0) continue; CComVariant val; cols.c[c]->get(i, val); if (val.vt == VT_NULL) hr = ipRowBuffer->put_Value(cols.c[c]->pos, cols.c[c]->vNULL); else hr = ipRowBuffer->put_Value(cols.c[c]->pos, val); if (FAILED(hr)) return showError<true>(L"insert row value failed"), R_NilValue; } VARIANT oid; if (isShape) { ATLASSERT(ipFBuffer); CComQIPtr<IGeometry> ipNewShape; hr = extractor.at(i, &ipNewShape); if (hr != S_OK) return R_NilValue; hr = ipFBuffer->putref_Shape(ipNewShape); if (FAILED(hr)) return showError<true>(L"insert shape failed"), R_NilValue; } hr = ipCursor->InsertRow(ipRowBuffer, &oid); if (hr != S_OK) return showError<true>(L"insert row failed"), R_NilValue; } return R_NilValue; }