static SEXP CreateHess(SEXP names)
{
SEXP p, q, data, dim, dimnames;
int i, n;
n = length(names);
PROTECT(dimnames = lang4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
SETCAR(dimnames, install("list"));
p = install("c");
PROTECT(q = allocList(n));
SETCADDR(dimnames, LCONS(p, q));
UNPROTECT(1);
for(i = 0 ; i < n ; i++) {
SETCAR(q, ScalarString(STRING_ELT(names, i)));
q = CDR(q);
}
SETCADDDR(dimnames, duplicate(CADDR(dimnames)));
PROTECT(dim = lang4(R_NilValue, R_NilValue, R_NilValue,R_NilValue));
SETCAR(dim, install("c"));
SETCADR(dim, lang2(install("length"), install(".value")));
SETCADDR(dim, ScalarInteger(length(names)));
SETCADDDR(dim, ScalarInteger(length(names)));
PROTECT(data = ScalarReal(0.));
PROTECT(p = lang4(install("array"), data, dim, dimnames));
p = lang3(install("<-"), install(".hessian"), p);
UNPROTECT(4);
return p;
}
/* used in devWindows.c and cairoDevice */
void doMouseEvent(pDevDesc dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), dd->eventEnv);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, dd->eventEnv);
if (TYPEOF(handler) == CLOSXP) {
defineVar(install("which"), ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = ScalarReal( (x - dd->left) / (dd->right - dd->left) ));
PROTECT(sy = ScalarReal((y - dd->bottom) / (dd->top - dd->bottom) ));
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(5);
R_FlushConsole();
}
dd->gettingEvent = TRUE;
return;
}
static SEXP DerivAssign(SEXP name, SEXP expr)
{
SEXP ans, newname;
PROTECT(ans = lang3(install("<-"), R_NilValue, expr));
PROTECT(newname = ScalarString(name));
SETCADR(ans, lang4(R_BracketSymbol, install(".grad"), R_MissingArg, newname));
UNPROTECT(2);
return ans;
}
/*==========================================================================*/
void derivs(SEXP Func, double t, double* y, SEXP Parms, SEXP Rho,
double *ydot, double *yout, int j, int neq, int *ipar, int isDll,
int isForcing) {
SEXP Val, rVal, R_fcall;
SEXP R_t;
SEXP R_y;
int i = 0;
int nout = ipar[0];
double *yy;
double ytmp[neq];
if (isDll) {
/*------------------------------------------------------------------------*/
/* Function is a DLL function */
/*------------------------------------------------------------------------*/
C_deriv_func_type *cderivs;
if (isForcing) updatedeforc(&t);
cderivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(Func);
cderivs(&neq, &t, y, ytmp, yout, ipar);
if (j >= 0)
for (i = 0; i < neq; i++) ydot[i + neq * j] = ytmp[i];
} else {
/*------------------------------------------------------------------------*/
/* Function is an R function */
/*------------------------------------------------------------------------*/
PROTECT(R_t = ScalarReal(t)); incr_N_Protect();
PROTECT(R_y = allocVector(REALSXP, neq)); incr_N_Protect();
yy = REAL(R_y);
for (i=0; i< neq; i++) yy[i] = y[i];
PROTECT(R_fcall = lang4(Func, R_t, R_y, Parms)); incr_N_Protect();
PROTECT(Val = eval(R_fcall, Rho)); incr_N_Protect();
/* extract the states from first list element of "Val" */
if (j >= 0)
for (i = 0; i < neq; i++) ydot[i + neq * j] = REAL(VECTOR_ELT(Val, 0))[i];
/* extract outputs from second and following list elements */
/* this is essentially an unlist for non-nested numeric lists */
if (j < 0) {
int elt = 1, ii = 0, l;
for (i = 0; i < nout; i++) {
l = LENGTH(VECTOR_ELT(Val, elt));
if (ii == l) {
ii = 0; elt++;
}
//yout[i] = REAL(VECTOR_ELT(Val, elt))[ii];
// thpe 2012-08-04: make sure the return value is double and not int
PROTECT(rVal = coerceVector(VECTOR_ELT(Val, elt), REALSXP));
yout[i] = REAL(rVal)[ii];
UNPROTECT(1);
ii++;
}
}
my_unprotect(4);
}
}
static void C_acdc_bound_func (int *ii, int *n, double *y, double *gout,
double *eps, double *rpar, int *ipar)
{
int i;
SEXP R_fcall, J, ans;
REAL(EPS)[0] = *eps;
for (i = 0; i < n_eq ; i++) REAL(Y)[i] = y[i];
PROTECT(J = ScalarInteger(*ii)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_cont_bound_func,J,Y,EPS)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
/* only one element returned... */
gout[0] = REAL(ans)[0];
my_unprotect(3);
}
/* interface between fortran call to jacobian and R function */
static void C_acdc_jac_func (int *n, double *x, double *y, double *pd,
double *eps, double *rpar, int *ipar)
{
int i;
SEXP R_fcall, X, ans;
REAL(EPS)[0] = *eps;
for (i = 0; i < n_eq; i++) REAL(Y)[i] = y[i];
PROTECT(X = ScalarReal(*x)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_cont_jac_func,X,Y,EPS)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq * n_eq; i++) pd[i] = REAL(ans)[i];
my_unprotect(3);
}
SEXP R_exec4 (const char* command, SEXP structure1, SEXP structure2, SEXP structure3) {
SEXP e;
SEXP val = NILSXP;
int errorOccurred;
PROTECT(e = lang4(install((char*) command), structure1, structure2, structure3));
val = R_tryEval(e, R_GlobalEnv, &errorOccurred);
UNPROTECT(1);
if (!errorOccurred) {
return(val);
}
else {
return(NILSXP);
}
}
SEXP InstanceObjectTable::methodClosure(const char *name) const {
static SEXP qtbaseNS = R_FindNamespace(mkString("qtbase"));
static SEXP qinvokeSym = install("qinvoke");
SEXP f, pf, body;
PROTECT(f = allocSExp(CLOSXP));
SET_CLOENV(f, qtbaseNS);
pf = allocList(1);
SET_FORMALS(f, pf);
SET_TAG(pf, R_DotsSymbol);
SETCAR(pf, R_MissingArg);
PROTECT(body =
lang4(qinvokeSym, _instance->sexp(), mkString(name), R_DotsSymbol));
SET_BODY(f, body);
UNPROTECT(2);
return f;
}
static void C_res_func (double *t, double *y, double *yprime, double *cj,
double *delta, int *ires, double *yout, int *iout)
{
int i;
SEXP R_fcall, Time, ans;
for (i = 0; i < n_eq; i++)
{
REAL(Y)[i] = y[i];
REAL (YPRIME)[i] = yprime[i];
}
PROTECT(Time = ScalarReal(*t)); incr_N_Protect();
PROTECT(R_fcall = lang4(R_res_func,Time, Y, YPRIME)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq; i++) delta[i] = REAL(ans)[i];
my_unprotect(3);
}
static void C_jac_func (double *t, double *y, double *yprime,
double *pd, double *cj, double *RPAR, int *IPAR)
{
int i;
SEXP R_fcall, ans;
REAL(Rin)[0] = *t;
REAL(Rin)[1] = *cj;
for (i = 0; i < n_eq; i++)
{
REAL(Y)[i] = y[i];
REAL (YPRIME)[i] = yprime[i];
}
PROTECT(R_fcall = lang4(R_daejac_func, Rin, Y, YPRIME)); incr_N_Protect();
PROTECT(ans = eval(R_fcall, R_envir)); incr_N_Protect();
for (i = 0; i < n_eq * nrowpd; i++) pd[i] = REAL(ans)[i];
my_unprotect(2);
}
SEXP doMouseEvent(SEXP eventRho, NewDevDesc *dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), eventRho);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, eventRho);
result = NULL;
if (handler != R_UnboundValue && handler != R_NilValue) {
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = allocVector(REALSXP, 1));
REAL(sx)[0] = (x - dd->left) / (dd->right - dd->left);
PROTECT(sy = allocVector(REALSXP, 1));
REAL(sy)[0] = (y - dd->bottom) / (dd->top - dd->bottom);
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, eventRho));
R_FlushConsole();
UNPROTECT(5);
}
dd->gettingEvent = TRUE;
return result;
}
/* I probably need some of the cache:
parent
children
root
And the precomputed results:
init
base
pij
These need to be the *untransposed* calculations.
*/
SEXP r_asr_marginal_mkn(SEXP r_k, SEXP r_pars, SEXP r_nodes,
SEXP cache, SEXP res,
SEXP root_f, SEXP rho) {
const int n_states = INTEGER(r_k)[0];
const int neq = n_states;
int n_nodes = LENGTH(r_nodes), *nodes = INTEGER(r_nodes);
/* I think these are the only elements of the cache that we need */
int *parent = INTEGER(VECTOR_ELT(cache, 0));
int *children = INTEGER(VECTOR_ELT(cache, 1));
int root = INTEGER(VECTOR_ELT(cache, 2))[0];
/* And these are the precomputed bits we need */
double *r_init = REAL(VECTOR_ELT(res, 0));
double *r_base = REAL(VECTOR_ELT(res, 1));
double *r_lq = REAL(VECTOR_ELT(res, 2));
/* Spot 3 has 'vals' as of 0.9-2 */
double *pij = REAL(VECTOR_ELT(res, 4));
int n_out = LENGTH(VECTOR_ELT(res, 2));
/* These will be modified each time */
double *lq = (double*) R_alloc(n_out * neq, sizeof(double));
double *init = (double*) R_alloc(n_out * neq, sizeof(double));
double *base = (double*) R_alloc(n_out * neq, sizeof(double));
/* And this is a pointer to the root variables within */
double *root_vals = init + root * neq;
SEXP ret, cpy_root_vals, cpy_lq, R_fcall, tmp;
int idx, i, j, k;
double *vals;
if ( !isFunction(root_f) )
error("root_f must be a function");
if ( !isEnvironment(rho) )
error("rho must be a function");
PROTECT(ret = allocMatrix(REALSXP, n_states, n_nodes));
PROTECT(cpy_root_vals = allocVector(REALSXP, neq));
PROTECT(cpy_lq = allocVector(REALSXP, n_out));
for ( i = 0; i < n_nodes; i++ ) {
idx = nodes[i];
vals = REAL(ret) + n_states * i;
for ( j = 0; j < n_states; j++ ) {
/* Copy clean data back in */
memcpy(lq, r_lq, n_out * sizeof(double));
memcpy(init, r_init, n_out * neq * sizeof(double));
memcpy(base, r_base, n_out * neq * sizeof(double));
for ( k = 0; k < n_states; k++ )
if ( k != j )
init[neq * idx + k] = 0.0;
asr_marginal_mkn_1(k, idx, root, parent, children, pij,
init, base, lq);
memcpy(REAL(cpy_root_vals), root_vals, neq * sizeof(double));
memcpy(REAL(cpy_lq), lq, n_out * sizeof(double));
PROTECT(R_fcall = lang4(root_f, r_pars, cpy_root_vals, cpy_lq));
PROTECT(tmp = eval(R_fcall, rho));
vals[j] = REAL(tmp)[0];
UNPROTECT(2);
}
asr_normalise(n_states, vals);
}
UNPROTECT(3);
return ret;
}
/*
* This function performs an analysis routine. The intput to this function
* is an SEXP object containing a list of input files, the name of the
* function and the analysis options.
*/
SEXP
performAssp(SEXP args)
{
SEXP el,
inputs,
res,
pBar = R_NilValue,
utilsPackage, /* to update the prograssbar */
newVal;
const char *name;
AOPTS OPTS;
AOPTS *opt = &OPTS;
W_OPT *wrasspOptions;
A_F_LIST *anaFunc = funclist;
int tmp,
expExt = 0,
toFile = 1,
i = 0;
char ext[SUFF_MAX + 1] = "",
*cPtr = NULL;
W_GENDER *gend = NULL;
WFLIST *wPtr = NULL;
LP_TYPE *lPtr = NULL;
SPECT_TYPE *sPtr = NULL;
DOBJ *inPtr,
*outPtr;
char *dPath,
*bPath,
*oExt,
outName[PATH_MAX + 1],
*outDir = NULL;
args = CDR(args); /* skip function name */
/*
* First element is input file name or vector of input file names
*/
inputs = CAR(args);
args = CDR(args);
/*
* Second element must be assp function name
* check for validity and pick the right function descriptor
*/
name = isNull(TAG(args)) ? "" : CHAR(PRINTNAME(TAG(args)));
if (strcmp(name, "fname") != 0)
error("Second argument must be named 'fname'");
el = CAR(args);
while (anaFunc->funcNum != AF_NONE) {
if (strcmp(CHAR(STRING_ELT(el, 0)), anaFunc->fName) == 0)
break;
anaFunc++;
}
if (anaFunc->funcNum == AF_NONE)
error("Invalid analysis function in performAssp.c");
/*
* generate the default settings for the analysis function
*/
if ((anaFunc->setFunc) (opt) == -1)
error("%d\t$%s\n", asspMsgNum, getAsspMsg(asspMsgNum));
args = CDR(args);
/*
* the rest is options; each of them is checked against the option list of the analysis function
*/
for (int i = 0; args != R_NilValue; i++, args = CDR(args)) {
name = isNull(TAG(args)) ? "" : CHAR(PRINTNAME(TAG(args)));
wrasspOptions = anaFunc->options;
while (wrasspOptions->name != NULL) {
if (strcmp(wrasspOptions->name, name) == 0)
break;
wrasspOptions++;
}
if (wrasspOptions->name == NULL)
error("Invalid option %s for ASSP analysis %s.", name,
anaFunc->fName);
el = CAR(args);
switch (wrasspOptions->optNum) {
case WO_BEGINTIME:
opt->beginTime = REAL(el)[0];
break;
case WO_ENDTIME:
opt->endTime = REAL(el)[0];
break;
case WO_CENTRETIME:
if (INTEGER(el)[0]) {
opt->options |= AOPT_USE_CTIME;
} else {
opt->options &= ~AOPT_USE_CTIME;
}
break;
case WO_MSEFFLEN:
if (INTEGER(el)[0]) {
opt->options |= AOPT_EFFECTIVE;
switch (anaFunc->funcNum) {
case AF_SPECTRUM:
opt->options &= ~AOPT_USE_ENBW;
break;
default:
/*
* do nothing
*/
break;
}
} else {
opt->options &= ~AOPT_EFFECTIVE;
switch (anaFunc->funcNum) {
case AF_FOREST:
opt->gender = 'u';
break;
default:
break;
}
}
break;
case WO_MSSIZE:
opt->msSize = REAL(el)[0];
switch (anaFunc->funcNum) {
case AF_FOREST:
switch (opt->gender) {
case 'f':
if (opt->msSize != FMT_DEF_EFFLENf)
opt->gender = 'u';
break;
case 'm':
if (opt->msSize != FMT_DEF_EFFLENm)
opt->gender = 'u';
break;
default:
break;
}
break;
case AF_SPECTRUM:
opt->options &= ~AOPT_USE_ENBW;
break;
default:
/*
* do nothing
*/
break;
}
break;
case WO_MSSHIFT:
opt->msShift = REAL(el)[0];
break;
case WO_MSSMOOTH:
opt->msSmooth = REAL(el)[0];
break;
case WO_BANDWIDTH:
opt->bandwidth = REAL(el)[0];
break;
case WO_RESOLUTION:
opt->resolution = REAL(el)[0];
break;
case WO_GAIN:
opt->gain = REAL(el)[0];
break;
case WO_RANGE:
opt->range = REAL(el)[0];
break;
case WO_PREEMPH:
opt->preEmph = REAL(el)[0];
break;
case WO_FFTLEN:
opt->FFTLen = INTEGER(el)[0];
break;
case WO_CHANNEL:
opt->channel = INTEGER(el)[0];
break;
case WO_GENDER:
/*
* some things need to be set here:
* for f0_ksv: maxf, minf
* for f0_mhs: maxf, minf
* for forest: eff. window length, nominal F1
*/
gend = gender;
while (gend->ident != NULL) {
if (strncmp(gend->ident, CHAR(STRING_ELT(el, 0)), 1) == 0)
break;
gend++;
}
if (gend->ident == NULL)
error("Invalid gender specification %s.",
CHAR(STRING_ELT(el, 0)));
switch (anaFunc->funcNum) {
case AF_KSV_PITCH:
tmp = setKSVgenderDefaults(opt, gend->code);
break;
case AF_MHS_PITCH:
tmp = setMHSgenderDefaults(opt, gend->code);
break;
case AF_FOREST:
if (gend->num == TG_UNKNOWN) {
opt->gender = tolower((int) gend->code);
tmp = 1;
} else
tmp = setFMTgenderDefaults(opt, gend->code);
break;
default:
tmp = 1;
break;
}
if (tmp < 0)
error("%s", applMessage);
break;
case WO_MHS_OPT_POWER:
if (INTEGER(el)[0])
opt->options |= MHS_OPT_POWER;
else
opt->options &= ~MHS_OPT_POWER;
break;
case WO_ORDER:
tmp = opt->order;
opt->order = INTEGER(el)[0];
if (anaFunc->funcNum == AF_FOREST) {
if ((opt->order % 2) != 0) {
opt->order = tmp;
error("Prediction order must be an even number.");
} else {
opt->options |= FMT_OPT_LPO_FIXED;
opt->increment = 0;
}
}
break;
case WO_INCREMENT:
opt->increment = INTEGER(el)[0];
if (anaFunc->funcNum == AF_FOREST) {
opt->options &= ~FMT_OPT_LPO_FIXED;
opt->order = 0;
}
break;
case WO_NUMLEVELS:
opt->numLevels = INTEGER(el)[0];
break;
case WO_NUMFORMANTS:
opt->numFormants = INTEGER(el)[0];
break;
case WO_PRECISION:
opt->precision = INTEGER(el)[0];
break;
case WO_ACCURACY:
opt->accuracy = INTEGER(el)[0];
break;
case WO_ALPHA:
opt->alpha = REAL(el)[0];
break;
case WO_THRESHOLD:
opt->threshold = REAL(el)[0];
break;
case WO_MAXF:
opt->maxF = REAL(el)[0];
switch (anaFunc->funcNum) {
case AF_KSV_PITCH:
case AF_MHS_PITCH:
opt->gender = 'u';
break;
default:
/*
* do nothing
*/
break;
}
break;
case WO_MINF:
opt->minF = REAL(el)[0];
switch (anaFunc->funcNum) {
case AF_KSV_PITCH:
case AF_MHS_PITCH:
opt->gender = 'u';
break;
default:
/*
* do nothing
*/
break;
}
break;
case WO_NOMF1: /* e.g. for formant analysis */
opt->nomF1 = REAL(el)[0];
switch (anaFunc->funcNum) {
case AF_FOREST:
switch (opt->gender) {
case 'f':
if (opt->nomF1 != FMT_DEF_NOMF1f)
opt->gender = 'u';
break;
case 'm':
if (opt->nomF1 != FMT_DEF_NOMF1m)
opt->gender = 'u';
break;
default:
break;
}
break;
default:
/*
* do nothing
*/
break;
}
break;
case WO_INS_EST:
if (INTEGER(el)[0])
opt->options |= FMT_OPT_INS_ESTS;
else
opt->options &= ~FMT_OPT_INS_ESTS;
break;
case WO_VOIAC1PP: /* VOICING thresholds */
opt->voiAC1 = REAL(el)[0];
break;
case WO_VOIMAG:
opt->voiMag = REAL(el)[0];
break;
case WO_VOIPROB:
opt->voiProb = REAL(el)[0];
break;
case WO_VOIRMS:
opt->voiRMS = REAL(el)[0];
break;
case WO_VOIZCR:
opt->voiZCR = REAL(el)[0];
break;
case WO_HPCUTOFF: /* filter parameters */
opt->hpCutOff = REAL(el)[0];
if (expExt == 0)
tmp = getFILTtype(opt, anaFunc->defExt);
break;
case WO_LPCUTOFF:
opt->lpCutOff = REAL(el)[0];
if (expExt == 0)
tmp = getFILTtype(opt, anaFunc->defExt);
break;
case WO_STOPDB:
opt->stopDB = REAL(el)[0];
if (expExt == 0)
tmp = getFILTtype(opt, anaFunc->defExt);
break;
case WO_TBWIDTH:
opt->tbWidth = REAL(el)[0];
if (expExt == 0)
tmp = getFILTtype(opt, anaFunc->defExt);
break;
case WO_USEIIR:
if (INTEGER(el)[0])
opt->options |= FILT_OPT_USE_IIR;
else
opt->options &= ~FILT_OPT_USE_IIR;
if (expExt == 0)
tmp = getFILTtype(opt, anaFunc->defExt);
break;
case WO_NUMIIRSECS:
opt->order = INTEGER(el)[0];
if (opt->order < 1) {
error
("Bad value for option -numIIRsections (%i), must be greater 0 (default 4).",
opt->order);
opt->order = FILT_DEF_SECTS;
}
break;
case WO_TYPE: /* hold-all */
switch (anaFunc->funcNum) {
case AF_RFCANA:
lPtr = lpType;
while (lPtr->ident != NULL) {
if (strcmp(lPtr->ident, CHAR(STRING_ELT(el, 0))) == 0)
break;
lPtr++;
}
if (lPtr->ident == NULL)
error("Invalid LP Type: %s.", CHAR(STRING_ELT(el, 0)));
strncpy(opt->type, lPtr->ident, strlen(lPtr->ident));
if (expExt == 0)
strncpy(ext, lPtr->ext, strlen(lPtr->ext));
break;
case AF_SPECTRUM:
sPtr = spectType;
while (sPtr->ident != NULL) {
if (strcmp(sPtr->ident, CHAR(STRING_ELT(el, 0))) == 0)
break;
sPtr++;
}
if (sPtr->ident == NULL)
error("Invalid SP Type: %s.", CHAR(STRING_ELT(el, 0)));
strncpy(opt->type, sPtr->ident, strlen(sPtr->ident));
if (setSPECTdefaults(opt) < 0) {
error("%s", getAsspMsg(asspMsgNum));
}
strncpy(opt->type, sPtr->ident, strlen(sPtr->ident));
switch (sPtr->type) {
case DT_FTPOW:
case DT_FTAMP:
case DT_FTSQR:
setDFTdefaults(opt);
break;
case DT_FTLPS:
setLPSdefaults(opt);
break;
case DT_FTCSS:
setCSSdefaults(opt);
break;
case DT_FTCEP:
setCEPdefaults(opt);
break;
default:
setAsspMsg(AEG_ERR_BUG,
"setSPECTdefaults: invalid default type");
error("%s.", getAsspMsg(asspMsgNum));
break;
}
if (expExt == 0)
strncpy(ext, sPtr->ext, strlen(sPtr->ext));
break;
default:
break;
}
break;
case WO_WINFUNC:
wPtr = wfShortList;
while (wPtr->code != NULL) {
if (strcmp(wPtr->code, CHAR(STRING_ELT(el, 0))) == 0)
break;
wPtr++;
}
if (wPtr->code == NULL)
error("Invalid window function code %s.",
CHAR(STRING_ELT(el, 0)));
strncpy(opt->winFunc, wPtr->code, strlen(wPtr->code));
break;
/*
* These are not in libassp but in wrassp
*/
case WO_ENERGYNORM:
if (INTEGER(el)[0])
opt->options |= ACF_OPT_NORM;
else
opt->options &= ~ACF_OPT_NORM;
break;
case WO_LENGTHNORM:
if (INTEGER(el)[0])
opt->options |= ACF_OPT_MEAN;
else
opt->options &= ~ACF_OPT_MEAN;
break;
case WO_DIFF_OPT_BACKWARD:
if (INTEGER(el)[0])
opt->options |= DIFF_OPT_BACKWARD;
else
opt->options &= ~DIFF_OPT_BACKWARD;
break;
case WO_DIFF_OPT_CENTRAL:
if (INTEGER(el)[0])
opt->options |= DIFF_OPT_CENTRAL;
else
opt->options &= ~DIFF_OPT_CENTRAL;
break;
case WO_RMS_OPT_LINEAR:
if (INTEGER(el)[0])
opt->options |= RMS_OPT_LINEAR;
else
opt->options &= ~RMS_OPT_LINEAR;
break;
case WO_LPS_OPT_DEEMPH:
if (INTEGER(el)[0])
opt->options |= LPS_OPT_DEEMPH;
else
opt->options &= ~LPS_OPT_DEEMPH;
break;
case WO_OUTPUTEXT:
if (TYPEOF(el) == NILSXP) {
expExt = 0;
break;
}
cPtr = strdup(CHAR(STRING_ELT(el, 0)));
if (*cPtr != '.' && strlen(cPtr) != 0) {
strncpy(ext, ".", strlen(".") + 1);
strcat(ext, cPtr);
} else {
strncpy(ext, cPtr, strlen(cPtr) + 1);
}
free(cPtr);
expExt = 1;
switch (anaFunc->funcNum) {
case AF_RFCANA:
lPtr = lpType;
while (lPtr->ident != NULL) {
if (strcmp(opt->type, lPtr->ident) == 0)
break;
lPtr++;
}
if (lPtr->ident == NULL)
error("Bad LP Type in memory (%s).", opt->type);
if (strcmp(lPtr->ext, ext) == 0) {
expExt = 0;
} else {
expExt = 1;
}
break;
case AF_SPECTRUM:
sPtr = spectType;
while (sPtr->ident != NULL) {
if (strcmp(opt->type, sPtr->ident) == 0)
break;
sPtr++;
}
if (sPtr->ident == NULL)
error("Bad SP Type in memory (%s).", opt->type);
if (strcmp(sPtr->ext, ext) == 0) {
expExt = 0;
} else {
expExt = 1;
}
break;
default:
break;
}
break;
case WO_TOFILE:
toFile = INTEGER(el)[0] != 0;
break;
case WO_OUTPUTDIR:
if (el == R_NilValue) {
outDir = NULL;
break;
}
outDir = strdup(CHAR(STRING_ELT(el, 0)));
if (outDir[strlen(outDir) - 1] != DIR_SEP_CHR) {
/* add trailing slash, but we need a bit more space first */
char *tmp = malloc(strlen(outDir) + 2);
strcpy(tmp, outDir);
tmp = strcat(tmp, DIR_SEP_STR);
free(outDir);
outDir = tmp;
}
break;
case WO_PBAR:
pBar = el;
break;
default:
break;
}
}
/*
* output extension might still be unset. For afdiff and for spectral
* analysis we need to take special care. In other cases it would be
* weird to get here but we can safely use the default.
*/
if (strcmp(ext, "") == 0) {
/*
* could be explicitely set to ""
*/
if (!expExt) {
switch (anaFunc->funcNum) {
case AF_AFDIFF:
/*
* needs to be handled on a per file basis
*/
break;
case AF_SPECTRUM:
sPtr = spectType;
while (sPtr->ident != NULL) {
if (strcmp(opt->type, sPtr->ident) == 0)
break;
sPtr++;
}
if (sPtr->ident == NULL)
error("Bad SP Type in memory (%s).", opt->type);
strcpy(ext, sPtr->ext);
break;
default:
strcpy(ext, anaFunc->defExt);
break;
}
}
}
/*
* do analysis
*/
/*
* hook into the progressbar if present
*/
if (pBar != R_NilValue) {
PROTECT(newVal = allocVector(INTSXP, 1));
PROTECT(utilsPackage = eval(lang2(install("getNamespace"),
ScalarString(mkChar("utils"))),
R_GlobalEnv));
INTEGER(newVal)[0] = 0;
eval(lang4(install("setTxtProgressBar"), pBar, newVal, R_NilValue),
utilsPackage);
}
/*
* in memory only works for single input, not for multiple input so,
* if toFile is false but there are multiple inputs set toFile to true
*/
toFile = toFile || length(inputs) != 1;
/*
* iterate over input files
*/
for (i = 0; i < length(inputs); i++) {
/*
* get inpput name and open
*/
name = strdup(CHAR(STRING_ELT(inputs, i)));
inPtr = asspFOpen(strdup(name), AFO_READ, (DOBJ *) NULL);
if (inPtr == NULL)
error("%s (%s)", getAsspMsg(asspMsgNum), strdup(name));
/*
* run the function (as pointed to in the descriptor) to generate
* the output object
*/
outPtr = (anaFunc->compProc) (inPtr, opt, (DOBJ *) NULL);
if (outPtr == NULL) {
asspFClose(inPtr, AFC_FREE);
error("%s (%s)", getAsspMsg(asspMsgNum), strdup(name));
}
/*
* input data object no longer needed
*/
asspFClose(inPtr, AFC_FREE);
if (toFile) {
/*
* in toFile mode, all DOBJs are written to file we will later
* return the number of successful analyses
*/
/*
* parse the input path to get directory (dPath), base file
* name (bPath) and original extension (oExt)
*/
parsepath((char *) name, &dPath, &bPath, &oExt);
/*
* outName is the same except for extension unless outDir is
* set
*/
strcpy(outName, "");
if (outDir == NULL)
strcat(outName, dPath);
else
strcat(outName, outDir);
strcat(outName, bPath);
/*
* Extension may have to be set for afdiff but only if
* extension is not set explicitely
*/
if (strcmp(ext, "") == 0 && !expExt) {
switch (anaFunc->funcNum) {
case AF_AFDIFF:
strcpy(ext, ".d");
oExt++; /* skip period */
strcat(ext, oExt);
break;
default:
error("Extension handling failed (performAssp).");
break;
}
}
strcat(outName, ext);
/*
* out put name is complete, use it to open the file for the
* output object, then write and close and free
*/
outPtr = asspFOpen(outName, AFO_WRITE, outPtr);
if (outPtr == NULL) {
asspFClose(outPtr, AFC_FREE);
error("%s (%s)", getAsspMsg(asspMsgNum), strdup(outName));
}
if (asspFFlush(outPtr, 0) == -1) {
asspFClose(outPtr, AFC_FREE);
error("%s (%s)", getAsspMsg(asspMsgNum), strdup(outName));
}
asspFClose(outPtr, AFC_FREE);
} else {
res = dobj2AsspDataObj(outPtr);
asspFClose(outPtr, AFC_FREE);
}
free((char *) name);
/*
* if a progress bar was passed over, increment its value
*/
if (pBar != R_NilValue) {
INTEGER(newVal)[0] = i + 1;
eval(lang4
(install("setTxtProgressBar"), pBar, newVal, R_NilValue),
utilsPackage);
}
}
free((void *) outDir);
if (toFile) {
/*
* in toFile mode, the number of successful analyses is returned
*/
PROTECT(res = allocVector(INTSXP, 1));
INTEGER(res)[0] = i;
}
/*
* for the progress bar, to SEXPs were protected
*/
if (pBar != R_NilValue)
UNPROTECT(2);
/*
* in toFile mode, the return value was protected
*/
if (toFile)
UNPROTECT(1);
return res;
}
Sampler *
sampler_new (SEXP opts)
{
Sampler *ss;
SEXP SEXPTmp;
ss = (Sampler *) R_alloc(1, sizeof(struct Sampler));
ss->nStreams = INTEGER(getListElement(opts, "nStreams"))[0];
ss->nPeriods = INTEGER(getListElement(opts, "nPeriods"))[0];
ss->nStreamsPreResamp = INTEGER(getListElement(opts, "nStreamsPreResamp"))[0];
ss->dimPerPeriod = INTEGER(getListElement(opts, "dimPerPeriod"))[0];
ss->dimSummPerPeriod = INTEGER(getListElement(opts, "dimSummPerPeriod"))[0];
ss->returnStreams = LOGICAL(getListElement(opts, "returnStreams"))[0];
ss->returnLogWeights = LOGICAL(getListElement(opts, "returnLogWeights"))[0];
ss->nMHSteps = INTEGER(getListElement(opts, "nMHSteps"))[0];
ss->verboseLevel = INTEGER(getListElement(opts, "verboseLevel"))[0];
ss->printEstTimeAt = 10; ss->printEstTimeNTimes = 10;
/* FIXME: The setting for ss->printDotAt, is it all right? */
ss->printInitialDotsWhen = ss->printEstTimeAt / 10;
ss->printDotAt = 0; ss->nDotsPerLine = 20;
ss->eachDotWorth = (int) ceil((ss->nPeriods - ss->printEstTimeAt + 1.0) / \
(ss->printEstTimeNTimes * ss->nDotsPerLine));
ss->nProtected = 0;
/* The user provided functions */
ss->propagateFunc = getListElement(opts, "propagateFunc");
ss->propagateArgsList = (ArgsList1 *) R_alloc(1, sizeof(struct ArgsList1));
ss->nProtected += args_list1_init(ss->propagateArgsList);
ss->resampCriterionFunc = getListElement(opts, "resampCriterionFunc");
ss->resampCriterionArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->resampCriterionArgsList);
ss->resampFunc = getListElement(opts, "resampFunc");
ss->resampArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->resampArgsList);
ss->summaryFunc = getListElement(opts, "summaryFunc");
ss->summaryArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
ss->nProtected += args_list2_init(ss->summaryArgsList);
ss->MHUpdateFunc = getListElement(opts, "MHUpdateFunc");
ss->MHUpdateArgsList = (ArgsList3 *) R_alloc(1, sizeof(struct ArgsList3));
ss->nProtected += args_list3_init(ss->MHUpdateArgsList);
SEXPTmp = getListElement(opts, "doCallFunc");
PROTECT(ss->doCallFuncCall = lang4(SEXPTmp, R_NilValue,
R_NilValue, R_NilValue));
++(ss->nProtected);
ss->doCallFuncEnv = getListElement(opts, "doCallFuncEnv");
SEXPTmp = getListElement(opts, "procTimeFunc");
PROTECT(ss->procTimeFuncCall = lang1(SEXPTmp));
++(ss->nProtected);
ss->procTimeFuncEnv = getListElement(opts, "procTimeFuncEnv");
ss->timeDetails = (TimeDetails *) R_alloc(1, sizeof(struct TimeDetails));
PROTECT(ss->SEXPCurrentPeriod = allocVector(INTSXP, 1)); ++(ss->nProtected);
PROTECT(ss->SEXPNStreamsToGenerate = allocVector(INTSXP, 1)); ++(ss->nProtected);
PROTECT(ss->SEXPNMHSteps = allocVector(INTSXP, 1)); ++(ss->nProtected);
ss->dotsList = getListElement(opts, "dotsList");
ss->SEXPCurrentStreams = R_NilValue;
PROTECT(ss->SEXPLag1Streams = allocMatrix(REALSXP, ss->nStreams, ss->dimPerPeriod));
++(ss->nProtected);
ss->SEXPCurrentLogWeights = R_NilValue;
PROTECT(ss->SEXPCurrentAdjWeights = allocVector(REALSXP, ss->nStreamsPreResamp));
++(ss->nProtected);
PROTECT(ss->SEXPLag1LogWeights = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPLag1AdjWeights = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPAcceptanceRates = allocVector(REALSXP, ss->nStreams));
++(ss->nProtected);
PROTECT(ss->SEXPSummary = allocVector(REALSXP, ss->dimSummPerPeriod));
++(ss->nProtected);
PROTECT(ss->SEXPPropUniqueStreamIds = allocVector(REALSXP, 1));
++(ss->nProtected);
ss->scratch_RC = (ResampleContext *) R_alloc(1, sizeof(struct ResampleContext));
ss->scratch_RC->streamIds = (int *) R_alloc(ss->nStreams, sizeof(int));
ss->scratch_RC->uniqueStreamIds = (int *) R_alloc(ss->nStreams, sizeof(int));
ss->scratch_RC->partialSum = (double *) R_alloc(ss->nStreamsPreResamp, sizeof(double));
return ss;
}
SEXP countdiffs(SEXP Rx, SEXP Ry, SEXP maxDiff, SEXP Rtype, SEXP Rquick, SEXP pBar) {
int nprotect=0;
SEXP Rdimx, Rdimy, Rcounts;
SEXP utilsPackage, percentComplete;
PROTECT(utilsPackage = eval(lang2(install("getNamespace"), ScalarString(mkChar("utils"))), R_GlobalEnv));
PROTECT(percentComplete = allocVector(INTSXP, 1));
nprotect+=2;
int *rPercentComplete = INTEGER(percentComplete);
PROTECT(Rdimx = getAttrib(Rx, R_DimSymbol));
nprotect++;
int nx = INTEGER(Rdimx)[0];
int mx = INTEGER(Rdimx)[1];
PROTECT(Rdimy = getAttrib(Ry, R_DimSymbol));
nprotect++;
int ny = INTEGER(Rdimy)[0];
int my = INTEGER(Rdimy)[1];
if(mx != my)
error("x and y need equal number of columns");
// maximum number of mismatches allowed
int maxdiff = INTEGER(maxDiff)[0];
// type of things to count
int type = INTEGER(Rtype)[0];
// be quick by assuming <=1 match per sample
int quick = INTEGER(Rquick)[0];
// pointers to x, y
unsigned char *x = RAW(Rx);
unsigned char *y = RAW(Ry);
// return indices of samples with < tol mismatches, number of mismatches
int MM = nx;
if(MM > ny)
MM = ny;
if(quick == 0)
MM=MM*4; // worst case: at maximum, each sample in x or y may have four matches in y or x
int xindex[MM], yindex[MM], mismatch[MM], total[MM];
int i=0, j=0, ii=0, jj=0, k=0;
// record matches
int xflag[nx], yflag[ny];
for(i=0; i<nx; i++)
xflag[i]=0;
for(i=0; i<ny; i++)
yflag[i]=0;
int ij=0;
for(i=0; i<nx; i++) { // index rows of x
if(xflag[i]==1) // already matched
continue;
for(j=0; j<ny; j++) { // index rows of y, ij indexes counts
if(yflag[j]==1)
continue;
int nonzero = 0, different=0;
for(k=0, ii=i, jj=j; k<mx; k++, ii+=nx, jj+=ny) { // index elements of each row in x, y
int xx=(int) x[ii];
int yy=(int) y[jj];
if( xx!=0 && yy!=0) {
nonzero++;
if((type==0 && xx!=yy) || (type==1 && xx==2 && yy!=2) || (type==1 && xx!=2 && yy==2)) {
different++;
if(different == maxdiff)
break;
}
}
}
if(different == maxdiff) // different samples
continue;
// low mismatch - store
fprintf(stderr, "i:%i j:%i, ij:%i\n", i, j, ij);
xindex[ij] = i+1; // switch to 1-based
yindex[ij] = j+1; // switch to 1-based
mismatch[ij] = different;
total[ij] = nonzero;
if(quick==1) {
xflag[i] = 1;
yflag[j] = 1;
}
ij++;
}
*rPercentComplete = i; //this value increments
eval(lang4(install("setTxtProgressBar"), pBar, percentComplete, R_NilValue), utilsPackage);
}
// trim Rcount
PROTECT(Rcounts = allocMatrix(INTSXP, ij, 4));
nprotect++;
int *pRcounts = INTEGER(Rcounts);
for(i=0; i<ij; i++) {
pRcounts[i] = xindex[i];
pRcounts[i+ij] = yindex[i];
pRcounts[i+2*ij] = mismatch[i];
pRcounts[i+3*ij] = total[i];
}
UNPROTECT(nprotect);
return(Rcounts);
}
