/* .Internal(identical(..)) */
SEXP attribute_hidden do_identical(SEXP call, SEXP op, SEXP args, SEXP env)
{
int num_eq = 1, single_NA = 1, attr_as_set = 1, ignore_bytecode = 1, nargs = length(args), flags;
/* avoid problems with earlier (and future) versions captured in S4 methods */
/* checkArity(op, args); */
if (nargs < 5)
error("%d arguments passed to .Internal(%s) which requires %d",
length(args), PRIMNAME(op), PRIMARITY(op));
if (nargs >= 5) {
num_eq = asLogical(CADDR(args));
single_NA = asLogical(CADDDR(args));
attr_as_set = asLogical(CAD4R(args));
}
if (nargs >= 6)
ignore_bytecode = asLogical(CAD4R(CDR(args)));
if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");
if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");
if(attr_as_set == NA_LOGICAL) error(_("invalid '%s' value"), "attrib.as.set");
if(ignore_bytecode == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.bytecode");
flags = (num_eq ? 0 : 1) + (single_NA ? 0 : 2) + (attr_as_set ? 0 : 4) + (ignore_bytecode ? 0 : 8);
return ScalarLogical(R_compute_identical(CAR(args), CADR(args), flags));
}
SEXP CatBoostCreateFromFile_R(SEXP poolFileParam,
SEXP cdFileParam,
SEXP pairsFileParam,
SEXP delimiterParam,
SEXP hasHeaderParam,
SEXP threadCountParam,
SEXP verboseParam) {
SEXP result = NULL;
R_API_BEGIN();
TPoolPtr poolPtr = std::make_unique<TPool>();
ReadPool(CHAR(asChar(cdFileParam)),
CHAR(asChar(poolFileParam)),
CHAR(asChar(pairsFileParam)),
asInteger(threadCountParam),
asLogical(verboseParam),
CHAR(asChar(delimiterParam))[0],
asLogical(hasHeaderParam),
TVector<TString>(),
poolPtr.get());
result = PROTECT(R_MakeExternalPtr(poolPtr.get(), R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(result, _Finalizer<TPoolHandle>, TRUE);
poolPtr.release();
R_API_END();
UNPROTECT(1);
return result;
}
/* to bu used for all three: '%*%', crossprod() and tcrossprod() */
SEXP dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans)
{
/* Because a must be square, the size of the answer, val,
* is the same as the size of b */
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(right); /* if(rt), compute b %*% op(a), else op(a) %*% b */
int tr = asLogical(trans);/* if true, use t(a) */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
int m = bdims[0], n = bdims[1];
double one = 1.;
if (adims[0] != adims[1])
error(_("dtrMatrix must be square"));
if ((rt && adims[0] != n) || (!rt && adims[1] != m))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else /* BLAS */
F77_CALL(dtrmm)(rt ? "R" : "L", uplo_P(a),
/*trans_A = */ tr ? "T" : "N",
diag_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims,
REAL(GET_SLOT(val, Matrix_xSym)), &m);
UNPROTECT(1);
return val;
}
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP d, s, x, stype;
int nargs = length(args);
#ifdef R_version_3_4_or_so
checkArity(op, args);
#else
// will work also for code byte-compiled *before* 'keepNA' was introduced
if (nargs < 3 || nargs > 4)
errorcall(call,
ngettext("%d argument passed to '%s' which requires %d to %d",
"%d arguments passed to '%s' which requires %d to %d",
(unsigned long) nargs),
nargs, PRIMNAME(op), 3, 4);
#endif
if (isFactor(CAR(args)))
error(_("'%s' requires a character vector"), "nchar()");
PROTECT(x = coerceVector(CAR(args), STRSXP));
if (!isString(x))
error(_("'%s' requires a character vector"), "nchar()");
R_xlen_t len = XLENGTH(x);
stype = CADR(args);
if (!isString(stype) || LENGTH(stype) != 1)
error(_("invalid '%s' argument"), "type");
const char *type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
size_t ntype = strlen(type);
if (ntype == 0) error(_("invalid '%s' argument"), "type");
nchar_type type_;
if (strncmp(type, "bytes", ntype) == 0) type_ = Bytes;
else if (strncmp(type, "chars", ntype) == 0) type_ = Chars;
else if (strncmp(type, "width", ntype) == 0) type_ = Width;
else error(_("invalid '%s' argument"), "type");
int allowNA = asLogical(CADDR(args));
if (allowNA == NA_LOGICAL) allowNA = 0;
int keepNA;
if(nargs >= 4) {
keepNA = asLogical(CADDDR(args));
if (keepNA == NA_LOGICAL) // default
keepNA = (type_ == Width) ? FALSE : TRUE;
} else keepNA = FALSE; // default
PROTECT(s = allocVector(INTSXP, len));
int *s_ = INTEGER(s);
for (R_xlen_t i = 0; i < len; i++) {
SEXP sxi = STRING_ELT(x, i);
char msg_i[20]; sprintf(msg_i, "element %ld", (long)i+1);
s_[i] = R_nchar(sxi, type_, allowNA, keepNA, msg_i);
}
R_FreeStringBufferL(&cbuff);
if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(s, R_NamesSymbol, d);
if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
setAttrib(s, R_DimSymbol, d);
if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(s, R_DimNamesSymbol, d);
UNPROTECT(2);
return s;
}
SEXP dsCMatrix_Cholesky(SEXP Ap, SEXP perm, SEXP LDL, SEXP super, SEXP Imult)
{
int c_pr = c.print;
c.print = 0;/* stop CHOLMOD printing; we cannot suppress it (in R), and
have error handler already */
SEXP r = chm_factor_to_SEXP(internal_chm_factor(Ap, asLogical(perm),
asLogical(LDL),
asLogical(super),
asReal(Imult)),
1 /* dofree */);
c.print = c_pr;
return r;
}
SEXP
RGDAL_OpenDataset(SEXP filename, SEXP read_only, SEXP silent) {
const char *fn = asString(filename);
GDALAccess RWFlag;
if (asLogical(read_only))
RWFlag = GA_ReadOnly;
else
RWFlag = GA_Update;
/* Modification suggested by Even Rouault, 2009-08-08: */
CPLErrorReset();
if (asLogical(silent))
CPLPushErrorHandler(CPLQuietErrorHandler);
else
installErrorHandler();
GDALDataset *pDataset = (GDALDataset *) GDALOpen(fn, RWFlag);
if (pDataset == NULL)
error("%s\n", CPLGetLastErrorMsg());
if (asLogical(silent))
CPLPopErrorHandler();
else
uninstallErrorHandlerAndTriggerError();
/* Similarly to SWIG bindings, the following lines will cause
RGDAL_OpenDataset() to fail on - uncleared - errors even if pDataset is not
NULL. They could also be just removed. While pDataset != NULL, there's some
hope ;-) */
/* CPLErr eclass = CPLGetLastErrorType();
if (pDataset != NULL && eclass == CE_Failure) {
GDALClose(pDataset);
pDataset = NULL;
__errorHandler(eclass, CPLGetLastErrorNo(), CPLGetLastErrorMsg());
}*/
SEXP sxpHandle = R_MakeExternalPtr((void *) pDataset,
mkChar("GDAL Dataset"),
R_NilValue);
return(sxpHandle);
}
SEXP R_gpg_export(SEXP id, SEXP secret){
gpgme_data_t keydata = NULL;
bail(gpgme_data_new(&keydata), "initiatie keydata");
#ifdef GPGME_EXPORT_MODE_SECRET
gpgme_export_mode_t mode = asLogical(secret) * GPGME_EXPORT_MODE_SECRET;
#else
int mode = 0;
#ifndef CHECK_OLD_GPGME
if(asLogical(secret)) Rf_error("gpgme is too old, GPGME_EXPORT_MODE_SECRET not supported");
#endif
#endif
bail(gpgme_op_export(ctx, CHAR(STRING_ELT(id, 0)), mode, keydata), "export key");
return data_to_string(keydata);
}
SEXP csc_matrix_mm(SEXP a, SEXP b, SEXP classed, SEXP right)
{
int cl = asLogical(classed), rt = asLogical(right);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*ai = INTEGER(GET_SLOT(a, Matrix_iSym)),
*ap = INTEGER(GET_SLOT(a, Matrix_pSym)),
*bdims = INTEGER(cl ? GET_SLOT(b, Matrix_DimSym) :
getAttrib(b, R_DimSymbol)),
*cdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2)),
chk, ione = 1, j, jj, k, m, n;
double *ax = REAL(GET_SLOT(a, Matrix_xSym)),
*bx = REAL(cl ? GET_SLOT(b, Matrix_xSym) : b), *cx;
if (rt) {
m = bdims[0]; n = adims[1]; k = bdims[1]; chk = adims[0];
} else {
m = adims[0]; n = bdims[1]; k = adims[1]; chk = bdims[0];
}
if (chk != k)
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
cx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
AZERO(cx, m * n); /* zero the accumulators */
for (j = 0; j < n; j++) { /* across columns of c */
if (rt) {
int kk, k2 = ap[j + 1];
for (kk = ap[j]; kk < k2; kk++) {
F77_CALL(daxpy)(&m, &ax[kk], &bx[ai[kk]*m],
&ione, &cx[j*m], &ione);
}
} else {
double *ccol = cx + j * m,
*bcol = bx + j * k;
for (jj = 0; jj < k; jj++) { /* across columns of a */
int kk, k2 = ap[jj + 1];
for (kk = ap[jj]; kk < k2; kk++) {
ccol[ai[kk]] += ax[kk] * bcol[jj];
}
}
}
}
cdims[0] = m; cdims[1] = n;
UNPROTECT(1);
return val;
}
SEXP attribute_hidden
in_do_curlGetHeaders(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
#ifndef HAVE_LIBCURL
error(_("curlGetHeaders is not supported on this platform"));
return R_NilValue;
#else
if (!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error("invalid %s argument", "url");
const char *url = translateChar(STRING_ELT(CAR(args), 0));
used = 0;
int redirect = asLogical(CADR(args));
if (redirect == NA_LOGICAL)
error(_("invalid %s argument"), "redirect");
int verify = asLogical(CADDR(args));
if (verify == NA_LOGICAL)
error(_("invalid %s argument"), "verify");
CURL *hnd = curl_easy_init();
curl_easy_setopt(hnd, CURLOPT_URL, url);
curl_easy_setopt(hnd, CURLOPT_NOPROGRESS, 1L);
curl_easy_setopt(hnd, CURLOPT_NOBODY, 1L);
curl_easy_setopt(hnd, CURLOPT_HEADERFUNCTION, &rcvHeaders);
curl_easy_setopt(hnd, CURLOPT_WRITEHEADER, &headers);
/* libcurl (at least 7.40.0) does not respect CURLOPT_NOBODY
for some ftp header info (Content-Length and Accept-ranges). */
curl_easy_setopt(hnd, CURLOPT_WRITEFUNCTION, &rcvBody);
curlCommon(hnd, redirect, verify);
char errbuf[CURL_ERROR_SIZE];
curl_easy_setopt(hnd, CURLOPT_ERRORBUFFER, errbuf);
CURLcode ret = curl_easy_perform(hnd);
if (ret != CURLE_OK)
error(_("libcurl error code %d\n\t%s\n"), ret, errbuf);
long http_code = 0;
curl_easy_getinfo (hnd, CURLINFO_RESPONSE_CODE, &http_code);
curl_easy_cleanup(hnd);
SEXP ans = PROTECT(allocVector(STRSXP, used));
for (int i = 0; i < used; i++)
SET_STRING_ELT(ans, i, mkChar(headers[i]));
SEXP sStatus = install("status");
setAttrib(ans, sStatus, ScalarInteger((int) http_code));
UNPROTECT(1);
return ans;
#endif
}
SEXP magma_dgeMatrix_LU(SEXP x, SEXP warn_singularity)
{
#ifdef HIPLAR_WITH_MAGMA
return magma_dgeMatrix_LU_(x, asLogical(warn_singularity));
#endif
return R_NilValue;
}
SEXP sparseQR_resid_fitted(SEXP qr, SEXP y, SEXP resid)
{
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(y));
CSP V = AS_CSP(GET_SLOT(qr, install("V")));
int *ydims = INTEGER(GET_SLOT(ans, Matrix_DimSym)),
*p = INTEGER(GET_SLOT(qr, Matrix_pSym)),
i, j, m = V->m, n = V->n, res = asLogical(resid);
double *ax = REAL(GET_SLOT(ans, Matrix_xSym)),
*beta = REAL(GET_SLOT(qr, install("beta")));
R_CheckStack();
/* apply row permutation and multiply by Q' */
sparseQR_Qmult(V, beta, p, 1, ax, ydims);
for (j = 0; j < ydims[1]; j++) {
if (res) /* zero first n rows */
for (i = 0; i < n; i++) ax[i + j * m] = 0;
else /* zero last m - n rows */
for (i = n; i < m; i++) ax[i + j * m] = 0;
}
/* multiply by Q and apply inverse row permutation */
sparseQR_Qmult(V, beta, p, 0, ax, ydims);
UNPROTECT(1);
return ans;
}
SEXP qt_qsetItemFlags_QGraphicsItem(SEXP x, SEXP flag, SEXP status)
{
setItemFlag_helper(unwrapQGraphicsItem(x, QGraphicsItem),
sexp2qstring(flag),
(bool) asLogical(status));
return R_NilValue;
}
SEXP csc_matrix_crossprod(SEXP x, SEXP y, SEXP classed)
{
int cl = asLogical(classed);
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xdims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*ydims = INTEGER(cl ? GET_SLOT(y, Matrix_DimSym) :
getAttrib(y, R_DimSymbol)),
*vdims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int *xi = INTEGER(GET_SLOT(x, Matrix_iSym)),
*xp = INTEGER(GET_SLOT(x, Matrix_pSym));
int j, k = xdims[0], m = xdims[1], n = ydims[1];
double *vx, *xx = REAL(GET_SLOT(x, Matrix_xSym)),
*yx = REAL(cl ? GET_SLOT(y, Matrix_xSym) : y);
if (!cl && !(isMatrix(y) && isReal(y)))
error(_("y must be a numeric matrix"));
if (ydims[0] != k)
error(_("x and y must have the same number of rows"));
if (m < 1 || n < 1 || k < 1)
error(_("Matrices with zero extents cannot be multiplied"));
vdims[0] = m; vdims[1] = n;
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, m * n));
for (j = 0; j < n; j++) {
int i; double *ypt = yx + j * k;
for(i = 0; i < m; i++) {
int ii; double accum = 0.;
for (ii = xp[i]; ii < xp[i+1]; ii++) {
accum += xx[ii] * ypt[xi[ii]];
}
vx[i + j * m] = accum;
}
}
UNPROTECT(1);
return val;
}
SEXP R_curl_escape(SEXP url, SEXP unescape_) {
if (TYPEOF(url) != STRSXP)
error("`url` must be a character vector.");
/* init curl */
CURL *curl = curl_easy_init();
if (!curl)
return(R_NilValue);
int unescape = asLogical(unescape_);
int n = Rf_length(url);
SEXP output = PROTECT(allocVector(STRSXP, n));
for (int i = 0; i < n; ++i) {
const char *in = CHAR(STRING_ELT(url, i));
char *out;
if (unescape) {
out = curl_easy_unescape(curl, in, 0, NULL);
} else {
out = curl_easy_escape(curl, in, 0);
}
SET_STRING_ELT(output, i, mkCharCE(out, CE_UTF8));
curl_free(out);
}
curl_easy_cleanup(curl);
UNPROTECT(1);
return output;
}
SEXP all_integer64(SEXP e1_, SEXP na_rm_, SEXP ret_){
long long i, n = LENGTH(e1_);
long long * e1 = (long long *) REAL(e1_);
Rboolean * ret = (Rboolean *) LOGICAL(ret_);
Rboolean hasna=FALSE;
if (asLogical(na_rm_)){
for(i=0; i<n; i++){
if (e1[i]!=NA_INTEGER64 && !e1[i]){
ret[0] = FALSE;
return ret_;
}
}
ret[0] = TRUE;
}else{
for(i=0; i<n; i++){
if (e1[i]==NA_INTEGER64){
hasna = TRUE;
}else if (!e1[i]){
ret[0] = FALSE;
return ret_;
}
}
ret[0] = hasna ? NA_LOGICAL : TRUE;
}
return ret_;
}
SEXP dgeMatrix_determinant(SEXP x, SEXP logarithm)
{
int lg = asLogical(logarithm);
int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
n = dims[0], sign = 1;
double modulus = lg ? 0. : 1; /* initialize; = result for n == 0 */
if (n != dims[1])
error(_("Determinant requires a square matrix"));
if (n > 0) {
SEXP lu = dgeMatrix_LU_(x, /* do not warn about singular LU: */ FALSE);
int i, *jpvt = INTEGER(GET_SLOT(lu, Matrix_permSym));
double *luvals = REAL(GET_SLOT(lu, Matrix_xSym));
for (i = 0; i < n; i++) if (jpvt[i] != (i + 1)) sign = -sign;
if (lg) {
for (i = 0; i < n; i++) {
double dii = luvals[i*(n + 1)]; /* ith diagonal element */
modulus += log(dii < 0 ? -dii : dii);
if (dii < 0) sign = -sign;
}
} else {
for (i = 0; i < n; i++)
modulus *= luvals[i*(n + 1)];
if (modulus < 0) {
modulus = -modulus;
sign = -sign;
}
}
}
return as_det_obj(modulus, lg, sign);
}
SEXP dgeMatrix_dgeMatrix_crossprod(SEXP x, SEXP y, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x,y) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xDims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*yDims = INTEGER(GET_SLOT(y, Matrix_DimSym)),
*vDims;
int m = xDims[!tr], n = yDims[!tr];/* -> result dim */
int xd = xDims[ tr], yd = yDims[ tr];/* the conformable dims */
double one = 1.0, zero = 0.0;
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
vDims = INTEGER(GET_SLOT(val, Matrix_DimSym));
if (xd > 0 && yd > 0 && n > 0 && m > 0) {
if (xd != yd)
error(_("Dimensions of x and y are not compatible for %s"),
tr ? "tcrossprod" : "crossprod");
vDims[0] = m; vDims[1] = n;
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
F77_CALL(dgemm)(tr ? "N" : "T", tr ? "T" : "N", &m, &n, &xd, &one,
REAL(GET_SLOT(x, Matrix_xSym)), xDims,
REAL(GET_SLOT(y, Matrix_xSym)), yDims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), &m);
}
UNPROTECT(1);
return val;
}
SEXP influence(SEXP mqr, SEXP do_coef, SEXP e, SEXP stol)
{
SEXP qr = getListElement(mqr, "qr"), qraux = getListElement(mqr, "qraux");
int n = nrows(qr), k = asInteger(getListElement(mqr, "rank"));
int docoef = asLogical(do_coef);
double tol = asReal(stol);
SEXP hat = PROTECT(allocVector(REALSXP, n));
double *rh = REAL(hat);
SEXP coefficients;
if(docoef) coefficients = PROTECT(allocMatrix(REALSXP, n, k));
else coefficients = PROTECT(allocVector(REALSXP, 0));
SEXP sigma = PROTECT(allocVector(REALSXP, n));
F77_CALL(lminfl)(REAL(qr), &n, &n, &k, &docoef, REAL(qraux),
REAL(e), rh, REAL(coefficients), REAL(sigma), &tol);
for (int i = 0; i < n; i++) if (rh[i] > 1. - tol) rh[i] = 1.;
SEXP ans = PROTECT(allocVector(VECSXP, docoef ? 4 : 3));
SEXP nm = allocVector(STRSXP, docoef ? 4 : 3);
setAttrib(ans, R_NamesSymbol, nm);
int m = 0;
SET_VECTOR_ELT(ans, m, hat);
SET_STRING_ELT(nm, m++, mkChar("hat"));
if (docoef) {
SET_VECTOR_ELT(ans, m, coefficients);
SET_STRING_ELT(nm, m++, mkChar("coefficients"));
}
SET_VECTOR_ELT(ans, m, sigma);
SET_STRING_ELT(nm, m++, mkChar("sigma"));
SET_VECTOR_ELT(ans, m, e);
SET_STRING_ELT(nm, m, mkChar("wt.res"));
UNPROTECT(4);
return ans;
}
SEXP dsCMatrix_chol(SEXP x, SEXP pivot)
{
cholmod_factor
*N = as_cholmod_factor(dsCMatrix_Cholesky(x, pivot,
ScalarLogical(FALSE),
ScalarLogical(FALSE)));
/* Must use a copy; cholmod_factor_to_sparse modifies first arg. */
cholmod_factor *Ncp = cholmod_copy_factor(N, &c);
cholmod_sparse *L, *R;
SEXP ans;
L = cholmod_factor_to_sparse(Ncp, &c); cholmod_free_factor(&Ncp, &c);
R = cholmod_transpose(L, /*values*/ 1, &c); cholmod_free_sparse(&L, &c);
ans = PROTECT(chm_sparse_to_SEXP(R, /*cholmod_free*/ 1,
/*uploT*/ 1, /*diag*/ "N",
GET_SLOT(x, Matrix_DimNamesSym)));
if (asLogical(pivot)) {
SEXP piv = PROTECT(allocVector(INTSXP, N->n));
int *dest = INTEGER(piv), *src = (int*)N->Perm, i;
for (i = 0; i < N->n; i++) dest[i] = src[i] + 1;
setAttrib(ans, install("pivot"), piv);
/* FIXME: Because of the cholmod_factor -> S4 obj ->
* cholmod_factor conversions, the value of N->minor will
* always be N->n. Change as_cholmod_factor and
* chm_factor_as_SEXP to keep track of Minor.
*/
setAttrib(ans, install("rank"), ScalarInteger((size_t) N->minor));
UNPROTECT(1);
}
Free(N);
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden
do_setTimeLimit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
double cpu, elapsed, old_cpu = cpuLimitValue,
old_elapsed = elapsedLimitValue;
int transient;
checkArity(op, args);
cpu = asReal(CAR(args));
elapsed = asReal(CADR(args));
transient = asLogical(CADDR(args));
if (R_FINITE(cpu) && cpu > 0) cpuLimitValue = cpu; else cpuLimitValue = -1;
if (R_FINITE(elapsed) && elapsed > 0) elapsedLimitValue = elapsed;
else elapsedLimitValue = -1;
resetTimeLimits();
if (transient == TRUE) {
cpuLimitValue = old_cpu;
elapsedLimitValue = old_elapsed;
}
return R_NilValue;
}
SEXP ngCMatrix_colSums(SEXP x, SEXP NArm, SEXP spRes, SEXP trans, SEXP means)
{
if(asLogical(means)) /* ==> result will be "double" / "dsparseVector" */
return ngCMatrix_colSums_d(x, NArm, spRes, trans, means);
else
return ngCMatrix_colSums_i(x, NArm, spRes, trans, means);
}
SEXP CatBoostPredictMulti_R(SEXP modelParam, SEXP poolParam, SEXP verboseParam,
SEXP typeParam, SEXP treeCountStartParam, SEXP treeCountEndParam, SEXP threadCountParam) {
SEXP result = NULL;
R_API_BEGIN();
TFullModelHandle model = reinterpret_cast<TFullModelHandle>(R_ExternalPtrAddr(modelParam));
TPoolHandle pool = reinterpret_cast<TPoolHandle>(R_ExternalPtrAddr(poolParam));
EPredictionType predictionType;
CB_ENSURE(TryFromString<EPredictionType>(CHAR(asChar(typeParam)), predictionType),
"unsupported prediction type: 'Probability', 'Class' or 'RawFormulaVal' was expected");
TVector<TVector<double>> prediction = ApplyModelMulti(*model,
*pool,
asLogical(verboseParam),
predictionType,
asInteger(treeCountStartParam),
asInteger(treeCountEndParam),
asInteger(threadCountParam));
size_t predictionSize = prediction.size() * pool->Docs.GetDocCount();
result = PROTECT(allocVector(REALSXP, predictionSize));
for (size_t i = 0, k = 0; i < pool->Docs.GetDocCount(); ++i) {
for (size_t j = 0; j < prediction.size(); ++j) {
REAL(result)[k++] = prediction[j][i];
}
}
R_API_END();
UNPROTECT(1);
return result;
}
SEXP dgeMatrix_matrix_crossprod(SEXP x, SEXP y, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x,y) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dgeMatrix")));
int *xDims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*yDims = INTEGER(getAttrib(y, R_DimSymbol)),
*vDims, nprot = 1;
int m = xDims[!tr], n = yDims[!tr];/* -> result dim */
int xd = xDims[ tr], yd = yDims[ tr];/* the conformable dims */
double one = 1.0, zero = 0.0;
if (isInteger(y)) {
y = PROTECT(coerceVector(y, REALSXP));
nprot++;
}
if (!(isMatrix(y) && isReal(y)))
error(_("Argument y must be a numeric matrix"));
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
SET_SLOT(val, Matrix_DimSym, allocVector(INTSXP, 2));
vDims = INTEGER(GET_SLOT(val, Matrix_DimSym));
if (xd > 0 && yd > 0 && n > 0 && m > 0) {
if (xd != yd)
error(_("Dimensions of x and y are not compatible for %s"),
tr ? "tcrossprod" : "crossprod");
vDims[0] = m; vDims[1] = n;
SET_SLOT(val, Matrix_xSym, allocVector(REALSXP, m * n));
F77_CALL(dgemm)(tr ? "N" : "T", tr ? "T" : "N", &m, &n, &xd, &one,
REAL(GET_SLOT(x, Matrix_xSym)), xDims,
REAL(y), yDims,
&zero, REAL(GET_SLOT(val, Matrix_xSym)), &m);
}
UNPROTECT(nprot);
return val;
}
SEXP range_integer64(SEXP e1_, SEXP na_rm_, SEXP ret_){
long long i, n = LENGTH(e1_);
long long * e1 = (long long *) REAL(e1_);
long long * ret = (long long *) REAL(ret_);
ret[0] = MAX_INTEGER64;
ret[1] = MIN_INTEGER64;
if (asLogical(na_rm_)){
for(i=0; i<n; i++){
if (e1[i]!=NA_INTEGER64){
if (e1[i]<ret[0])
ret[0] = e1[i];
if (e1[i]>ret[1])
ret[1] = e1[i];
}
}
}else{
for(i=0; i<n; i++){
if (e1[i]==NA_INTEGER64){
ret[0] = ret[1] = NA_INTEGER64;
return ret_;
}else{
if (e1[i]<ret[0])
ret[0] = e1[i];
if (e1[i]>ret[1])
ret[1] = e1[i];
}
}
}
return ret_;
}
SEXP dgeMatrix_crossprod(SEXP x, SEXP trans)
{
int tr = asLogical(trans);/* trans=TRUE: tcrossprod(x) */
SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dpoMatrix"))),
nms = VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym), tr ? 0 : 1),
vDnms = ALLOC_SLOT(val, Matrix_DimNamesSym, VECSXP, 2);
int *Dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
*vDims = INTEGER(ALLOC_SLOT(val, Matrix_DimSym, INTSXP, 2));
int k = tr ? Dims[1] : Dims[0], n = tr ? Dims[0] : Dims[1];
double *vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n)),
one = 1.0, zero = 0.0;
AZERO(vx, n * n);
SET_SLOT(val, Matrix_uploSym, mkString("U"));
ALLOC_SLOT(val, Matrix_factorSym, VECSXP, 0);
vDims[0] = vDims[1] = n;
SET_VECTOR_ELT(vDnms, 0, duplicate(nms));
SET_VECTOR_ELT(vDnms, 1, duplicate(nms));
F77_CALL(dsyrk)("U", tr ? "N" : "T", &n, &k,
&one, REAL(GET_SLOT(x, Matrix_xSym)), Dims,
&zero, vx, &n);
SET_SLOT(val, Matrix_factorSym, allocVector(VECSXP, 0));
UNPROTECT(1);
return val;
}
/** Return a 2 column matrix '' cbind(i, j) '' of 0-origin index vectors (i,j)
* which entirely correspond to the (i,j) slots of
* as(x, "TsparseMatrix") :
*/
SEXP compressed_non_0_ij(SEXP x, SEXP colP)
{
int col = asLogical(colP); /* 1 if "C"olumn compressed; 0 if "R"ow */
SEXP ans, indSym = col ? Matrix_iSym : Matrix_jSym;
SEXP indP = GET_SLOT(x, indSym),
pP = GET_SLOT(x, Matrix_pSym);
int i, *ij;
int nouter = INTEGER(GET_SLOT(x, Matrix_DimSym))[col ? 1 : 0],
n_el = INTEGER(pP)[nouter]; /* is only == length(indP), if the
inner slot is not over-allocated */
ij = INTEGER(ans = PROTECT(allocMatrix(INTSXP, n_el, 2)));
/* expand the compressed margin to 'i' or 'j' : */
expand_cmprPt(nouter, INTEGER(pP), &ij[col ? n_el : 0]);
/* and copy the other one: */
if (col)
for(i = 0; i < n_el; i++)
ij[i] = INTEGER(indP)[i];
else /* row compressed */
for(i = 0; i < n_el; i++)
ij[i + n_el] = INTEGER(indP)[i];
UNPROTECT(1);
return ans;
}
SEXP mean_integer64(SEXP e1_, SEXP na_rm_, SEXP ret_){
long long i, n = LENGTH(e1_);
long long * e1 = (long long *) REAL(e1_);
long long * ret = (long long *) REAL(ret_);
long double longret = 0;
if (asLogical(na_rm_)){
long long nvalid = 0;
for(i=0; i<n; i++){
if (e1[i]!=NA_INTEGER64){
longret += e1[i];
nvalid++;
}
}
ret[0] = longret / nvalid;
}else{
for(i=0; i<n; i++){
if (e1[i]==NA_INTEGER64){
ret[0] = NA_INTEGER64;
return ret_;
}else{
longret += e1[i];
}
}
ret[0] = longret / n;
}
return ret_;
}
SEXP dsyMatrix_matrix_mm(SEXP a, SEXP b, SEXP rtP)
{
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));// incl. its dimnames
int rt = asLogical(rtP); /* if(rt), compute b %*% a, else a %*% b */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym)),
m = bdims[0], n = bdims[1];
double one = 1., zero = 0., mn = ((double) m) * ((double) n);
if (mn > INT_MAX)
error(_("Matrix dimension %d x %d (= %g) is too large"), m, n, mn);
// else: m * n will not overflow below
double *bcp, *vx = REAL(GET_SLOT(val, Matrix_xSym));
C_or_Alloca_TO(bcp, m * n, double);
Memcpy(bcp, vx, m * n);
if ((rt && n != adims[0]) || (!rt && m != adims[0]))
error(_("Matrices are not conformable for multiplication"));
if (m >=1 && n >= 1)
F77_CALL(dsymm)(rt ? "R" :"L", uplo_P(a), &m, &n, &one,
REAL(GET_SLOT(a, Matrix_xSym)), adims, bcp,
&m, &zero, vx, &m);
// add dimnames:
int nd = rt ?
1 : // v <- b %*% a : rownames(v) == rownames(b) are already there
0; // v <- a %*% b : colnames(v) == colnames(b) are already there
SEXP nms = PROTECT(duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), nd)));
SET_VECTOR_ELT(GET_SLOT(val, Matrix_DimNamesSym), nd, nms);
if(mn >= SMALL_4_Alloca) Free(bcp);
UNPROTECT(2);
return val;
}
SEXP rgl_init(SEXP initValue, SEXP useNULL, SEXP in_namespace)
{
int success = 0;
bool useNULLDevice = asLogical(useNULL);
gInitValue = 0;
gHandle = NULL;
rglNamespace = in_namespace;
if ( isNumeric(initValue) ) {
gInitValue = asInteger(initValue);
}
else if ( TYPEOF(initValue) == EXTPTRSXP ) {
gHandle = R_ExternalPtrAddr(initValue);
}
else if ( !isNull(initValue) )
{
return ScalarInteger( 0 );
}
if ( init(useNULLDevice) ) {
deviceManager = new DeviceManager(useNULLDevice);
success = 1;
}
return(ScalarInteger(success));
}
SEXP dsCMatrix_chol(SEXP x, SEXP pivot)
{
int pivP = asLogical(pivot);
CHM_FR L = internal_chm_factor(x, pivP, 0, 0, 0.);
CHM_SP R, Rt;
SEXP ans;
Rt = cholmod_l_factor_to_sparse(L, &c);
R = cholmod_l_transpose(Rt, /*values*/ 1, &c);
cholmod_l_free_sparse(&Rt, &c);
ans = PROTECT(chm_sparse_to_SEXP(R, 1/*do_free*/, 1/*uploT*/, 0/*Rkind*/,
"N"/*diag*/, GET_SLOT(x, Matrix_DimNamesSym)));
if (pivP) {
SEXP piv = PROTECT(allocVector(INTSXP, L->n));
int *dest = INTEGER(piv), *src = (int*)L->Perm;
for (int i = 0; i < L->n; i++) dest[i] = src[i] + 1;
setAttrib(ans, install("pivot"), piv);
setAttrib(ans, install("rank"), ScalarInteger((size_t) L->minor));
UNPROTECT(1);
}
cholmod_l_free_factor(&L, &c);
UNPROTECT(1);
return ans;
}
