void Plot2DProfile::drawSymbol( QPainter* painter, const QwtScaleMap & xMap,
const QwtScaleMap & yMap, const QRectF & canvasRect, int from, int to ) const{
QPen curvePen( m_defaultColor );
QBrush brush( m_defaultColor );
QSize symbolSize( 10, 10 );
QwtSymbol symbol ( QwtSymbol::Diamond, brush, curvePen, symbolSize );
drawSymbols( painter, symbol, xMap, yMap, canvasRect, from, to );
}
static void recordTicks(void)
{
/*debugging stuff*/
if (GUBED & 8)
{
long thisticks, mticks, i;
if (CurrentN < 0)
{
SymhTicks = Lookup("TICKS");
if (SymhTicks == (Symbolhandle) 0)
{
mticks = NTICKS*(MAXTICKS/NTICKS);
SymhTicks = RInstall("TICKS", mticks);
}
else
{
mticks = symbolSize(SymhTicks);
}
for (i = 0;i < mticks; i++)
{
setMissing(DATAVALUE(SymhTicks, i));
}
Lastticks = TickCount();
CurrentN = 0;
}
else if (CurrentN < DIMVAL(SymhTicks, 1))
{
thisticks = TickCount();
DATAVALUE(SymhTicks, CurrentN++) = (double) (thisticks - Lastticks);
Lastticks = thisticks;
}
else
{
GUBED &= ~8;
CurrentN = -1;
}
} /*if (GUBED & 8)*/
else
{
CurrentN = -1;
}
} /*recordTicks()*/
long getmodel(Symbolhandle list, long nargs, long startKey, long silent,
Symbolhandle symhWts, Symbolhandle symhOffset,
Symbolhandle symhN)
{
long i, j, i2, inc;
long ny, ndata, nvars, nfactors, nterms, nerrorterms;
long needed, balanced;
long foundNonIntY = 0, foundNonIntN = 0;
long intercept;
long nmissing, nzerowt;
long dim[2];
modelPointer kterm;
Symbolhandle symh;
double tmp;
double *glmoffset, *casewts, *misswts, *ptmp, *factorvar;
double yi, logitni, *y, *logitn, maxlevel;
long caseweights = MODELTYPE & CASEWEIGHTS;
char *ipfwarning =
"WARNING: ipf() cannot be used, poisson() substituted";
modelInfoPointer info = (modelInfoPointer) 0;
WHERE("getmodel");
TRASH(NTRASH,errorExit);
*OUTSTR = '\0';
USEGLMOFFSET = 0;
if (!initmodelparse(STRMODEL) || modelparse() != 0)
{/* parse it */
goto errorExit;
}
info = getModelInfo(); /* retrieve model information */
if((ndata = checkVariables(info)) < 0)
{
goto errorExit;
}
if(!(GLMCONTROL & MULTIVAR) && !isVector(info->modelvars[0]))
{
sprintf(OUTSTR,
"ERROR: non-vector response variable for %s()", FUNCNAME);
goto errorExit;
}
NVARS = nvars = MODELINFO->nvars = info->nvars;
NFACTORS = nfactors = MODELINFO->nfactors = info->nfactors;
NTERMS = nterms = MODELINFO->nterms = info->nterms;
NERRORTERMS = nerrorterms = MODELINFO->nerrorterms = info->nerrorterms;
for(i=0;i<nerrorterms;i++)
{
modeltermAssign((modelPointer) info->errorterms[i],
(modelPointer) MODELINFO->errorterms[i]);
}
/* Note: As of 930601, INTMODEL has been eliminated */
MODEL = info->model;
info->model = (modelHandle) 0;
if(MODELTYPE & (OLSREG|LEAPS))
{
NFACTORS = nfactors = MODELINFO->nfactors = 0;
intercept = 0;
for(j=0;j<nterms;j++)
{
kterm = modelterm(MODEL,j);
if(nvInTerm(kterm) > 1)
{
sprintf(OUTSTR,
"ERROR: crossed variates and/or factors are illegal for %s()",
FUNCNAME);
goto errorExit;
} /*if(nvInTerm(modelterm(MODEL,j)) > 1)*/
if(modeltermEqual(kterm,(modelPointer) NULLTERM))
{
intercept = 1;
}
} /*for(j=0;j<nterms;j++)*/
} /*if(MODELTYPE & (OLSREG|LEAPS))*/
if (MODELTYPE & LEAPS && !intercept)
{
sprintf(OUTSTR,
"ERROR: a model without an intercept is illegal for %s()",
FUNCNAME);
goto errorExit;
}
/* set up MODELVARS */
for (i = 0; i <= nvars; i++)
{
if(MODELVARS[i] != (Symbolhandle) 0)
{
Delete(MODELVARS[i]);
}
MODELVARS[i] = Makesymbol(REAL);
if (MODELVARS[i] == (Symbolhandle) 0)
{
goto errorExit;
}
if (!Copy(info->modelvars[i], MODELVARS[i]))
{
goto errorExit;
}
info->modelvars[i] = (Symbolhandle) 0;
strcpy(VARNAMES[i], NAME(MODELVARS[i]));
if(i < nvars)
{
NCLASSES[i] = info->nclasses[i];
}
clearNotes(MODELVARS[i]);
} /*for (i = 0; i <= nvars; i++)*/
/* set up Y and X */
/* response and factors are known to be matrix or vector */
for (i = 0; i <= nvars; i++)
{
symh = MODELVARS[i];
(void) isMatrix(symh,dim); /* get dimensions */
if (HASLABELS(symh) && NDIMS(symh) != 2)
{
if (!fixupMatLabels(symh, USEBOTHLABELS))
{
goto errorExit;
}
} /*if (HASLABELS(symh) && NDIMS(symh) != 2)*/
else
{
Setdims(symh, 2, dim);
}
if(i == 0)
{
Y = DATA(symh);
ny = dim[1];
NDATA = (double) ndata;
NY = (double) ny;
/* make sure dimensions are correct, always 2 */
} /*if(i == 0)*/
else
{/* i > 0 */
X[i - 1] = DATA(symh);
if (isVariate(i-1))
{
GLMCONTROL |= UNBALANCED;
} /*if (isVariate(i-1))*/
} /*if(i == 0){}else{}*/
if(*OUTSTR)
{
goto errorExit;
}
} /*for (i = 0; i <= nvars; i++)*/
/* check for crossed variates */
for (i = 0; i < nvars-1; i++)
{
if (isVariate(i))
{
/* variable i is a variate */
for (j = 0; j < nterms; j++)
{ /*
find the terms it is in and check to see it is not crossed
with another variate
*/
kterm = modelterm(MODEL,j);
if(inTerm(i,kterm) && nvInTerm(kterm) > 1)
{
/*
j-th term has variable i and there are at least 2
variables or factors in the term.
Check to see if j-th term has another variate
*/
for (i2 = i+1; i2 < nvars; i2++)
{
if (isVariate(i2) && inTerm(i2,kterm))
{
sprintf(OUTSTR,
"ERROR: crossed variates in model are illegal for %s()",
FUNCNAME);
goto errorExit;
} /*if (isVariate(i2) && inTerm(i2,kterm))*/
} /*for (i2 = 0; i2 < nvars; i2++)*/
} /*if(inTerm(i,kterm))*/
} /*for (j = 0; j < nterms; j++)*/
} /*if (isVariate(i))*/
} /*for (i = 0; i < nvars; i++)*/
/* check for case weights, i.e., user specified weights */
if (caseweights)
{
if (symhWts == (Symbolhandle) 0)
{
sprintf(OUTSTR,
"ERROR: no weights given for %s()",FUNCNAME);
}
else if (TYPE(symhWts) != REAL || !isVector(symhWts) ||
symbolSize(symhWts) != ndata)
{
sprintf(OUTSTR,
"ERROR: weights for %s() not REAL vector with length = nrows(%s)",
FUNCNAME, NAME(MODELVARS[0]));
}
else
{
CASEWTS = (double **) mygethandle(ndata * sizeof(double));
if (CASEWTS == (double **) 0)
{
goto errorExit;
}
casewts = *CASEWTS;
doubleCopy( DATAPTR(symhWts), casewts, ndata);
for (i = 0; i < ndata; i++)
{
if (!isMissing(casewts[i]) && casewts[i] < 0)
{
sprintf(OUTSTR,"ERROR: negative case weights for %s()",
FUNCNAME);
break;
}
} /*for (i = 0; i < ndata; i++)*/
}
if(*OUTSTR)
{
goto errorExit;
}
} /* if(caseweights) */
/* check for logistic N */
if (GLMCONTROL & BINOMDIST)
{
if (symhN == (Symbolhandle) 0)
{
sprintf(OUTSTR,"ERROR: no N variable given for %s()", FUNCNAME);
}
else if(!isVector(symhN) || TYPE(symhN) != REAL ||
symbolSize(symhN) != ndata && symbolSize(symhN) != 1)
{
sprintf(OUTSTR,
"ERROR: %s() N not REAL scalar or vector of same length as response",
FUNCNAME);
}
else
{
LOGITN = (double **) mygethandle(ndata * sizeof(double));
if (LOGITN == (double **) 0)
{
goto errorExit;
}
}
if(*OUTSTR)
{
goto errorExit;
}
inc = (symbolSize(symhN) == 1) ? 0 : 1;
i2 = 0;
y = *Y;
logitn = *LOGITN;
ptmp = DATAPTR(symhN);
for (i = 0; i < ndata; i++)
{
yi = y[i];
logitni = logitn[i] = ptmp[i2];
if (!isMissing(yi) && !isMissing(logitni))
{
tmp = floor(logitni);
if (tmp <= 0.0)
{
sprintf(OUTSTR,
"ERROR: N values must be nonnegative for %s()",
FUNCNAME);
}
else if (yi < 0.0 || yi > logitni)
{
sprintf(OUTSTR,
"ERROR: response value out of range for %s()",
FUNCNAME);
}
if(*OUTSTR)
{
goto errorExit;
}
if (!foundNonIntY && yi != floor(yi))
{
foundNonIntY = 1;
}
if (!foundNonIntN && logitni != tmp)
{
foundNonIntN = 1;
}
} /*if (!isMissing(yi) && !isMissing(logitni))*/
i2 += inc;
}/* for (i = 0; i < ndata; i++) */
} /*if (GLMCONTROL & BINOMDIST)*/
else if (GLMCONTROL & POISSONDIST)
{/* check for nonnegative Y in Poisson distributed glm */
y = *Y;
for (i = 0; i < ndata; i++)
{
yi = y[i];
if (!isMissing(yi))
{
if (yi < 0.0)
{
sprintf(OUTSTR,
"ERROR: response variable negative for %s()",
FUNCNAME);
goto errorExit;
}
if (!foundNonIntY && floor(yi) != yi)
{
foundNonIntY = 1;
}
} /*if (!isMissing(yi))*/
} /*for (i = 0; i < ndata; i++)*/
} /*if (glmcontrol & POISSONDIST)*/
if (!silent)
{
if (foundNonIntY)
{
sprintf(OUTSTR,
"WARNING: non-integer value(s) of response variable for %s()",
FUNCNAME);
putErrorOUTSTR();
}
if (foundNonIntN)
{
sprintf(OUTSTR,
"WARNING: non-integer number N of trials for %s()",
FUNCNAME);
putErrorOUTSTR();
}
} /*if (!silent)*/
/* check for user defined glmoffset */
if (symhOffset != (Symbolhandle) 0)
{
if (TYPE(symhOffset) != REAL || !isVector(symhOffset) ||
symbolSize(symhOffset) != ndata)
{
sprintf(OUTSTR,
"ERROR: offsets for %s() not REAL vector nrows(offset) = nrows(response)",
FUNCNAME);
goto errorExit;
}
USEGLMOFFSET = 1;
GLMOFFSET = (double **) mygethandle(ndata * sizeof(double));
if (GLMOFFSET == (double **) 0)
{
goto errorExit;
}
doubleCopy(DATAPTR(symhOffset), *GLMOFFSET, ndata);
} /*if (symhOffset != (Symbolhandle) 0)*/
/* check for missing & fill MISSWTS if any are missing*/
nmissing = countMissing(MODELINFO, &MISSWTS);
if(nmissing < 0)
{
goto errorExit;
}
if(caseweights || GLMCONTROL & BINOMDIST || USEGLMOFFSET)
{
casewts = (caseweights) ? *CASEWTS : (double *) 0;
logitn = (GLMCONTROL & BINOMDIST) ? *LOGITN : (double *) 0;
glmoffset = (USEGLMOFFSET) ? *GLMOFFSET : (double *) 0;
misswts = (nmissing > 0) ? *MISSWTS : (double *) 0;
for (i = 0; i < ndata; i++)
{
if (caseweights && isMissing(casewts[i]) ||
(GLMCONTROL & BINOMDIST) && isMissing(logitn[i]) ||
USEGLMOFFSET && isMissing(glmoffset[i]))
{
if(nmissing == 0)
{
MISSWTS = (double **) mygethandle(ndata * sizeof(double));
if (MISSWTS == (double **) 0)
{
goto errorExit;
}
misswts = *MISSWTS;
doubleFill(misswts, 1.0, ndata);
casewts = (caseweights) ? *CASEWTS : (double *) 0;
logitn = (GLMCONTROL & BINOMDIST) ? *LOGITN : (double *) 0;
glmoffset = (USEGLMOFFSET) ? *GLMOFFSET : (double *) 0;
} /*if(nmissing == 0)*/
if (misswts[i] != 0.0)
{
misswts[i] = 0.0;
nmissing++;
}
}
} /*for (i = 0; i < ndata; i++)*/
} /*if(caseweights || GLMCONTROL & BINOMDIST || USEGLMOFFSET)*/
if(nmissing > 0)
{
MODELTYPE |= MISSWEIGHTS;
GLMCONTROL |= UNBALANCED;
misswts = *MISSWTS;
} /*if(nmissing > 0)*/
/* find the actual maximum factor levels included */
if (nfactors > 0)
{
for (j = 0; j < nvars; j++)
{
if (!isVariate(j))
{
factorvar = *(X[j]);
maxlevel = 0;
for (i = 0;i < ndata; i++)
{
if (!isMissing(factorvar[i]) && factorvar[i] > maxlevel &&
(nmissing == 0 || misswts[i] > 0.0))
{
maxlevel = factorvar[i];
}
} /*for (i = 0;i < ndata; i++)*/
NCLASSES[j] = (long) maxlevel;
} /*if (!isVariate(j))*/
} /*for (j = 0; j < nvars; j++)*/
} /*if (nfactors > 0)*/
if (nmissing > 0 && !silent)
{
putOutErrorMsg("WARNING: cases with missing values deleted");
}
/* check for zero case weights, i.e., user specified weights */
if (caseweights)
{
casewts = *CASEWTS;
misswts = (MODELTYPE & MISSWEIGHTS) ? *MISSWTS : (double *) 0;
nzerowt = 0;
for (i = 0; i < ndata; i++)
{
if ((!(MODELTYPE & MISSWEIGHTS) || misswts[i] > 0.0) &&
casewts[i] == 0)
{
nzerowt++;
}
}
if (nzerowt != 0 && !silent)
{
putOutErrorMsg("WARNING: cases with zero weight completely removed");
}
nmissing += nzerowt;
} /*if (caseweights)*/
NOTMISSING = NDATA - nmissing;
if(NOTMISSING == 0)
{
sprintf(OUTSTR,
"ERROR: no non-missing cases with non-zero weight");
goto errorExit;
}
/*
Check for possible Latin Square or other balanced main effect design
for which balanced computation is appropriate
In the future, we need code to recognize fractional factorials,
confounded factorials, etc
*/
balanced = (!(GLMCONTROL & UNBALANCED) && !(MODELTYPE & FASTANOVA) &&
isBalanced(ONEWAYBALANCE));
if (balanced && nvars > 1)
{
if (anovaEffectsOnly(1))
{
balanced = isBalanced(TWOWAYBALANCE);
}
else
{
balanced = isBalanced(COMPLETEBALANCE);
}
if (balanced < 0)
{
goto errorExit;
}
} /*if (balanced)*/
if(!balanced)
{
GLMCONTROL |= UNBALANCED;
if (MODELTYPE & IPF)
{
MODELTYPE &= ~IPF;
MODELTYPE |= POISSONREG;
if(!silent)
{
putOutErrorMsg(ipfwarning);
}
}
} /*if(!balanced)*/
/* check for incremental deviances specified by extra argument */
if (MODELTYPE & (ITERGLMS | IPF) && !INCREMENTAL &&
nargs > startKey && !isKeyword(COMPVALUE(list,nargs-1)))
{
INCREMENTAL = 1;
}
/*
990319 moved creation of side-effect variables DEPVNAME and
TERMNAMES to glm()
*/
/* save dependent variable name */
needed = strlen(VARNAME(0)) + 1;
DEPVNAME = mygethandle(needed);
if(DEPVNAME == (char **) 0)
{
goto errorExit;
}
/* re-dereference name after memory allocation */
strcpy(*DEPVNAME, VARNAME(0));
/* Create TERMNAMES */
needed = makeTermNames(0); /* get space requirement */
TERMNAMES = mygethandle(needed);
if (TERMNAMES == (char **) 0)
{
goto errorExit;
}
/* now fill in TERMNAMES */
(void) makeTermNames(needed);
emptyTrash();
return (0); /* normal (no error) return */
/* NOTE: cleanup of globals is done in glm after error return */
errorExit:
putErrorOUTSTR();
emptyTrash();
if(info != (modelInfoPointer) 0)
{
mydisphandle((char **) info->model);
MODEL = info->model = (modelHandle) 0;
}
return (1);
} /*getmodel()*/
Symbolhandle setseed(Symbolhandle list)
{
Symbolhandle symhf, symhl, symhKey;
double first, last;
long nargs = NARGS(list);
long margs = nargs;
long verbose = 1;
char *keyword;
OUTSTR[0] = '\0';
if (nargs > 3)
{
badNargs(FUNCNAME, -3);
goto errorExit;
}
if (nargs > 1)
{ /* check for quiet:T or simply logical scalar 3rd argument */
symhKey = COMPVALUE(list,nargs-1);
if (!argOK(symhKey, 0, nargs))
{
goto errorExit;
}
if ((keyword = isKeyword(symhKey)) && strcmp(keyword, "quiet") != 0)
{
badKeyword(FUNCNAME, keyword);
goto errorExit;
}
if (isTorF(symhKey))
{
verbose = (DATAVALUE(symhKey,0) == 0);
nargs--;
}
else if(keyword || nargs == 3)
{
notTorF((keyword) ? keyword : "argument 3");
goto errorExit;
}
} /*if (nargs > 1)*/
symhf = COMPVALUE(list,0);
if(!argOK(symhf, REAL, (margs > 1) ? 1 : 0))
{
goto errorExit;
}
if(nargs == 2)
{
if(!argOK(symhl = COMPVALUE(list,1), REAL,2))
{
goto errorExit;
}
if (!isInteger(symhf, NONNEGATIVEVALUE) ||
!isInteger(symhl, NONNEGATIVEVALUE))
{
sprintf(OUTSTR,
"ERROR: when seeds are separate arguments, both must be integers >= 0");
}
else
{
first = DATAVALUE(symhf,0);
last = DATAVALUE(symhl,0);
}
} /*if(nargs == 2)*/
else
{
if(!isVector(symhf) || symbolSize(symhf) != 2)
{
sprintf(OUTSTR,
"ERROR: a single seed argument to %s must be a vector of length 2",
FUNCNAME);
}
else
{
first = DATAVALUE(symhf,0);
last = DATAVALUE(symhf,1);
}
} /*if(nargs == 2){}else{}*/
if(*OUTSTR)
{
goto errorExit;
}
if(isMissing(first) || isMissing(last))
{
sprintf(OUTSTR,"ERROR: missing values not allowed as seeds");
}
else if(first != floor(first) || first < 0 ||
last != floor(last) || last < 0 ||
first > RANDM1 || last > RANDM2)
{
sprintf(OUTSTR,
"ERROR: seeds must non-negative integers, seed1 <= %ld and seed2 <= %ld",
RANDM1, RANDM2);
}
if(*OUTSTR)
{
goto errorExit;
}
if(first == 0 || last == 0)
{
randomSeed(verbose);
}
else
{
Rands1 = first;
Rands2 = last;
}
return (NULLSYMBOL);
errorExit:
putErrorOUTSTR();
return (0);
} /*setseed()*/
Symbolhandle rangen(Symbolhandle list)
{
Symbolhandle result = (Symbolhandle) 0, symhN, symhParam1, symhParam2;
long sampleSize, lengthParam1, lengthParam2;
long op, verbose = 1;
long nargs = NARGS(list), margs;
char *what1, *what2;
char *badarg = "argument %ld (%s) to %s()";
char *badParam =
"ERROR: argument %ld to %s() (%s) not REAL scalar or vector";
char *hasMissing =
"ERROR: argument %ld to %s() (%s) has 1 or more MISSING values";
char *badLength =
"ERROR: length of vector argument %ld to %s() (%s) differs from sample size";
WHERE("rangen");
/* generate a list of random numbers */
if (strcmp(FUNCNAME, "rnorm") == 0)
{
op = IRNORM;
}
else if (strcmp(FUNCNAME, "rpoi") == 0)
{
op = IRPOI;
what1 = "mean";
}
else if (strcmp(FUNCNAME, "rbin") == 0)
{
op = IRBINOM;
what1 = "n";
what2 = "p";
}
else
{
op = IRUNI;
}
margs = (op == IRBINOM) ? 3 : ((op == IRPOI) ? 2 : 1);
OUTSTR[0] = '\0';
if (nargs != margs)
{
badNargs(FUNCNAME, margs);
goto errorExit;
}
symhN = COMPVALUE(list,0);
if (!isInteger(symhN, POSITIVEVALUE))
{
char outstr[30];
sprintf(outstr, badarg, 1L, "sample size", FUNCNAME);
notPositiveInteger(outstr);
goto errorExit;
} /*if (!isInteger(symhN, POSITIVEVALUE))*/
sampleSize = (long) DATAVALUE(symhN,0);
if (margs > 1)
{
symhParam1 = COMPVALUE(list, 1);
if (!argOK(symhParam1, 0, 2))
{
goto errorExit;
}
lengthParam1 = symbolSize(symhParam1);
if (TYPE(symhParam1) != REAL || !isVector(symhParam1))
{
sprintf(OUTSTR, badParam, 2L, what1, FUNCNAME);
}
else if (anyMissing(symhParam1))
{
sprintf(OUTSTR, hasMissing, 2L, what1, FUNCNAME);
}
else if (lengthParam1 > 1 && lengthParam1 != sampleSize)
{
sprintf(OUTSTR, badLength, 2L, what1, FUNCNAME);
}
else if (margs > 2)
{
symhParam2 = COMPVALUE(list, 2);
if (!argOK(symhParam2, 0, 3))
{
goto errorExit;
}
lengthParam2 = symbolSize(symhParam2);
if (TYPE(symhParam2) != REAL || !isVector(symhParam2))
{
sprintf(OUTSTR, badParam, 3L, what2, FUNCNAME);
}
else if (anyMissing(symhParam2))
{
sprintf(OUTSTR, hasMissing, 3L, what2, FUNCNAME);
}
else if (lengthParam2 > 1 && lengthParam2 != sampleSize)
{
sprintf(OUTSTR, badLength, 3L, what2, FUNCNAME);
}
}
if (*OUTSTR)
{
goto errorExit;
}
if (op == IRPOI)
{
/*rpoi(lambda)*/
if (doubleMin(DATAPTR(symhParam1), lengthParam1) < 0.0)
{
sprintf(OUTSTR,
"ERROR: argument 2 (%s) to %s() has negative element",
what1, FUNCNAME);
}
}
else if (op == IRBINOM)
{
/*rbinom(samplesize,n,p)*/
long i;
double *n = DATAPTR(symhParam1);
for (i = 0; i < lengthParam1; i++)
{
if (n[i] < 1 || n[i] != floor(n[i]))
{
sprintf(OUTSTR,
"ERROR: not all elements of argument 2 (%s) to %s() are positive integers",
what1, FUNCNAME);
goto errorExit;
}
} /*for (i = 0; i < lengthParam1; i++)*/
if (doubleMin(DATAPTR(symhParam2), lengthParam2) < 0.0 ||
doubleMax(DATAPTR(symhParam2), lengthParam2) > 1.0)
{
sprintf(OUTSTR,
"ERROR: argument 3 (%s) to %s() has value < 0 or > 1",
what2, FUNCNAME);
}
} /*else if (op == IRBINOM)*/
if (*OUTSTR)
{
goto errorExit;
}
} /*if (margs > 1)*/
if (Rands1 == 0 && Rands2 == 0)
{
randomSeed(verbose);
} /*if (Rands1 == 0 && Rands2 == 0)*/
result = RInstall(SCRATCH, sampleSize);
if (result != (Symbolhandle) 0)
{
switch (op)
{
case IRUNI:
vuni(sampleSize, DATAPTR(result));
break;
case IRNORM:
vnorm(sampleSize, DATAPTR(result));
break;
case IRPOI:
vpoi(sampleSize, DATAPTR(symhParam1), lengthParam1,
DATAPTR(result));
break;
case IRBINOM:
vbinom(sampleSize, DATAPTR(symhParam1), lengthParam1,
DATAPTR(symhParam2), lengthParam2, DATAPTR(result));
break;
} /*switch (op)*/
} /*if (result != (Symbolhandle) 0)*/
return (result);
errorExit:
putErrorOUTSTR();
return (0);
} /*rangen()*/
/*
Setup for if, else, elseif, while, and for
Routine to test logic and correspondingly set globals to affect course
of parsing. It sets globals affecting subsequent parsing. It returns 0
when an error is found.
The first argument list is a LIST and the second is IF, ELSEIF, ELSE, WHILE
or FOR.
On IF, ELSEIF and WHILE, NCOMPS(list) should be 1 and COMPVALUE(list,0)
should be a LOGICAL scalar specifying the condition.
On ELSE, list is a null handle.
On FOR, 2 <= NCOMPS(list) <= 4.
NAME(COMPVALUE(list, 0)) is the name of the index variable
If NCOMPS(list) == 2, COMPVALUE(list,1) is a REAL vector specifying
the values of the index.
If NCOMPS(list) == 4, COMPVALUE(list,3) must be a non-zero non-MISSING
REAL scalar inc (default value 1)
If NCOMPS(list) == 3 or 4, COMPVALUE(list,1) and COMPVALUE(list,2) must
be non MISSING REAL scalars i1 and i2 and a range vector of the form
run(i1,i2,inc) is computed and saved.
The depth of nested for and while loops is given by WDEPTH which is
incremented here and decremented in the parser.
The name of the index variable used in for(index,range){} is
IndexNames[WDEPTH-1] and the vector of values is stored in reverse
order in FORVECTORS[WDEPTH-1].
The depth of nested if/elseif/else statements is given by IDEPTH which is
incremented here and decremented in the parser.
The value of Logical in if(Logical){} or ...elseif(Logical){} is
put in IFCONDITIONS[IDEPTH-1]
As of 911002 only IF was processed and the input stream was modified was
to skip ahead to be just before '{' and to wipe out input stream on
errors. It was changed so that the input stream is not changed and all
control of parsing is through globals.
931110 Ifsetup() now returns error code rather than set Global IfsetupError
980208 Fixed divide by zero bug in for(i,1,1){}
Modified some of the code checking arguments to make use of
isScalar() which incorporates a check for a 0 Symbolhandle
Removed some unneeded externs
980218 Corrected handling of MISSING i1, i2 and inc in for(i,i1,i2[,inc])
980220 for(i,NULL){...} just skips compound statment and is not an error.
*/
int Ifsetup(Symbolhandle list, long op)
{
Symbolhandle logic, indexVal, range, start, end, inc;
char *opname;
long condition;
long i,i1, length, halfLength;
long iftype = (op == IF || op == ELSEIF);
long nullList = (list == (Symbolhandle) 0);
long ncomps = (nullList) ? 0 : NCOMPS(list);
long badForList;
double startVal, endVal, incVal = 1.0, endVal1, span, val;
double *forVector, *rangeVec;
WHERE("Ifsetup");
OUTSTR[0] = '\0';
if (op != ELSE)
{ /* IF, ELSEIF, FOR and WHILE */
if (iftype)
{
opname = (op == IF) ? "if" : "elseif";
}
else
{
opname = (op == WHILE) ? "while" : "for";
}
if ((!iftype && WDEPTH >= MAXWDEPTH) ||
(op == IF && IDEPTH >= MAXIDEPTH))
{
sprintf(OUTSTR,"ERROR: too many nested %s's",opname);
goto yyerrorExit;
}
if (!iftype)
{ /* for & while */
WDEPTH++;
}
else if (op == IF)
{
IDEPTH++;
}
if (op == WHILE || (iftype && !nullList))
{
char *condValue = "conditional value";
if (ncomps > 1)
{
sprintf(OUTSTR,"ERROR: usage is %s(LOGICAL){ ... }", opname);
}
else if ((logic = COMPVALUE(list,0)) == (Symbolhandle) 0)
{
sprintf(OUTSTR,"ERROR: no %s %s", opname, condValue);
}
else if (!isDefined(logic))
{
sprintf(OUTSTR,"ERROR: %s %s is UNDEFINED", opname, condValue);
}
else if (TYPE(logic) != LOGIC)
{
sprintf(OUTSTR,"ERROR: %s %s not LOGICAL", opname, condValue);
}
else if (!isScalar(logic))
{
sprintf(OUTSTR,
"ERROR: %s %s has length > 1", opname, condValue);
}
else if (isMissing(DATAVALUE(logic,0)))
{
sprintf(OUTSTR, "ERROR: %s %s is MISSING", opname, condValue);
}
if (*OUTSTR)
{
goto yyerrorExit;
}
condition = (DATAVALUE(logic,0) != 0.0);
} /* if (op == WHILE || (iftype && !nullList) */
else if (op == FOR)
{ /* for */
opname = "for";
if (FORVECTORS[WDEPTH-1] == (double **) 0)
{
/* first time through at this level */
indexVal = COMPVALUE(list,0);
COMPVALUE(list,0) = (Symbolhandle) 0;
/* Check index symbol */
if (indexVal == (Symbolhandle) 0 ||
TYPE(indexVal) == BLTIN || isscratch(NAME(indexVal)))
{
sprintf(OUTSTR,
"ERROR: %s index to %s loop",
(indexVal==(Symbolhandle) 0) ? "missing" : "illegal",
opname);
goto yyerrorExit;
}
badForList = (ncomps == 1 || ncomps > 4) ? BADNCOMPS : 0;
if (!badForList)
{
if (ncomps == 2)
{
range = COMPVALUE(list, 1);
if (TYPE(range) != NULLSYM &&
(!isVector(range) || TYPE(range) != REAL))
{
badForList = BADRANGEVAL;
}
} /*if (ncomps == 2)*/
else
{
start = COMPVALUE(list, 1);
end = COMPVALUE(list, 2);
inc = (ncomps == 4) ?
COMPVALUE(list, 3) : (Symbolhandle) 0;
if (!isScalar(start) || TYPE(start) != REAL ||
!isScalar(end) || TYPE(end) != REAL ||
(ncomps == 4 &&
(!isScalar(inc) || TYPE(inc) != REAL)))
{
badForList = BADLIMITSVAL;
}
else
{
startVal = DATAVALUE(start, 0);
endVal = DATAVALUE(end, 0);
incVal = (ncomps == 4) ? DATAVALUE(inc, 0) : 1.0;
if (isMissing(startVal) || isMissing(endVal) ||
isMissing(incVal))
{
badForList = MISSVALLIMITS;
}
else
{
double howFar = endVal - startVal;
if (ncomps == 3)
{
incVal = (howFar >= 0) ? 1.0 : -1.0;
}
else if (howFar != 0.0 && incVal == 0.0)
{
badForList = ZEROINC;
}
else if (incVal * howFar < 0.0)
{
badForList = WRONGSIGNINC;
}
}
}
} /*if (ncomps == 2){}else{}*/
} /*if (!badForList)*/
if (badForList)
{
char *usage1 = "for(index,i1,i2[,inc]){...}";
char *usage2 = "for(index,i1,i2,inc){...}";
switch (badForList)
{
case BADNCOMPS:
sprintf(OUTSTR,
"ERROR: usage is for(index,realVec){...} or %s", usage1);
break;
case BADRANGEVAL:
sprintf(OUTSTR,
"ERROR: range must be REAL vector in for(index, range){...}");
break;
case BADLIMITSVAL:
sprintf(OUTSTR,
"ERROR: i1, i2, inc must be non-MISSING REAL scalars in %s",
usage1);
break;
case MISSVALLIMITS:
sprintf(OUTSTR,
"ERROR: i1, i2, inc must not be MISSING in %s",
usage1);
break;
case ZEROINC:
sprintf(OUTSTR,
"ERROR: inc must not be 0 in %s", usage2);
break;
case WRONGSIGNINC:
sprintf(OUTSTR,
"ERROR: inc has wrong sign in %s", usage2);
break;
} /*switch (badForList)*/
goto yyerrorExit;
} /*if (badForList)*/
incVal = (incVal) ? incVal : 1.0;
if (ncomps == 2)
{
length = symbolSize(range);
} /*if (ncomps == 2)*/
else
{
span = endVal - startVal;
length = (long) (span / incVal) + 1;
/*
The following is intended to insure that if endVal is essentially an exact
multiple of by away from startVal, then the last element of the result
will be close to endVal, even if slightly outside the interval from
startVal to endVal; in addition, a very near zero is made exactly zero
The behavior is supposed to be exactly that of run().
*/
if (length > 1)
{
for (endVal1 = startVal + length * incVal;
incVal > 0.0 && endVal1 <= endVal ||
incVal < 0.0 && endVal1 >= endVal ||
fabs((endVal1 - endVal)/span) <= RUNFUZZ;
endVal1 = startVal + length * incVal)
{
length++;
}
} /*if (length > 1)*/
} /*if (ncomps == 2){}else{}*/
WHILELIMITS[WDEPTH-1] = length;
/* get temporary storage for range */
if (length == 0)
{
/* must be for(i,NULL){...} */
FORVECTORS[WDEPTH-1] = (double **) 0;
WHILECONDITIONS[WDEPTH-1] = 0;
/* return signal to skip compound statement*/
return (-1);
} /*if (length == 0)*/
if (ncomps > 2 || !isscratch(NAME(range)))
{
FORVECTORS[WDEPTH-1] =
(double **) mygethandle(length*sizeof(double));
if (FORVECTORS[WDEPTH-1] == (double **) 0)
{
goto errorExit;
}
if (ncomps == 2)
{
rangeVec = DATAPTR(range);
}
} /*if (ncomps > 2 || !isscratch(NAME(range)))*/
else
{ /* for(i,scratchVec){}*/
rangeVec = DATAPTR(range);
FORVECTORS[WDEPTH-1] = DATA(range);
setDATA(range, (double **) 0);
} /*if (ncomps > 2 || !isscratch(NAME(range))){}else{}*/
forVector = *FORVECTORS[WDEPTH-1];
/*
Copy range or run(startVal,endVal, incVal) to FORVECTORS
in reverse order, doing it in such a way that forVector
can be the same as rangeVec
*/
if (ncomps == 2)
{ /* copy from rangeVec to forVector in reverse order */
halfLength = length/2;
for (i = 0,i1 = length - 1;i < halfLength;i++, i1--)
{
val = rangeVec[i];
forVector[i] = rangeVec[i1];
forVector[i1] = val;
}
if (2*halfLength != length)
{
forVector[i] = rangeVec[i1];
}
} /*if (ncomps == 2)*/
else if (length == 1)
{
forVector[0] = startVal;
}
else
{ /* generate run(startVal,endVal,incVal)*/
for (i = 0,i1 = length - 1;i1 >= 0;i1--, i++)
{
val = startVal + (double) i * incVal;
forVector[i1] =
(incVal && fabs(val/span) < RUNFUZZ) ? 0.0 : val;
}
if (fabs((val-endVal)/span) < RUNFUZZ)
{
forVector[0] = endVal;
}
} /*if (ncomps == 2){}else{}*/
/* save index name */
strncpy(IndexNames[WDEPTH-1],NAME(indexVal),NAMELENGTH);
IndexNames[WDEPTH-1][NAMELENGTH] = '\0';
} /* if (FORVECTORS[WDEPTH-1] == (double **) 0) */
else
{ /* not first time through */
indexVal = Lookup(IndexNames[WDEPTH-1]);
}
/* re-use index variable if it is a REAL scalar */
if (!isScalar(indexVal) || TYPE(indexVal) != REAL)
{
Removesymbol(indexVal);
indexVal = (Symbolhandle) 0;
}
if (indexVal == (Symbolhandle) 0)
{
indexVal = RInstall(IndexNames[WDEPTH-1],1);
if (indexVal == (Symbolhandle) 0)
{
goto errorExit;
}
}
val = (*FORVECTORS[WDEPTH-1])[WHILELIMITS[WDEPTH-1]-1];
#if (USENOMISSING)
if (isMissing(val))
{
clearNOMISSING(indexVal);
}
else
{
setNOMISSING(indexVal);
}
#endif /*USENOMISSING*/
DATAVALUE(indexVal,0) = val;
}
if (op == WHILE)
{
/* WHILESTARTS, WHILEBRACKETLEV, and IFBRACKETLEV set in yylex */
if (--WHILELIMITS[WDEPTH-1] <= 0 && condition)
{ /* safety precaution */
/* Note: Parser also recognizes this condition and terminates
loop
*/
sprintf(OUTSTR,"ERROR: more than %ld repetitions of %s loop",
(long) MAXWHILE-1,opname);
putErrorOUTSTR();
}
WHILECONDITIONS[WDEPTH-1] = condition;
} /*if (op == WHILE)*/
else if (op == FOR)
{/* Note: WDEPTH & WHILELIMITS[WDEPTH-1] are decremented in mainpars */
WHILECONDITIONS[WDEPTH-1] = 1;
if (WHILELIMITS[WDEPTH-1] == 1)
{ /* this is the last time */
IndexNames[WDEPTH-1][0] = '\0';
mydisphandle((char **) FORVECTORS[WDEPTH-1]);
FORVECTORS[WDEPTH-1] = (double **) 0;
}
} /*if (op == WHILE){}else if (op == FOR)*/
else if (!nullList) /* op == IF or op == ELSEIF */
{
IFCONDITIONS[IDEPTH-1] = condition;
}
} /* if (op != ELSE) */
else
{
opname = "else";
}
/* go look for starting bracket enclosing the compound statement */
if (!findLParen(op, '{'))
{
goto errorExit;
}
if (op == FOR)
{
WHILESTARTS[WDEPTH-1] = ISTRCHAR;
}
*OUTSTR = '\0';
if (interrupted(DEFAULTTICKS) != INTNOTSET)
{
goto errorExit;
}
return (1);
yyerrorExit:
yyerror(OUTSTR);
return (0);
errorExit:
putErrorOUTSTR();
/* report error to parser */
return (0);
} /*Ifsetup()*/
