std::string name(int t)
{
char buf[16];
std::string res;
int i=0;
while (names[i].name != NULL && names[i].t != t)
++i;
if (names[i].name != NULL)
{
res = names[i].name;
}
else if (isMatrix(t))
{
res = "Mat<";
snprintf(buf,sizeof(buf),"%d",ny(t));
res += buf;
res += ",";
snprintf(buf,sizeof(buf),"%d",nx(t));
res += buf;
res += ",";
res += name(toSingle(t));
res += ">";
}
else if (isVector(t))
{
res = "Vec<";
snprintf(buf,sizeof(buf),"%d",nx(t));
res += buf;
res += ",";
res += name(toSingle(t));
res += ">";
}
else if (isString(t))
{
if (size(t)==0)
res = "String";
else
{
res = "String<";
snprintf(buf,sizeof(buf),"%d",size(t));
res += buf;
res += ">";
}
}
else
{
snprintf(buf,sizeof(buf),"0x%x",t);
res = buf;
}
return res;
}
bool isSquareMatrix(const Expr& x, int& N)
{
N = 0;
/* do the simplest checks first */
if (x.size()*x.size() != x.totalSize()) return false;
N = x.size();
for (int i=0; i<N; i++)
{
int M = 0;
if (!isVector(x[i],M)) return false;
if (M != N) return false;
}
return true;
}
void SharedMap::NvGetKey(const ArrayData* ad, TypedValue* out, ssize_t pos) {
auto a = asSharedMap(ad);
if (a->isVector()) {
out->m_data.num = pos;
out->m_type = KindOfInt64;
} else {
Variant k = a->m_map->getKey(pos);
TypedValue* tv = k.asTypedValue();
// copy w/out clobbering out->_count.
out->m_type = tv->m_type;
out->m_data.num = tv->m_data.num;
if (tv->m_type != KindOfInt64) out->m_data.pstr->incRefCount();
}
}
SEXP r_offsetPtr(SEXP x, SEXP offset)
{
if ( LENGTH(offset) == 0 ) error("offset is missing");
ptrdiff_t offsetval = INTEGER(offset)[0];
unsigned char* ptr = 0;
if (isVector(x)) {
ptr = (unsigned char*) DATAPTR(x);
} else if (TYPEOF(x) == EXTPTRSXP ) {
ptr = (unsigned char*) R_ExternalPtrAddr(x);
} else {
error("unsupported type");
}
return R_MakeExternalPtr( ptr + offsetval , R_NilValue, x );
}
SEXP c_check_vector(SEXP x, SEXP strict, SEXP any_missing, SEXP all_missing, SEXP len, SEXP min_len, SEXP max_len, SEXP unique, SEXP names) {
if (!isVector(x))
return make_type_error(x, "vector");
if (asFlag(strict, "strict")) {
SEXP attr = ATTRIB(x);
if ((length(attr) > 0 && (TAG(attr) != R_NamesSymbol)) || CDR(attr) != R_NilValue)
return make_type_error(x, "vector");
}
assert(check_vector_len(x, len, min_len, max_len));
assert(check_vector_names(x, names));
assert(check_vector_missings(x, any_missing, all_missing));
assert(check_vector_unique(x, unique));
return ScalarLogical(TRUE);
}
SEXP makeSubscript(SEXP x, SEXP s, int *stretch)
{
int nx;
SEXP ans;
ans = R_NilValue;
if (isVector(x) || isList(x) || isLanguage(x)) {
nx = length(x);
ans = vectorSubscript(nx, s, stretch, getAttrib, (STRING_ELT), x);
}
else error(_("subscripting on non-vector"));
return ans;
}
TString TType::getCompleteString() const
{
TStringStream stream;
if (qualifier != EvqTemporary && qualifier != EvqGlobal)
stream << getQualifierString() << " ";
if (precision != EbpUndefined)
stream << getPrecisionString() << " ";
if (array)
stream << "array[" << getArraySize() << "] of ";
if (isMatrix())
stream << getCols() << "X" << getRows() << " matrix of ";
else if (isVector())
stream << getNominalSize() << "-component vector of ";
stream << getBasicString();
return stream.str();
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_cpos2rbound(SEXP inAttribute, SEXP inCpos)" --
*
*
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_cpos2rbound(SEXP inAttribute, SEXP inCpos)
{
SEXP result = R_NilValue;
int cpos;
int len, i, struc, lb, rb;
char * a;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
PROTECT(inAttribute);
if (!isVector(inCpos)) error("argument 'cpos' must be a vector of integers");
PROTECT(inCpos);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
len = length(inCpos);
attribute = cqi_lookup_attribute(a, ATT_STRUC);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
result = PROTECT(allocVector(INTSXP, len));
for (i=0; i<len; i++) {
cpos = INTEGER(inCpos)[i];
struc = cl_cpos2struc(attribute, cpos);
/* Return -1 if cpos is out of range */
if (struc < 0) {
struc = -1;
} else {
if (cl_struc2cpos(attribute, struc, &lb, &rb)) {
struc = rb;
} else {
struc = -1;
}
}
INTEGER(result)[i] = struc;
}
}
UNPROTECT(3);
return result;
}
Var& Var::getAt(std::size_t n)
{
if (isVector())
return holderImpl<std::vector<Var>,
InvalidAccessException>("Not a vector.")->operator[](n);
else if (isList())
return holderImpl<std::list<Var>,
InvalidAccessException>("Not a list.")->operator[](n);
else if (isDeque())
return holderImpl<std::deque<Var>,
InvalidAccessException>("Not a deque.")->operator[](n);
else if (isStruct())
return structIndexOperator(holderImpl<Struct<int>,
InvalidAccessException>("Not a struct."), static_cast<int>(n));
else if (!isString() && !isEmpty() && (n == 0))
return *this;
throw RangeException("Index out of bounds.");
}
//
// Recursively generate mangled names.
//
void TType::buildMangledName(TString& mangledName)
{
if (isMatrix())
mangledName += 'm';
else if (isVector())
mangledName += 'v';
switch (type) {
case EbtFloat: mangledName += 'f'; break;
case EbtInt: mangledName += 'i'; break;
case EbtBool: mangledName += 'b'; break;
case EbtSampler1D: mangledName += "s1"; break;
case EbtSampler2D: mangledName += "s2"; break;
case EbtSampler3D: mangledName += "s3"; break;
case EbtSamplerCube: mangledName += "sC"; break;
case EbtSampler1DShadow: mangledName += "sS1"; break;
case EbtSampler2DShadow: mangledName += "sS2"; break;
case EbtSamplerRect: mangledName += "sR2"; break; // ARB_texture_rectangle
case EbtSamplerRectShadow: mangledName += "sSR2"; break; // ARB_texture_rectangle
case EbtStruct:
mangledName += "struct-";
if (typeName)
mangledName += *typeName;
{// support MSVC++6.0
for (unsigned int i = 0; i < structure->size(); ++i) {
mangledName += '-';
(*structure)[i].type->buildMangledName(mangledName);
}
}
default:
break;
}
mangledName += static_cast<char>('0' + getNominalSize());
if (isArray()) {
char buf[10];
sprintf(buf, "%d", arraySize);
mangledName += '[';
mangledName += buf;
mangledName += ']';
}
}
static double mavg1d(SEXP v, int col, int w)
{
double s=0.00;
int i, z=0;
int startcol, endcol;
if (isVector(v)) {
startcol = (col-w>0 ? col-w : 0);
endcol = (col+w<LENGTH(v) ? col+w+1 : LENGTH(v));
for(i=startcol, z=0, s=0.00; i<endcol; i++) {
if (R_FINITE(REAL(v)[i])) {
z++;
s += REAL(v)[i];
}
}
} else error("Input is not a vector or Matrix.");
if (z == 0) return R_NaN;
return s/z;
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_id2cpos(SEXP inAttribute, SEXP inId)" --
*
*
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_id2cpos(SEXP inAttribute, SEXP inId)
{
SEXP result = R_NilValue;
int idx;
int len, i;
int * cposlist;
char *a;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
PROTECT(inAttribute);
if (!isVector(inId) || length(inId) != 1) error("argument 'id' must be an integer");
PROTECT(inId);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
idx = INTEGER(inId)[0];
attribute = cqi_lookup_attribute(a, ATT_POS);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
cposlist = cl_id2cpos(attribute, idx, &len);
result = PROTECT(allocVector(INTSXP, len));
if (cposlist == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
for (i=0; i<len; i++) {
INTEGER(result)[i] = cposlist[i];
}
free(cposlist);
}
}
UNPROTECT(3);
return result;
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_alg2cpos(SEXP inAttribute, SEXP inAlg)" --
*
*
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_alg2cpos(SEXP inAttribute, SEXP inAlg)
{
SEXP result = R_NilValue;
int alg, s1, s2, t1, t2;
char * a;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
if (!isVector(inAlg) || length(inAlg) != 1) error("argument 'alg' must be an integer");
PROTECT(inAttribute);
PROTECT(inAlg);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
alg = asInteger(inAlg);
if (alg == NA_INTEGER) {
UNPROTECT(2);
error("invalid 'alg' value (too large or NA)");
}
attribute = cqi_lookup_attribute(a, ATT_ALIGN);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
if (cl_alg2cpos(attribute, alg, &s1, &s2, &t1, &t2)) {
result = PROTECT(allocVector(INTSXP, 4));
INTEGER(result)[0] = s1;
INTEGER(result)[1] = s2;
INTEGER(result)[2] = t1;
INTEGER(result)[3] = t2;
} else {
rcqp_send_error();
}
}
UNPROTECT(3);
return result;
}
void CReactionInterface::printDebug() const
{
std::cout << "Reaction interface " << std::endl;
std::cout << " Function: " << getFunctionName() << std::endl;
std::cout << " ChemEq: " << getChemEqString() << std::endl;
size_t i, imax = size();
for (i = 0; i < imax; ++i)
{
std::cout << " --- " << i << ": " << getParameterName(i)
<< ", vector: " << isVector(i) << " local: " << isLocalValue(i)
<< ", value: " << mValues[i] << std::endl;
size_t j, jmax = mNameMap[i].size();
for (j = 0; j < jmax; ++j)
std::cout << " " << mNameMap[i][j] << std::endl;
}
std::cout << std::endl;
}
/**
* Retrieves the emission probabilities which either can be stored as list of vectors
* or as a list of matrices (time-dependent then).
*
* We assume that at least one element has been stored before.
*/
void cRUtil::GetEmissionSexp(SEXP theSEXP, uint theNum, std::vector<cDMatrix> &theList)
{
SEXP myAux = VECTOR_ELT(theSEXP, theNum) ;
uint nrow = theList.at(0).mNRow;
uint ncol = theList.at(0).mNCol;
uint i,j;
if (!isVector(myAux))
return;
if (!isMatrix(VECTOR_ELT(myAux,0)))
{
/* Parameter is a list of vectors, as the first elements is no matrix */
cDVector vec;
vec.ReAlloc(ncol);
for (i=0;i<nrow;i++)
{
GetVectSexp(myAux, i, vec);
for (j=0;j<ncol;j++)
theList.at(0)[i][j] = vec[j];
}
} else
{
/* Parameter is a list of matrices */
for (i=0;i<(uint)length(myAux);i++)
{
if (theList.size() <= i)
{
cDMatrix *mat = new cDMatrix(nrow,ncol,0.0);
theList.push_back(*mat);
}
GetMatSexp(myAux, i, theList.at(i) );
}
}
}
SEXP kz(SEXP x, SEXP window, SEXP iterations)
{
SEXP ans=R_NilValue, dim;
dim = getAttrib(x, R_DimSymbol);
if (isArray(x) && LENGTH(dim) >= 3) {
if (LENGTH(dim) > 3) {
error("Too many dimensions -- not yet implemented, please contact the author for more info.");
return(ans);
}
PROTECT(ans = kz3d(x, window, iterations));
UNPROTECT(1);
} else if (isMatrix(x)) {
PROTECT(ans = kz2d(x, window, iterations));
UNPROTECT(1);
} else if (isVector(x)) {
PROTECT(ans = kz1d(x, window, iterations));
UNPROTECT(1);
}
return(ans);
}
bool qvariant_into_vector(QVariant variant, SEXP v, int index) {
if (!isVector(v))
error("Setting vector element from QVariant: not a vector");
switch(TYPEOF(v)) {
case RAWSXP:
RAW(v)[index] = variant.value<unsigned char>();
break;
case LGLSXP:
LOGICAL(v)[index] = variant.value<bool>();
break;
case REALSXP:
REAL(v)[index] = variant.value<double>();
break;
case INTSXP:
{
SEXP levels;
if ((levels = getAttrib(v, R_LevelsSymbol)) != R_NilValue) {
QString qstr = variant.value<QString>();
int level = 0;
for (int i = 0; i < length(levels); i++)
if (qstr == CHAR(STRING_ELT(levels, i)))
level = i + 1;
if (level == 0)
return(false);
INTEGER(v)[index] = level;
} else INTEGER(v)[index] = variant.value<int>();
break;
}
case STRSXP:
SET_STRING_ELT(v, index, qstring2sexp(variant.value<QString>()));
break;
case VECSXP:
SET_VECTOR_ELT(v, index, to_sexp(variant));
break;
default:
error("Setting vector element from QVariant: unhandled vector type");
}
return(true);
}
ArrayData* SharedMap::loadElems(bool mapInit /* = false */) const {
uint count = size();
bool isVec = isVector();
auto ai =
mapInit ? ArrayInit(count, ArrayInit::mapInit) :
isVec ? ArrayInit(count, ArrayInit::vectorInit) :
ArrayInit(count);
if (isVec) {
for (uint i = 0; i < count; i++) {
ai.set(getValueRef(i));
}
} else {
for (uint i = 0; i < count; i++) {
ai.add(m_map->getKey(i), getValueRef(i),
true);
}
}
ArrayData* elems = ai.create();
if (elems->isStatic()) elems = elems->copy();
return elems;
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_struc2str(SEXP inAttribute, SEXP inIds)" --
*
* Function gets value of struc_num'th instance of the specified s-attribute.
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_struc2str(SEXP inAttribute, SEXP inIds)
{
SEXP result = R_NilValue;
int idx;
int len, i;
char *a, *str;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
PROTECT(inAttribute);
if (!isVector(inIds)) error("argument 'ids' must be a vector of integers");
PROTECT(inIds);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
len = length(inIds);
attribute = cqi_lookup_attribute(a, ATT_STRUC);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
result = PROTECT(allocVector(STRSXP, len));
for (i=0; i<len; i++) {
idx = INTEGER(inIds)[i];
str = cl_struc2str(attribute, idx);
/* Sends "" if str == NULL (cpos out of range) */
if (str != NULL) {
SET_STRING_ELT(result, i, mkChar(str));
}
}
}
UNPROTECT(3);
return result;
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_cpos2alg(SEXP inAttribute, SEXP inCpos)" --
*
*
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_cpos2alg(SEXP inAttribute, SEXP inCpos)
{
SEXP result = R_NilValue;
int cpos;
int len, i, alg;
char * a;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
PROTECT(inAttribute);
if (!isVector(inCpos)) error("argument 'cpos' must be a vector of integers");
PROTECT(inCpos);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
len = length(inCpos);
attribute = cqi_lookup_attribute(a, ATT_ALIGN);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
result = PROTECT(allocVector(INTSXP, len));
for (i=0; i<len; i++) {
cpos = INTEGER(inCpos)[i];
alg = cl_cpos2alg(attribute, cpos);
/* Return -1 if cpos is out of range */
if (alg < 0) alg = -1;
INTEGER(result)[i] = alg;
}
}
UNPROTECT(3);
return result;
}
/*
* ------------------------------------------------------------------------
*
* "rcqpCmd_id2freq(SEXP inAttribute, SEXP inIds)" --
*
*
*
* ------------------------------------------------------------------------
*/
SEXP rcqpCmd_id2freq(SEXP inAttribute, SEXP inIds)
{
SEXP result = R_NilValue;
int idx;
int len, i, f;
char *a;
Attribute * attribute;
if (!isString(inAttribute) || length(inAttribute) != 1) error("argument 'attribute' must be a string");
PROTECT(inAttribute);
if (!isVector(inIds)) error("argument 'ids' must be a vector of integers");
PROTECT(inIds);
a = (char*)CHAR(STRING_ELT(inAttribute,0));
len = length(inIds);
attribute = cqi_lookup_attribute(a, ATT_POS);
if (attribute == NULL) {
UNPROTECT(2);
rcqp_error_code(cqi_errno);
} else {
result = PROTECT(allocVector(INTSXP, len));
for (i=0; i<len; i++) {
idx = INTEGER(inIds)[i];
f = cl_id2freq(attribute, idx);
/* Return 0 if ID is out of range */
if (f < 0) f = 0;
INTEGER(result)[i] = f;
}
}
UNPROTECT(3);
return result;
}
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, dims, dimnames, indx, subs, x;
int i, ndims, nsubs;
int drop = 1, pok, exact = -1;
int named_x;
R_xlen_t offset = 0;
PROTECT(args);
ExtractDropArg(args, &drop);
/* Is partial matching ok? When the exact arg is NA, a warning is
issued if partial matching occurs.
*/
exact = ExtractExactArg(args);
if (exact == -1)
pok = exact;
else
pok = !exact;
x = CAR(args);
/* This code was intended for compatibility with S, */
/* but in fact S does not do this. Will anyone notice? */
if (x == R_NilValue) {
UNPROTECT(1); /* args */
return x;
}
/* Get the subscripting and dimensioning information */
/* and check that any array subscripting is compatible. */
subs = CDR(args);
if(0 == (nsubs = length(subs)))
errorcall(call, _("no index specified"));
dims = getAttrib(x, R_DimSymbol);
ndims = length(dims);
if(nsubs > 1 && nsubs != ndims)
errorcall(call, _("incorrect number of subscripts"));
/* code to allow classes to extend environment */
if(TYPEOF(x) == S4SXP) {
x = R_getS4DataSlot(x, ANYSXP);
if(x == R_NilValue)
errorcall(call, _("this S4 class is not subsettable"));
}
PROTECT(x);
/* split out ENVSXP for now */
if( TYPEOF(x) == ENVSXP ) {
if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 )
errorcall(call, _("wrong arguments for subsetting an environment"));
ans = findVarInFrame(x, installTrChar(STRING_ELT(CAR(subs), 0)));
if( TYPEOF(ans) == PROMSXP ) {
PROTECT(ans);
ans = eval(ans, R_GlobalEnv);
UNPROTECT(1); /* ans */
} else SET_NAMED(ans, 2);
UNPROTECT(2); /* args, x */
if(ans == R_UnboundValue)
return(R_NilValue);
if (NAMED(ans))
SET_NAMED(ans, 2);
return ans;
}
/* back to the regular program */
if (!(isVector(x) || isList(x) || isLanguage(x)))
errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */
if(nsubs == 1) { /* vector indexing */
SEXP thesub = CAR(subs);
int len = length(thesub);
if (len > 1) {
#ifdef SWITCH_TO_REFCNT
if (IS_GETTER_CALL(call)) {
/* this is (most likely) a getter call in a complex
assighment so we duplicate as needed. The original
x should have been duplicated if it might be
shared */
if (MAYBE_SHARED(x))
error("getter call used outside of a complex assignment.");
x = vectorIndex(x, thesub, 0, len-1, pok, call, TRUE);
}
else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#else
x = vectorIndex(x, thesub, 0, len-1, pok, call, FALSE);
#endif
named_x = NAMED(x);
UNPROTECT(1); /* x */
PROTECT(x);
}
SEXP xnames = PROTECT(getAttrib(x, R_NamesSymbol));
offset = get1index(thesub, xnames,
xlength(x), pok, len > 1 ? len-1 : -1, call);
UNPROTECT(1); /* xnames */
if (offset < 0 || offset >= xlength(x)) {
/* a bold attempt to get the same behaviour for $ and [[ */
if (offset < 0 && (isNewList(x) ||
isExpression(x) ||
isList(x) ||
isLanguage(x))) {
UNPROTECT(2); /* args, x */
return R_NilValue;
}
else errorcall(call, R_MSG_subs_o_b);
}
} else { /* matrix indexing */
/* Here we use the fact that: */
/* CAR(R_NilValue) = R_NilValue */
/* CDR(R_NilValue) = R_NilValue */
int ndn; /* Number of dimnames. Unlikely to be anything but
0 or nsubs, but just in case... */
PROTECT(indx = allocVector(INTSXP, nsubs));
dimnames = getAttrib(x, R_DimNamesSymbol);
ndn = length(dimnames);
for (i = 0; i < nsubs; i++) {
INTEGER(indx)[i] = (int)
get1index(CAR(subs),
(i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue,
INTEGER(indx)[i], pok, -1, call);
subs = CDR(subs);
if (INTEGER(indx)[i] < 0 ||
INTEGER(indx)[i] >= INTEGER(dims)[i])
errorcall(call, R_MSG_subs_o_b);
}
offset = 0;
for (i = (nsubs - 1); i > 0; i--)
offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1];
offset += INTEGER(indx)[0];
UNPROTECT(1); /* indx */
}
if(isPairList(x)) {
#ifdef LONG_VECTOR_SUPPORT
if (offset > R_SHORT_LEN_MAX)
error("invalid subscript for pairlist");
#endif
ans = CAR(nthcdr(x, (int) offset));
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else if(isVectorList(x)) {
/* did unconditional duplication before 2.4.0 */
ans = VECTOR_ELT(x, offset);
if (named_x > NAMED(ans))
SET_NAMED(ans, named_x);
} else {
ans = allocVector(TYPEOF(x), 1);
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(ans)[0] = INTEGER(x)[offset];
break;
case REALSXP:
REAL(ans)[0] = REAL(x)[offset];
break;
case CPLXSXP:
COMPLEX(ans)[0] = COMPLEX(x)[offset];
break;
case STRSXP:
SET_STRING_ELT(ans, 0, STRING_ELT(x, offset));
break;
case RAWSXP:
RAW(ans)[0] = RAW(x)[offset];
break;
default:
UNIMPLEMENTED_TYPE("do_subset2", x);
}
}
UNPROTECT(2); /* args, x */
return ans;
}
SEXP R_cpermdist2(SEXP score_a, SEXP score_b, SEXP m_a, SEXP m_b,
SEXP retProb) {
/*
compute the joint permutation distribution of the
sum of the first m_a elements of score_a and score_b
(usually score_a = rep(1, length(score_a)) and
score_b = Data scores, Wilcoxon, Ansari ...).
In this case the exact conditional distribution
in the simple independent two-sample problem is computed.
*/
int n, im_a, im_b; /* number of observations */
SEXP H, x; /* matrix of permutations and vector
of probabilities */
int i, j, k, sum_a = 0, sum_b = 0, s_a = 0, s_b = 0, isb;
double msum = 0.0; /* little helpers */
int *iscore_a, *iscore_b; /* pointers to R structures */
double *dH, *dx;
/* some basic checks, should be improved */
if (!isVector(score_a))
error("score_a is not a vector");
n = LENGTH(score_a);
if (!isVector(score_b))
error("score_b is not a vector");
if (LENGTH(score_b) != n)
error("length of score_a and score_b differ");
iscore_a = INTEGER(score_a);
iscore_b = INTEGER(score_b);
if (TYPEOF(retProb) != LGLSXP)
error("retProb is not a logical");
im_a = INTEGER(m_a)[0]; /* cosmetics only */
im_b = INTEGER(m_b)[0];
/* compute the total sum of the scores and check if they are >= 0 */
for (i = 0; i < n; i++) {
if (iscore_a[i] < 0)
error("score_a for observation number %d is negative", i);
if (iscore_b[i] < 0)
error("score_b for observation number %d is negative", i);
sum_a += iscore_a[i];
sum_b += iscore_b[i];
}
/*
optimization according to Streitberg & Roehmel
*/
sum_a = imin2(sum_a, im_a);
sum_b = imin2(sum_b, im_b);
/*
initialize H
*/
PROTECT(H = allocVector(REALSXP, (sum_a + 1) * (sum_b + 1)));
dH = REAL(H);
for (i = 0; i <= sum_a; i++) {
isb = i * (sum_b + 1);
for (j = 0; j <= sum_b; j++) dH[isb + j] = 0.0;
}
/*
start the Shift-Algorithm with H[0,0] = 1
*/
dH[0] = 1.0;
for (k = 0; k < n; k++) {
s_a += iscore_a[k];
s_b += iscore_b[k];
/*
compute H up to row im_aand column im_b
Note:
sum_a = min(sum_a, m)
sum_b = min(sum_b, c)
*/
for (i = imin2(im_a, s_a); i >= iscore_a[k]; i--) {
isb = i * (sum_b + 1);
for (j = imin2(im_b,s_b); j >= iscore_b[k]; j--)
dH[isb + j] +=
dH[(i - iscore_a[k]) * (sum_b + 1) + (j - iscore_b[k])];
}
}
/*
return the whole matrix H
Note: use matrix(H, nrow=m_a+1, byrow=TRUE) in R
*/
if (!LOGICAL(retProb)[0]) {
UNPROTECT(1);
return(H);
} else {
PROTECT(x = allocVector(REALSXP, sum_b));
dx = REAL(x);
/*
get the values for sample size im_a (in row m) and sum it up
*/
isb = im_a * (sum_b + 1);
for (j = 0; j < sum_b; j++) {
if (!R_FINITE(dH[isb + j + 1]))
error("overflow error; cannot compute exact distribution");
dx[j] = dH[isb + j + 1];
msum += dx[j];
}
if (!R_FINITE(msum) || msum == 0.0)
error("overflow error; cannot compute exact distribution");
/*
compute probabilities and return the density x to R
the support is min(score_b):sum(score_b)
[dpq] stuff is done in R
*/
for (j = 0; j < sum_b; j++)
dx[j] = dx[j]/msum;
UNPROTECT(2);
return(x);
}
}
SEXP RCatnetSearchP::estimate(SEXP rSamples, SEXP rPerturbations, SEXP rClasses, SEXP rClsdist,
SEXP rMaxParents, SEXP rParentSizes, SEXP rMaxComplexity, SEXP rOrder, SEXP rNodeCats,
SEXP rParentsPool, SEXP rFixedParentsPool, SEXP rMatEdgeLiks, SEXP rUseCache, SEXP rEcho) {
int i, ii, j, k, len, sampleline, bUseCache, maxParentSet, maxComplexity, numnets, inet, echo, klmode;
int *pRperturbations, *pPerturbations, *pNodeOffsets,
**parentsPool, **fixedParentsPool, *pPool, *pParentSizes,
hasClasses, *pRclasses, *pClasses;
double *pRsamples, *pSamples, *matEdgeLiks, *pMatEdgeLiks;
RCatnetP rcatnet;
SEXP dim, rnodecat, rparpool, cnetlist, cnetnode;
if(!isMatrix(rSamples))
error("Data is not a matrix");
Rprintf("RCatnetSearchP\n");
PROTECT(rMaxParents = AS_INTEGER(rMaxParents));
maxParentSet = INTEGER_POINTER(rMaxParents)[0];
UNPROTECT(1);
PROTECT(rMaxComplexity = AS_INTEGER(rMaxComplexity));
maxComplexity = INTEGER_POINTER(rMaxComplexity)[0];
UNPROTECT(1);
PROTECT(rUseCache = AS_LOGICAL(rUseCache));
bUseCache = LOGICAL(rUseCache)[0];
//Rprintf("bUseCache = %d\n", bUseCache);
UNPROTECT(1);
PROTECT(rEcho = AS_LOGICAL(rEcho));
echo = LOGICAL(rEcho)[0];
UNPROTECT(1);
klmode = 0;
PROTECT(rClsdist = AS_INTEGER(rClsdist));
klmode = INTEGER_POINTER(rClsdist)[0];
UNPROTECT(1);
hasClasses = 0;
if(!isNull(rClasses) && isInteger(rClasses))
hasClasses = 1;
dim = GET_DIM(rSamples);
sampleline = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
if(isNull(rNodeCats))
error("Node categories must be specified");
m_numNodes = length(rNodeCats);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = new SEARCH_PARAMETERS(
m_numNodes, m_numSamples,
maxParentSet, maxComplexity, echo,
!isNull(rNodeCats),
!isNull(rParentSizes), !isNull(rPerturbations),
!isNull(rParentsPool), !isNull(rFixedParentsPool),
!isNull(rMatEdgeLiks), 0,
NULL, this, sampleline, 0, hasClasses, klmode);
if (!m_pSearchParams) {
CATNET_MEM_ERR();
}
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if(m_pRorderInverse)
CATNET_FREE(m_pRorderInverse);
m_pRorderInverse = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!m_pRorder || !m_pRorderInverse) {
CATNET_MEM_ERR();
}
PROTECT(rOrder = AS_INTEGER(rOrder));
if(length(rOrder) < m_numNodes) {
warning("Invalid nodeOrder parameter - reset to default node order.");
for(i = 0; i < m_numNodes; i++)
m_pRorder[i] = i + 1;
}
else {
memcpy(m_pRorder, INTEGER(rOrder), m_numNodes*sizeof(int));
}
for(i = 0; i < m_numNodes; i++) {
if(m_pRorder[i] <= 0 || m_pRorder[i] > m_numNodes) {
error("Invalid nodeOrder parameter");
}
else
m_pRorderInverse[m_pRorder[i]-1] = i + 1;
}
UNPROTECT(1);
pNodeOffsets = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!pNodeOffsets) {
CATNET_MEM_ERR();
}
memset(pNodeOffsets, 0, m_numNodes*sizeof(int));
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, i));
len = length(rnodecat);
pNodeOffsets[i] = len;
if(i > 0)
pNodeOffsets[i] = pNodeOffsets[i-1] + len;
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (m_pSearchParams->m_pNodeCats[i]) {
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
}
for(i = m_numNodes - 1; i > 0; i--)
pNodeOffsets[i] = pNodeOffsets[i-1];
pNodeOffsets[0] = 0;
UNPROTECT(1);
if(!isNull(rParentSizes)) {
pParentSizes = m_pSearchParams->m_pParentSizes;
PROTECT(rParentSizes = AS_INTEGER(rParentSizes));
if(length(rParentSizes) == m_numNodes) {
for(i = 0; i < m_numNodes; i++)
pParentSizes[i] = INTEGER(rParentSizes)[m_pRorder[i] - 1];
}
UNPROTECT(1);
}
PROTECT(rSamples = AS_NUMERIC(rSamples));
pSamples = (double*)m_pSearchParams->m_pSamples;
pRsamples = REAL(rSamples);
if (pSamples && pRsamples) {
ii = 0;
for(i = 0; i < m_numNodes; i++) {
for(j = 0; j < m_numSamples; j++) {
memcpy(pSamples+j*sampleline + ii,
pRsamples+j*sampleline + pNodeOffsets[m_pRorder[i] - 1],
m_pSearchParams->m_pNodeNumCats[i]*sizeof(double));
if(R_IsNA(pSamples[j*sampleline + ii]) || pSamples[j*sampleline + ii] < 0) {
pSamples[j*sampleline + ii] = CATNET_NAN;
}
}
ii += m_pSearchParams->m_pNodeNumCats[i];
}
}
UNPROTECT(1); // rSamples
CATNET_FREE(pNodeOffsets);
pNodeOffsets = 0;
pPerturbations = 0;
if(!isNull(rPerturbations)) {
PROTECT(rPerturbations = AS_INTEGER(rPerturbations));
pPerturbations = m_pSearchParams->m_pPerturbations;
pRperturbations = INTEGER_POINTER(rPerturbations);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pPerturbations[j*m_numNodes + i] = pRperturbations[j*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(hasClasses) {
PROTECT(rClasses = AS_INTEGER(rClasses));
pClasses = (int*)m_pSearchParams->m_pClasses;
pRclasses = INTEGER(rClasses);
if (pClasses && pRclasses)
memcpy(pClasses, pRclasses, m_numSamples*sizeof(int));
UNPROTECT(1); // rClasses
}
parentsPool = 0;
if(!isNull(rParentsPool)) {
PROTECT(rParentsPool = AS_LIST(rParentsPool));
parentsPool = m_pSearchParams->m_parentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
parentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
pPool = INTEGER(rparpool);
if (parentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
parentsPool[i][j] = k;
else
parentsPool[i][j] = -1;
}
}
parentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
fixedParentsPool = 0;
if(!isNull(rFixedParentsPool)) {
PROTECT(rFixedParentsPool = AS_LIST(rFixedParentsPool));
fixedParentsPool = m_pSearchParams->m_fixedParentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rFixedParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
fixedParentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
if(maxParentSet < len)
maxParentSet = len;
pPool = INTEGER(rparpool);
if (fixedParentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
fixedParentsPool[i][j] = k;
else
fixedParentsPool[i][j] = -1;
}
}
}
fixedParentsPool[i][len] = -1;
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
if(!isNull(rMatEdgeLiks) && m_pSearchParams->m_matEdgeLiks) {
PROTECT(rMatEdgeLiks = AS_NUMERIC(rMatEdgeLiks));
matEdgeLiks = m_pSearchParams->m_matEdgeLiks;
pMatEdgeLiks = REAL(rMatEdgeLiks);
for(j = 0; j < m_numNodes; j++) {
for(i = 0; i < m_numNodes; i++) {
matEdgeLiks[j*m_numNodes + i] = pMatEdgeLiks[(m_pRorder[j] - 1)*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(bUseCache)
setCacheParams(m_numNodes, maxParentSet, m_pRorder, m_pRorderInverse);
search(m_pSearchParams);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = 0;
if(!m_nCatnets || !m_pCatnets) {
warning("No networks are found");
return R_NilValue;
}
// create a R-list of catNetworks
numnets = 0;
for(i = 0; i < m_nCatnets; i++) {
if(m_pCatnets[i]) {
m_pCatnets[i]->setNodesOrder(m_pRorder);
numnets++;
}
}
PROTECT(cnetlist = allocVector(VECSXP, numnets));
inet = 0;
for(i = 0; i < m_nCatnets; i++) {
if(!m_pCatnets[i])
continue;
rcatnet = *m_pCatnets[i];
PROTECT(cnetnode = rcatnet.genRcatnet("catNetwork"));
SET_VECTOR_ELT(cnetlist, inet, cnetnode);
UNPROTECT(1);
inet++;
}
UNPROTECT(1);
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = 0;
if(m_pRorderInverse)
CATNET_FREE(m_pRorderInverse);
m_pRorderInverse = 0;
Rprintf("estimate exit");
return cnetlist;
}
//
// Recursively generate mangled names.
//
void TType::buildMangledName(TString& mangledName) const
{
if (isMatrix())
mangledName += 'm';
else if (isVector())
mangledName += 'v';
switch (basicType) {
case EbtFloat: mangledName += 'f'; break;
case EbtDouble: mangledName += 'd'; break;
#ifdef AMD_EXTENSIONS
case EbtFloat16: mangledName += "f16"; break;
#endif
case EbtInt: mangledName += 'i'; break;
case EbtUint: mangledName += 'u'; break;
case EbtInt64: mangledName += "i64"; break;
case EbtUint64: mangledName += "u64"; break;
#ifdef AMD_EXTENSIONS
case EbtInt16: mangledName += "i16"; break;
case EbtUint16: mangledName += "u16"; break;
#endif
case EbtBool: mangledName += 'b'; break;
case EbtAtomicUint: mangledName += "au"; break;
case EbtSampler:
switch (sampler.type) {
case EbtInt: mangledName += "i"; break;
case EbtUint: mangledName += "u"; break;
default: break; // some compilers want this
}
if (sampler.image)
mangledName += "I"; // a normal image
else if (sampler.sampler)
mangledName += "p"; // a "pure" sampler
else if (!sampler.combined)
mangledName += "t"; // a "pure" texture
else
mangledName += "s"; // traditional combined sampler
if (sampler.arrayed)
mangledName += "A";
if (sampler.shadow)
mangledName += "S";
if (sampler.external)
mangledName += "E";
switch (sampler.dim) {
case Esd1D: mangledName += "1"; break;
case Esd2D: mangledName += "2"; break;
case Esd3D: mangledName += "3"; break;
case EsdCube: mangledName += "C"; break;
case EsdRect: mangledName += "R2"; break;
case EsdBuffer: mangledName += "B"; break;
case EsdSubpass: mangledName += "P"; break;
default: break; // some compilers want this
}
switch (sampler.vectorSize) {
case 1: mangledName += "1"; break;
case 2: mangledName += "2"; break;
case 3: mangledName += "3"; break;
case 4: break; // default to prior name mangle behavior
}
if (sampler.ms)
mangledName += "M";
break;
case EbtStruct:
case EbtBlock:
if (basicType == EbtStruct)
mangledName += "struct-";
else
mangledName += "block-";
if (typeName)
mangledName += *typeName;
for (unsigned int i = 0; i < structure->size(); ++i) {
mangledName += '-';
(*structure)[i].type->buildMangledName(mangledName);
}
default:
break;
}
if (getVectorSize() > 0)
mangledName += static_cast<char>('0' + getVectorSize());
else {
mangledName += static_cast<char>('0' + getMatrixCols());
mangledName += static_cast<char>('0' + getMatrixRows());
}
if (arraySizes) {
const int maxSize = 11;
char buf[maxSize];
for (int i = 0; i < arraySizes->getNumDims(); ++i) {
if (arraySizes->getDimNode(i)) {
if (arraySizes->getDimNode(i)->getAsSymbolNode())
snprintf(buf, maxSize, "s%d", arraySizes->getDimNode(i)->getAsSymbolNode()->getId());
else
snprintf(buf, maxSize, "s%p", arraySizes->getDimNode(i));
} else
snprintf(buf, maxSize, "%d", arraySizes->getDimSize(i));
mangledName += '[';
mangledName += buf;
mangledName += ']';
}
}
}
SEXP RDagSearch::estimate(SEXP rSamples, SEXP rPerturbations, SEXP rClasses, SEXP rClsdist,
SEXP rMaxParents, SEXP rParentSizes, SEXP rMaxComplexity, SEXP rOrder, SEXP rNodeCats,
SEXP rParentsPool, SEXP rFixedParentsPool, SEXP rMatEdgeLiks, SEXP rUseCache, SEXP rEcho, int bIntSample = 0) {
int i, j, k, len, maxParentSet, maxCategories, maxComplexity, bEqualCategories, node, echo, klmode;
int *pRperturbations, *pPerturbations, **parentsPool, **fixedParentsPool, *pPool, *pParentSizes;
double *matEdgeLiks, *pMatEdgeLiks;
SEXP dim, rnodecat, rparpool;
int sampleline, *pNodeOffsets;
int *pRsamples, *pSamples;
double *pfRsamples, *pfSamples;
DAG_LIST<double, int> *pDagList;
int hasClasses, *pRclasses, *pClasses;
if(!isMatrix(rSamples))
error("Data is not a matrix");
PROTECT(rMaxParents = AS_INTEGER(rMaxParents));
maxParentSet = INTEGER_POINTER(rMaxParents)[0];
UNPROTECT(1);
PROTECT(rMaxComplexity = AS_INTEGER(rMaxComplexity));
maxComplexity = INTEGER_POINTER(rMaxComplexity)[0];
UNPROTECT(1);
PROTECT(rEcho = AS_LOGICAL(rEcho));
echo = LOGICAL(rEcho)[0];
UNPROTECT(1);
klmode = 0;
PROTECT(rClsdist = AS_INTEGER(rClsdist));
klmode = INTEGER_POINTER(rClsdist)[0];
UNPROTECT(1);
hasClasses = 0;
if(!isNull(rClasses) && isInteger(rClasses))
hasClasses = 1;
sampleline = 0;
if(bIntSample) {
dim = GET_DIM(rSamples);
m_numNodes = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
}
else {
dim = GET_DIM(rSamples);
sampleline = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
if(isNull(rNodeCats))
error("Node categories must be specified");
m_numNodes = length(rNodeCats);
}
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!m_pRorder) {
CATNET_MEM_ERR();
}
PROTECT(rOrder = AS_INTEGER(rOrder));
if(length(rOrder) < m_numNodes) {
warning("Invalid nodeOrder parameter - reset to default node order.");
for(i = 0; i < m_numNodes; i++)
m_pRorder[i] = i + 1;
}
else {
memcpy(m_pRorder, INTEGER(rOrder), m_numNodes*sizeof(int));
}
UNPROTECT(1);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = new SEARCH_PARAMETERS(
m_numNodes, m_numSamples,
maxParentSet, maxComplexity, echo,
!isNull(rNodeCats),
!isNull(rParentSizes), !isNull(rPerturbations),
!isNull(rParentsPool), !isNull(rFixedParentsPool),
!isNull(rMatEdgeLiks), 0,
NULL, this, sampleline, 0, hasClasses, klmode);
if (!m_pSearchParams) {
CATNET_MEM_ERR();
}
pPerturbations = 0;
if(!isNull(rPerturbations)) {
PROTECT(rPerturbations = AS_INTEGER(rPerturbations));
pPerturbations = m_pSearchParams->m_pPerturbations;
pRperturbations = INTEGER_POINTER(rPerturbations);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pPerturbations[j*m_numNodes + i] = pRperturbations[j*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(hasClasses) {
pClasses = (int*)m_pSearchParams->m_pClasses;
PROTECT(rClasses = AS_INTEGER(rClasses));
pRclasses = INTEGER(rClasses);
memcpy(pClasses, pRclasses, m_numSamples*sizeof(int));
UNPROTECT(1); // rClasses
}
parentsPool = 0;
if(!isNull(rParentsPool)) {
PROTECT(rParentsPool = AS_LIST(rParentsPool));
parentsPool = m_pSearchParams->m_parentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
parentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
pPool = INTEGER(rparpool);
if (parentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
parentsPool[i][j] = k;
else
parentsPool[i][j] = -1;
}
}
parentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
fixedParentsPool = 0;
if(!isNull(rFixedParentsPool)) {
PROTECT(rFixedParentsPool = AS_LIST(rFixedParentsPool));
fixedParentsPool = m_pSearchParams->m_fixedParentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rFixedParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
fixedParentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
if(maxParentSet < len)
maxParentSet = len;
pPool = INTEGER(rparpool);
if (fixedParentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
fixedParentsPool[i][j] = k;
else
fixedParentsPool[i][j] = -1;
}
}
fixedParentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
if(!isNull(rMatEdgeLiks) && m_pSearchParams->m_matEdgeLiks) {
PROTECT(rMatEdgeLiks = AS_NUMERIC(rMatEdgeLiks));
matEdgeLiks = m_pSearchParams->m_matEdgeLiks;
pMatEdgeLiks = REAL(rMatEdgeLiks);
for(j = 0; j < m_numNodes; j++) {
for(i = 0; i < m_numNodes; i++) {
matEdgeLiks[j*m_numNodes + i] = pMatEdgeLiks[(m_pRorder[j] - 1)*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(!isNull(rParentSizes)) {
pParentSizes = m_pSearchParams->m_pParentSizes;
PROTECT(rParentSizes = AS_INTEGER(rParentSizes));
if(length(rParentSizes) == m_numNodes) {
for(i = 0; i < m_numNodes; i++)
pParentSizes[i] = INTEGER(rParentSizes)[m_pRorder[i] - 1];
}
UNPROTECT(1);
}
pDagList = 0;
if(bIntSample) {
PROTECT(rSamples = AS_INTEGER(rSamples));
pSamples = (int*)m_pSearchParams->m_pSamples;
pRsamples = INTEGER(rSamples);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pSamples[j*m_numNodes + i] = pRsamples[j*m_numNodes + m_pRorder[i] - 1];
if(R_IsNA(pSamples[j*m_numNodes + i]) || pSamples[j*m_numNodes + i] < 1) {
pSamples[j*m_numNodes + i] = CATNET_NAN;
}
}
}
UNPROTECT(1); // rSamples
maxCategories = 0;
if(!isNull(rNodeCats)) {
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (!m_pSearchParams->m_pNodeCats[i]) {
CATNET_MEM_ERR();
}
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
UNPROTECT(1);
}
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 1, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 1, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 2, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 2, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 3, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 3, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 4, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 4, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGD_SEARCH_DC<double, int, int, 1>; break;
case 2:
pDagList = new DAGD_SEARCH_DC<double, int, int, 2>; break;
case 3:
pDagList = new DAGD_SEARCH_DC<double, int, int, 3>; break;
case 4:
pDagList = new DAGD_SEARCH_DC<double, int, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
else /* !bIntSample */ {
pNodeOffsets = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!pNodeOffsets) {
CATNET_MEM_ERR();
}
memset(pNodeOffsets, 0, m_numNodes*sizeof(int));
maxCategories = 0;
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
//rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, i));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
pNodeOffsets[i] = len;
if(i > 0)
pNodeOffsets[i] = pNodeOffsets[i-1] + len;
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (m_pSearchParams->m_pNodeCats[i]) {
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
}
for(i = m_numNodes - 1; i > 0; i--)
pNodeOffsets[i] = pNodeOffsets[i-1];
pNodeOffsets[0] = 0;
UNPROTECT(1);
PROTECT(rSamples = AS_NUMERIC(rSamples));
pfSamples = (double*)m_pSearchParams->m_pSamples;
pfRsamples = REAL(rSamples);
int ii = 0;
if (pfSamples && pfRsamples) {
for(i = 0; i < m_numNodes; i++) {
for(j = 0; j < m_numSamples; j++) {
memcpy(pfSamples+j*sampleline + ii,
pfRsamples+j*sampleline + pNodeOffsets[m_pRorder[i] - 1],
m_pSearchParams->m_pNodeNumCats[i]*sizeof(double));
if(R_IsNA(pfSamples[j*sampleline + ii]) || pfSamples[j*sampleline + ii] < 0) {
pfSamples[j*sampleline + ii] = CATNET_NAN;
}
}
ii += m_pSearchParams->m_pNodeNumCats[i];
}
}
UNPROTECT(1); // rSamples
CATNET_FREE(pNodeOffsets);
pNodeOffsets = 0;
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 1, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 1, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 2, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 2, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 3, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 3, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 4, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 4, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGP_SEARCH_DC<double, int, 1>; break;
case 2:
pDagList = new DAGP_SEARCH_DC<double, int, 2>; break;
case 3:
pDagList = new DAGP_SEARCH_DC<double, int, 3>; break;
case 4:
pDagList = new DAGP_SEARCH_DC<double, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
if(!pDagList)
CATNET_MEM_ERR();
pDagList->search(m_pSearchParams);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = 0;
if(!pDagList->m_dagPars || pDagList->m_numDags < 1) {
warning("No networks are found");
return R_NilValue;
}
int *pn;
SEXP plist, pint, ppars, pLoglik, pComplx;
SEXP daglist = PROTECT(NEW_OBJECT(MAKE_CLASS("dagEvaluate")));
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numNodes;
SET_SLOT(daglist, install("numnodes"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numSamples;
SET_SLOT(daglist, install("numsamples"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxCategories;
SET_SLOT(daglist, install("maxcats"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxParentSet;
SET_SLOT(daglist, install("maxpars"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSlots[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]/*maxParentSet*/*maxParentSet));
pn = INTEGER_POINTER(ppars);
for(j = 0; j < pDagList->m_numParSlots[k]/*maxParentSet*/; j++) {
i = 0;
while(i < maxParentSet && pDagList->m_parSlots[k][j*maxParentSet+i] >= 0) {
pn[j*maxParentSet+i] =
m_pRorder[pDagList->m_parSlots[k][j*maxParentSet+i]];
i++;
}
for(; i < maxParentSet; i++)
pn[j*maxParentSet+i] = 0;
}
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSlots"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parLogliks[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_NUMERIC(pDagList->m_numParSlots[k]));
memcpy(NUMERIC_POINTER(ppars), pDagList->m_parLogliks[k], pDagList->m_numParSlots[k]*sizeof(double));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parLogliks"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parComplx[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parComplx[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parComplx"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSampleSize[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parSampleSize[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSampleSize"), plist);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = pDagList->m_numDags;
SET_SLOT(daglist, install("numDags"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, pDagList->m_numDags));
PROTECT(pLoglik = NEW_NUMERIC(pDagList->m_numDags));
PROTECT(pComplx = NEW_INTEGER(pDagList->m_numDags));
DAG_PARS<double> *pDags = pDagList->m_dagPars;
char *pParBuff = (char*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int *pIntBuff = (int*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int nParBuff;
if (!pParBuff || !pIntBuff) {
CATNET_MEM_ERR();
}
for(k = 0; k < pDagList->m_numDags && pDags; k++) {
NUMERIC_POINTER(pLoglik)[k] = pDags->loglik;
INTEGER_POINTER(pComplx)[k] = pDags->complx;
if(pDags->numPars == 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = m_numNodes;
if(pDags->compressNumPars(pIntBuff, pParBuff, nParBuff, m_pRorder) <= 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = 1 + (int)((nParBuff*sizeof(char))/sizeof(int));
PROTECT(ppars = NEW_INTEGER(nParBuff));
memcpy(INTEGER_POINTER(ppars), pParBuff, nParBuff*sizeof(int));
SET_VECTOR_ELT(plist, k, ppars);
UNPROTECT(1);
pDags = pDags->next;
}
CATNET_FREE(pParBuff);
CATNET_FREE(pIntBuff);
SET_SLOT(daglist, install("numPars"), plist);
SET_SLOT(daglist, install("loglik"), pLoglik);
SET_SLOT(daglist, install("complx"), pComplx);
UNPROTECT(3);
UNPROTECT(1); // cnet
delete pDagList;
pDagList = 0;
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = 0;
return daglist;
}
bool SharedMap::exists(const StringData* k) const {
if (isVector()) return false;
return m_map->indexOf(k) != -1;
}
ssize_t SharedMap::getIndex(const StringData* k) const {
if (isVector()) return -1;
return m_map->indexOf(k);
}
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()*/
/* This is a special .Internal */
SEXP attribute_hidden do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP R_fcall, ans, names = R_NilValue, rowNames = R_NilValue,
X, XX, FUN, value, dim_v;
R_xlen_t i, n;
int commonLen;
int useNames, rnk_v = -1; // = array_rank(value) := length(dim(value))
Rboolean array_value;
SEXPTYPE commonType;
PROTECT_INDEX index = 0; /* initialize to avoid a warning */
checkArity(op, args);
PROTECT(X = CAR(args));
PROTECT(XX = eval(CAR(args), rho));
FUN = CADR(args); /* must be unevaluated for use in e.g. bquote */
PROTECT(value = eval(CADDR(args), rho));
if (!isVector(value)) error(_("'FUN.VALUE' must be a vector"));
useNames = asLogical(eval(CADDDR(args), rho));
if (useNames == NA_LOGICAL) error(_("invalid '%s' value"), "USE.NAMES");
n = xlength(XX);
if (n == NA_INTEGER) error(_("invalid length"));
Rboolean realIndx = n > INT_MAX;
commonLen = length(value);
if (commonLen > 1 && n > INT_MAX)
error(_("long vectors are not supported for matrix/array results"));
commonType = TYPEOF(value);
// check once here
if (commonType != CPLXSXP && commonType != REALSXP &&
commonType != INTSXP && commonType != LGLSXP &&
commonType != RAWSXP && commonType != STRSXP &&
commonType != VECSXP)
error(_("type '%s' is not supported"), type2char(commonType));
dim_v = getAttrib(value, R_DimSymbol);
array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1);
PROTECT(ans = allocVector(commonType, n*commonLen));
if (useNames) {
PROTECT(names = getAttrib(XX, R_NamesSymbol));
if (isNull(names) && TYPEOF(XX) == STRSXP) {
UNPROTECT(1);
PROTECT(names = XX);
}
PROTECT_WITH_INDEX(rowNames = getAttrib(value,
array_value ? R_DimNamesSymbol
: R_NamesSymbol),
&index);
}
/* The R level code has ensured that XX is a vector.
If it is atomic we can speed things up slightly by
using the evaluated version.
*/
{
SEXP ind, tmp;
/* Build call: FUN(XX[[<ind>]], ...) */
SEXP isym = install("i");
PROTECT(ind = allocVector(realIndx ? REALSXP : INTSXP, 1));
defineVar(isym, ind, rho);
SET_NAMED(ind, 1);
/* Notice that it is OK to have one arg to LCONS do memory
allocation and not PROTECT the result (LCONS does memory
protection of its args internally), but not both of them,
since the computation of one may destroy the other */
PROTECT(tmp = LCONS(R_Bracket2Symbol,
LCONS(X, LCONS(isym, R_NilValue))));
PROTECT(R_fcall = LCONS(FUN,
LCONS(tmp, LCONS(R_DotsSymbol, R_NilValue))));
int common_len_offset = 0;
for(i = 0; i < n; i++) {
SEXP val; SEXPTYPE valType;
PROTECT_INDEX indx;
if (realIndx) REAL(ind)[0] = (double)(i + 1);
else INTEGER(ind)[0] = (int)(i + 1);
val = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(val))
val = lazy_duplicate(val); // Need to duplicate? Copying again anyway
PROTECT_WITH_INDEX(val, &indx);
if (length(val) != commonLen)
error(_("values must be length %d,\n but FUN(X[[%d]]) result is length %d"),
commonLen, i+1, length(val));
valType = TYPEOF(val);
if (valType != commonType) {
Rboolean okay = FALSE;
switch (commonType) {
case CPLXSXP: okay = (valType == REALSXP) || (valType == INTSXP)
|| (valType == LGLSXP); break;
case REALSXP: okay = (valType == INTSXP) || (valType == LGLSXP); break;
case INTSXP: okay = (valType == LGLSXP); break;
}
if (!okay)
error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"),
type2char(commonType), i+1, type2char(valType));
REPROTECT(val = coerceVector(val, commonType), indx);
}
/* Take row names from the first result only */
if (i == 0 && useNames && isNull(rowNames))
REPROTECT(rowNames = getAttrib(val,
array_value ? R_DimNamesSymbol : R_NamesSymbol),
index);
// two cases - only for efficiency
if(commonLen == 1) { // common case
switch (commonType) {
case CPLXSXP: COMPLEX(ans)[i] = COMPLEX(val)[0]; break;
case REALSXP: REAL(ans) [i] = REAL (val)[0]; break;
case INTSXP: INTEGER(ans)[i] = INTEGER(val)[0]; break;
case LGLSXP: LOGICAL(ans)[i] = LOGICAL(val)[0]; break;
case RAWSXP: RAW(ans) [i] = RAW (val)[0]; break;
case STRSXP: SET_STRING_ELT(ans, i, STRING_ELT(val, 0)); break;
case VECSXP: SET_VECTOR_ELT(ans, i, VECTOR_ELT(val, 0)); break;
}
} else { // commonLen > 1 (typically, or == 0) :
switch (commonType) {
case REALSXP:
memcpy(REAL(ans) + common_len_offset,
REAL(val), commonLen * sizeof(double)); break;
case INTSXP:
memcpy(INTEGER(ans) + common_len_offset,
INTEGER(val), commonLen * sizeof(int)); break;
case LGLSXP:
memcpy(LOGICAL(ans) + common_len_offset,
LOGICAL(val), commonLen * sizeof(int)); break;
case RAWSXP:
memcpy(RAW(ans) + common_len_offset,
RAW(val), commonLen * sizeof(Rbyte)); break;
case CPLXSXP:
memcpy(COMPLEX(ans) + common_len_offset,
COMPLEX(val), commonLen * sizeof(Rcomplex)); break;
case STRSXP:
for (int j = 0; j < commonLen; j++)
SET_STRING_ELT(ans, common_len_offset + j, STRING_ELT(val, j));
break;
case VECSXP:
for (int j = 0; j < commonLen; j++)
SET_VECTOR_ELT(ans, common_len_offset + j, VECTOR_ELT(val, j));
break;
}
common_len_offset += commonLen;
}
UNPROTECT(1);
}
UNPROTECT(3);
}
if (commonLen != 1) {
SEXP dim;
rnk_v = array_value ? LENGTH(dim_v) : 1;
PROTECT(dim = allocVector(INTSXP, rnk_v+1));
if(array_value)
for(int j = 0; j < rnk_v; j++)
INTEGER(dim)[j] = INTEGER(dim_v)[j];
else
INTEGER(dim)[0] = commonLen;
INTEGER(dim)[rnk_v] = (int) n; // checked above
setAttrib(ans, R_DimSymbol, dim);
UNPROTECT(1);
}
if (useNames) {
if (commonLen == 1) {
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
} else {
if (!isNull(names) || !isNull(rowNames)) {
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, rnk_v+1));
if(array_value && !isNull(rowNames)) {
if(TYPEOF(rowNames) != VECSXP || LENGTH(rowNames) != rnk_v)
// should never happen ..
error(_("dimnames(<value>) is neither NULL nor list of length %d"),
rnk_v);
for(int j = 0; j < rnk_v; j++)
SET_VECTOR_ELT(dimnames, j, VECTOR_ELT(rowNames, j));
} else
SET_VECTOR_ELT(dimnames, 0, rowNames);
SET_VECTOR_ELT(dimnames, rnk_v, names);
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(1);
}
}
}
UNPROTECT(useNames ? 6 : 4); /* X, XX, value, ans, and maybe names and rowNames */
return ans;
}