int check_index_bounds(int x, size_t len) {
if (x < 1 || x > (int)len) {
Rf_error("Expected index on [1..%d] (%d out of bounds)", len, x);
}
return x - 1;
}
SEXP flatten_impl(SEXP x) {
if (TYPEOF(x) != VECSXP) {
stop_bad_type(x, "a list", NULL, ".x");
}
int m = Rf_length(x);
// Determine output size and check type
int n = 0;
int has_names = 0;
SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol));
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
if (!is_vector(x_j) && x_j != R_NilValue) {
stop_bad_element_type(x_j, j + 1, "a vector", NULL, ".x");
}
n += Rf_length(x_j);
if (!has_names) {
if (!Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
// Sub-element is named
has_names = 1;
} else if (Rf_length(x_j) == 1 && !Rf_isNull(x_names)) {
// Element is a "scalar" and has name in parent
SEXP name = STRING_ELT(x_names, j);
if (name != NA_STRING && strcmp(CHAR(name), "") != 0)
has_names = 1;
}
}
}
SEXP out = PROTECT(Rf_allocVector(VECSXP, n));
SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
if (has_names)
Rf_setAttrib(out, R_NamesSymbol, names);
int i = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
int n_j = Rf_length(x_j);
SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol));
int has_names_j = !Rf_isNull(names_j);
for (int k = 0; k < n_j; ++k, ++i) {
switch(TYPEOF(x_j)) {
case LGLSXP: SET_VECTOR_ELT(out, i, Rf_ScalarLogical(LOGICAL(x_j)[k])); break;
case INTSXP: SET_VECTOR_ELT(out, i, Rf_ScalarInteger(INTEGER(x_j)[k])); break;
case REALSXP: SET_VECTOR_ELT(out, i, Rf_ScalarReal(REAL(x_j)[k])); break;
case CPLXSXP: SET_VECTOR_ELT(out, i, Rf_ScalarComplex(COMPLEX(x_j)[k])); break;
case STRSXP: SET_VECTOR_ELT(out, i, Rf_ScalarString(STRING_ELT(x_j, k))); break;
case RAWSXP: SET_VECTOR_ELT(out, i, Rf_ScalarRaw(RAW(x_j)[k])); break;
case VECSXP: SET_VECTOR_ELT(out, i, VECTOR_ELT(x_j, k)); break;
default:
Rf_error("Internal error: `flatten_impl()` should have failed earlier");
}
if (has_names) {
if (has_names_j) {
SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
} else if (n_j == 1) {
SET_STRING_ELT(names, i, !Rf_isNull(x_names) ? STRING_ELT(x_names, j) : Rf_mkChar(""));
}
}
if (i % 1024 == 0)
R_CheckUserInterrupt();
}
UNPROTECT(1);
}
UNPROTECT(3);
return out;
}
SEXP R_mpc_sub(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e1, "mpc")) {
Rprintf("It's an mpc");
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_sub(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_sub_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_sub_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operand 2 of MPC subtraction.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_sub(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e1)[0], GMP_RNDN);
mpc_fr_sub(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else {
/* TODO(mstokely): Add support for mpfr types here. */
Rprintf("It's unknown");
free(z);
Rf_error("Invalid second operand for mpc subtraction.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
RcppExport SEXP treePhaser(SEXP Rsignal, SEXP RkeyFlow, SEXP RflowCycle, SEXP Rcf, SEXP Rie, SEXP Rdr, SEXP Rbasecaller)
{
SEXP ret = R_NilValue;
char *exceptionMesg = NULL;
try {
RcppMatrix<double> signal(Rsignal);
RcppVector<int> keyFlow(RkeyFlow);
string flowCycle = Rcpp::as<string>(RflowCycle);
double cf = Rcpp::as<double>(Rcf);
double ie = Rcpp::as<double>(Rie);
double dr = Rcpp::as<double>(Rdr);
string basecaller = Rcpp::as<string>(Rbasecaller);
unsigned int nFlow = signal.cols();
unsigned int nRead = signal.rows();
if(basecaller != "treephaser-swan" && basecaller != "dp-treephaser" && basecaller != "treephaser-adaptive") {
std::string exception = "base value for basecaller supplied: " + basecaller;
exceptionMesg = copyMessageToR(exception.c_str());
} else if (flowCycle.length() < nFlow) {
std::string exception = "Flow cycle is shorter than number of flows to solve";
exceptionMesg = copyMessageToR(exception.c_str());
} else {
// Prepare objects for holding and passing back results
RcppMatrix<double> predicted_out(nRead,nFlow);
RcppMatrix<double> residual_out(nRead,nFlow);
RcppMatrix<int> hpFlow_out(nRead,nFlow);
std::vector< std::string> seq_out(nRead);
// Set up key flow vector
int nKeyFlow = keyFlow.size();
vector <int> keyVec(nKeyFlow);
for(int iFlow=0; iFlow < nKeyFlow; iFlow++)
keyVec[iFlow] = keyFlow(iFlow);
// Iterate over all reads
vector <float> sigVec(nFlow);
string result;
for(unsigned int iRead=0; iRead < nRead; iRead++) {
for(unsigned int iFlow=0; iFlow < nFlow; iFlow++)
sigVec[iFlow] = (float) signal(iRead,iFlow);
BasecallerRead read;
read.SetDataAndKeyNormalize(&(sigVec[0]), (int)nFlow, &(keyVec[0]), nKeyFlow-1);
DPTreephaser dpTreephaser(flowCycle.c_str(), flowCycle.length(), 8);
if (basecaller == "dp-treephaser")
dpTreephaser.SetModelParameters(cf, ie, dr);
else
dpTreephaser.SetModelParameters(cf, ie, 0); // Adaptive normalization
// Execute the iterative solving-normalization routine
if (basecaller == "dp-treephaser")
dpTreephaser.NormalizeAndSolve4(read, nFlow);
else if (basecaller == "treephaser-adaptive")
dpTreephaser.NormalizeAndSolve3(read, nFlow); // Adaptive normalization
else
dpTreephaser.NormalizeAndSolve5(read, nFlow); // sliding window adaptive normalization
read.flowToString(flowCycle,seq_out[iRead]);
for(unsigned int iFlow=0; iFlow < nFlow; iFlow++) {
predicted_out(iRead,iFlow) = (double) read.prediction[iFlow];
residual_out(iRead,iFlow) = (double) read.normalizedMeasurements[iFlow] - read.prediction[iFlow];
hpFlow_out(iRead,iFlow) = (int) read.solution[iFlow];
}
// Store results
RcppResultSet rs;
rs.add("seq", seq_out);
rs.add("predicted", predicted_out);
rs.add("residual", residual_out);
rs.add("hpFlow", hpFlow_out);
ret = rs.getReturnList();
}
}
} catch(std::exception& ex) {
exceptionMesg = copyMessageToR(ex.what());
} catch(...) {
exceptionMesg = copyMessageToR("unknown reason");
}
if(exceptionMesg != NULL)
Rf_error(exceptionMesg);
return ret;
}
SEXP _vcftype_as_SEXP(struct vcftype_t *vcftype)
{
if (NULL == vcftype || NILSXP == vcftype->type)
return R_NilValue;
const int ncol = vcftype->isArray ? vcftype->ncol : 1,
nrow = vcftype->nrow;
SEXP ans = PROTECT(Rf_allocVector(vcftype->type, nrow * ncol));
/* FIXME: transpose matricies */
switch (vcftype->type) {
case LGLSXP: {
int *val = LOGICAL(ans);
TPOSE(val, vcftype->u.logical, nrow, ncol);
}
break;
case INTSXP: {
int *val = INTEGER(ans);
TPOSE(val, vcftype->u.integer, nrow, ncol);
}
break;
case REALSXP: {
double *val = REAL(ans);
TPOSE(val, vcftype->u.numeric, nrow, ncol);
}
break;
case STRSXP: {
SEXP elt;
int idx = 0;
for (int j = 0; j < ncol; ++j)
for (int i = 0; i < nrow; ++i) {
const char *s = vcftype->u.character[i * ncol + j];
elt = (NULL == s) ? R_NaString : mkChar(s);
SET_STRING_ELT(ans, idx++, elt);
Free(vcftype->u.character[i * ncol + j]);
vcftype->u.character[i * ncol + j] = NULL;
}
}
break;
case VECSXP: {
SEXP elt;
int idx = 0;
for (int j = 0; j < ncol; ++j)
for (int i = 0; i < nrow; ++i) {
struct vcftype_t *t = vcftype->u.list[i * ncol + j];
elt = (NULL == t) ? R_NilValue : _vcftype_as_SEXP(t);
SET_VECTOR_ELT(ans, idx++, elt);
vcftype->u.list[i * ncol + j] = NULL;
}
}
break;
default:
Rf_error("(internal) unhandled type '%s'",
type2char(vcftype->type));
}
if (TRUE == vcftype->isArray) {
SEXP dim = PROTECT(Rf_allocVector(INTSXP, 2));
INTEGER(dim)[0] = vcftype->nrow;
INTEGER(dim)[1] = vcftype->ncol;
Rf_setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
_vcftype_free(vcftype);
UNPROTECT(1);
return ans;
}
SEXP getTreeDim(SEXP sp){
if(R_ExternalPtrTag(sp) != install("covatreePointer"))
Rf_error("The pointer must be to a covatree object");
covatree<double>* ptr=(covatree<double>*)R_ExternalPtrAddr(sp);
return(asSEXP(ptr->getDim()));
}
SEXP Rserve_oc_resolve(SEXP what) {
SEXP res;
if (!inherits(what, "OCref") || TYPEOF(what) != STRSXP || LENGTH(what) != 1)
Rf_error("invalid OCref");
return CAR(oc_resolve(CHAR(STRING_ELT(what, 0))));
}
void AlgebraFitFunction::setVarGroup(FreeVarGroup *vg)
{
varGroup = vg;
if (verbose) {
mxLog("%s: rebuild parameter map for var group %d",
ff->matrix->name(), varGroup->id[0]);
}
numDeriv = 0;
if (gradient) {
if (int(std::max(gradient->rownames.size(),
gradient->colnames.size())) !=
std::max(gradient->rows, gradient->cols)) {
Rf_error("%s: gradient must have row or column names", ff->matrix->name());
}
}
if (hessian) {
if (hessian->rows != hessian->cols) {
Rf_error("%s: Hessian must be square (instead of %dx%d)",
ff->matrix->name(), hessian->rows, hessian->cols);
}
if (int(hessian->rownames.size()) != hessian->rows ||
int(hessian->colnames.size()) != hessian->rows) {
Rf_error("%s: Hessian must have row and column names", ff->matrix->name());
}
for (int hx=0; hx < hessian->rows; ++hx) {
if (strcmp(hessian->colnames[hx], hessian->rownames[hx]) != 0) {
Rf_error("%s: Hessian must have identical row and column names (mismatch at %d)",
ff->matrix->name(), 1+hx);
}
}
// Is this the best way to test? TODO
vec2diag = hessian->algebra->oate && strcmp(hessian->algebra->oate->rName, "vec2diag")==0;
}
if (gradient && hessian) {
int size = gradient->rows * gradient->cols;
if (hessian->rows != size) {
Rf_error("%s: derivatives non-conformable (gradient is size %d and Hessian is %dx%d)",
ff->matrix->name(), size, hessian->rows, hessian->cols);
}
std::vector<const char*> &gnames = gradient->rownames;
if (gnames.size() == 0) gnames = gradient->colnames;
for (int hx=0; hx < hessian->rows; ++hx) {
if (strcmp(hessian->colnames[hx], gnames[hx]) != 0) {
Rf_error("%s: Hessian and gradient must have identical names (mismatch at %d)",
ff->matrix->name(), 1+hx);
}
}
}
std::vector<const char*> *names = NULL;
if (gradient) {
names = &gradient->rownames;
if (names->size() == 0) names = &gradient->colnames;
}
if (hessian && names == NULL) {
names = &hessian->rownames;
}
if (!names) return;
gradMap.resize(names->size());
for (size_t nx=0; nx < names->size(); ++nx) {
int to = varGroup->lookupVar((*names)[nx]);
gradMap[nx] = to;
if (to >= 0) ++numDeriv;
if (verbose) {
mxLog("%s: name '%s' mapped to free parameter %d",
ff->matrix->name(), (*names)[nx], gradMap[nx]);
}
}
}
/** Get localized time zone info
*
* @param tz single string or NULL
* @param locale single string or NULL
* @param display_type single string
* @return list
*
* @version 0.5-1 (Marek Gagolewski, 2014-12-24)
*
* @version 0.5-1 (Marek Gagolewski, 2015-03-01)
* new out: WindowsID, NameDaylight, new in: display_type
*/
SEXP stri_timezone_info(SEXP tz, SEXP locale, SEXP display_type) {
TimeZone* curtz = stri__prepare_arg_timezone(tz, "tz", R_NilValue);
const char* qloc = stri__prepare_arg_locale(locale, "locale", true); /* this is R_alloc'ed */
const char* dtype_str = stri__prepare_arg_string_1_notNA(display_type, "display_type"); /* this is R_alloc'ed */
const char* dtype_opts[] = {
"short", "long", "generic_short", "generic_long", "gmt_short", "gmt_long",
"common", "generic_location",
NULL};
int dtype_cur = stri__match_arg(dtype_str, dtype_opts);
TimeZone::EDisplayType dtype;
switch (dtype_cur) {
case 0: dtype = TimeZone::SHORT; break;
case 1: dtype = TimeZone::LONG; break;
case 2: dtype = TimeZone::SHORT_GENERIC; break;
case 3: dtype = TimeZone::LONG_GENERIC; break;
case 4: dtype = TimeZone::SHORT_GMT; break;
case 5: dtype = TimeZone::LONG_GMT; break;
case 6: dtype = TimeZone::SHORT_COMMONLY_USED; break;
case 7: dtype = TimeZone::GENERIC_LOCATION; break;
default: Rf_error(MSG__INCORRECT_MATCH_OPTION, "display_type"); break;
}
const R_len_t infosize = 6;
SEXP vals;
PROTECT(vals = Rf_allocVector(VECSXP, infosize));
for (int i=0; i<infosize; ++i)
SET_VECTOR_ELT(vals, i, R_NilValue);
R_len_t curidx = -1;
++curidx;
UnicodeString val_ID;
curtz->getID(val_ID);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_ID));
++curidx;
UnicodeString val_name;
curtz->getDisplayName(false, dtype, Locale::createFromName(qloc), val_name);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name));
++curidx;
if ((bool)curtz->useDaylightTime()) {
UnicodeString val_name2;
curtz->getDisplayName(true, dtype, Locale::createFromName(qloc), val_name2);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name2));
}
else
SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING));
++curidx;
UnicodeString val_windows;
UErrorCode status = U_ZERO_ERROR;
#if U_ICU_VERSION_MAJOR_NUM>=52
TimeZone::getWindowsID(val_ID, val_windows, status); // Stable since ICU 52
#endif
if (U_SUCCESS(status) && val_windows.length() > 0)
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_windows));
else
SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING));
++curidx;
SET_VECTOR_ELT(vals, curidx, Rf_ScalarReal(curtz->getRawOffset()/1000.0/3600.0));
++curidx;
SET_VECTOR_ELT(vals, curidx, Rf_ScalarLogical((bool)curtz->useDaylightTime()));
delete curtz;
stri__set_names(vals, infosize, "ID", "Name", "Name.Daylight", "Name.Windows", "RawOffset", "UsesDaylightTime");
UNPROTECT(1);
return vals;
}
static double
ba81ComputeEMFit(omxFitFunction* oo, int want, FitContext *fc)
{
const double Scale = Global->llScale;
BA81FitState *state = (BA81FitState*) oo->argStruct;
BA81Expect *estate = (BA81Expect*) oo->expectation->argStruct;
omxMatrix *itemParam = estate->itemParam;
std::vector<const double*> &itemSpec = estate->grp.spec;
std::vector<int> &cumItemOutcomes = estate->grp.cumItemOutcomes;
ba81NormalQuad &quad = estate->getQuad();
const int maxDims = quad.maxDims;
const size_t numItems = itemSpec.size();
const int do_fit = want & FF_COMPUTE_FIT;
const int do_deriv = want & (FF_COMPUTE_GRADIENT | FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN);
if (do_deriv && !state->freeItemParams) {
omxRaiseErrorf("%s: no free parameters", oo->name());
return NA_REAL;
}
if (state->returnRowLikelihoods) {
omxRaiseErrorf("%s: vector=TRUE not implemented", oo->name());
return NA_REAL;
}
if (estate->verbose >= 3) mxLog("%s: complete data fit(want fit=%d deriv=%d)", oo->name(), do_fit, do_deriv);
if (do_fit) estate->grp.ba81OutcomeProb(itemParam->data, TRUE);
const int thrDerivSize = itemParam->cols * state->itemDerivPadSize;
std::vector<double> thrDeriv(thrDerivSize * Global->numThreads);
double *wherePrep = quad.wherePrep.data();
double ll = 0;
#pragma omp parallel for num_threads(Global->numThreads) reduction(+:ll)
for (size_t ix=0; ix < numItems; ix++) {
const int thrId = omx_absolute_thread_num();
const double *spec = itemSpec[ix];
const int id = spec[RPF_ISpecID];
const int dims = spec[RPF_ISpecDims];
Eigen::VectorXd ptheta(dims);
const rpf_dLL1_t dLL1 = Glibrpf_model[id].dLL1;
const int iOutcomes = estate->grp.itemOutcomes[ix];
const int outcomeBase = cumItemOutcomes[ix] * quad.totalQuadPoints;
const double *weight = estate->expected + outcomeBase;
const double *oProb = estate->grp.outcomeProb + outcomeBase;
const double *iparam = omxMatrixColumn(itemParam, ix);
double *myDeriv = thrDeriv.data() + thrDerivSize * thrId + ix * state->itemDerivPadSize;
for (int qx=0; qx < quad.totalQuadPoints; qx++) {
if (do_fit) {
for (int ox=0; ox < iOutcomes; ox++) {
ll += weight[ox] * oProb[ox];
}
}
if (do_deriv) {
double *where = wherePrep + qx * maxDims;
for (int dx=0; dx < dims; dx++) {
ptheta[dx] = where[std::min(dx, maxDims-1)];
}
(*dLL1)(spec, iparam, ptheta.data(), weight, myDeriv);
}
weight += iOutcomes;
oProb += iOutcomes;
}
}
size_t excluded = 0;
if (do_deriv) {
double *deriv0 = thrDeriv.data();
int perThread = itemParam->cols * state->itemDerivPadSize;
for (int th=1; th < Global->numThreads; th++) {
double *thrD = thrDeriv.data() + th * perThread;
for (int ox=0; ox < perThread; ox++) deriv0[ox] += thrD[ox];
}
int numFreeParams = int(state->numFreeParam);
int ox=-1;
for (size_t ix=0; ix < numItems; ix++) {
const double *spec = itemSpec[ix];
int id = spec[RPF_ISpecID];
double *iparam = omxMatrixColumn(itemParam, ix);
double *pad = deriv0 + ix * state->itemDerivPadSize;
(*Glibrpf_model[id].dLL2)(spec, iparam, pad);
HessianBlock *hb = state->hBlocks[ix].clone();
hb->mat.triangularView<Eigen::Upper>().setZero();
for (int dx=0; dx < state->itemDerivPadSize; ++dx) {
int to = state->paramMap[++ox];
if (to == -1) continue;
// Need to check because this can happen if
// lbounds/ubounds are not set appropriately.
if (0 && !std::isfinite(deriv0[ox])) {
int item = ox / itemParam->rows;
mxLog("item parameters:\n");
const double *spec = itemSpec[item];
int id = spec[RPF_ISpecID];
int numParam = (*Glibrpf_model[id].numParam)(spec);
double *iparam = omxMatrixColumn(itemParam, item);
pda(iparam, numParam, 1);
// Perhaps bounds can be pulled in from librpf? TODO
Rf_error("Deriv %d for item %d is %f; are you missing a lbound/ubound?",
ox, item, deriv0[ox]);
}
if (to < numFreeParams) {
if (want & FF_COMPUTE_GRADIENT) {
fc->grad(to) -= Scale * deriv0[ox];
}
} else {
if (want & (FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN)) {
int Hto = state->hbMap[ox];
if (Hto >= 0) hb->mat.data()[Hto] -= Scale * deriv0[ox];
}
}
}
fc->queue(hb);
}
}
if (excluded && estate->verbose >= 1) {
mxLog("%s: Hessian not positive definite for %d/%d items",
oo->name(), (int) excluded, (int) numItems);
}
if (excluded == numItems) {
omxRaiseErrorf("Hessian not positive definite for %d/%d items",
(int) excluded, (int) numItems);
}
return Scale * ll;
}
static void sandwich(omxFitFunction *oo, FitContext *fc)
{
const double abScale = fabs(Global->llScale);
omxExpectation *expectation = oo->expectation;
BA81FitState *state = (BA81FitState*) oo->argStruct;
BA81Expect *estate = (BA81Expect*) expectation->argStruct;
if (estate->verbose >= 1) mxLog("%s: sandwich", oo->name());
estate->grp.ba81OutcomeProb(estate->itemParam->data, FALSE);
const int numThreads = Global->numThreads;
const int numUnique = estate->getNumUnique();
ba81NormalQuad &quad = estate->getQuad();
const int numSpecific = quad.numSpecific;
const int maxDims = quad.maxDims;
std::vector<int> &rowMap = estate->grp.rowMap;
double *rowWeight = estate->grp.rowWeight;
std::vector<bool> &rowSkip = estate->grp.rowSkip;
const int totalQuadPoints = quad.totalQuadPoints;
omxMatrix *itemParam = estate->itemParam;
omxBuffer<double> patternLik(numUnique);
std::vector<const double*> &itemSpec = estate->grp.spec;
const int totalOutcomes = estate->totalOutcomes();
const int numItems = estate->grp.numItems();
const size_t numParam = fc->varGroup->vars.size();
const double *wherePrep = quad.wherePrep.data();
std::vector<double> thrBreadG(numThreads * numParam * numParam);
std::vector<double> thrBreadH(numThreads * numParam * numParam);
std::vector<double> thrMeat(numThreads * numParam * numParam);
if (numSpecific == 0) {
omxBuffer<double> thrLxk(totalQuadPoints * numThreads);
#pragma omp parallel for num_threads(numThreads)
for (int px=0; px < numUnique; px++) {
if (rowSkip[px]) continue;
int thrId = omx_absolute_thread_num();
double *lxk = thrLxk.data() + thrId * totalQuadPoints;
omxBuffer<double> itemDeriv(state->itemDerivPadSize);
omxBuffer<double> expected(totalOutcomes); // can use maxOutcomes instead TODO
double *breadG = thrBreadG.data() + thrId * numParam * numParam; //a
double *breadH = thrBreadH.data() + thrId * numParam * numParam; //a
double *meat = thrMeat.data() + thrId * numParam * numParam; //b
std::vector<double> patGrad(numParam);
estate->grp.ba81LikelihoodSlow2(px, lxk);
// If patternLik is already valid, maybe could avoid this loop TODO
double patternLik1 = 0;
for (int qx=0; qx < totalQuadPoints; qx++) {
patternLik1 += lxk[qx];
}
patternLik[px] = patternLik1;
// if (!validPatternLik(state, patternLik1)) complain
double weight = 1 / patternLik[px];
for (int qx=0; qx < totalQuadPoints; qx++) {
double tmp = lxk[qx] * weight;
double sqrtTmp = sqrt(tmp);
std::vector<double> gradBuf(numParam);
int gradOffset = 0;
for (int ix=0; ix < numItems; ++ix) {
if (ix) gradOffset += state->paramPerItem[ix-1];
int pick = estate->grp.dataColumns[ix][rowMap[px]];
if (pick == NA_INTEGER) continue;
pick -= 1;
const int iOutcomes = estate->itemOutcomes(ix);
OMXZERO(expected.data(), iOutcomes);
expected[pick] = 1;
const double *spec = itemSpec[ix];
double *iparam = omxMatrixColumn(itemParam, ix);
const int id = spec[RPF_ISpecID];
OMXZERO(itemDeriv.data(), state->itemDerivPadSize);
(*Glibrpf_model[id].dLL1)(spec, iparam, wherePrep + qx * maxDims,
expected.data(), itemDeriv.data());
(*Glibrpf_model[id].dLL2)(spec, iparam, itemDeriv.data());
for (int par = 0; par < state->paramPerItem[ix]; ++par) {
int to = state->itemGradMap[gradOffset + par];
if (to >= 0) {
gradBuf[to] -= itemDeriv[par] * sqrtTmp;
patGrad[to] -= itemDeriv[par] * tmp;
}
}
int derivBase = ix * state->itemDerivPadSize;
for (int ox=0; ox < state->itemDerivPadSize; ox++) {
int to = state->paramMap[derivBase + ox];
if (to >= int(numParam)) {
int Hto = to - numParam;
breadH[Hto] += abScale * itemDeriv[ox] * tmp * rowWeight[px];
}
}
}
addSymOuterProd(abScale * rowWeight[px], gradBuf.data(), numParam, breadG);
}
addSymOuterProd(abScale * rowWeight[px], patGrad.data(), numParam, meat);
}
} else {
Rf_error("Sandwich information matrix method is not implemented for bifactor models");
const int totalPrimaryPoints = quad.totalPrimaryPoints;
const int specificPoints = quad.quadGridSize;
omxBuffer<double> thrLxk(totalQuadPoints * numSpecific * numThreads);
omxBuffer<double> thrEi(totalPrimaryPoints * numThreads);
omxBuffer<double> thrEis(totalPrimaryPoints * numSpecific * numThreads);
#pragma omp parallel for num_threads(numThreads)
for (int px=0; px < numUnique; px++) {
if (rowSkip[px]) continue;
int thrId = omx_absolute_thread_num();
omxBuffer<double> expected(totalOutcomes); // can use maxOutcomes instead TODO
omxBuffer<double> itemDeriv(state->itemDerivPadSize);
double *breadG = thrBreadG.data() + thrId * numParam * numParam; //a
double *breadH = thrBreadH.data() + thrId * numParam * numParam; //a
double *meat = thrMeat.data() + thrId * numParam * numParam; //b
std::vector<double> patGrad(numParam);
double *lxk = thrLxk.data() + totalQuadPoints * numSpecific * thrId;
double *Ei = thrEi.data() + totalPrimaryPoints * thrId;
double *Eis = thrEis.data() + totalPrimaryPoints * numSpecific * thrId;
estate->grp.cai2010EiEis(px, lxk, Eis, Ei);
// If patternLik is already valid, maybe could avoid this loop TODO
double patternLik1 = 0;
for (int qx=0; qx < totalPrimaryPoints; ++qx) {
patternLik1 += Ei[qx];
}
patternLik[px] = patternLik1;
for (int qx=0, qloc = 0; qx < totalPrimaryPoints; qx++) {
for (int sgroup=0; sgroup < numSpecific; ++sgroup) {
Eis[qloc] = Ei[qx] / Eis[qloc];
++qloc;
}
}
// WARNING: I didn't work out the math. I just coded this the way
// it seems to make sense.
for (int qloc=0, eisloc=0, qx=0; eisloc < totalPrimaryPoints * numSpecific; eisloc += numSpecific) {
for (int sx=0; sx < specificPoints; sx++) {
for (int Sgroup=0; Sgroup < numSpecific; Sgroup++) {
std::vector<double> gradBuf(numParam);
int gradOffset = 0;
double lxk1 = lxk[qloc + Sgroup];
double Eis1 = Eis[eisloc + Sgroup];
double tmp = Eis1 * lxk1 / patternLik1;
double sqrtTmp = sqrt(tmp);
for (int ix=0; ix < numItems; ++ix) {
if (ix) gradOffset += state->paramPerItem[ix-1];
if (estate->grp.Sgroup[ix] != Sgroup) continue;
int pick = estate->grp.dataColumns[ix][rowMap[px]];
if (pick == NA_INTEGER) continue;
OMXZERO(expected.data(), estate->itemOutcomes(ix));
expected[pick-1] = 1;
const double *spec = itemSpec[ix];
double *iparam = omxMatrixColumn(itemParam, ix);
const int id = spec[RPF_ISpecID];
const int dims = spec[RPF_ISpecDims];
OMXZERO(itemDeriv.data(), state->itemDerivPadSize);
const double *where = wherePrep + qx * maxDims;
Eigen::VectorXd ptheta(dims);
for (int dx=0; dx < dims; dx++) {
ptheta[dx] = where[std::min(dx, maxDims-1)];
}
(*Glibrpf_model[id].dLL1)(spec, iparam, ptheta.data(),
expected.data(), itemDeriv.data());
(*Glibrpf_model[id].dLL2)(spec, iparam, itemDeriv.data());
for (int par = 0; par < state->paramPerItem[ix]; ++par) {
int to = state->itemGradMap[gradOffset + par];
if (to >= 0) {
gradBuf[to] -= itemDeriv[par] * sqrtTmp;
patGrad[to] -= itemDeriv[par] * tmp;
}
}
int derivBase = ix * state->itemDerivPadSize;
for (int ox=0; ox < state->itemDerivPadSize; ox++) {
int to = state->paramMap[derivBase + ox];
if (to >= int(numParam)) {
int Hto = to - numParam;
breadH[Hto] += (abScale * itemDeriv[ox] *
tmp * rowWeight[px]);
}
}
}
addSymOuterProd(abScale * rowWeight[px], gradBuf.data(), numParam, breadG);
}
qloc += numSpecific;
++qx;
}
}
addSymOuterProd(abScale * rowWeight[px], patGrad.data(), numParam, meat);
}
}
// only need upper triangle TODO
for (int tx=1; tx < numThreads; ++tx) {
double *th = thrBreadG.data() + tx * numParam * numParam;
for (size_t en=0; en < numParam * numParam; ++en) {
thrBreadG[en] += th[en];
}
}
for (int tx=1; tx < numThreads; ++tx) {
double *th = thrBreadH.data() + tx * numParam * numParam;
for (size_t en=0; en < numParam * numParam; ++en) {
thrBreadH[en] += th[en];
}
}
for (int tx=1; tx < numThreads; ++tx) {
double *th = thrMeat.data() + tx * numParam * numParam;
for (size_t en=0; en < numParam * numParam; ++en) {
thrMeat[en] += th[en];
}
}
//pda(thrBreadG.data(), numParam, numParam);
//pda(thrBreadH.data(), numParam, numParam);
//pda(thrMeat.data(), numParam, numParam);
if (fc->infoA) {
for (size_t d1=0; d1 < numParam; ++d1) {
for (size_t d2=0; d2 < numParam; ++d2) {
int cell = d1 * numParam + d2;
fc->infoA[cell] += thrBreadH[cell] - thrBreadG[cell] + thrMeat[cell];
}
}
}
if (fc->infoB) {
for (size_t d1=0; d1 < numParam; ++d1) {
for (size_t d2=0; d2 < numParam; ++d2) {
int cell = d1 * numParam + d2;
fc->infoB[cell] += thrMeat[cell];
}
}
}
}
static void buildItemParamMap(omxFitFunction* oo, FitContext *fc)
{
FreeVarGroup *fvg = fc->varGroup;
BA81FitState *state = (BA81FitState *) oo->argStruct;
BA81Expect *estate = (BA81Expect*) oo->expectation->argStruct;
std::vector<const double*> &itemSpec = estate->grp.spec;
if (state->haveItemMap == fc->varGroup->id[0]) return;
if (estate->verbose >= 1) mxLog("%s: rebuild item parameter map for var group %d",
oo->name(), fc->varGroup->id[0]);
omxMatrix *itemParam = estate->itemParam;
int size = itemParam->cols * state->itemDerivPadSize;
state->freeItemParams = false;
state->hBlocks.clear();
state->hBlocks.resize(itemParam->cols);
state->hbMap.assign(size, -1); // matrix location to HessianBlock offset
state->paramMap.assign(size, -1); // matrix location to free param index
state->itemParamFree.assign(itemParam->rows * itemParam->cols, FALSE);
const size_t numFreeParam = state->numFreeParam;
state->paramFlavor.assign(numFreeParam, NULL);
int totalParam = 0;
state->paramPerItem.resize(itemParam->cols);
for (int cx=0; cx < itemParam->cols; ++cx) {
const double *spec = itemSpec[cx];
const int id = spec[RPF_ISpecID];
const int numParam = (*Glibrpf_model[id].numParam)(spec);
state->paramPerItem[cx] = numParam;
totalParam += numParam;
}
state->itemGradMap.assign(totalParam, -1);
for (size_t px=0; px < numFreeParam; px++) {
omxFreeVar *fv = fvg->vars[px];
for (size_t lx=0; lx < fv->locations.size(); lx++) {
omxFreeVarLocation *loc = &fv->locations[lx];
int matNum = ~loc->matrix;
if (matNum != itemParam->matrixNumber) continue;
int at = loc->col * state->itemDerivPadSize + loc->row;
state->paramMap[at] = px;
std::vector<int> &varMap = state->hBlocks[loc->col].vars;
if (std::find(varMap.begin(), varMap.end(), px) == varMap.end()) {
varMap.push_back(px);
}
state->itemParamFree[loc->col * itemParam->rows + loc->row] = TRUE;
state->freeItemParams = true;
const double *spec = itemSpec[loc->col];
int id = spec[RPF_ISpecID];
const char *flavor;
double upper, lower;
(*Glibrpf_model[id].paramInfo)(spec, loc->row, &flavor, &upper, &lower);
if (state->paramFlavor[px] == 0) {
state->paramFlavor[px] = flavor;
} else if (strcmp(state->paramFlavor[px], flavor) != 0) {
Rf_error("Cannot equate %s with %s[%d,%d]", fv->name,
itemParam->name(), loc->row, loc->col);
}
if (fv->lbound == NEG_INF && std::isfinite(lower)) {
fv->lbound = lower;
Global->boundsUpdated = true;
if (fc->est[px] < fv->lbound) {
Rf_error("Starting value %s %f less than lower bound %f",
fv->name, fc->est[px], lower);
}
}
if (fv->ubound == INF && std::isfinite(upper)) {
fv->ubound = upper;
Global->boundsUpdated = true;
if (fc->est[px] > fv->ubound) {
Rf_error("Starting value %s %f greater than upper bound %f",
fv->name, fc->est[px], upper);
}
}
}
}
int gradOffset = 0;
for (int cx=0; cx < itemParam->cols; ++cx) {
for (int rx=0; rx < state->paramPerItem[cx]; ++rx) {
int at = cx * state->itemDerivPadSize + rx;
int px = state->paramMap[at];
if (px >= 0) state->itemGradMap[gradOffset] = px;
++gradOffset;
}
}
for (int cx=0; cx < itemParam->cols; ++cx) {
HessianBlock &hb = state->hBlocks[cx];
int numParam = state->paramPerItem[cx];
for (int p1=0; p1 < numParam; p1++) {
const int outer_at1 = state->paramMap[cx * state->itemDerivPadSize + p1];
if (outer_at1 < 0) continue;
const int outer_hb1 = std::lower_bound(hb.vars.begin(), hb.vars.end(), outer_at1) - hb.vars.begin();
if (hb.vars[outer_hb1] != outer_at1) Rf_error("oops");
for (int p2=0; p2 <= p1; p2++) {
int at1 = outer_at1;
int hb1 = outer_hb1;
int at2 = state->paramMap[cx * state->itemDerivPadSize + p2];
if (at2 < 0) continue;
if (p1 == p2 && at1 != at2) Rf_error("oops");
int hb2 = std::lower_bound(hb.vars.begin(), hb.vars.end(), at2) - hb.vars.begin();
if (hb.vars[hb2] != at2) Rf_error("oops");
if (at1 < at2) std::swap(at1, at2); // outer_at1 unaffected
if (hb1 < hb2) std::swap(hb1, hb2); // outer_hb1 unaffected
// mxLog("Item %d param(%d,%d) -> H[%d,%d] B[%d,%d]",
// cx, p1, p2, at1, at2, hb1, hb2);
int at = cx * state->itemDerivPadSize + numParam + triangleLoc1(p1) + p2;
int hoffset = at1 * numFreeParam + at2;
state->paramMap[at] = numFreeParam + hoffset;
state->hbMap[at] = hb1 * hb.vars.size() + hb2;
}
}
}
state->haveItemMap = fc->varGroup->id[0];
//pia(state->paramMap.data(), state->itemDerivPadSize, itemParam->cols);
}
static void
ba81ComputeFit(omxFitFunction* oo, int want, FitContext *fc)
{
BA81FitState *state = (BA81FitState*) oo->argStruct;
BA81Expect *estate = (BA81Expect*) oo->expectation->argStruct;
if (fc) state->numFreeParam = fc->varGroup->vars.size();
if (want & FF_COMPUTE_INITIAL_FIT) return;
if (estate->type == EXPECTATION_AUGMENTED) {
buildItemParamMap(oo, fc);
if (want & FF_COMPUTE_PARAMFLAVOR) {
for (size_t px=0; px < state->numFreeParam; ++px) {
if (state->paramFlavor[px] == NULL) continue;
fc->flavor[px] = state->paramFlavor[px];
}
return;
}
if (want & FF_COMPUTE_PREOPTIMIZE) {
omxExpectationCompute(fc, oo->expectation, NULL);
return;
}
if (want & FF_COMPUTE_INFO) {
buildLatentParamMap(oo, fc);
if (!state->freeItemParams) {
omxRaiseErrorf("%s: no free parameters", oo->name());
return;
}
ba81SetupQuadrature(oo->expectation);
if (fc->infoMethod == INFO_METHOD_HESSIAN) {
ba81ComputeEMFit(oo, FF_COMPUTE_HESSIAN, fc);
} else {
omxRaiseErrorf("Information matrix approximation method %d is not available",
fc->infoMethod);
return;
}
return;
}
double got = ba81ComputeEMFit(oo, want, fc);
oo->matrix->data[0] = got;
return;
} else if (estate->type == EXPECTATION_OBSERVED) {
if (want == FF_COMPUTE_STARTING) {
buildLatentParamMap(oo, fc);
if (state->freeLatents) setLatentStartingValues(oo, fc);
return;
}
if (want & (FF_COMPUTE_INFO | FF_COMPUTE_GRADIENT)) {
buildLatentParamMap(oo, fc); // only to check state->freeLatents
buildItemParamMap(oo, fc);
if (!state->freeItemParams && !state->freeLatents) {
omxRaiseErrorf("%s: no free parameters", oo->name());
return;
}
ba81SetupQuadrature(oo->expectation);
if (want & FF_COMPUTE_GRADIENT ||
(want & FF_COMPUTE_INFO && fc->infoMethod == INFO_METHOD_MEAT)) {
gradCov(oo, fc);
} else {
if (state->freeLatents) {
omxRaiseErrorf("Information matrix approximation method %d is not available",
fc->infoMethod);
return;
}
if (!state->freeItemParams) {
omxRaiseErrorf("%s: no free parameters", oo->name());
return;
}
sandwich(oo, fc);
}
}
if (want & (FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN)) {
omxRaiseErrorf("%s: Hessian is not available for observed data", oo->name());
}
if (want & FF_COMPUTE_MAXABSCHANGE) {
double mac = std::max(omxMaxAbsDiff(state->itemParam, estate->itemParam),
omxMaxAbsDiff(state->latentMean, estate->_latentMeanOut));
fc->mac = std::max(mac, omxMaxAbsDiff(state->latentCov, estate->_latentCovOut));
state->copyEstimates(estate);
}
if (want & FF_COMPUTE_FIT) {
omxExpectationCompute(fc, oo->expectation, NULL);
Eigen::ArrayXd &patternLik = estate->grp.patternLik;
const int numUnique = estate->getNumUnique();
if (state->returnRowLikelihoods) {
const double OneOverLargest = estate->grp.quad.getReciprocalOfOne();
omxData *data = estate->data;
for (int rx=0; rx < numUnique; rx++) {
int dups = omxDataNumIdenticalRows(data, estate->grp.rowMap[rx]);
for (int dup=0; dup < dups; dup++) {
int dest = omxDataIndex(data, estate->grp.rowMap[rx]+dup);
oo->matrix->data[dest] = patternLik[rx] * OneOverLargest;
}
}
} else {
double *rowWeight = estate->grp.rowWeight;
const double LogLargest = estate->LogLargestDouble;
double got = 0;
#pragma omp parallel for num_threads(Global->numThreads) reduction(+:got)
for (int ux=0; ux < numUnique; ux++) {
if (patternLik[ux] == 0) continue;
got += rowWeight[ux] * (log(patternLik[ux]) - LogLargest);
}
double fit = nan("infeasible");
if (estate->grp.excludedPatterns < numUnique) {
fit = Global->llScale * got;
// add in some badness for excluded patterns
fit += fit * estate->grp.excludedPatterns;
}
if (estate->verbose >= 1) mxLog("%s: observed fit %.4f (%d/%d excluded)",
oo->name(), fit, estate->grp.excludedPatterns, numUnique);
oo->matrix->data[0] = fit;
}
}
} else {
Rf_error("%s: Predict nothing or scores before computing %d", oo->name(), want);
}
}
/* ev_err -- reports error (err_num) in file "file" at line "line_num" and
returns to user error handler;
list_num is an error list number (0 is the basic list
pointed by err_mesg, 1 is the basic list of warnings)
*/
int ev_err(char *file,int err_num,int line_num,char *fn_name,int list_num)
{
int num;
if ( err_num < 0 ) err_num = 0;
#ifndef USING_R
if (list_num < 0 || list_num >= err_list_end ||
err_list[list_num].listp == (char **)NULL) {
fprintf(stderr,
"\n Not (properly) attached list of errors: list_num = %d\n",
list_num);
fprintf(stderr," Call \"err_list_attach\" in your program\n");
if ( ! isatty(fileno(stdout)) ) {
fprintf(stderr,
"\n Not (properly) attached list of errors: list_num = %d\n",
list_num);
fprintf(stderr," Call \"err_list_attach\" in your program\n");
}
printf("\nExiting program\n");
exit(0);
}
#endif
num = err_num;
if ( num >= err_list[list_num].len ) num = 0;
#ifndef USING_R
if ( cnt_errs && ++num_errs >= MAX_ERRS ) /* too many errors */
{
fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
if ( ! isatty(fileno(stdout)) )
fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
printf("Sorry, too many errors: %d\n",num_errs);
printf("Exiting program\n");
exit(0);
}
#endif
if ( err_list[list_num].warn )
switch ( err_flag )
{
case EF_SILENT: break;
default:
#ifdef USING_R
Rprintf("\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#else
fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
if ( ! isatty(fileno(stdout)) )
fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#endif
break;
}
else
switch ( err_flag )
{
case EF_SILENT:
longjmp(restart,(err_num==0)? -1 : err_num);
break;
case EF_ABORT:
#ifdef USING_R
Rprintf("\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#else
fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
if ( ! isatty(fileno(stdout)) )
fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#endif
#ifdef USING_R
Rf_error("");
#else
abort();
#endif
break;
case EF_JUMP:
#ifdef USING_R
Rprintf("\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#else
fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
if ( ! isatty(fileno(stdout)) )
fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#endif
longjmp(restart,(err_num==0)? -1 : err_num);
break;
case EF_R_ERROR:
#ifdef USING_R /* EJP */
Rprintf("\n\"%s\", line %d: %s in function %s()\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
s_gstat_error(isascii(*fn_name) ? fn_name : "???", 0);
#endif
break;
default:
#ifdef USING_R
Rprintf("\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#else
fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
if ( ! isatty(fileno(stdout)) )
fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n",
file,line_num,err_list[list_num].listp[num],
isascii(*fn_name) ? fn_name : "???");
#endif
break;
}
/* ensure exit if fall through */
if ( ! err_list[list_num].warn )
#ifdef USING_R /* EJP */
s_gstat_error("err.c", 0);
#else
exit(0);
#endif
return 0;
}
void omxInitWLSFitFunction(omxFitFunction* oo) {
omxMatrix *cov, *means, *weights;
if(OMX_DEBUG) { mxLog("Initializing WLS FitFunction function."); }
int vectorSize = 0;
omxSetWLSFitFunctionCalls(oo);
if(OMX_DEBUG) { mxLog("Retrieving expectation.\n"); }
if (!oo->expectation) { Rf_error("%s requires an expectation", oo->fitType); }
if(OMX_DEBUG) { mxLog("Retrieving data.\n"); }
omxData* dataMat = oo->expectation->data;
if (dataMat->hasDefinitionVariables()) Rf_error("%s: def vars not implemented", oo->name());
if(!strEQ(omxDataType(dataMat), "acov") && !strEQ(omxDataType(dataMat), "cov")) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "WLS FitFunction unable to handle data type %s. Data must be of type 'acov'.\n", omxDataType(dataMat));
omxRaiseError(errstr);
free(errstr);
if(OMX_DEBUG) { mxLog("WLS FitFunction unable to handle data type %s. Aborting.", omxDataType(dataMat)); }
return;
}
omxWLSFitFunction *newObj = (omxWLSFitFunction*) R_alloc(1, sizeof(omxWLSFitFunction));
OMXZERO(newObj, 1);
oo->argStruct = (void*)newObj;
oo->units = FIT_UNITS_SQUARED_RESIDUAL;
/* Get Expectation Elements */
newObj->expectedCov = omxGetExpectationComponent(oo->expectation, "cov");
newObj->expectedMeans = omxGetExpectationComponent(oo->expectation, "means");
// FIXME: threshold structure should be asked for by omxGetExpectationComponent
/* Read and set expected means, variances, and weights */
cov = omxDataCovariance(dataMat);
means = omxDataMeans(dataMat);
weights = omxDataAcov(dataMat);
newObj->observedCov = cov;
newObj->observedMeans = means;
newObj->weights = weights;
newObj->n = omxDataNumObs(dataMat);
// NOTE: If there are any continuous columns then these vectors
// will not match because eThresh is indexed by column number
// not by ordinal column number.
std::vector< omxThresholdColumn > &oThresh = omxDataThresholds(oo->expectation->data);
std::vector< omxThresholdColumn > &eThresh = oo->expectation->thresholds;
// Error Checking: Observed/Expected means must agree.
// ^ is XOR: true when one is false and the other is not.
if((newObj->expectedMeans == NULL) ^ (newObj->observedMeans == NULL)) {
if(newObj->expectedMeans != NULL) {
omxRaiseError("Observed means not detected, but an expected means matrix was specified.\n If you wish to model the means, you must provide observed means.\n");
return;
} else {
omxRaiseError("Observed means were provided, but an expected means matrix was not specified.\n If you provide observed means, you must specify a model for the means.\n");
return;
}
}
if((eThresh.size()==0) ^ (oThresh.size()==0)) {
if (eThresh.size()) {
omxRaiseError("Observed thresholds not detected, but an expected thresholds matrix was specified.\n If you wish to model the thresholds, you must provide observed thresholds.\n ");
return;
} else {
omxRaiseError("Observed thresholds were provided, but an expected thresholds matrix was not specified.\nIf you provide observed thresholds, you must specify a model for the thresholds.\n");
return;
}
}
/* Error check weight matrix size */
int ncol = newObj->observedCov->cols;
vectorSize = (ncol * (ncol + 1) ) / 2;
if(newObj->expectedMeans != NULL) {
vectorSize = vectorSize + ncol;
}
for(int i = 0; i < int(oThresh.size()); i++) {
vectorSize = vectorSize + oThresh[i].numThresholds;
}
if(OMX_DEBUG) { mxLog("Intial WLSFitFunction vectorSize comes to: %d.", vectorSize); }
if(weights != NULL && (weights->rows != weights->cols || weights->cols != vectorSize)) {
omxRaiseError("Developer Error in WLS-based FitFunction object: WLS-based expectation specified an incorrectly-sized weight matrix.\nIf you are not developing a new expectation type, you should probably post this to the OpenMx forums.");
return;
}
// FIXME: More Rf_error checking for incoming Fit Functions
/* Temporary storage for calculation */
newObj->observedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
newObj->expectedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
newObj->standardExpectedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
newObj->P = omxInitMatrix(1, vectorSize, TRUE, oo->matrix->currentState);
newObj->B = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
newObj->standardExpectedCov = omxInitMatrix(ncol, ncol, TRUE, oo->matrix->currentState);
if (oo->expectation->thresholdsMat) {
newObj->standardExpectedThresholds = omxInitMatrix(oo->expectation->thresholdsMat->rows, oo->expectation->thresholdsMat->cols, TRUE, oo->matrix->currentState);
}
if(means){
newObj->standardExpectedMeans = omxInitMatrix(1, ncol, TRUE, oo->matrix->currentState);
}
omxMatrix *obsThresholdsMat = oo->expectation->data->obsThresholdsMat;
flattenDataToVector(newObj->observedCov, newObj->observedMeans, obsThresholdsMat, oThresh, newObj->observedFlattened);
flattenDataToVector(newObj->expectedCov, newObj->expectedMeans, oo->expectation->thresholdsMat,
eThresh, newObj->expectedFlattened);
}
SEXP r_do_tips(SEXP extPtr, SEXP vars, SEXP lambda, SEXP mu,
SEXP drift, SEXP diffusion, SEXP nt, SEXP dt,
SEXP padding) {
Rf_error("FFTW support not included");
}
int git_rebase_open(git_rebase **out, git_repository *repo)
{
git_rebase *rebase;
git_buf path = GIT_BUF_INIT, orig_head_name = GIT_BUF_INIT,
orig_head_id = GIT_BUF_INIT, onto_id = GIT_BUF_INIT;
int state_path_len, error;
assert(repo);
rebase = git__calloc(1, sizeof(git_rebase));
GITERR_CHECK_ALLOC(rebase);
rebase->repo = repo;
if ((error = rebase_state_type(&rebase->type, &rebase->state_path, repo)) < 0)
goto done;
if (rebase->type == GIT_REBASE_TYPE_NONE) {
giterr_set(GITERR_REBASE, "There is no rebase in progress");
error = GIT_ENOTFOUND;
goto done;
}
if ((error = git_buf_puts(&path, rebase->state_path)) < 0)
goto done;
state_path_len = git_buf_len(&path);
if ((error = git_buf_joinpath(&path, path.ptr, HEAD_NAME_FILE)) < 0 ||
(error = git_futils_readbuffer(&orig_head_name, path.ptr)) < 0)
goto done;
git_buf_rtrim(&orig_head_name);
if (strcmp(ORIG_DETACHED_HEAD, orig_head_name.ptr) == 0)
rebase->head_detached = 1;
git_buf_truncate(&path, state_path_len);
if ((error = git_buf_joinpath(&path, path.ptr, ORIG_HEAD_FILE)) < 0)
goto done;
if (!git_path_isfile(path.ptr)) {
/* Previous versions of git.git used 'head' here; support that. */
git_buf_truncate(&path, state_path_len);
if ((error = git_buf_joinpath(&path, path.ptr, HEAD_FILE)) < 0)
goto done;
}
if ((error = git_futils_readbuffer(&orig_head_id, path.ptr)) < 0)
goto done;
git_buf_rtrim(&orig_head_id);
if ((error = git_oid_fromstr(&rebase->orig_head_id, orig_head_id.ptr)) < 0)
goto done;
git_buf_truncate(&path, state_path_len);
if ((error = git_buf_joinpath(&path, path.ptr, ONTO_FILE)) < 0 ||
(error = git_futils_readbuffer(&onto_id, path.ptr)) < 0)
goto done;
git_buf_rtrim(&onto_id);
if ((error = git_oid_fromstr(&rebase->onto_id, onto_id.ptr)) < 0)
goto done;
if (!rebase->head_detached)
rebase->orig_head_name = git_buf_detach(&orig_head_name);
switch (rebase->type) {
case GIT_REBASE_TYPE_INTERACTIVE:
giterr_set(GITERR_REBASE, "Interactive rebase is not supported");
error = -1;
break;
case GIT_REBASE_TYPE_MERGE:
error = rebase_open_merge(rebase);
break;
case GIT_REBASE_TYPE_APPLY:
giterr_set(GITERR_REBASE, "Patch application rebase is not supported");
error = -1;
break;
default:
Rf_error(
"Error in 'git_rebase_open': Unexpected error. Please report at"
" https://github.com/ropensci/git2r/issues");
}
done:
if (error == 0)
*out = rebase;
else
git_rebase_free(rebase);
git_buf_free(&path);
git_buf_free(&orig_head_name);
git_buf_free(&orig_head_id);
git_buf_free(&onto_id);
return error;
}
SEXP r_make_quasse_fft(SEXP r_nx, SEXP r_dx, SEXP r_nd, SEXP r_flags) {
Rf_error("FFTW support not included");
}
// [[register]]
SEXP transpose_list(SEXP x_) {
SEXP x;
bool do_coerce = false;
int n = length(x_);
int N = length(VECTOR_ELT(x_, 0));
char type = max_type1(x_);
for (int i=0; i < n; ++i) {
if (length(VECTOR_ELT(x_, i)) != N) {
Rf_error("Each element in the list must be of the same length");
}
}
for (int i=0; i < n; ++i) {
if (TYPEOF( VECTOR_ELT(x_, i) ) != type) {
Rf_warning("Coercing vectors in the list to type '%s'", type2char(type));
do_coerce = true;
break;
}
}
if (do_coerce) {
x = PROTECT( duplicate(x_) );
for (int i=0; i < n; ++i) {
if (TYPEOF(VECTOR_ELT(x, i)) != type) {
SET_VECTOR_ELT(x, i, coerceVector(VECTOR_ELT(x, i), type));
}
}
} else {
x = x_;
}
SEXP output = PROTECT( allocVector(VECSXP, N) );
#define HANDLE_CASE(RTYPE, CTYPE, ACCESSOR) { \
for (int j=0; j < N; ++j) { \
SET_VECTOR_ELT(output, j, allocVector(RTYPE, n)); \
CTYPE* ptr = ACCESSOR( VECTOR_ELT(output, j) ); \
for (int i=0; i < n; ++i) { \
ptr[i] = ACCESSOR( VECTOR_ELT(x, i) )[j]; \
} \
} \
break; \
} \
switch (type) {
case LGLSXP: HANDLE_CASE(LGLSXP, int, LOGICAL);
case INTSXP: HANDLE_CASE(INTSXP, int, INTEGER);
case REALSXP: HANDLE_CASE(REALSXP, double, REAL);
case STRSXP: HANDLE_CASE(STRSXP, SEXP, STRING_PTR);
}
#undef HANDLE_CASE
UNPROTECT(1);
if (do_coerce) UNPROTECT(1);
return output;
}
void CodeVerifier::verifyFunctionLayout(SEXP sexp, InterpreterInstance* ctx) {
if (TYPEOF(sexp) != EXTERNALSXP)
Rf_error("RIR Verifier: Invalid SEXPTYPE");
Function* f = Function::unpack(sexp);
// get the code objects
std::vector<Code*> objs;
objs.push_back(f->body());
for (size_t i = 0; i < f->numArgs; ++i)
if (f->defaultArg(i))
objs.push_back(f->defaultArg(i));
if (f->size > XLENGTH(sexp))
Rf_error("RIR Verifier: Reported size must be smaller than the size of "
"the vector");
// check that the call instruction has proper arguments and number of
// instructions is valid
while (!objs.empty()) {
auto c = objs.back();
objs.pop_back();
if (c->info.magic != CODE_MAGIC)
Rf_error("RIR Verifier: Invalid code magic number");
if (c->src == 0)
Rf_error("RIR Verifier: Code must have AST");
unsigned oldo = c->stackLength;
calculateAndVerifyStack(c);
if (oldo != c->stackLength)
Rf_error("RIR Verifier: Invalid stack layout reported");
if (((uintptr_t)(c + 1) + pad4(c->codeSize) +
c->srcLength * sizeof(Code::SrclistEntry)) == 0)
Rf_error("RIR Verifier: Invalid code length reported");
Opcode* cptr = c->code();
Opcode* start = cptr;
Opcode* end = start + c->codeSize;
while (true) {
if (cptr > end)
Rf_error("RIR Verifier: Bytecode overflow");
BC cur = BC::decode(cptr, c);
switch (hasSources(cur.bc)) {
case Sources::Required:
if (c->getSrcIdxAt(cptr, true) == 0)
Rf_error("RIR Verifier: Source required but not found");
break;
case Sources::NotNeeded:
if (c->getSrcIdxAt(cptr, true) != 0)
Rf_error("RIR Verifier: Sources not needed but stored");
break;
case Sources::May: {
}
}
if (*cptr == Opcode::br_ || *cptr == Opcode::brobj_ ||
*cptr == Opcode::brtrue_ || *cptr == Opcode::brfalse_) {
int off = *reinterpret_cast<int*>(cptr + 1);
if (cptr + cur.size() + off < start ||
cptr + cur.size() + off > end)
Rf_error("RIR Verifier: Branch outside closure");
}
if (*cptr == Opcode::ldvar_) {
unsigned* argsIndex = reinterpret_cast<Immediate*>(cptr + 1);
if (*argsIndex >= cp_pool_length(ctx))
Rf_error("RIR Verifier: Invalid arglist index");
SEXP sym = cp_pool_at(ctx, *argsIndex);
if (TYPEOF(sym) != SYMSXP)
Rf_error("RIR Verifier: LdVar binding not a symbol");
if (!(strlen(CHAR(PRINTNAME(sym)))))
Rf_error("RIR Verifier: LdVar empty binding name");
}
if (*cptr == Opcode::promise_) {
unsigned* promidx = reinterpret_cast<Immediate*>(cptr + 1);
objs.push_back(c->getPromise(*promidx));
}
if (*cptr == Opcode::ldarg_) {
unsigned idx = *reinterpret_cast<Immediate*>(cptr + 1);
if (idx >= MAX_ARG_IDX)
Rf_error("RIR Verifier: Loading out of index argument");
}
if (*cptr == Opcode::call_implicit_ ||
*cptr == Opcode::named_call_implicit_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().immediateCallArguments[i];
if (offset == MISSING_ARG_IDX || offset == DOTS_ARG_IDX)
continue;
objs.push_back(c->getPromise(offset));
}
if (*cptr == Opcode::named_call_implicit_) {
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().callArgumentNames[i];
if (offset) {
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP && name != R_NilValue)
Rf_error("RIR Verifier: Calling target not a "
"symbol");
}
}
}
}
if (*cptr == Opcode::named_call_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.callExtra().callArgumentNames[i];
if (offset) {
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP && name != R_NilValue)
Rf_error(
"RIR Verifier: Calling target not a symbol");
}
}
}
if (*cptr == Opcode::mk_env_ || *cptr == Opcode::mk_stub_env_) {
uint32_t nargs = *reinterpret_cast<Immediate*>(cptr + 1);
for (size_t i = 0, e = nargs; i != e; ++i) {
uint32_t offset = cur.mkEnvExtra().names[i];
SEXP name = cp_pool_at(ctx, offset);
if (TYPEOF(name) != SYMSXP)
Rf_error(
"RIR Verifier: environment argument not a symbol");
}
}
cptr += cur.size();
if (cptr == start + c->codeSize) {
if (!(cur.isJmp() && cur.immediate.offset < 0) &&
!(cur.isExit()))
Rf_error("RIR Verifier: Last opcode should jump backwards "
"or exit");
break;
}
}
}
}
/** Generate random strings
*
* @param n single integer
* @param length integer vector
* @param pattern character vector
* @return character vector
*
* @version 0.2-1 (Marek Gagolewski, 2014-04-04)
*
* @version 0.2-1 (Marek Gagolewski, 2014-04-05)
* Use StriContainerCharClass which now contains UnicodeSets;
* vectorized also over pattern
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_rand_strings(SEXP n, SEXP length, SEXP pattern)
{
int n_val = stri__prepare_arg_integer_1_notNA(n, "n");
PROTECT(length = stri_prepare_arg_integer(length, "length"));
PROTECT(pattern = stri_prepare_arg_string(pattern, "pattern"));
if (n_val < 0) n_val = 0; /* that's not NA for sure now */
R_len_t length_len = LENGTH(length);
if (length_len <= 0) {
UNPROTECT(2);
Rf_error(MSG__ARG_EXPECTED_NOT_EMPTY, "length");
}
else if (length_len > n_val || n_val % length_len != 0)
Rf_warning(MSG__WARN_RECYCLING_RULE2);
R_len_t pattern_len = LENGTH(pattern);
if (pattern_len <= 0) {
UNPROTECT(2);
Rf_error(MSG__ARG_EXPECTED_NOT_EMPTY, "pattern");
}
else if (pattern_len > n_val || n_val % pattern_len != 0)
Rf_warning(MSG__WARN_RECYCLING_RULE2);
GetRNGstate();
STRI__ERROR_HANDLER_BEGIN(2)
StriContainerCharClass pattern_cont(pattern, max(n_val, pattern_len));
StriContainerInteger length_cont(length, max(n_val, length_len));
// get max required bufsize
int* length_tab = INTEGER(length);
R_len_t bufsize = 0;
for (R_len_t i=0; i<length_len; ++i) {
if (length_tab[i] != NA_INTEGER && length_tab[i] > bufsize)
bufsize = length_tab[i];
}
bufsize *= 4; // 1 UChar32 -> max. 4 UTF-8 bytes
String8buf buf(bufsize);
char* bufdata = buf.data();
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(STRSXP, n_val));
for (R_len_t i=0; i<n_val; ++i) {
if (length_cont.isNA(i) || pattern_cont.isNA(i)) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
int length_cur = length_cont.get(i);
if (length_cur < 0) length_cur = 0;
const UnicodeSet* uset = &(pattern_cont.get(i));
int32_t uset_size = uset->size();
// generate string:
R_len_t j = 0;
UBool err = FALSE;
for (R_len_t k=0; k<length_cur; ++k) {
int32_t idx = (int32_t)floor(unif_rand()*(double)uset_size); /* 0..uset_size-1 */
UChar32 c = uset->charAt(idx);
if (c < 0) throw StriException(MSG__INTERNAL_ERROR);
U8_APPEND((uint8_t*)bufdata, j, bufsize, c, err);
if (err) throw StriException(MSG__INTERNAL_ERROR);
}
SET_STRING_ELT(ret, i, Rf_mkCharLenCE(bufdata, j, CE_UTF8));
}
PutRNGstate();
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({
PutRNGstate();
})
}
SEXP CombineSubMaps(BigMatrix *oneVox_allSubs, SEXP allVoxs_allSubs, index_type seed, double *pVoxs, index_type nvoxs, index_type nsubs) {
//using namespace Rcpp;
BMAccessorType outMat( *oneVox_allSubs );
if (nsubs != oneVox_allSubs->ncol())
Rf_error("nsubs must equal oneVox_allSubs->ncol");
if (nvoxs != oneVox_allSubs->nrow())
Rf_error("nsubs must equal oneVox_allSubs->nrow");
// loop through each subject's map
index_type s = 0;
index_type v = 0;
index_type vv = 0;
LDOUBLE x = 0;
LDOUBLE delta = 0;
LDOUBLE mean = 0;
LDOUBLE M2 = 0;
LDOUBLE stdev = 0;
// CType *inCol;
CType *outCol;
LDOUBLE scaled_x;
BigMatrix *allVoxs_oneSub;
SEXP Rp;
SEXP tmp;
//RObject RallVoxs_oneSub;
for (s=0; s < nsubs; ++s) {
PROTECT(tmp = VECTOR_ELT(allVoxs_allSubs, s));
//RallVoxs_oneSub(tmp);
//Rp = RallVoxs_oneSub.slot("address");
PROTECT(Rp = GET_SLOT(tmp, install("address")));
//tmp = allVoxs_allSubs[s];
//RObject RallVoxs_oneSub(tmp);
//Rp = RallVoxs_oneSub.slot("address");
allVoxs_oneSub = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(Rp));
UNPROTECT(2);
BMAccessorType inMat( *allVoxs_oneSub );
// inCol = inMat[seed];
delta = mean = M2 = stdev = 0;
for (v=0; v < nvoxs; ++v) {
// todo: add checking for NaN...but shouldn't really have any!
// maybe can also pass the exact list of voxs to loop through!
// if (!ISNAN(pColumn[curj]))
// NA_REAL
vv = static_cast<index_type>(pVoxs[v]-1);
x = static_cast<LDOUBLE>(inMat[vv][seed]);
delta = x - mean;
mean = mean + delta/static_cast<LDOUBLE>(v+1);
M2 = M2 + delta*(x - mean);
}
stdev = sqrt(M2/(static_cast<LDOUBLE>(nvoxs-1)));
//printf("mean: %f; stdev: %f\n", mean, stdev);
outCol = outMat[s];
for (v=0; v < nvoxs; ++v) {
vv = static_cast<index_type>(pVoxs[v]-1);
scaled_x = (static_cast<LDOUBLE>(inMat[vv][seed])-mean)/stdev;
outCol[v] = static_cast<CType>(scaled_x);
}
}
return R_NilValue;
}
void R_init_sodium(DllInfo *info) {
if (sodium_init() < 0)
Rf_error("Failed to initialize libsodium.");
}
/**
* Convert case (upper, lowercase)
*
*
* @param str character vector
* @param locale single string identifying
* the locale ("" or NULL for default locale)
* @return character vector
*
*
* @version 0.1-?? (Marek Gagolewski)
*
* @version 0.1-?? (Marek Gagolewski)
* use StriContainerUTF16
*
* @version 0.1-?? (Marek Gagolewski, 2013-06-16)
* make StriException-friendly
*
* @version 0.1-?? (Marek Gagolewski, 2013-11-19)
* use UCaseMap + StriContainerUTF8
* **THIS DOES NOT WORK WITH ICU 4.8**, we have to revert the changes
* ** BTW, since stringi_0.1-25 we require ICU>=50 **
*
* @version 0.2-1 (Marek Gagolewski, 2014-03-18)
* use UCaseMap + StriContainerUTF8
* (this is much faster for UTF-8 and slightly faster for 8bit enc)
* Estimates minimal buffer size.
*
* @version 0.3-1 (Marek Gagolewski, 2014-10-24)
* Use a custom BreakIterator with stri_trans_totitle
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-03)
* use StriUBreakIterator
*
* @version 0.6-1 (Marek Gagolewski, 2015-07-11)
* now this is an internal function
*/
SEXP stri_trans_casemap(SEXP str, int _type, SEXP locale)
{
if (_type < 1 || _type > 2) Rf_error(MSG__INCORRECT_INTERNAL_ARG);
const char* qloc = stri__prepare_arg_locale(locale, "locale", true); /* this is R_alloc'ed */
PROTECT(str = stri_prepare_arg_string(str, "str")); // prepare string argument
// version 0.2-1 - Does not work with ICU 4.8 (but we require ICU >= 50)
UCaseMap* ucasemap = NULL;
STRI__ERROR_HANDLER_BEGIN(1)
UErrorCode status = U_ZERO_ERROR;
ucasemap = ucasemap_open(qloc, U_FOLD_CASE_DEFAULT, &status);
STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */})
R_len_t str_n = LENGTH(str);
StriContainerUTF8 str_cont(str, str_n);
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(STRSXP, str_n));
// STEP 1.
// Estimate the required buffer length
// Notice: The resulting number of codepoints may be larger or smaller than
// the number before casefolding
R_len_t bufsize = str_cont.getMaxNumBytes();
bufsize += 10; // a small margin
String8buf buf(bufsize);
// STEP 2.
// Do case folding
for (R_len_t i = str_cont.vectorize_init();
i != str_cont.vectorize_end();
i = str_cont.vectorize_next(i))
{
if (str_cont.isNA(i)) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
R_len_t str_cur_n = str_cont.get(i).length();
const char* str_cur_s = str_cont.get(i).c_str();
status = U_ZERO_ERROR;
int buf_need;
if (_type == 1) buf_need = ucasemap_utf8ToLower(ucasemap,
buf.data(), buf.size(), (const char*)str_cur_s, str_cur_n, &status);
else buf_need = ucasemap_utf8ToUpper(ucasemap,
buf.data(), buf.size(), (const char*)str_cur_s, str_cur_n, &status);
if (U_FAILURE(status)) { /* retry */
buf.resize(buf_need, false/*destroy contents*/);
status = U_ZERO_ERROR;
if (_type == 1) buf_need = ucasemap_utf8ToLower(ucasemap,
buf.data(), buf.size(), (const char*)str_cur_s, str_cur_n, &status);
else buf_need = ucasemap_utf8ToUpper(ucasemap,
buf.data(), buf.size(), (const char*)str_cur_s, str_cur_n, &status);
STRI__CHECKICUSTATUS_THROW(status, {/* do nothing special on err */}) // this shouldn't happen
// we do have the buffer size required to complete this op
}
SET_STRING_ELT(ret, i, Rf_mkCharLenCE(buf.data(), buf_need, CE_UTF8));
}
if (ucasemap) { ucasemap_close(ucasemap); ucasemap = NULL;}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({
if (ucasemap) { ucasemap_close(ucasemap); ucasemap = NULL; }
})
}
void omxInitGREMLFitFunction(omxFitFunction *oo){
if(OMX_DEBUG) { mxLog("Initializing GREML fitfunction."); }
SEXP rObj = oo->rObj;
SEXP dV, dVnames;
int i=0;
oo->units = FIT_UNITS_MINUS2LL;
oo->computeFun = omxCallGREMLFitFunction;
oo->ciFun = loglikelihoodCIFun;
oo->destructFun = omxDestroyGREMLFitFunction;
oo->populateAttrFun = omxPopulateGREMLAttributes;
omxGREMLFitState *newObj = new omxGREMLFitState;
oo->argStruct = (void*)newObj;
omxExpectation* expectation = oo->expectation;
omxState* currentState = expectation->currentState;
newObj->usingGREMLExpectation = (strcmp(expectation->expType, "MxExpectationGREML")==0 ? 1 : 0);
if(!newObj->usingGREMLExpectation){
//Maybe someday GREML fitfunction could be made compatible with another expectation, but not at present:
Rf_error("GREML fitfunction is currently only compatible with GREML expectation");
}
else{
omxGREMLExpectation* oge = (omxGREMLExpectation*)(expectation->argStruct);
oge->alwaysComputeMeans = 0;
}
newObj->y = omxGetExpectationComponent(expectation, oo, "y");
newObj->cov = omxGetExpectationComponent(expectation, oo, "cov");
newObj->invcov = omxGetExpectationComponent(expectation, oo, "invcov");
newObj->X = omxGetExpectationComponent(expectation, oo, "X");
newObj->means = omxGetExpectationComponent(expectation, oo, "means");
newObj->nll = 0;
newObj->REMLcorrection = 0;
newObj->varGroup = NULL;
//Derivatives:
{ScopedProtect p1(dV, R_do_slot(rObj, Rf_install("dV")));
ScopedProtect p2(dVnames, R_do_slot(rObj, Rf_install("dVnames")));
newObj->dVlength = Rf_length(dV);
newObj->dV.resize(newObj->dVlength);
newObj->dVnames.resize(newObj->dVlength);
if(newObj->dVlength){
if(!newObj->usingGREMLExpectation){
//Probably best not to allow use of dV if we aren't sure means will be calculated GREML-GLS way:
Rf_error("derivatives of 'V' matrix in GREML fitfunction only compatible with GREML expectation");
}
if(OMX_DEBUG) { mxLog("Processing derivatives of V."); }
int* dVint = INTEGER(dV);
for(i=0; i < newObj->dVlength; i++){
newObj->dV[i] = omxMatrixLookupFromState1(dVint[i], currentState);
SEXP elem;
{ScopedProtect p3(elem, STRING_ELT(dVnames, i));
newObj->dVnames[i] = CHAR(elem);}
}}
}
if(newObj->dVlength){
oo->gradientAvailable = true;
newObj->gradient.setZero(newObj->dVlength,1);
oo->hessianAvailable = true;
newObj->avgInfo.setZero(newObj->dVlength,newObj->dVlength);
for(i=0; i < newObj->dVlength; i++){
if( (newObj->dV[i]->rows != newObj->cov->rows) || (newObj->dV[i]->cols != newObj->cov->cols) ){
Rf_error("all derivatives of V must have the same dimensions as V");
}}}}
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
char sep;
int nsep, use_ncol, resilient, ncol;
long i, j, k, m, len, nmsep_flag, skip, quoteLen;
unsigned long nrow;
char num_buf[48];
const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
long nlines = asLong(sNlines, -1);
SEXP sOutput, tmp, sOutputNames, st, clv;
/* Parse inputs */
sep = CHAR(STRING_ELT(sSep, 0))[0];
nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;
nmsep_flag = (nsep > 0);
use_ncol = asInteger(sNcol);
resilient = asInteger(sResilient);
ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
so ncol *does* include the key column */
skip = asLong(sSkip, 0);
/* parse quote information */
quoteChars = CHAR(STRING_ELT(sQuote, 0));
quoteLen = strlen(quoteChars);
/* count non-NA columns */
for (i = 0; i < use_ncol; i++)
if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;
/* check input */
if (TYPEOF(s) == RAWSXP) {
nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
sraw = (const char*) RAW(s);
send = sraw + XLENGTH(s);
if (nrow >= skip) {
unsigned long slen = XLENGTH(s);
nrow = nrow - skip;
i = 0;
while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
} else {
nrow = 0;
sraw = send;
}
} else if (TYPEOF(s) == STRSXP) {
nrow = XLENGTH(s);
if (nrow >= skip) {
nrow -= skip;
} else {
skip = nrow;
nrow = 0;
}
} else
Rf_error("invalid input to split - must be a raw or character vector");
if (nlines >= 0 && nrow > nlines) nrow = nlines;
/* allocate result */
PROTECT(sOutput = allocVector(VECSXP, ncol));
/* set names */
setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));
if (nrow > INT_MAX)
Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
else {
/* set automatic row names */
PROTECT(tmp = allocVector(INTSXP, 2));
INTEGER(tmp)[0] = NA_INTEGER;
INTEGER(tmp)[1] = -nrow;
setAttrib(sOutput, R_RowNamesSymbol, tmp);
UNPROTECT(1);
/* set class */
classgets(sOutput, mkString("data.frame"));
}
/* Create SEXP for each element of the output */
j = 0;
for (i = 0; i < use_ncol; i++) {
if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));
switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
break;
case VECSXP:
SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
clv = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
setAttrib(st, R_ClassSymbol, clv);
/* this is somewhat a security precaution such that users
don't get surprised -- if there is no TZ R will
render it in local time - which is correct but
may confuse people that didn't use GMT to start with */
setAttrib(st, install("tzone"), mkString("GMT"));
UNPROTECT(1);
break;
case NILSXP:
break;
default:
Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
break;
}
}
/* Cycle through the rows and extract the data */
for (k = 0; k < nrow; k++) {
const char *l = 0, *le;
if (TYPEOF(s) == RAWSXP) {
l = sraw;
le = memchr(l, '\n', send - l);
if (!le) le = send;
sraw = le + 1;
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, k + skip));
le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
}
if (nmsep_flag) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
}
i = nmsep_flag;
j = nmsep_flag;
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (i >= use_ncol) {
if (resilient) break;
Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
}
switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
j++;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
j++;
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
j++;
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
j++;
break;
case STRSXP:
c2 = c;
if (quoteLen) {
for (m = 0; m < quoteLen; m++) {
if (*l == quoteChars[m]) {
l++;
if (!(c2 = memchr(l, quoteChars[m], le - l))) {
Rf_error("End of line within quoted string.");
} else {
if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
c = le;
}
}
}
}
SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
j++;
break;
case RAWSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
j++;
break;
case VECSXP:
REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
j++;
}
l = c + 1;
i++;
}
/* fill-up unused columns */
while (i < use_ncol) {
switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case INTSXP:
INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case REALSXP:
case VECSXP:
REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
break;
case RAWSXP:
RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
break;
}
i++;
}
}
UNPROTECT(1); /* sOutput */
return(sOutput);
}
SEXP R_NPAPI_Invoke(SEXP plug, SEXP Robj, SEXP Rname, SEXP Rargs, SEXP RconvArgsEnum, SEXP RconvArgsFuns, SEXP RconvRet, SEXP RkeepRes )
{
NPP inst = (NPP) R_ExternalPtrAddr(GET_SLOT( plug , Rf_install( "ref" ) ) );
NPNetscapeFuncs *funcs = (NPNetscapeFuncs *) R_ExternalPtrAddr(GET_SLOT( GET_SLOT(plug, Rf_install("funcs")), Rf_install("ref")));
NPVariant *obj = (NPVariant *) R_ExternalPtrAddr(GET_SLOT( Robj , Rf_install( "ref" ) ) );
if(!NPVARIANT_IS_OBJECT(*obj))
{
//What should we return in this case?
Rf_error("Robj is not an NPVariant containing an NPObject.");
return R_NilValue;
}
//custom conversion functions are applied on R side for return value.
convert_t convRet = (convert_t) INTEGER(RconvRet)[0];
convert_t curConvArg;
int nargs = LENGTH(Rargs);
NPVariant *args = (NPVariant *) funcs->memalloc(nargs*sizeof(NPVariant));
for(int i = 0; i < nargs; i++)
{
curConvArg = (convert_t) INTEGER(RconvArgsEnum)[i];
ConvertRToNP(VECTOR_ELT(Rargs, i), inst, funcs, &(args[i]), curConvArg);
//If we have a custom converter we invoke it with here
if(curConvArg == CONV_CUSTOM)
{
fprintf(stderr, "Custom argument converter detected. Attempting to call JS Conversion function.");fflush(stderr);
funcs->invokeDefault(inst, ((NPVariant *) R_ExternalPtrAddr(GET_SLOT( VECTOR_ELT(RconvArgsFuns, i), Rf_install( "ref" ) ) ) ) -> value.objectValue, &args[i], 1, &args[i]) ;
}
}
NPVariant *ret = (NPVariant *) funcs->memalloc(sizeof(NPVariant));
const char *ccname = CHAR(STRING_ELT(Rname, 0));
bool hasMethod = funcs->hasmethod(inst, obj->value.objectValue, funcs->getstringidentifier(ccname));
if(!hasMethod)
{
char msg[200];
sprintf(msg, "Object has no %s method.", ccname);
Rf_error(msg);
return R_NilValue;
}
bool success = funcs->invoke(inst, obj->value.objectValue, funcs->getstringidentifier(ccname), args, nargs, ret);
if(!success)
{
fprintf(stderr, "\nInvocation of JS method %s failed.", ccname);fflush(stderr);
}
for(int j=0; j<nargs; j++)
{
if (NPVARIANT_IS_OBJECT(args[j]))
funcs->releaseobject(args[j].value.objectValue);
//funcs->releasevariantvalue(&args[j]);
}
funcs->memfree(args);
if(!success)
{
char msg2[200];
sprintf(msg2, "Invoke failed for %s method.", ccname);
Rf_error(msg2);
return R_NilValue;
}
SEXP ans;
//PROTECT(ans = R_NilValue);
PROTECT(ans = NEW_INTEGER(1));
bool canfree = ConvertNPToR(ret, inst, funcs, convRet, &ans);
bool keepRes = LOGICAL(RkeepRes)[0];
if(canfree || !keepRes)
funcs->releasevariantvalue(ret);
UNPROTECT(1);
if(keepRes)
return ans ;
else
return R_NilValue;
}
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; // -Wall
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = CXXRCONSTRUCT(Rboolean, n > INT_MAX);
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
dim_v = getAttrib(value, R_DimSymbol);
array_value = CXXRCONSTRUCT(Rboolean, (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1));
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(ind = allocVector(INTSXP, 1));
if(isVectorAtomic(XX))
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(XX, CONS(ind, R_NilValue))));
else
PROTECT(tmp = LCONS(R_Bracket2Symbol,
CONS(X, CONS(ind, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
CONS(tmp, CONS(R_DotsSymbol, R_NilValue))));
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = double(i + 1);
else INTEGER(ind)[0] = int(i + 1);
val = eval(R_fcall, rho);
if (NAMED(val))
val = duplicate(val);
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
bool okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
default:
Rf_error(_("Internal error: unexpected SEXPTYPE"));
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
for (int j = 0; j < commonLen; j++) {
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i*commonLen + j] = COMPLEX(val)[j]; break;
case REALSXP: REAL(ans)[i*commonLen + j] = REAL(val)[j]; break;
case INTSXP: INTEGER(ans)[i*commonLen + j] = INTEGER(val)[j]; break;
case LGLSXP: LOGICAL(ans)[i*commonLen + j] = LOGICAL(val)[j]; break;
case RAWSXP: RAW(ans)[i*commonLen + j] = RAW(val)[j]; break;
case STRSXP: SET_STRING_ELT(ans, i*commonLen + j, STRING_ELT(val, j)); break;
case VECSXP: SET_VECTOR_ELT(ans, i*commonLen + j, VECTOR_ELT(val, j)); break;
default:
error(_("type '%s' is not supported"), type2char(commonType));
}
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = int( n); // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}
/* Added by Yixuan Qiu */
void PNG_ABORT_WITH_R_HANDLER()
{
Rf_error("unexpected error from libpng");
}
void ifaGroup::setFactorNames(std::vector<const char *> &names)
{
if (int(names.size()) < itemDims) Rf_error("Not enough names");
factorNames.resize(itemDims);
for (int fx=0; fx < itemDims; ++fx) factorNames[fx] = names[fx];
}
