SEXP lsq_dense_Chol(SEXP X, SEXP y)
{
SEXP ans;
int info, n, p, k, *Xdims, *ydims;
double *xpx, d_one = 1., d_zero = 0.;
if (!(isReal(X) & isMatrix(X)))
error(_("X must be a numeric (double precision) matrix"));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
n = Xdims[0];
p = Xdims[1];
if (!(isReal(y) & isMatrix(y)))
error(_("y must be a numeric (double precision) matrix"));
ydims = INTEGER(coerceVector(getAttrib(y, R_DimSymbol), INTSXP));
if (ydims[0] != n)
error(_(
"number of rows in y (%d) does not match number of rows in X (%d)"),
ydims[0], n);
k = ydims[1];
if (k < 1 || p < 1) return allocMatrix(REALSXP, p, k);
ans = PROTECT(allocMatrix(REALSXP, p, k));
F77_CALL(dgemm)("T", "N", &p, &k, &n, &d_one, REAL(X), &n, REAL(y), &n,
&d_zero, REAL(ans), &p);
xpx = (double *) R_alloc(p * p, sizeof(double));
F77_CALL(dsyrk)("U", "T", &p, &n, &d_one, REAL(X), &n, &d_zero,
xpx, &p);
F77_CALL(dposv)("U", &p, &k, xpx, &p, REAL(ans), &p, &info);
if (info) error(_("Lapack routine dposv returned error code %d"), info);
UNPROTECT(1);
return ans;
}
//
// Recursively generate mangled names.
//
TString TType::buildMangledName() const
{
TString mangledName;
if (isMatrix())
mangledName += 'm';
else if (isVector())
mangledName += 'v';
switch (type)
{
case EbtFloat: mangledName += 'f'; break;
case EbtInt: mangledName += 'i'; break;
case EbtUInt: mangledName += 'u'; break;
case EbtBool: mangledName += 'b'; break;
case EbtSampler2D: mangledName += "s2"; break;
case EbtSampler3D: mangledName += "s3"; break;
case EbtSamplerCube: mangledName += "sC"; break;
case EbtSampler2DArray: mangledName += "s2a"; break;
case EbtSamplerExternalOES: mangledName += "sext"; break;
case EbtSampler2DRect: mangledName += "s2r"; break;
case EbtISampler2D: mangledName += "is2"; break;
case EbtISampler3D: mangledName += "is3"; break;
case EbtISamplerCube: mangledName += "isC"; break;
case EbtISampler2DArray: mangledName += "is2a"; break;
case EbtUSampler2D: mangledName += "us2"; break;
case EbtUSampler3D: mangledName += "us3"; break;
case EbtUSamplerCube: mangledName += "usC"; break;
case EbtUSampler2DArray: mangledName += "us2a"; break;
case EbtSampler2DShadow: mangledName += "s2s"; break;
case EbtSamplerCubeShadow: mangledName += "sCs"; break;
case EbtSampler2DArrayShadow: mangledName += "s2as"; break;
case EbtStruct: mangledName += structure->mangledName(); break;
case EbtInterfaceBlock: mangledName += interfaceBlock->mangledName(); break;
default: UNREACHABLE();
}
if (isMatrix())
{
mangledName += static_cast<char>('0' + getCols());
mangledName += static_cast<char>('x');
mangledName += static_cast<char>('0' + getRows());
}
else
{
mangledName += static_cast<char>('0' + getNominalSize());
}
if (isArray()) {
char buf[20];
snprintf(buf, sizeof(buf), "%d", arraySize);
mangledName += '[';
mangledName += buf;
mangledName += ']';
}
return mangledName;
}
SEXP _split_col(SEXP x) {
if (TYPEOF(x) != INTSXP)
error("'x' not integer");
int n, m;
SEXP r;
if (!isMatrix(x))
error("'x' not a matrix");
r = getAttrib(x, R_DimSymbol);
n = INTEGER(r)[0];
m = INTEGER(r)[1];
r = PROTECT(allocVector(VECSXP, m));
int k = 0;
for (int i = 0; i < m; i++) {
SEXP s;
SET_VECTOR_ELT(r, i, (s = allocVector(INTSXP, n)));
for (int j = 0; j < n; j++, k++)
INTEGER(s)[j] = INTEGER(x)[k];
}
UNPROTECT(1);
return r;
}
//
// Recursively generate mangled names.
//
TString TType::buildMangledName() const
{
TString mangledName;
if (isMatrix())
mangledName += 'm';
else if (isVector())
mangledName += 'v';
switch (type) {
case EbtFloat: mangledName += 'f'; break;
case EbtInt: mangledName += 'i'; break;
case EbtBool: mangledName += 'b'; break;
case EbtSampler2D: mangledName += "s2"; break;
case EbtSamplerCube: mangledName += "sC"; break;
case EbtStruct: mangledName += structure->mangledName(); break;
default: break;
}
mangledName += static_cast<char>('0' + getNominalSize());
if (isArray()) {
char buf[20];
snprintf(buf, sizeof(buf), "%d", arraySize);
mangledName += '[';
mangledName += buf;
mangledName += ']';
}
return mangledName;
}
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;
}
static double mavg2d(SEXP v, int row, int col, int m1, int m2)
{
double s=0.00;
int i, j, z=0;
int startrow, startcol, endrow, endcol;
int nr=nrows(v);
if (isMatrix(v)) {
startrow = (row-m1>0 ? row-m1 : 0);
startcol = (col-m2>0 ? col-m2 : 0);
endrow = (row+m1<nr ? row+m1+1 : nrows(v));
endcol = (col+m2<ncols(v) ? col+m2+1 : ncols(v));
for(i=startrow, z=0, s=0.00; i<endrow; i++) {
for(j=startcol; j<endcol; j++) {
if (R_FINITE(REAL(v)[i+nr*j])) {
z++;
s += REAL(v)[i+nr*j];
}
}
}
} else error("Input is not a vector or Matrix.");
if (z == 0) return R_NaN;
return s/z;
}
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 matrix_to_csc(SEXP A)
{
if (!(isMatrix(A) && isReal(A)))
error(_("A must be a numeric matrix"));
return double_to_csc(REAL(A),
INTEGER(getAttrib(A, R_DimSymbol)));
}
/**
* Retrieves the list of matrix and stores it in theList.
* We assume that at least one element has been stored before.
*/
void cRUtil::GetMatListSexp(SEXP theSEXP, uint theNum, std::vector<cDMatrix> &theList)
{
SEXP myAux = VECTOR_ELT(theSEXP, theNum) ;
if (isMatrix(myAux))
{
/* Fill as first matrix */
GetMatSexp(theSEXP,theNum,theList[0]);
} else
{
uint i;
uint nrow = theList.at(0).mNRow;
uint ncol = theList.at(0).mNCol;
for (i=0;i<(uint)length(myAux);i++)
{
if (theList.size() <= i)
{
cDMatrix *mat = new cDMatrix(nrow,ncol,0.0);
theList.push_back(*mat);
}
GetMatSexp(myAux, i, theList.at(i) );
}
}
}
// Evaluate a BBOB function call.
//
// @param r_dimension [unsigned int] Dimension of the problem.
// @param r_fid [unsigned int] Function id. Integer in {1, ..., 24}.
// @param r_iid [unsigned int] Instance id.
// @param r_x [R::numeric] Numeric parameter vector of size 'dimension'.
//
// @return [numeric(1)] Function value of the corresponding BBOB function.
SEXP evaluateBBOBFunctionCPP(SEXP r_dimension, SEXP r_fid, SEXP r_iid, SEXP r_x) {
unsigned int fid = asInteger(r_fid);
unsigned int iid = asInteger(r_iid);
unsigned int dimension = asInteger(r_dimension);
initializeBBOBFunction(dimension, fid, iid);
// get the bbob function
bbobFunction bbob_fun = *bbob_funs[last_fid - 1];
// unwrap integer
double *param = REAL(r_x);
// we allow 'vectorized' input here
// Note: since C stores 2D arrays as a 1D array with the consecutive rows one after
// another, there is no straight-forward way to access the columns. We thus
// require the user to pass the parameters col-wise!
unsigned int n_values = 1;
if (isMatrix(r_x)) {
n_values = ncols(r_x);
}
// setup R result object and protect R object in C
SEXP r_value = ALLOC_REAL_VECTOR(n_values);
double *value = REAL(r_value);
for (int i = 0; i < n_values; ++i) {
value[i] = bbob_fun(param + i * dimension).Fval;
}
// unprotect for R
UNPROTECT(1);
return (r_value);
}
SEXP dense_to_Csparse(SEXP x)
{
CHM_DN chxd = AS_CHM_xDN(PROTECT(mMatrix_as_geMatrix(x)));
/* cholmod_dense_to_sparse() in CHOLMOD/Core/ below does only work for
"REAL" 'xtypes', i.e. *not* for "nMatrix".
===> need "_x" in above AS_CHM_xDN() call.
Also it cannot keep symmetric / triangular, hence the
as_geMatrix() above. Note that this is already a *waste* for
symmetric matrices; However, we could conceivably use an
enhanced cholmod_dense_to_sparse(), with an extra boolean
argument for symmetry.
*/
CHM_SP chxs = cholmod_dense_to_sparse(chxd, 1, &c);
int Rkind = (chxd->xtype == CHOLMOD_REAL) ? Real_KIND2(x) : 0;
/* Note: when 'x' was integer Matrix, Real_KIND(x) = -1, but *_KIND2(.) = 0 */
R_CheckStack();
UNPROTECT(1);
/* chm_sparse_to_SEXP() *could* deal with symmetric
* if chxs had such an stype; and we should be able to use uplo below */
return chm_sparse_to_SEXP(chxs, 1, 0/*TODO: uplo_P(x) if x has an uplo slot*/,
Rkind, "",
isMatrix(x) ? getAttrib(x, R_DimNamesSymbol)
: GET_SLOT(x, Matrix_DimNamesSym));
}
Matrix&
Value::toMatrix()
{
if (not isMatrix()) {
throw utils::CastError(_("Value is not a matrix"));
}
return static_cast<Matrix&>(*this);
}
vector<int> getSEXPdims(SEXP Sx) {
if(!isNumeric(Sx)) {PRINTF("Error, getSEXPdims called for something not numeric\n"); return(vector<int>());}
if(!isVector(Sx)) {PRINTF("Error, getSEXPdims called for something not vector\n"); return(vector<int>());}
if(!isArray(Sx) & !isMatrix(Sx)) {
vector<int> ans;
ans.resize(1); ans[0] = LENGTH(Sx); return(ans);
}
return(SEXP_2_vectorInt(getAttrib(Sx, R_DimSymbol), 0));
}
Matrix* getAsMatrix(types::InternalType* _pIT)
{
if (isMatrix(_pIT))
{
return dynamic_cast<Matrix*>(getAsVariable(_pIT));
}
return NULL;
}
void Call_piiA(SEXP A)
{
if (!isMatrix(A))
error("a matrix is required");
double *pA;
PROTECT(A = AS_NUMERIC(A));
pA = NUMERIC_POINTER(A);
pA[0] = 77;
UNPROTECT(1);
}
SEXP _vector_index(SEXP d, SEXP x) {
if (TYPEOF(d) != INTSXP ||
TYPEOF(x) != INTSXP)
error("'d, x' not integer");
int n, m;
SEXP r, dd;
if (!isMatrix(x))
error("'x' not a matrix");
r = getAttrib(x, R_DimSymbol);
n = INTEGER(r)[0];
m = INTEGER(r)[1];
if (m != LENGTH(d))
error("'x' and 'd' do not conform");
r = PROTECT(allocVector(INTSXP, n));
if (m > 2) {
dd = PROTECT(duplicate(d));
for (int i = 1; i < m; i++) {
double z = INTEGER(dd)[i] * (double) INTEGER(dd)[i-1];
if (z < INT_MAX)
INTEGER(dd)[i] = (int) z;
else
error("'d' too large for integer");
}
} else
dd = d;
for (int i = 0; i < n; i++) {
int k = i;
int l = INTEGER(x)[i];
if (l != NA_INTEGER) {
if (l < 1 || l > INTEGER(d)[0])
error("'x' invalid");
for (int j = 1; j < m; j++) {
k += n;
int ll = INTEGER(x)[k];
if (ll == NA_INTEGER) {
l = ll;
break;
}
if (ll < 1 || ll > INTEGER(d)[j])
error("'x' invalid");
l += INTEGER(dd)[j - 1] * (ll - 1);
}
}
INTEGER(r)[i] = l;
}
UNPROTECT(1 + (m > 2));
return r;
}
DataObject::DataObject(QString val)
{
mValue = val.trimmed();
if (isVector()) {
mVector = parseVector(mValue);
} else if (is4x4Matrix()) {
m4x4Matrix = parse4x4Matrix(mValue);
} else if (isMatrix()) {
mMatrix = parseMatrix(mValue);
}
}
SEXP lsq_dense_QR(SEXP X, SEXP y)
{
SEXP ans;
int info, n, p, k, *Xdims, *ydims, lwork;
double *work, tmp, *xvals;
if (!(isReal(X) & isMatrix(X)))
error(_("X must be a numeric (double precision) matrix"));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
n = Xdims[0];
p = Xdims[1];
if (!(isReal(y) & isMatrix(y)))
error(_("y must be a numeric (double precision) matrix"));
ydims = INTEGER(coerceVector(getAttrib(y, R_DimSymbol), INTSXP));
if (ydims[0] != n)
error(_(
"number of rows in y (%d) does not match number of rows in X (%d)"),
ydims[0], n);
k = ydims[1];
if (k < 1 || p < 1) return allocMatrix(REALSXP, p, k);
xvals = (double *) R_alloc(n * p, sizeof(double));
Memcpy(xvals, REAL(X), n * p);
ans = PROTECT(duplicate(y));
lwork = -1;
F77_CALL(dgels)("N", &n, &p, &k, xvals, &n, REAL(ans), &n,
&tmp, &lwork, &info);
if (info)
error(_("First call to Lapack routine dgels returned error code %d"),
info);
lwork = (int) tmp;
work = (double *) R_alloc(lwork, sizeof(double));
F77_CALL(dgels)("N", &n, &p, &k, xvals, &n, REAL(ans), &n,
work, &lwork, &info);
if (info)
error(_("Second call to Lapack routine dgels returned error code %d"),
info);
UNPROTECT(1);
return ans;
}
std::string name(int t)
{
char buf[16];
std::string res;
int i=0;
while (names[i].name != NULL && names[i].t != t)
++i;
if (names[i].name != NULL)
{
res = names[i].name;
}
else if (isMatrix(t))
{
res = "Mat<";
snprintf(buf,sizeof(buf),"%d",ny(t));
res += buf;
res += ",";
snprintf(buf,sizeof(buf),"%d",nx(t));
res += buf;
res += ",";
res += name(toSingle(t));
res += ">";
}
else if (isVector(t))
{
res = "Vec<";
snprintf(buf,sizeof(buf),"%d",nx(t));
res += buf;
res += ",";
res += name(toSingle(t));
res += ">";
}
else if (isString(t))
{
if (size(t)==0)
res = "String";
else
{
res = "String<";
snprintf(buf,sizeof(buf),"%d",size(t));
res += buf;
res += ">";
}
}
else
{
snprintf(buf,sizeof(buf),"0x%x",t);
res = buf;
}
return res;
}
static void neggrad(SEXP gf, SEXP rho, SEXP gg)
{
SEXP val = PROTECT(eval(gf, rho));
int *dims = INTEGER(getAttrib(val, R_DimSymbol)),
*gdims = INTEGER(getAttrib(gg, R_DimSymbol));
int i, ntot = gdims[0] * gdims[1];
if (TYPEOF(val) != TYPEOF(gg) || !isMatrix(val) || dims[0] != gdims[0] ||
dims[1] != gdims[1])
error(_("'gradient' must be a numeric matrix of dimension (%d,%d)"),
gdims[0], gdims[1]);
for (i = 0; i < ntot; i++) REAL(gg)[i] = - REAL(val)[i];
UNPROTECT(1);
}
SEXP checkGivens(SEXP X, SEXP jmin, SEXP rank)
{
SEXP ans = PROTECT(allocVector(VECSXP, 2)),
Xcp = PROTECT(duplicate(X));
int *Xdims;
if (!(isReal(X) & isMatrix(X)))
error(_("X must be a numeric (double precision) matrix"));
Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
SET_VECTOR_ELT(ans, 1, getGivens(REAL(Xcp), Xdims[0],
asInteger(jmin), asInteger(rank)));
SET_VECTOR_ELT(ans, 0, Xcp);
UNPROTECT(2);
return ans;
}
static int get_variable(SEXP variable, struct design *s, struct design *r, struct design2 *d,
struct variable *v)
{
int err = 0;
if (isMatrix(variable) || inherits(variable, "matrix")) {
err = get_trait(variable, s, r, v);
} else if (inherits(variable, "special")) {
err = get_special(variable, s, r, d, v);
} else {
DOMAIN_ERROR("unknown variable type");
}
return err;
}
SEXP _all_row(SEXP x, SEXP _na_rm) {
if (TYPEOF(x) != LGLSXP)
error("'x' not logical");
if (!isMatrix(x))
error("'x' not a matrix");
int n, m;
SEXP r;
r = getAttrib(x, R_DimSymbol);
n = INTEGER(r)[0];
m = INTEGER(r)[1];
int na_rm;
if (TYPEOF(_na_rm) != LGLSXP)
error("'na_rm' not logical");
if (!LENGTH(_na_rm))
error("'na_rm' invalid length");
na_rm = LOGICAL(_na_rm)[0] == TRUE;
r = PROTECT(allocVector(LGLSXP, n));
for (int i = 0; i < n; i++) {
int k = i;
Rboolean l = TRUE;
for (int j = 0; j < m; j++, k += n) {
Rboolean ll = LOGICAL(x)[k];
if (ll == NA_LOGICAL) {
if (na_rm)
continue;
else {
l = ll;
break;
}
}
if (ll == FALSE) {
l = ll;
if (na_rm)
break;
}
}
LOGICAL(r)[i] = l;
}
UNPROTECT(1);
return r;
}
TString TType::getCompleteString() const
{
TStringStream stream;
if (qualifier != EvqTemporary && qualifier != EvqGlobal)
stream << getQualifierString() << " ";
if (precision != EbpUndefined)
stream << getPrecisionString() << " ";
if (array)
stream << "array[" << getArraySize() << "] of ";
if (isMatrix())
stream << getCols() << "X" << getRows() << " matrix of ";
else if (isVector())
stream << getNominalSize() << "-component vector of ";
stream << getBasicString();
return stream.str();
}
SEXP dpoMatrix_matrix_solve(SEXP a, SEXP b)
{
SEXP Chol = dpoMatrix_chol(a),
val = PROTECT(duplicate(b));
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(getAttrib(b, R_DimSymbol)),
info;
if (!(isReal(b) && isMatrix(b)))
error(_("Argument b must be a numeric matrix"));
if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
error(_("Dimensions of system to be solved are inconsistent"));
F77_CALL(dpotrs)(uplo_P(Chol), adims, bdims + 1,
REAL(GET_SLOT(Chol, Matrix_xSym)), adims,
REAL(val), bdims, &info);
UNPROTECT(1);
return val;
}
/**
* Simulate a sample of random matrices from a Wishart distribution
*
* @param ns Number of samples to generate
* @param nuP Degrees of freedom
* @param scal Positive-definite scale matrix
*
* @return
*/
SEXP
rWishart(SEXP ns, SEXP nuP, SEXP scal)
{
SEXP ans;
int *dims = INTEGER(getAttrib(scal, R_DimSymbol)), info,
n = asInteger(ns), psqr;
double *scCp, *ansp, *tmp, nu = asReal(nuP), one = 1, zero = 0;
if (!isMatrix(scal) || !isReal(scal) || dims[0] != dims[1])
error(_("'scal' must be a square, real matrix"));
if (n <= 0) n = 1;
// allocate early to avoid memory leaks in Callocs below.
PROTECT(ans = alloc3DArray(REALSXP, dims[0], dims[0], n));
psqr = dims[0] * dims[0];
tmp = Calloc(psqr, double);
scCp = Calloc(psqr, double);
Memcpy(scCp, REAL(scal), psqr);
memset(tmp, 0, psqr * sizeof(double));
F77_CALL(dpotrf)("U", &(dims[0]), scCp, &(dims[0]), &info);
if (info)
error(_("'scal' matrix is not positive-definite"));
ansp = REAL(ans);
GetRNGstate();
for (int j = 0; j < n; j++) {
double *ansj = ansp + j * psqr;
std_rWishart_factor(nu, dims[0], 1, tmp);
F77_CALL(dtrmm)("R", "U", "N", "N", dims, dims,
&one, scCp, dims, tmp, dims);
F77_CALL(dsyrk)("U", "T", &(dims[1]), &(dims[1]),
&one, tmp, &(dims[1]),
&zero, ansj, &(dims[1]));
for (int i = 1; i < dims[0]; i++)
for (int k = 0; k < i; k++)
ansj[i + k * dims[0]] = ansj[k + i * dims[0]];
}
PutRNGstate();
Free(scCp); Free(tmp);
UNPROTECT(1);
return ans;
}
/* Main function, the only one used by .External(). */
SEXP do_expm(SEXP x, SEXP kind)
{
SEXP dims, z;
int n, nprot = 1;
double *rx, *rz;
const char *ch_kind = CHAR(asChar(kind));
precond_type PC_kind = Ward_2 /* -Wall */;
if (!isNumeric(x) || !isMatrix(x))
error(_("invalid argument: not a numeric matrix"));
if (isInteger(x)) {
nprot++;
x = PROTECT(coerceVector(x, REALSXP));
}
rx = REAL(x);
if(!strcmp(ch_kind, "Ward77")) {
PC_kind = Ward_2;
} else if(!strcmp(ch_kind, "buggy_Ward77")) {
PC_kind = Ward_buggy_octave;
} else if(!strcmp(ch_kind, "Ward77_1")) {
PC_kind = Ward_1;
} else
error(_("invalid 'kind' argument: %s\n"), ch_kind);
dims = getAttrib(x, R_DimSymbol);
n = INTEGER(dims)[0];
if (n != INTEGER(dims)[1])
error(_("non-square matrix"));
if (n == 0)
return(allocMatrix(REALSXP, 0, 0));
PROTECT(z = allocMatrix(REALSXP, n, n));
rz = REAL(z);
expm(rx, n, rz, PC_kind);
/* ---- */
setAttrib(z, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
UNPROTECT(nprot);
return z;
}
//
// Recursively generate mangled names.
//
void TType::buildMangledName(TString& mangledName)
{
if (isMatrix())
mangledName += 'm';
else if (isVector())
mangledName += 'v';
switch (type) {
case EbtFloat: mangledName += 'f'; break;
case EbtInt: mangledName += 'i'; break;
case EbtBool: mangledName += 'b'; break;
case EbtSampler1D: mangledName += "s1"; break;
case EbtSampler2D: mangledName += "s2"; break;
case EbtSampler3D: mangledName += "s3"; break;
case EbtSamplerCube: mangledName += "sC"; break;
case EbtSampler1DShadow: mangledName += "sS1"; break;
case EbtSampler2DShadow: mangledName += "sS2"; break;
case EbtSamplerRect: mangledName += "sR2"; break; // ARB_texture_rectangle
case EbtSamplerRectShadow: mangledName += "sSR2"; break; // ARB_texture_rectangle
case EbtStruct:
mangledName += "struct-";
if (typeName)
mangledName += *typeName;
{// support MSVC++6.0
for (unsigned int i = 0; i < structure->size(); ++i) {
mangledName += '-';
(*structure)[i].type->buildMangledName(mangledName);
}
}
default:
break;
}
mangledName += static_cast<char>('0' + getNominalSize());
if (isArray()) {
char buf[10];
sprintf(buf, "%d", arraySize);
mangledName += '[';
mangledName += buf;
mangledName += ']';
}
}
// reverse a vector - equivalent of rev(x) in base, but implemented in C and about 12x faster (on 1e8)
SEXP setrev(SEXP x) {
R_len_t j, n, len;
size_t size;
char *tmp, *xt;
if (TYPEOF(x) == VECSXP || isMatrix(x)) error("Input 'x' must be a vector");
len = length(x);
if (len <= 1) return(x);
size = SIZEOF(x);
if (!size) error("don't know how to reverse type '%s' of input 'x'.",type2char(TYPEOF(x)));
n = (int)(len/2);
xt = (char *)DATAPTR(x);
if (size==4) {
tmp = (char *)Calloc(1, int);
if (!tmp) error("unable to allocate temporary working memory for reordering x");
for (j=0;j<n;j++) {
*(int *)tmp = ((int *)xt)[j]; // just copies 4 bytes (pointers on 32bit too)
((int *)xt)[j] = ((int *)xt)[len-1-j];
((int *)xt)[len-1-j] = *(int *)tmp;
}
} else {
SEXP predictTree(SEXP sp, SEXP x){
if(R_ExternalPtrTag(sp) != install("covatreePointer"))
Rf_error("The pointer must be to a covatree object");
covatree<double>* ptr=(covatree<double>*)R_ExternalPtrAddr(sp);
int dim = ptr->getDim();
if(isMatrix(x)){
MatrixXd res(nrows(x),1 + dim);
MatrixXd x0 = asMatrix(x);
for(int i = 0; i < nrows(x); ++i)
res.row(i) = ptr->operator()((vector)x0.row(i));
return asSEXP(res);
}else if(isNumeric(x)){
return asSEXP(ptr->operator()(asVector(x)));
}else{
Rf_error("Element must be a matrix or numeric vector");
}
return R_NilValue;
}