/*
The real invoke mechanism that handles all the details.
*/
SEXP
R_COM_Invoke(SEXP obj, SEXP methodName, SEXP args, WORD callType, WORD doReturn,
SEXP ids)
{
IDispatch* disp;
SEXP ans = R_NilValue;
int numNamedArgs = 0, *namedArgPositions = NULL, i;
HRESULT hr;
// callGC();
disp = (IDispatch *) getRDCOMReference(obj);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "<COM> %s %d %p\n", CHAR(STRING_ELT(methodName, 0)), (int) callType,
disp);fflush(stderr);
#endif
DISPID *methodIds;
const char *pmname = CHAR(STRING_ELT(methodName, 0));
BSTR *comNames = NULL;
SEXP names = GET_NAMES(args);
int numNames = Rf_length(names) + 1;
SetErrorInfo(0L, NULL);
methodIds = (DISPID *) S_alloc(numNames, sizeof(DISPID));
namedArgPositions = (int*) S_alloc(numNames, sizeof(int)); // we may not use all of these, but we allocate them
if(Rf_length(ids) == 0) {
comNames = (BSTR*) S_alloc(numNames, sizeof(BSTR));
comNames[0] = AsBstr(pmname);
for(i = 0; i < Rf_length(names); i++) {
const char *str = CHAR(STRING_ELT(names, i));
if(str && str[0]) {
comNames[numNamedArgs+1] = AsBstr(str);
namedArgPositions[numNamedArgs] = i;
numNamedArgs++;
}
}
numNames = numNamedArgs + 1;
hr = disp->GetIDsOfNames(IID_NULL, comNames, numNames, LOCALE_USER_DEFAULT, methodIds);
if(FAILED(hr) || hr == DISP_E_UNKNOWNNAME /* || DISPID mid == DISPID_UNKNOWN */) {
PROBLEM "Cannot locate %d name(s) %s in COM object (status = %d)", numNamedArgs, pmname, (int) hr
ERROR;
}
} else {
for(i = 0; i < Rf_length(ids); i++) {
methodIds[i] = (MEMBERID) NUMERIC_DATA(ids)[i];
//XXX What about namedArgPositions here.
}
}
DISPPARAMS params = {NULL, NULL, 0, 0};
if(args != NULL && Rf_length(args) > 0) {
hr = R_getCOMArgs(args, ¶ms, methodIds, numNamedArgs, namedArgPositions);
if(FAILED(hr)) {
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
PROBLEM "Failed in converting arguments to DCOM call"
ERROR;
}
if(callType & DISPATCH_PROPERTYPUT) {
params.rgdispidNamedArgs = (DISPID*) S_alloc(1, sizeof(DISPID));
params.rgdispidNamedArgs[0] = DISPID_PROPERTYPUT;
params.cNamedArgs = 1;
}
}
VARIANT varResult, *res = NULL;
if(doReturn && callType != DISPATCH_PROPERTYPUT)
VariantInit(res = &varResult);
EXCEPINFO exceptionInfo;
memset(&exceptionInfo, 0, sizeof(exceptionInfo));
unsigned int nargErr = 100;
#ifdef RDCOM_VERBOSE
if(params.cNamedArgs) {
errorLog("# of named arguments to %d: %d\n", (int) methodIds[0],
(int) params.cNamedArgs);
for(int p = params.cNamedArgs; p > 0; p--)
errorLog("%d) id %d, type %d\n", p,
(int) params.rgdispidNamedArgs[p-1],
(int) V_VT(&(params.rgvarg[p-1])));
}
#endif
hr = disp->Invoke(methodIds[0], IID_NULL, LOCALE_USER_DEFAULT, callType, ¶ms, res, &exceptionInfo, &nargErr);
if(FAILED(hr)) {
if(hr == DISP_E_MEMBERNOTFOUND) {
errorLog("Error because member not found %d\n", nargErr);
}
#ifdef RDCOM_VERBOSE
errorLog("Error (%d): <in argument %d>, call type = %d, call = \n",
(int) hr, (int)nargErr, (int) callType, pmname);
#endif
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
if(checkErrorInfo(disp, hr, NULL) != S_OK) {
fprintf(stderr, "checkErrorInfo %d\n", (int) hr);fflush(stderr);
COMError(hr);
}
}
if(res) {
ans = R_convertDCOMObjectToR(&varResult);
VariantClear(&varResult);
}
clearVariants(¶ms);
freeSysStrings(comNames, numNames);
#ifdef ANNOUNCE_COM_CALLS
fprintf(stderr, "</COM>\n", (int) callType);fflush(stderr);
#endif
return(ans);
}
#include "RS_XML.h"
#include <libxml/xpath.h>
#include "Utils.h"
static SEXP
convertNodeSetToR(xmlNodeSetPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans, expr = NULL, arg = NULL, ref;
int i;
if(!obj)
return(NULL_USER_OBJECT);
PROTECT(ans = NEW_LIST(obj->nodeNr));
if(GET_LENGTH(fun) && (TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)) {
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, fun);
arg = CDR(expr);
} else if(TYPEOF(fun) == LANGSXP) {
expr = fun;
arg = CDR(expr);
}
for(i = 0; i < obj->nodeNr; i++) {
xmlNodePtr el;
el = obj->nodeTab[i];
if(el->type == XML_ATTRIBUTE_NODE) {
#if 0
PROTECT(ref = mkString((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : ""));
SET_NAMES(ref, mkString(el->name));
#else
PROTECT(ref = ScalarString(mkCharCE((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : "", encoding)));
SET_NAMES(ref, ScalarString(mkCharCE(el->name, encoding)));
#endif
SET_CLASS(ref, mkString("XMLAttributeValue"));
UNPROTECT(1);
} else if(el->type == XML_NAMESPACE_DECL)
ref = R_createXMLNsRef((xmlNsPtr) el);
else
ref = R_createXMLNodeRef(el, manageMemory);
if(expr) {
PROTECT(ref);
SETCAR(arg, ref);
PROTECT(ref = Rf_eval(expr, R_GlobalEnv)); /*XXX do we want to catch errors here? Maybe to release the namespaces. */
SET_VECTOR_ELT(ans, i, ref);
UNPROTECT(2);
} else
SET_VECTOR_ELT(ans, i, ref);
}
if(expr) {
if(TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)
UNPROTECT(1);
} else
SET_CLASS(ans, mkString("XMLNodeSet"));
UNPROTECT(1);
return(ans);
}
SEXP
convertXPathObjectToR(xmlXPathObjectPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans = NULL_USER_OBJECT;
switch(obj->type) {
case XPATH_NODESET:
ans = convertNodeSetToR(obj->nodesetval, fun, encoding, manageMemory);
break;
case XPATH_BOOLEAN:
ans = ScalarLogical(obj->boolval);
break;
case XPATH_NUMBER:
ans = ScalarReal(obj->floatval);
if(xmlXPathIsInf(obj->floatval))
REAL(ans)[0] = xmlXPathIsInf(obj->floatval) < 0 ? R_NegInf : R_PosInf;
else if(xmlXPathIsNaN(obj->floatval))
REAL(ans)[0] = NA_REAL;
break;
case XPATH_STRING:
ans = mkString(XMLCHAR_TO_CHAR(obj->stringval)); //XXX encoding
break;
case XPATH_POINT:
case XPATH_RANGE:
case XPATH_LOCATIONSET:
case XPATH_USERS:
PROBLEM "currently unsupported xmlXPathObject type %d in convertXPathObjectToR. Please send mail to maintainer.", obj->type
WARN
default:
ans = R_NilValue;
}
return(ans);
}
#include <libxml/xpathInternals.h> /* For xmlXPathRegisterNs() */
xmlNsPtr *
R_namespaceArray(SEXP namespaces, xmlXPathContextPtr ctxt)
{
int i, n;
SEXP names = GET_NAMES(namespaces);
xmlNsPtr *els;
n = GET_LENGTH(namespaces);
els = xmlMallocAtomic(sizeof(xmlNsPtr) * n);
if(!els) {
PROBLEM "Failed to allocated space for namespaces"
ERROR;
}
for(i = 0; i < n; i++) {
/*XXX who owns these strings. */
const xmlChar *prefix, *href;
href = CHAR_TO_XMLCHAR(strdup(CHAR_DEREF(STRING_ELT(namespaces, i))));
prefix = names == NULL_USER_OBJECT ? CHAR_TO_XMLCHAR("") /* NULL */
: CHAR_TO_XMLCHAR(strdup(CHAR_DEREF(STRING_ELT(names, i))));
els[i] = xmlNewNs(NULL, href, prefix);
if(ctxt)
xmlXPathRegisterNs(ctxt, prefix, href);
}
return(els);
}
/* --- .Call ENTRY POINT --- */
SEXP fastq_geometry(SEXP filexp_list,
SEXP nrec, SEXP skip, SEXP seek_first_rec)
{
int nrec0, skip0, seek_rec0, i, recno;
FASTQGEOM_loaderExt loader_ext;
FASTQloader loader;
const char *errmsg;
SEXP filexp, ans;
nrec0 = INTEGER(nrec)[0];
skip0 = INTEGER(skip)[0];
seek_rec0 = LOGICAL(seek_first_rec)[0];
loader_ext = new_FASTQGEOM_loaderExt();
loader = new_FASTQGEOM_loader(&loader_ext);
recno = 0;
for (i = 0; i < LENGTH(filexp_list); i++) {
filexp = VECTOR_ELT(filexp_list, i);
errmsg = parse_FASTQ_file(filexp, nrec0, skip0, seek_rec0,
&loader, &recno);
if (errmsg != NULL)
error("reading FASTQ file %s: %s",
CHAR(STRING_ELT(GET_NAMES(filexp_list), i)),
errmsg_buf);
}
PROTECT(ans = NEW_INTEGER(2));
INTEGER(ans)[0] = loader.nrec;
INTEGER(ans)[1] = loader_ext.width;
UNPROTECT(1);
return ans;
}
/* Get the font description object defined in swfFont.h */
static pfontDesc swfGetFontDesc(const pGEcontext gc, pswfDesc swfInfo)
{
int gcfontface = gc->fontface;
pfontDesc font;
SEXP fontList;
SEXP fontNames;
SEXP extPtr;
int i, listLen;
/* Font list is .pkg.env$.font.list, defined in font.R */
PROTECT(fontList = Rf_findVar(install(".font.list"), swfInfo->pkgEnv));
UNPROTECT(1);
fontNames = GET_NAMES(fontList);
listLen = Rf_length(fontList);
for(i = 0; i < listLen; i++)
{
if(strcmp(gc->fontfamily, CHAR(STRING_ELT(fontNames, i))) == 0)
{
break;
}
}
if(i == listLen) i = 0;
if(gcfontface < 1 || gcfontface > 5) gcfontface = 1;
extPtr = VECTOR_ELT(VECTOR_ELT(fontList, i), gcfontface - 1);
font = (pfontDesc) R_ExternalPtrAddr(extPtr);
return font;
}
HRESULT
R_getCOMArgs(SEXP args, DISPPARAMS *parms, DISPID *ids, int numNamedArgs, int *namedArgPositions)
{
HRESULT hr;
int numArgs = Rf_length(args), i, ctr;
if(numArgs == 0)
return(S_OK);
#ifdef RDCOM_VERBOSE
errorLog("Converting arguments (# %d, # %d named)\n", numArgs, numNamedArgs);
#endif
parms->rgvarg = (VARIANT *) S_alloc(numArgs, sizeof(VARIANT));
parms->cArgs = numArgs;
/* If there are named arguments, then put these at the beginning of the
rgvarg*/
if(numNamedArgs > 0) {
int namedArgCtr = 0;
VARIANT *var;
SEXP el;
SEXP names = GET_NAMES(args);
parms->rgdispidNamedArgs = (DISPID *) S_alloc(numNamedArgs, sizeof(DISPID));
parms->cNamedArgs = numNamedArgs;
for(i = 0, ctr = numArgs-1; i < numArgs ; i++) {
if(strcmp(CHAR(STRING_ELT(names, i)), "") != 0) {
var = &(parms->rgvarg[namedArgCtr]);
parms->rgdispidNamedArgs[namedArgCtr] = ids[namedArgCtr + 1];
#ifdef RDCOM_VERBOSE
errorLog("Putting named argument %d into %d\n", i+1, namedArgCtr);
Rf_PrintValue(VECTOR_ELT(args, i));
#endif
namedArgCtr++;
} else {
var = &(parms->rgvarg[ctr]);
ctr--;
}
el = VECTOR_ELT(args, i);
VariantInit(var);
hr = R_convertRObjectToDCOM(el, var);
}
} else {
parms->cNamedArgs = 0;
parms->rgdispidNamedArgs = NULL;
for(i = 0, ctr = numArgs-1; i < numArgs; i++, ctr--) {
SEXP el = VECTOR_ELT(args, i);
VariantInit(&parms->rgvarg[ctr]);
hr = R_convertRObjectToDCOM(el, &(parms->rgvarg[ctr]));
}
}
return(S_OK);
}
/* Return NULL on failure */
SEXP
Sexp_get_names(const SEXP sexp) {
if (! RINTERF_ISREADY()) {
return NULL;
}
SEXP res = GET_NAMES(sexp);
R_PreserveObject(res);
return res;
}
SEXP graph_sublist_assign(SEXP x, SEXP subs, SEXP sublist, SEXP values)
{
SEXP idx, names, tmpItem, newsubs, ans, ansnames, val;
int ns, i, j, nnew, nextempty, origlen, numVals, tmpIdx;
ns = length(subs);
origlen = length(x);
numVals = length(values);
if (numVals > 1 && ns != numVals)
error("invalid args: subs and values must be the same length");
names = GET_NAMES(x);
PROTECT(idx = match(names, subs, -1));
PROTECT(newsubs = allocVector(STRSXP, ns));
nnew = 0;
for (i = 0; i < ns; i++) {
if (INTEGER(idx)[i] == -1)
SET_STRING_ELT(newsubs, nnew++, STRING_ELT(subs, i));
}
PROTECT(ans = allocVector(VECSXP, origlen + nnew));
PROTECT(ansnames = allocVector(STRSXP, length(ans)));
for (i = 0; i < origlen; i++) {
SET_VECTOR_ELT(ans, i, duplicate(VECTOR_ELT(x, i)));
SET_STRING_ELT(ansnames, i, duplicate(STRING_ELT(names, i)));
}
j = origlen;
for (i = 0; i < nnew; i++)
SET_STRING_ELT(ansnames, j++, STRING_ELT(newsubs, i));
SET_NAMES(ans, ansnames);
UNPROTECT(1);
nextempty = origlen; /* index of next unfilled element of ans */
for (i = 0; i < ns; i++) {
if (numVals > 1)
PROTECT(val = graph_makeItem(values, i));
else if (numVals == 1 && isVectorList(values))
PROTECT(val = duplicate(VECTOR_ELT(values, 0)));
else
PROTECT(val = duplicate(values));
j = INTEGER(idx)[i];
if (j < 0) {
tmpItem = graph_addItemToList(R_NilValue, val, sublist);
SET_VECTOR_ELT(ans, nextempty, tmpItem);
nextempty++;
} else {
tmpItem = VECTOR_ELT(ans, j-1);
tmpIdx = graph_getListIndex(tmpItem, sublist);
if (tmpIdx == -1) {
tmpItem = graph_addItemToList(tmpItem, val, sublist);
SET_VECTOR_ELT(ans, j-1, tmpItem);
} else
SET_VECTOR_ELT(tmpItem, tmpIdx, val);
}
UNPROTECT(1);
}
UNPROTECT(3);
return ans;
}
SEXP
R_ocr(SEXP filename, SEXP r_vars, SEXP r_level)
{
SEXP ans = R_NilValue;
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
if(api->Init(NULL, "eng")) {
PROBLEM "could not intialize tesseract engine."
ERROR;
}
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0]; //RIL_WORD;
if(ri != 0) {
int n = 1, i;
while(ri->Next(level)) n++;
// printf("num words %d\n", n);
delete ri; // XXX check
// api->Recognize(0);
ri = api->GetIterator();
SEXP names;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_NUMERIC(n));
i = 0;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
SET_STRING_ELT(names, i, Rf_mkChar(word));
REAL(ans)[i] = conf;
delete[] word;
i++;
} while (ri->Next(level));
delete ri; // XXX check
SET_NAMES(ans, names);
UNPROTECT(2);
}
pixDestroy(&image);
return(ans);
}
/* --- .Call ENTRY POINT --- */
SEXP fasta_index(SEXP filexp_list,
SEXP nrec, SEXP skip, SEXP seek_first_rec, SEXP lkup)
{
int nrec0, skip0, seek_rec0, i, recno, old_nrec, new_nrec, k;
FASTAINDEX_loaderExt loader_ext;
FASTAloader loader;
IntAE *seqlength_buf, *fileno_buf;
SEXP filexp;
long long int offset, ninvalid;
const char *errmsg;
nrec0 = INTEGER(nrec)[0];
skip0 = INTEGER(skip)[0];
seek_rec0 = LOGICAL(seek_first_rec)[0];
loader_ext = new_FASTAINDEX_loaderExt();
loader = new_FASTAINDEX_loader(lkup, 1, &loader_ext);
seqlength_buf = loader_ext.seqlength_buf;
fileno_buf = new_IntAE(0, 0, 0);
for (i = recno = 0; i < LENGTH(filexp_list); i++) {
filexp = VECTOR_ELT(filexp_list, i);
offset = ninvalid = 0LL;
errmsg = parse_FASTA_file(filexp, nrec0, skip0, seek_rec0,
&loader, &recno, &offset, &ninvalid);
if (errmsg != NULL)
error("reading FASTA file %s: %s",
CHAR(STRING_ELT(GET_NAMES(filexp_list), i)),
errmsg_buf);
if (ninvalid != 0LL)
warning("reading FASTA file %s: ignored %lld "
"invalid one-letter sequence codes",
CHAR(STRING_ELT(GET_NAMES(filexp_list), i)),
ninvalid);
old_nrec = IntAE_get_nelt(fileno_buf);
new_nrec = IntAE_get_nelt(seqlength_buf);
for (k = old_nrec; k < new_nrec; k++)
IntAE_insert_at(fileno_buf, k, i + 1);
}
return make_fasta_index_data_frame(loader_ext.recno_buf,
fileno_buf,
loader_ext.offset_buf,
loader_ext.desc_buf,
seqlength_buf);
}
/* default constants for the exit condition */
static SEXP getListElement(SEXP list, const char *str) {
SEXP elmt = R_NilValue, names = GET_NAMES(list);
for (int i = 0; i < length(list); i++) {
if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
elmt = VECTOR_ELT(list, i);
break;
}
}
return elmt;
}
static int graph_getListIndex(SEXP list, SEXP name)
{
SEXP names = GET_NAMES(list);
int i;
const char* str = CHAR(STRING_ELT(name, 0));
for (i = 0; i < length(list); i++)
if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0)
return i;
return -1;
}
SEXP c_which_last(SEXP x, SEXP use_names) {
if (!isLogical(x))
error("Argument 'x' must be logical");
if (!isLogical(use_names) || length(use_names) != 1)
error("Argument 'use.names' must be a flag");
int *xp = LOGICAL(x);
for (R_len_t i = length(x) - 1; i >= 0; i--) {
if (xp[i] != NA_LOGICAL && xp[i]) {
if (LOGICAL(use_names)[0])
return named_return(i, GET_NAMES(x));
else
return ScalarInteger(i+1);
}
}
return allocVector(INTSXP, 0);
}
USER_OBJECT_
RS_XML(findFunction)(const char *opName, USER_OBJECT_ _userObject)
{
int i;
USER_OBJECT_ fun = NULL;
/* Get the names of the list. */
USER_OBJECT_ names = GET_NAMES(_userObject);
/* lookup function in the names of the list */
for (i = 0; i < GET_LENGTH(names); i++) {
if(!strcmp(opName, CHAR_DEREF(STRING_ELT(names, i)))) {
fun = VECTOR_ELT(_userObject, i);
break;
}
}
return(fun);
}
/*
* --- .Call ENTRY POINT ---
*/
SEXP SimpleIRangesList_isNormal(SEXP x)
{
SEXP list_ir, ans, ans_names;
IRanges_holder ir_holder;
int x_len, i;
list_ir = GET_SLOT(x, install("listData"));
x_len = LENGTH(list_ir);
PROTECT(ans = NEW_LOGICAL(x_len));
for (i = 0; i < x_len; i++) {
ir_holder = _hold_IRanges(VECTOR_ELT(list_ir, i));
LOGICAL(ans)[i] = _is_normal_IRanges_holder(&ir_holder);
}
PROTECT(ans_names = duplicate(GET_NAMES(list_ir)));
SET_NAMES(ans, ans_names);
UNPROTECT(2);
return ans;
}
SEXP
R_ocr_alternatives(SEXP filename, SEXP r_vars, SEXP r_level)
{
SEXP ans = R_NilValue;
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
api->Init(NULL, "eng");
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0];
int n = 1;
while(ri->Next(level))
n++;
ri = api->GetIterator();
SEXP names;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_LIST(n));
i = 0;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
SET_STRING_ELT(names, i, Rf_mkChar(word));
SET_VECTOR_ELT(ans, i, getAlternatives(ri, word, conf));
delete[] word;
i++;
} while (ri->Next(level));
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
static SEXP graph_addItemToList(SEXP list, SEXP item, SEXP name)
{
SEXP ans, ansnames, listnames;
int len = length(list);
int i;
PROTECT(ans = allocVector(VECSXP, len + 1));
PROTECT(ansnames = allocVector(STRSXP, len + 1));
listnames = GET_NAMES(list);
for (i = 0; i < len; i++) {
SET_STRING_ELT(ansnames, i, STRING_ELT(listnames, i));
SET_VECTOR_ELT(ans, i, VECTOR_ELT(list, i));
}
SET_STRING_ELT(ansnames, len, STRING_ELT(name, 0));
SET_VECTOR_ELT(ans, len, item);
SET_NAMES(ans, ansnames);
UNPROTECT(2);
return ans;
}
static SEXP graph_list_lookup(SEXP x, SEXP subs, SEXP defaultVal)
{
SEXP ans, idx, names;
int ns, i, j;
ns = length(subs);
names = GET_NAMES(x);
PROTECT(idx = match(names, subs, -1));
PROTECT(ans = allocVector(VECSXP, ns));
for (i = 0; i < ns; i++) {
j = INTEGER(idx)[i];
if (j < 0)
SET_VECTOR_ELT(ans, i, defaultVal); /* need to duplicate? */
else {
SET_VECTOR_ELT(ans, i, VECTOR_ELT(x, j-1));
}
}
SET_NAMES(ans, subs);
UNPROTECT(2);
return ans;
}
int
R_isBranch(const xmlChar *localname, RS_XMLParserData *rinfo)
{
int n;
if(rinfo->current)
return(-2); /* we are processing a branch */
if((n = GET_LENGTH(rinfo->branches)) > 0) {
int i;
USER_OBJECT_ names = GET_NAMES(rinfo->branches);
for(i = 0 ; i < n ; i++) {
if(strcmp(XMLCHAR_TO_CHAR(localname), CHAR_DEREF(STRING_ELT(names, i))) == 0) {
return(i);
}
}
}
return(-1);
}
SEXP stringEltByName(SEXP strv, const char *str) {
/* Given STRSXP (character vector in R) and a string, return the
* element of the strv (CHARSXP) which has the name that
* corresponds to the string.
*/
SEXP elmt = R_NilValue;
SEXP names = GET_NAMES(strv);
int i;
if (names == R_NilValue) error("the character vector must have names");
/* simple linear search */
for (i = 0; i < length(strv); i++) {
if (strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
elmt = STRING_ELT(strv, i);
break;
}
}
return(elmt);
}
static SEXP graph_sublist_lookup(SEXP x, SEXP subs, SEXP sublist,
SEXP defaultVal)
{
SEXP ans, idx, names, el;
int ns, i, j;
sublist = STRING_ELT(sublist, 0);
ns = length(subs);
names = GET_NAMES(x);
PROTECT(idx = match(names, subs, -1));
PROTECT(ans = allocVector(VECSXP, ns));
for (i = 0; i < ns; i++) {
j = INTEGER(idx)[i];
if (j < 0)
SET_VECTOR_ELT(ans, i, defaultVal);
else {
el = graph_getListElement(VECTOR_ELT(x, j-1), CHAR(sublist),
defaultVal);
SET_VECTOR_ELT(ans, i, el);
}
}
SET_NAMES(ans, subs);
UNPROTECT(2);
return ans;
}
/*
* --- .Call ENTRY POINT ---
*/
SEXP SimpleNormalIRangesList_max(SEXP x)
{
SEXP list_ir, ans, ans_names;
IRanges_holder ir_holder;
int x_len, ir_len, i;
int *ans_elt;
list_ir = GET_SLOT(x, install("listData"));
x_len = LENGTH(list_ir);
PROTECT(ans = NEW_INTEGER(x_len));
for (i = 0, ans_elt = INTEGER(ans); i < x_len; i++, ans_elt++) {
ir_holder = _hold_IRanges(VECTOR_ELT(list_ir, i));
ir_len = _get_length_from_IRanges_holder(&ir_holder);
if (ir_len == 0) {
*ans_elt = R_INT_MIN;
} else {
*ans_elt = _get_end_elt_from_IRanges_holder(&ir_holder, ir_len - 1);
}
}
PROTECT(ans_names = duplicate(GET_NAMES(list_ir)));
SET_NAMES(ans, ans_names);
UNPROTECT(2);
return ans;
}
SEXP do_rmeasure (SEXP object, SEXP x, SEXP times, SEXP params, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP cvec, tvec = R_NilValue, xvec = R_NilValue, pvec = R_NilValue;
SEXP fn, fcall, rho = R_NilValue, ans, nm;
SEXP pompfun;
SEXP Y;
int *dim;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
struct lookup_table covariate_table;
pomp_measure_model_simulator *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'rmeasure': length('times') = 0, no work to do");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'rmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'rmeasure': larger number of replicates is not a multiple of smaller");
dim = INTEGER(GET_DIM(GET_SLOT(object,install("data"))));
nobs = dim[0];
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(GET_SLOT(object,install("data"))))); nprotect++;
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
{
int dim[3] = {nobs, nreps, ntimes};
const char *dimnm[3] = {"variable","rep","time"};
PROTECT(Y = makearray(3,dim)); nprotect++;
setrownames(Y,Onames,3);
fixdimnames(Y,dimnm,3);
}
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("rmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // use R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // use native routine
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
int use_names = 0;
double *yt = REAL(Y);
double *time = REAL(times);
double *tp = REAL(tvec);
double *cp = REAL(cvec);
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *xs = REAL(x);
double *ps = REAL(params);
double *ys;
int *posn;
int i, j, k;
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*tp,cp); // interpolate the covariates
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
// copy the states and parameters into place
for (i = 0; i < nvars; i++) xp[i] = xs[i+nvars*((j%nrepsx)+nrepsx*k)];
for (i = 0; i < npars; i++) pp[i] = ps[i+npars*(j%nrepsp)];
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != nobs) {
errorcall(R_NilValue,"in 'rmeasure': user 'rmeasure' returns a vector of %d observables but %d are expected: compare 'data' slot?",
LENGTH(ans),nobs);
}
// get name information to fix potential alignment problems
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) { // match names against names from data slot
posn = INTEGER(PROTECT(matchnames(Onames,nm,"observables"))); nprotect++;
} else {
posn = 0;
}
ys = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ys = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nobs; i++) yt[posn[i]] = ys[i];
} else {
for (i = 0; i < nobs; i++) yt[i] = ys[i];
}
}
}
}
break;
case native: // native routine
{
double *yt = REAL(Y);
double *time = REAL(times);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *xp, *pp;
int j, k;
set_pomp_userdata(fcall);
GetRNGstate();
for (k = 0; k < ntimes; k++, time++) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, yt += nobs) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(yt,xp,pp,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'rmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return Y;
}
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi)
{
int nprotect = 0;
SEXP Pnames, Snames;
SEXP x = R_NilValue;
int *dim;
int npar, nrep, nvar, ns;
int definit;
int xdim[2];
const char *dimnms[2] = {"variable","rep"};
ns = *(INTEGER(AS_INTEGER(nsim)));
PROTECT(params = as_matrix(params)); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
dim = INTEGER(GET_DIM(params));
npar = dim[0]; nrep = dim[1];
if (ns % nrep != 0)
errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')");
definit = *(INTEGER(GET_SLOT(object,install("default.init"))));
if (definit) { // default initializer
SEXP fcall, pat, repl, val, ivpnames, statenames;
int *pidx, j, k;
double *xp, *pp;
PROTECT(pat = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(pat,0,mkChar("\\.0$"));
PROTECT(repl = NEW_CHARACTER(1)); nprotect++;
SET_STRING_ELT(repl,0,mkChar(""));
PROTECT(val = NEW_LOGICAL(1)); nprotect++;
*(INTEGER(val)) = 1;
// extract names of IVPs
PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++;
SET_TAG(fcall,install("value"));
PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++;
PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++;
nvar = LENGTH(ivpnames);
if (nvar < 1) {
errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'.");
}
pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++;
for (k = 0; k < nvar; k++) pidx[k]--;
// construct names of state variables
PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(repl,fcall)); nprotect++;
SET_TAG(fcall,install("replacement"));
PROTECT(fcall = LCONS(pat,fcall)); nprotect++;
SET_TAG(fcall,install("pattern"));
PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++;
PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++;
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,statenames,2);
fixdimnames(x,dimnms,2);
for (j = 0, xp = REAL(x); j < ns; j++) {
pp = REAL(params) + npar*(j%nrep);
for (k = 0; k < nvar; k++, xp++)
*xp = pp[pidx[k]];
}
} else { // user-supplied initializer
SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue;
pompfunmode mode = undef;
double *cp = NULL;
// extract the initializer function and its environment
PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract covariates and interpolate
PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++;
if (LENGTH(tcovar) > 0) { // do table lookup
PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++;
PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++;
cp = REAL(covars);
}
// extract userdata
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
switch (mode) {
case Rfun: // use R function
{
SEXP par, rho, x1, x2;
double *p, *pp, *xp, *xt;
int j, *midx;
// extract covariates and interpolate
if (LENGTH(tcovar) > 0) { // add covars to call
PROTECT(fcall = LCONS(covars,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
}
// parameter vector
PROTECT(par = NEW_NUMERIC(npar)); nprotect++;
SET_NAMES(par,Pnames);
pp = REAL(par);
// finish constructing the call
PROTECT(fcall = LCONS(t0,fcall)); nprotect++;
SET_TAG(fcall,install("t0"));
PROTECT(fcall = LCONS(par,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// evaluation environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
p = REAL(params);
memcpy(pp,p,npar*sizeof(double)); // copy the parameters
PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call
PROTECT(Snames = GET_NAMES(x1)); nprotect++;
if (!IS_NUMERIC(x1) || isNull(Snames)) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector");
}
nvar = LENGTH(x1);
xp = REAL(x1);
midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++;
for (j = 0; j < nvar; j++) {
if (midx[j]!=0) {
UNPROTECT(nprotect);
errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j)));
}
}
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
xt = REAL(x);
memcpy(xt,xp,nvar*sizeof(double));
for (j = 1, xt += nvar; j < ns; j++, xt += nvar) {
memcpy(pp,p+npar*(j%nrep),npar*sizeof(double));
PROTECT(x2 = eval(fcall,rho));
xp = REAL(x2);
if (LENGTH(x2)!=nvar)
errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length");
memcpy(xt,xp,nvar*sizeof(double));
UNPROTECT(1);
}
}
break;
case native: // use native routine
{
SEXP Cnames;
int *sidx, *pidx, *cidx;
double *xt, *ps, time;
pomp_initializer *ff = NULL;
int j;
PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
// construct state, parameter, covariate, observable indices
sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++;
pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++;
cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++;
// address of native routine
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
nvar = LENGTH(Snames);
xdim[0] = nvar; xdim[1] = ns;
PROTECT(x = makearray(2,xdim)); nprotect++;
setrownames(x,Snames,2);
fixdimnames(x,dimnms,2);
set_pomp_userdata(fcall);
GetRNGstate();
time = *(REAL(t0));
// loop over replicates
for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar)
(*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp);
PutRNGstate();
unset_pomp_userdata();
}
break;
default:
errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov
break;
}
}
UNPROTECT(nprotect);
return x;
}
SEXP getRNames(SEXP obj)
{
return(GET_NAMES(obj));
}
HRESULT
R_convertRObjectToDCOM(SEXP obj, VARIANT *var)
{
HRESULT status;
int type = R_typeof(obj);
if(!var)
return(S_FALSE);
#ifdef RDCOM_VERBOSE
errorLog("Type of argument %d\n", type);
#endif
if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) {
VARIANT *tmp;
tmp = (VARIANT *) R_ExternalPtrAddr(obj);
if(tmp) {
//XXX
VariantCopy(var, tmp);
return(S_OK);
}
}
if(ISCOMIDispatch(obj)) {
IDispatch *ptr;
ptr = (IDispatch *) derefRIDispatch(obj);
V_VT(var) = VT_DISPATCH;
V_DISPATCH(var) = ptr;
//XX
ptr->AddRef();
return(S_OK);
}
if(ISSInstanceOf(obj, "COMDate")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_DATE;
V_DATE(var) = val;
return(S_OK);
} else if(ISSInstanceOf(obj, "COMCurrency")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_CY);
return(S_OK);
} else if(ISSInstanceOf(obj, "COMDecimal")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_DECIMAL);
return(S_OK);
}
/* We have a complex object and we are not going to try to convert it directly
but instead create an COM server object to represent it to the outside world. */
if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) {
status = createGenericCOMObject(obj, var);
if(status == S_OK)
return(S_OK);
}
if(Rf_length(obj) == 0) {
V_VT(var) = VT_VOID;
return(S_OK);
}
if(type == VECSXP || Rf_length(obj) > 1) {
createRDCOMArray(obj, var);
return(S_OK);
}
switch(type) {
case STRSXP:
V_VT(var) = VT_BSTR;
V_BSTR(var) = AsBstr(getRString(obj, 0));
break;
case INTSXP:
V_VT(var) = VT_I4;
V_I4(var) = R_integerScalarValue(obj, 0);
break;
case REALSXP:
V_VT(var) = VT_R8;
V_R8(var) = R_realScalarValue(obj, 0);
break;
case LGLSXP:
V_VT(var) = VT_BOOL;
V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case VECSXP:
break;
}
return(S_OK);
}
SEXP do_partrans (SEXP object, SEXP params, SEXP dir, SEXP gnsi)
{
int nprotect = 0;
SEXP fn, fcall, rho, ans, nm;
SEXP pdim, pvec;
SEXP pompfun;
SEXP tparams = R_NilValue;
pompfunmode mode = undef;
char direc;
int qmat;
int ndim[2], *dim, *idx;
double *pp, *ps, *pt, *pa;
int npar1, npar2, nreps;
pomp_transform_fn *ff = NULL;
int k;
direc = *(INTEGER(dir));
// extract the user-defined function
switch (direc) {
case 1: // forward transformation
PROTECT(pompfun = GET_SLOT(object,install("from.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
case -1: // inverse transformation
PROTECT(pompfun = GET_SLOT(object,install("to.trans"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
break;
default:
error("impossible error");
break;
}
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
PROTECT(pdim = GET_DIM(params)); nprotect++;
if (isNull(pdim)) { // a single vector
npar1 = LENGTH(params); nreps = 1;
qmat = 0;
} else { // a parameter matrix
dim = INTEGER(pdim);
npar1 = dim[0]; nreps = dim[1];
qmat = 1;
}
switch (mode) {
case Rfun: // use user-supplied R function
// set up the function call
if (qmat) { // matrix case
PROTECT(pvec = NEW_NUMERIC(npar1)); nprotect++;
SET_NAMES(pvec,GET_ROWNAMES(GET_DIMNAMES(params)));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
} else { // vector case
PROTECT(fcall = LCONS(params,fcall)); nprotect++;
}
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
if (qmat) { // matrix case
const char *dimnm[2] = {"variable","rep"};
ps = REAL(params);
pp = REAL(pvec);
memcpy(pp,ps,npar1*sizeof(double));
PROTECT(ans = eval(fcall,rho)); nprotect++;
PROTECT(nm = GET_NAMES(ans)); nprotect++;
if (isNull(nm))
error("user transformation functions must return a named numeric vector");
// set up matrix to hold the results
npar2 = LENGTH(ans);
ndim[0] = npar2; ndim[1] = nreps;
PROTECT(tparams = makearray(2,ndim)); nprotect++;
setrownames(tparams,nm,2);
fixdimnames(tparams,dimnm,2);
pt = REAL(tparams);
pa = REAL(AS_NUMERIC(ans));
memcpy(pt,pa,npar2*sizeof(double));
ps += npar1;
pt += npar2;
for (k = 1; k < nreps; k++, ps += npar1, pt += npar2) {
memcpy(pp,ps,npar1*sizeof(double));
pa = REAL(AS_NUMERIC(eval(fcall,rho)));
memcpy(pt,pa,npar2*sizeof(double));
}
} else { // vector case
PROTECT(tparams = eval(fcall,rho)); nprotect++;
if (isNull(GET_NAMES(tparams)))
error("user transformation functions must return a named numeric vector");
}
break;
case native: // use native routine
ff = (pomp_transform_fn *) R_ExternalPtrAddr(fn);
if (qmat) {
idx = INTEGER(PROTECT(name_index(GET_ROWNAMES(GET_DIMNAMES(params)),pompfun,"paramnames"))); nprotect++;
} else {
idx = INTEGER(PROTECT(name_index(GET_NAMES(params),pompfun,"paramnames"))); nprotect++;
}
set_pomp_userdata(fcall);
PROTECT(tparams = duplicate(params)); nprotect++;
for (k = 0, ps = REAL(params), pt = REAL(tparams); k < nreps; k++, ps += npar1, pt += npar1) {
R_CheckUserInterrupt();
(*ff)(pt,ps,idx);
}
unset_pomp_userdata();
break;
default:
error("unrecognized 'mode' slot in 'partrans'");
}
UNPROTECT(nprotect);
return tparams;
}
// examines weights for filtering failure
// computes log likelihood and effective sample size
// computes (if desired) prediction mean, prediction variance, filtering mean.
// it is assumed that ncol(x) == ncol(params).
// weights are used in filtering mean computation.
// if length(weights) == 1, an unweighted average is computed.
// returns all of the above in a named list
SEXP pfilter2_computations (SEXP x, SEXP params, SEXP Np,
SEXP rw, SEXP rw_sd,
SEXP predmean, SEXP predvar,
SEXP filtmean, SEXP onepar,
SEXP weights, SEXP tol)
{
int nprotect = 0;
SEXP pm = R_NilValue, pv = R_NilValue, fm = R_NilValue;
SEXP rw_names, ess, fail, loglik;
SEXP newstates = R_NilValue, newparams = R_NilValue;
SEXP retval, retvalnames;
double *xpm = 0, *xpv = 0, *xfm = 0, *xw = 0, *xx = 0, *xp = 0, *xpw=0;
int *xpa=0;
SEXP dimX, dimP, newdim, Xnames, Pnames, pindex;
SEXP pw=R_NilValue,pa=R_NilValue, psample=R_NilValue;
int *dim, *pidx, lv, np;
int nvars, npars = 0, nrw = 0, nreps, offset, nlost;
int do_rw, do_pm, do_pv, do_fm, do_par_resamp, all_fail = 0;
double sum, sumsq, vsq, ws, w, toler;
int j, k;
PROTECT(dimX = GET_DIM(x)); nprotect++;
dim = INTEGER(dimX);
nvars = dim[0]; nreps = dim[1];
xx = REAL(x);
PROTECT(Xnames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(dimP = GET_DIM(params)); nprotect++;
dim = INTEGER(dimP);
npars = dim[0];
if (nreps != dim[1])
error("'states' and 'params' do not agree in second dimension");
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
np = INTEGER(AS_INTEGER(Np))[0]; // number of particles to resample
PROTECT(rw_names = GET_NAMES(rw_sd)); nprotect++; // names of parameters undergoing random walk
do_rw = *(LOGICAL(AS_LOGICAL(rw))); // do random walk in parameters?
do_pm = *(LOGICAL(AS_LOGICAL(predmean))); // calculate prediction means?
do_pv = *(LOGICAL(AS_LOGICAL(predvar))); // calculate prediction variances?
do_fm = *(LOGICAL(AS_LOGICAL(filtmean))); // calculate filtering means?
do_par_resamp = *(LOGICAL(AS_LOGICAL(onepar))); // are all cols of 'params' the same?
do_par_resamp = !do_par_resamp || do_rw || (np != nreps); // should we do parameter resampling?
PROTECT(ess = NEW_NUMERIC(1)); nprotect++; // effective sample size
PROTECT(loglik = NEW_NUMERIC(1)); nprotect++; // log likelihood
PROTECT(fail = NEW_LOGICAL(1)); nprotect++; // particle failure?
xw = REAL(weights);
toler = *(REAL(tol)); // failure tolerance
// check the weights and compute sum and sum of squares
for (k = 0, w = 0, ws = 0, nlost = 0; k < nreps; k++) {
if (xw[k] >= 0) {
w += xw[k];
ws += xw[k]*xw[k];
} else { // this particle is lost
xw[k] = 0;
nlost++;
}
}
if (nlost >= nreps) all_fail = 1; // all particles are lost
if (all_fail) {
*(REAL(loglik)) = log(toler); // minimum log-likelihood
*(REAL(ess)) = 0; // zero effective sample size
} else {
*(REAL(loglik)) = log(w/((double) nreps)); // mean of weights is likelihood
*(REAL(ess)) = w*w/ws; // effective sample size
}
*(LOGICAL(fail)) = all_fail;
if (do_rw) {
// indices of parameters undergoing random walk
PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++;
xp = REAL(params);
pidx = INTEGER(pindex);
nrw = LENGTH(rw_names);
lv = nvars+nrw;
} else {
pidx = NULL;
lv = nvars;
}
if (do_pm || do_pv) {
PROTECT(pm = NEW_NUMERIC(lv)); nprotect++;
xpm = REAL(pm);
}
if (do_pv) {
PROTECT(pv = NEW_NUMERIC(lv)); nprotect++;
xpv = REAL(pv);
}
if (do_fm) {
if (do_rw) {
PROTECT(fm = NEW_NUMERIC(nvars+npars)); nprotect++;
} else {
PROTECT(fm = NEW_NUMERIC(nvars)); nprotect++;
}
xfm = REAL(fm);
}
PROTECT(pa = NEW_INTEGER(np)); nprotect++;
xpa = INTEGER(pa);
for (j = 0; j < nvars; j++) { // state variables
// compute prediction mean
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xx[j+k*nvars];
sum /= ((double) nreps);
xpm[j] = sum;
}
// compute prediction variance
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xx[j+k*nvars]-sum;
sumsq += vsq*vsq;
}
xpv[j] = sumsq / ((double) (nreps - 1));
}
// compute filter mean
if (do_fm) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars];
xfm[j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]*xw[k];
xfm[j] = ws/w;
}
}
}
// compute means and variances for parameters (if needed)
if (do_rw) {
for (j = 0; j < nrw; j++) {
offset = pidx[j]; // position of the parameter
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xp[offset+k*npars];
sum /= ((double) nreps);
xpm[nvars+j] = sum;
}
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xp[offset+k*npars]-sum;
sumsq += vsq*vsq;
}
xpv[nvars+j] = sumsq / ((double) (nreps - 1));
}
}
if (do_fm) {
for (j = 0; j < npars; j++) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars];
xfm[nvars+j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]*xw[k];
xfm[nvars+j] = ws/w;
}
}
}
}
GetRNGstate();
if (!all_fail) { // resample the particles unless we have filtering failure
int xdim[2];
//int sample[np];
double *ss = 0, *st = 0, *ps = 0, *pt = 0;
// create storage for new states
xdim[0] = nvars; xdim[1] = np;
PROTECT(newstates = makearray(2,xdim)); nprotect++;
setrownames(newstates,Xnames,2);
ss = REAL(x);
st = REAL(newstates);
// create storage for new parameters
if (do_par_resamp) {
xdim[0] = npars; xdim[1] = np;
PROTECT(newparams = makearray(2,xdim)); nprotect++;
setrownames(newparams,Pnames,2);
ps = REAL(params);
pt = REAL(newparams);
}
PROTECT(pw = NEW_NUMERIC(nreps)); nprotect++;
xpw = REAL(pw);
for (k = 0; k < nreps; k++)
xpw[k]=REAL(weights)[k];
nosort_resamp(nreps,REAL(weights),np,xpa,0);
for (k = 0; k < np; k++) { // copy the particles
for (j = 0, xx = ss+nvars*xpa[k]; j < nvars; j++, st++, xx++)
*st = *xx;
if (do_par_resamp) {
for (j = 0, xp = ps+npars*xpa[k]; j < npars; j++, pt++, xp++){
*pt = *xp;
}
}
}
} else { // don't resample: just drop 3rd dimension in x prior to return
PROTECT(newdim = NEW_INTEGER(2)); nprotect++;
dim = INTEGER(newdim);
dim[0] = nvars; dim[1] = nreps;
SET_DIM(x,newdim);
setrownames(x,Xnames,2);
}
if (do_rw) { // if random walk, adjust prediction variance and move particles
xx = REAL(rw_sd);
xp = (all_fail || !do_par_resamp) ? REAL(params) : REAL(newparams);
nreps = (all_fail) ? nreps : np;
for (j = 0; j < nrw; j++) {
offset = pidx[j];
vsq = xx[j];
if (do_pv) {
xpv[nvars+j] += vsq*vsq;
}
for (k = 0; k < nreps; k++)
xp[offset+k*npars] += rnorm(0,vsq);
}
}
renormalize(xpw,nreps,0);
PutRNGstate();
PROTECT(retval = NEW_LIST(10)); nprotect++;
PROTECT(retvalnames = NEW_CHARACTER(10)); nprotect++;
SET_STRING_ELT(retvalnames,0,mkChar("fail"));
SET_STRING_ELT(retvalnames,1,mkChar("loglik"));
SET_STRING_ELT(retvalnames,2,mkChar("ess"));
SET_STRING_ELT(retvalnames,3,mkChar("states"));
SET_STRING_ELT(retvalnames,4,mkChar("params"));
SET_STRING_ELT(retvalnames,5,mkChar("pm"));
SET_STRING_ELT(retvalnames,6,mkChar("pv"));
SET_STRING_ELT(retvalnames,7,mkChar("fm"));
SET_STRING_ELT(retvalnames,8,mkChar("weight"));
SET_STRING_ELT(retvalnames,9,mkChar("pa"));
SET_NAMES(retval,retvalnames);
SET_ELEMENT(retval,0,fail);
SET_ELEMENT(retval,1,loglik);
SET_ELEMENT(retval,2,ess);
if (all_fail) {
SET_ELEMENT(retval,3,x);
} else {
SET_ELEMENT(retval,3,newstates);
}
if (all_fail || !do_par_resamp) {
SET_ELEMENT(retval,4,params);
} else {
SET_ELEMENT(retval,4,newparams);
}
if (do_pm) {
SET_ELEMENT(retval,5,pm);
}
if (do_pv) {
SET_ELEMENT(retval,6,pv);
}
if (do_fm) {
SET_ELEMENT(retval,7,fm);
}
SET_ELEMENT(retval,8,pw);
SET_ELEMENT(retval,9,pa);
UNPROTECT(nprotect);
return(retval);
}
SEXP
R_ocr_boundingBoxes(SEXP filename, SEXP r_vars, SEXP r_level, SEXP r_names)
{
SEXP ans = R_NilValue;
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
if(api->Init(NULL, "eng")) {
PROBLEM "could not intialize tesseract engine."
ERROR;
}
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0]; //RIL_WORD;
if(ri != 0) {
int n = 1, i;
while(ri->Next(level)) n++;
ri = api->GetIterator();
SEXP names, tmp;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_LIST(n));
i = 0;
int x1, y1, x2, y2;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
ri->BoundingBox(level, &x1, &y1, &x2, &y2);
SET_STRING_ELT(names, i, Rf_mkChar(word));
SET_VECTOR_ELT(ans, i, tmp = NEW_NUMERIC(5));
REAL(tmp)[0] = conf;
REAL(tmp)[1] = x1;
REAL(tmp)[2] = y1;
REAL(tmp)[3] = x2;
REAL(tmp)[4] = y2;
SET_NAMES(tmp, r_names);
delete[] word;
i++;
} while (ri->Next(level));
SET_NAMES(ans, names);
UNPROTECT(2);
}
pixDestroy(&image);
return(ans);
}
/* NOTE: R vectors of length 1 will yield a python list of length 1*/
int
to_Pyobj_vector(SEXP robj, PyObject **obj, int mode)
{
PyObject *it, *tmp;
SEXP names, dim;
int len, *integers, i, type;
const char *strings, *thislevel;
double *reals;
Rcomplex *complexes;
#ifdef WITH_NUMERIC
PyObject *array;
#endif
if (!robj)
{
// return -1; /* error */
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "robj does not exist"));
// PyObject_CallObject(my_callback, argslist);
// }
return 1;
}
if (robj == R_NilValue) {
Py_INCREF(Py_None);
*obj = Py_None;
return 1; /* succeed */
}
len = GET_LENGTH(robj);
tmp = PyList_New(len);
type = TYPEOF(robj);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(si)", "robj length is ", len));
// PyObject_CallObject(my_callback, argslist);
// }
/// break for checking the R length and other aspects
for (i=0; i<len; i++) {
switch (type)
{
case LGLSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LGLSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(integers[i]==NA_INTEGER) /* watch out for NA's */
{
if (!(it = PyInt_FromLong(integers[i])))
//return -1;
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//it = Py_None;
}
else if (!(it = PyBool_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyBool_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
break;
case INTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In INTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
integers = INTEGER(robj);
if(isFactor(robj)) {
/* Watch for NA's! */
if(integers[i]==NA_INTEGER)
it = PyString_FromString(CHAR(NA_STRING));
else
{
thislevel = CHAR(STRING_ELT(GET_LEVELS(robj), integers[i]-1));
if (!(it = PyString_FromString(thislevel)))
{
tmp = Py_BuildValue("s", "failed in the PyString_FromString"); // we are at least getting an robj
*obj = tmp;
return 1;
}
//return -1;
}
}
else {
if (!(it = PyInt_FromLong(integers[i])))
{
tmp = Py_BuildValue("s", "failed in the PyInt_FromLong"); // we are at least getting an robj
*obj = tmp;
return 1;
//return -1;
}
}
break;
case REALSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In REALSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
reals = REAL(robj);
if (!(it = PyFloat_FromDouble(reals[i])))
{
// tmp = Py_BuildValue("s", "failed in the PyFloat_FromDouble"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case CPLXSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In CPLXSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
complexes = COMPLEX(robj);
if (!(it = PyComplex_FromDoubles(complexes[i].r,
complexes[i].i)))
{
// tmp = Py_BuildValue("s", "failed in PyComplex_FromDoubles!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case STRSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In STRSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if(STRING_ELT(robj, i)==R_NaString)
it = PyString_FromString(CHAR(NA_STRING));
else
{
strings = CHAR(STRING_ELT(robj, i));
if (!(it = PyString_FromString(strings)))
{
// tmp = Py_BuildValue("s", "failed in PyString_FromString!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
break;
case LISTSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In LISTSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(elt(robj, i), mode)))
{
// tmp = Py_BuildValue("s", "failed in to_Pyobj_with_mode LISTSXP!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
break;
case VECSXP:
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "In VECSXP"));
// PyObject_CallObject(my_callback, argslist);
// }
if (!(it = to_Pyobj_with_mode(VECTOR_ELT(robj, i), mode)))
{
return -1;
}
break;
default:
Py_DECREF(tmp);
return 0; /* failed */
}
if (PyList_SetItem(tmp, i, it) < 0) // there was a failure in setting the item
{
// tmp = Py_BuildValue("s", "failed in PyList_SetItem!!!"); // we are at least getting an robj
// *obj = tmp;
// return 1;
return -1;
}
}
dim = GET_DIM(robj);
if (dim != R_NilValue) {
// #ifdef WITH_NUMERIC
// if(use_numeric)
// {
// array = to_PyNumericArray(tmp, dim);
// if (array) { /* If the conversion to Numeric succeed.. */
// *obj = array; /* we are done */
// Py_DECREF(tmp);
// return 1;
// }
// PyErr_Clear();
// }
// #endif
len = GET_LENGTH(dim);
*obj = to_PyArray(tmp, INTEGER(dim), len);
Py_DECREF(tmp);
return 1;
}
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(O)", tmp));
// PyObject_CallObject(my_callback, argslist);
// }
names = GET_NAMES(robj);
if (names == R_NilValue)
{
*obj = tmp;
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as list (of lists)"));
// PyObject_CallObject(my_callback, argslist);
// }
}
else {
*obj = to_PyDict(tmp, names);
// if(my_callback){
// argslist = Py_BuildValue("(O)", Py_BuildValue("(s)", "returning as dict"));
// PyObject_CallObject(my_callback, argslist);
// }
Py_DECREF(tmp);
}
return 1;
}
SEXP euler_model_simulator (SEXP func,
SEXP xstart, SEXP times, SEXP params,
SEXP deltat, SEXP method, SEXP zeronames,
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
int nstep = 0;
double dt, dtt;
SEXP X;
SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
pomp_onestep_sim *ff = NULL;
int meth = INTEGER_VALUE(method);
// meth: 0 = Euler, 1 = one-step, 2 = fixed step
dtt = NUMERIC_VALUE(deltat);
if (dtt <= 0)
errorcall(R_NilValue,"'delta.t' should be a positive number");
{
int *dim;
dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// indices of accumulator variables
nzeros = LENGTH(zeronames);
zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
// set up
switch (mode) {
case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
SET_TAG(fcall,install("delta.t"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[3] = {nvars, nreps, ntimes};
PROTECT(X = makearray(3,dim)); nprotect++;
setrownames(X,Snames,3);
}
// copy the start values into the result array
memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));
if (mode==1) {
set_pomp_userdata(args);
GetRNGstate();
}
// now do computations
{
int first = 1;
int use_names = 0;
int *posn = 0;
double *time = REAL(times);
double *xs = REAL(X);
double *xt = REAL(X)+nvars*nreps;
double *cp = REAL(cvec);
double *ps = REAL(params);
double t = time[0];
double *pm, *xm;
int i, j, k, step;
for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {
R_CheckUserInterrupt();
if (t > time[step]) {
errorcall(R_NilValue,"'times' is not an increasing sequence");
}
memcpy(xt,xs,nreps*nvars*sizeof(double));
// set accumulator variables to zero
for (j = 0; j < nreps; j++)
for (i = 0; i < nzeros; i++)
xt[zidx[i]+nvars*j] = 0.0;
switch (meth) {
case 0: // Euler method
dt = dtt;
nstep = num_euler_steps(t,time[step],&dt);
break;
case 1: // one step
dt = time[step]-t;
nstep = (dt > 0) ? 1 : 0;
break;
case 2: // fixed step
dt = dtt;
nstep = num_map_steps(t,time[step],dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
break;
}
for (k = 0; k < nstep; k++) { // loop over Euler steps
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,t,cp);
for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
switch (mode) {
case Rfun: // R function
{
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *tp = REAL(tvec);
double *dtp = REAL(dtvec);
double *ap;
*tp = t;
*dtp = dt;
memcpy(xp,xm,nvars*sizeof(double));
memcpy(pp,pm,npars*sizeof(double));
if (first) {
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ap = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
} else {
for (i = 0; i < nvars; i++) xm[i] = ap[i];
}
}
break;
case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
}
t += dt;
if ((meth == 0) && (k == nstep-2)) { // penultimate step
dt = time[step]-t;
t = time[step]-dt;
}
}
}
}
if (mode==1) {
PutRNGstate();
unset_pomp_userdata();
}
UNPROTECT(nprotect);
return X;
}
