// Copyright (c) 2014 by Contributors #include #include #include #include #include #include #include #include #include #include "./xgboost_R.h" /*! * \brief macro to annotate begin of api */ #define R_API_BEGIN() \ GetRNGstate(); \ try { /*! * \brief macro to annotate end of api */ #define R_API_END() \ } catch(dmlc::Error& e) { \ PutRNGstate(); \ error(e.what()); \ } \ PutRNGstate(); /*! * \brief macro to check the call. */ #define CHECK_CALL(x) \ if ((x) != 0) { \ error(XGBGetLastError()); \ } using namespace dmlc; SEXP XGCheckNullPtr_R(SEXP handle) { return ScalarLogical(R_ExternalPtrAddr(handle) == NULL); } void _DMatrixFinalizer(SEXP ext) { R_API_BEGIN(); if (R_ExternalPtrAddr(ext) == NULL) return; CHECK_CALL(XGDMatrixFree(R_ExternalPtrAddr(ext))); R_ClearExternalPtr(ext); R_API_END(); } SEXP XGDMatrixCreateFromFile_R(SEXP fname, SEXP silent) { SEXP ret; R_API_BEGIN(); DMatrixHandle handle; CHECK_CALL(XGDMatrixCreateFromFile(CHAR(asChar(fname)), asInteger(silent), &handle)); ret = PROTECT(R_MakeExternalPtr(handle, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ret, _DMatrixFinalizer, TRUE); UNPROTECT(1); R_API_END(); return ret; } SEXP XGDMatrixCreateFromMat_R(SEXP mat, SEXP missing) { SEXP ret; R_API_BEGIN(); SEXP dim = getAttrib(mat, R_DimSymbol); size_t nrow = static_cast(INTEGER(dim)[0]); size_t ncol = static_cast(INTEGER(dim)[1]); double *din = REAL(mat); std::vector data(nrow * ncol); #pragma omp parallel for schedule(static) for (omp_ulong i = 0; i < nrow; ++i) { for (size_t j = 0; j < ncol; ++j) { data[i * ncol +j] = din[i + nrow * j]; } } DMatrixHandle handle; CHECK_CALL(XGDMatrixCreateFromMat(BeginPtr(data), nrow, ncol, asReal(missing), &handle)); ret = PROTECT(R_MakeExternalPtr(handle, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ret, _DMatrixFinalizer, TRUE); UNPROTECT(1); R_API_END(); return ret; } SEXP XGDMatrixCreateFromCSC_R(SEXP indptr, SEXP indices, SEXP data) { SEXP ret; R_API_BEGIN(); const int *p_indptr = INTEGER(indptr); const int *p_indices = INTEGER(indices); const double *p_data = REAL(data); int nindptr = length(indptr); int ndata = length(data); std::vector col_ptr_(nindptr); std::vector indices_(ndata); std::vector data_(ndata); for (int i = 0; i < nindptr; ++i) { col_ptr_[i] = static_cast(p_indptr[i]); } #pragma omp parallel for schedule(static) for (int i = 0; i < ndata; ++i) { indices_[i] = static_cast(p_indices[i]); data_[i] = static_cast(p_data[i]); } DMatrixHandle handle; CHECK_CALL(XGDMatrixCreateFromCSC(BeginPtr(col_ptr_), BeginPtr(indices_), BeginPtr(data_), nindptr, ndata, &handle)); ret = PROTECT(R_MakeExternalPtr(handle, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ret, _DMatrixFinalizer, TRUE); UNPROTECT(1); R_API_END(); return ret; } SEXP XGDMatrixSliceDMatrix_R(SEXP handle, SEXP idxset) { SEXP ret; R_API_BEGIN(); int len = length(idxset); std::vector idxvec(len); for (int i = 0; i < len; ++i) { idxvec[i] = INTEGER(idxset)[i] - 1; } DMatrixHandle res; CHECK_CALL(XGDMatrixSliceDMatrix(R_ExternalPtrAddr(handle), BeginPtr(idxvec), len, &res)); ret = PROTECT(R_MakeExternalPtr(res, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ret, _DMatrixFinalizer, TRUE); UNPROTECT(1); R_API_END(); return ret; } void XGDMatrixSaveBinary_R(SEXP handle, SEXP fname, SEXP silent) { R_API_BEGIN(); CHECK_CALL(XGDMatrixSaveBinary(R_ExternalPtrAddr(handle), CHAR(asChar(fname)), asInteger(silent))); R_API_END(); } void XGDMatrixSetInfo_R(SEXP handle, SEXP field, SEXP array) { R_API_BEGIN(); int len = length(array); const char *name = CHAR(asChar(field)); if (!strcmp("group", name)) { std::vector vec(len); #pragma omp parallel for schedule(static) for (int i = 0; i < len; ++i) { vec[i] = static_cast(INTEGER(array)[i]); } CHECK_CALL(XGDMatrixSetGroup(R_ExternalPtrAddr(handle), BeginPtr(vec), len)); } else { std::vector vec(len); #pragma omp parallel for schedule(static) for (int i = 0; i < len; ++i) { vec[i] = REAL(array)[i]; } CHECK_CALL(XGDMatrixSetFloatInfo(R_ExternalPtrAddr(handle), CHAR(asChar(field)), BeginPtr(vec), len)); } R_API_END(); } SEXP XGDMatrixGetInfo_R(SEXP handle, SEXP field) { SEXP ret; R_API_BEGIN(); bst_ulong olen; const float *res; CHECK_CALL(XGDMatrixGetFloatInfo(R_ExternalPtrAddr(handle), CHAR(asChar(field)), &olen, &res)); ret = PROTECT(allocVector(REALSXP, olen)); for (size_t i = 0; i < olen; ++i) { REAL(ret)[i] = res[i]; } UNPROTECT(1); R_API_END(); return ret; } SEXP XGDMatrixNumRow_R(SEXP handle) { bst_ulong nrow; R_API_BEGIN(); CHECK_CALL(XGDMatrixNumRow(R_ExternalPtrAddr(handle), &nrow)); R_API_END(); return ScalarInteger(static_cast(nrow)); } // functions related to booster void _BoosterFinalizer(SEXP ext) { if (R_ExternalPtrAddr(ext) == NULL) return; CHECK_CALL(XGBoosterFree(R_ExternalPtrAddr(ext))); R_ClearExternalPtr(ext); } SEXP XGBoosterCreate_R(SEXP dmats) { SEXP ret; R_API_BEGIN(); int len = length(dmats); std::vector dvec; for (int i = 0; i < len; ++i) { dvec.push_back(R_ExternalPtrAddr(VECTOR_ELT(dmats, i))); } BoosterHandle handle; CHECK_CALL(XGBoosterCreate(BeginPtr(dvec), dvec.size(), &handle)); ret = PROTECT(R_MakeExternalPtr(handle, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ret, _BoosterFinalizer, TRUE); UNPROTECT(1); R_API_END(); return ret; } void XGBoosterSetParam_R(SEXP handle, SEXP name, SEXP val) { R_API_BEGIN(); CHECK_CALL(XGBoosterSetParam(R_ExternalPtrAddr(handle), CHAR(asChar(name)), CHAR(asChar(val)))); R_API_END(); } void XGBoosterUpdateOneIter_R(SEXP handle, SEXP iter, SEXP dtrain) { R_API_BEGIN(); CHECK_CALL(XGBoosterUpdateOneIter(R_ExternalPtrAddr(handle), asInteger(iter), R_ExternalPtrAddr(dtrain))); R_API_END(); } void XGBoosterBoostOneIter_R(SEXP handle, SEXP dtrain, SEXP grad, SEXP hess) { R_API_BEGIN(); CHECK_EQ(length(grad), length(hess)) << "gradient and hess must have same length"; int len = length(grad); std::vector tgrad(len), thess(len); #pragma omp parallel for schedule(static) for (int j = 0; j < len; ++j) { tgrad[j] = REAL(grad)[j]; thess[j] = REAL(hess)[j]; } CHECK_CALL(XGBoosterBoostOneIter(R_ExternalPtrAddr(handle), R_ExternalPtrAddr(dtrain), BeginPtr(tgrad), BeginPtr(thess), len)); R_API_END(); } SEXP XGBoosterEvalOneIter_R(SEXP handle, SEXP iter, SEXP dmats, SEXP evnames) { const char *ret; R_API_BEGIN(); CHECK_EQ(length(dmats), length(evnames)) << "dmats and evnams must have same length"; int len = length(dmats); std::vector vec_dmats; std::vector vec_names; std::vector vec_sptr; for (int i = 0; i < len; ++i) { vec_dmats.push_back(R_ExternalPtrAddr(VECTOR_ELT(dmats, i))); vec_names.push_back(std::string(CHAR(asChar(VECTOR_ELT(evnames, i))))); } for (int i = 0; i < len; ++i) { vec_sptr.push_back(vec_names[i].c_str()); } CHECK_CALL(XGBoosterEvalOneIter(R_ExternalPtrAddr(handle), asInteger(iter), BeginPtr(vec_dmats), BeginPtr(vec_sptr), len, &ret)); R_API_END(); return mkString(ret); } SEXP XGBoosterPredict_R(SEXP handle, SEXP dmat, SEXP option_mask, SEXP ntree_limit) { SEXP ret; R_API_BEGIN(); bst_ulong olen; const float *res; CHECK_CALL(XGBoosterPredict(R_ExternalPtrAddr(handle), R_ExternalPtrAddr(dmat), asInteger(option_mask), asInteger(ntree_limit), &olen, &res)); ret = PROTECT(allocVector(REALSXP, olen)); for (size_t i = 0; i < olen; ++i) { REAL(ret)[i] = res[i]; } UNPROTECT(1); R_API_END(); return ret; } void XGBoosterLoadModel_R(SEXP handle, SEXP fname) { R_API_BEGIN(); CHECK_CALL(XGBoosterLoadModel(R_ExternalPtrAddr(handle), CHAR(asChar(fname)))); R_API_END(); } void XGBoosterSaveModel_R(SEXP handle, SEXP fname) { R_API_BEGIN(); CHECK_CALL(XGBoosterSaveModel(R_ExternalPtrAddr(handle), CHAR(asChar(fname)))); R_API_END(); } void XGBoosterLoadModelFromRaw_R(SEXP handle, SEXP raw) { R_API_BEGIN(); CHECK_CALL(XGBoosterLoadModelFromBuffer(R_ExternalPtrAddr(handle), RAW(raw), length(raw))); R_API_END(); } SEXP XGBoosterModelToRaw_R(SEXP handle) { SEXP ret; R_API_BEGIN(); bst_ulong olen; const char *raw; CHECK_CALL(XGBoosterGetModelRaw(R_ExternalPtrAddr(handle), &olen, &raw)); ret = PROTECT(allocVector(RAWSXP, olen)); if (olen != 0) { memcpy(RAW(ret), raw, olen); } UNPROTECT(1); R_API_END(); return ret; } SEXP XGBoosterDumpModel_R(SEXP handle, SEXP fmap, SEXP with_stats) { SEXP out; R_API_BEGIN(); bst_ulong olen; const char **res; CHECK_CALL(XGBoosterDumpModel(R_ExternalPtrAddr(handle), CHAR(asChar(fmap)), asInteger(with_stats), &olen, &res)); out = PROTECT(allocVector(STRSXP, olen)); for (size_t i = 0; i < olen; ++i) { std::stringstream stream; stream << "booster[" << i <<"]\n" << res[i]; SET_STRING_ELT(out, i, mkChar(stream.str().c_str())); } UNPROTECT(1); R_API_END(); return out; }