/**
* [N]ot [E]qual (x, y) <==> x "!=" y
* where the NA/NaN and "-0." / "+0." cases treatment depend on 'str'.
*
* @param x
* @param y the two "number"s to be compared
* @param str a "strictness" indicator, one of 2*2 (one|bit)_NA__num_(eq|bit)
* "SINGLE_NA" means: x and y differ in the case
* that one, but not both are NaN. Two NaN values are judged
* identical for this purpose, but NA != NaN
*
* "NUM_EQ" means: (x != y) is used when both are not NA or NaN
* whereas "bit_NA" and "num_bit" use the bitwise memory comparison memcmp();
* notably "*_num_bit" will differentiate '+0.' and '-0.'.
*
* @return FALSE or TRUE indicating if x or y differ
*/
static Rboolean neWithNaN(double x, double y, ne_strictness_type str)
{
switch (str) {
case single_NA__num_eq:
case single_NA__num_bit:
if(R_IsNA(x))
return(R_IsNA(y) ? FALSE : TRUE);
if(R_IsNA(y))
return(R_IsNA(x) ? FALSE : TRUE);
if(ISNAN(x))
return(ISNAN(y) ? FALSE : TRUE);
case bit_NA__num_eq:
case bit_NA__num_bit:
; /* do nothing */
}
switch (str) {
case single_NA__num_eq:
return(x != y);
case bit_NA__num_eq:
if(!ISNAN(x) && !ISNAN(y))
return(x != y);
else /* bitwise check for NA/NaN's */
return memcmp((const void *) &x,
(const void *) &y, sizeof(double)) ? TRUE : FALSE;
case bit_NA__num_bit:
case single_NA__num_bit:
return memcmp((const void *) &x,
(const void *) &y, sizeof(double)) ? TRUE : FALSE;
default: /* Wall */
return FALSE;
}
}
SEXP encode_(SEXP sWhat, SEXP sMinLen) {
int np = 1, min_len = asInteger(sMinLen);
R_xlen_t i, n = XLENGTH(sWhat);
if (min_len > 22) Rf_error("invalid min.length, cannot exceed 22");
SEXP res = PROTECT(allocVector(STRSXP, n));
if (TYPEOF(sWhat) == INTSXP) {
int *d = INTEGER(sWhat);
for (i = 0; i < n; i++)
if (d[i] != NA_INTEGER)
SET_STRING_ELT(res, i, mkChar(encode_num((uint64_t)d[i], min_len)));
} else {
if (TYPEOF(sWhat) != REALSXP) {
sWhat = PROTECT(coerceVector(sWhat, REALSXP));
np++;
}
if (n != XLENGTH(sWhat))
Rf_error("coresion to numeric has changed the length");
double *d = REAL(sWhat);
for (i = 0; i < n; i++)
if (!R_IsNA(d[i]))
SET_STRING_ELT(res, i, mkChar(encode_num((uint64_t)d[i], min_len)));
}
UNPROTECT(np);
return res;
}
static
double set_rcond_sy(SEXP obj, char *typstr)
{
char typnm[] = {'\0', '\0'};
SEXP rcv = GET_SLOT(obj, Matrix_rcondSym);
double rcond;
typnm[0] = rcond_type(typstr);
rcond = get_double_by_name(rcv, typnm);
if (R_IsNA(rcond)) {
SEXP trf = dsyMatrix_trf(obj);
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym)), info;
double anorm = get_norm_sy(obj, "O");
F77_CALL(dsycon)(uplo_P(trf), dims,
REAL (GET_SLOT(trf, Matrix_xSym)), dims,
INTEGER(GET_SLOT(trf, Matrix_permSym)),
&anorm, &rcond,
(double *) R_alloc(2*dims[0], sizeof(double)),
(int *) R_alloc(dims[0], sizeof(int)), &info);
SET_SLOT(obj, Matrix_rcondSym,
set_double_by_name(rcv, rcond, typnm));
}
return rcond;
}
void MedianHLCircularPropRad(double *x,int *n,int *whichMethod,double *prop,double *result)
{
int nTotal;
int cond;
switch(*whichMethod)
{
//HL2
case 0:
nTotal = *n *((*n+1))/2;
cond = 0;
break;
//HL1
case 1:
nTotal = *n *((*n-1))/2;
cond = 1;
break;
//HL3
case 2:
nTotal = *n * (*n);
cond = 0;
break;
default:
nTotal = 1;
cond = 0;
break;
}
nTotal = fmax(1,round(nTotal*(*prop)));
if(nTotal>1)
{
int size=2;
int allIndex[(*n)];
double meanOfPair[nTotal];
double dataRnd[2];
int i,k=0;
for(i=0;i<nTotal;i++)
{
(cond==1)?sampleNoReplace(x,(*n),dataRnd,size,allIndex):sampleReplace(x,(*n),dataRnd,size);
MeanCircularRad(dataRnd,&size,&meanOfPair[k]);
if(R_IsNA(meanOfPair[k])==0)
{k++;}
}
int a = 0;
double tmp[(*n)];
MedianCircularRad(x,n,result,tmp,&a);
}
else
{
*result=x[0];
}
}
void MedianHLCircularRad(double *x,double *y,int *n,int *whichMethod,double *result)
{
int nTotal;
int cond;
switch(*whichMethod)
{
//HL2
case 0:
nTotal = *n *((*n+1))/2;
cond = 1;
break;
//HL1
case 1:
nTotal = *n *((*n-1))/2;
cond = 1;
break;
//HL3
case 2:
nTotal = *n * (*n);
cond = 0;
break;
default:
nTotal = 1;
cond = 0;
break;
}
int i,j;
int k=0;
double tempV[2];
double meanOfPair[nTotal];
int sizeTempv = 2;
int condI = (cond)?(*n - (*whichMethod)):(*n);
int initJ;
for (i=0;i<condI;i++)
{
initJ = (cond)?(i+(*whichMethod)):(0);
for (j=initJ;j<(*n);j++)
{
tempV[0] = x[i];
tempV[1] = y[j];
MeanCircularRad(tempV,&sizeTempv,&meanOfPair[k]);
if(R_IsNA(meanOfPair[k])==0)
{k++;}
}
}
int a = 0;
double tmp[(*n)];
MedianCircularRad(x,n,result,tmp,&a);
}
static double R_fun(double x, void *data){
mh_str *da = data ;
SEXP R_x, s ;
PROTECT_INDEX ipx;
PROTECT(R_x = allocVector(REALSXP, 1));
REAL(R_x)[0] = x ;
SETCADR(da->R_fcall, R_x); /* assign the argument */
/* evaluate function calls */
PROTECT_WITH_INDEX(s = eval(da->R_fcall, da->R_env), &ipx);
REPROTECT(s = coerceVector(s, REALSXP), ipx);
if (LENGTH(s) != 1)
error(("objective function evaluates to length %d not 1"), LENGTH(s));
if (!R_FINITE(REAL(s)[0]) || R_IsNaN(REAL(s)[0]) || R_IsNA(REAL(s)[0]))
error("objective funtion evaluates to Inf, NaN or NA");
UNPROTECT(2);
return REAL(s)[0];
}
//[[Rcpp::export]]
Rcpp::NumericVector getRange(Rcpp::NumericVector x, const bool na_rm) {
Rcpp::NumericVector out(2);
out[0] = R_PosInf;
out[1] = R_NegInf;
int n = x.length();
for(int i = 0; i < n; ++i) {
if (!na_rm && R_IsNA(x[i])) {
out[0] = NA_REAL;
out[1] = NA_REAL;
return(out);
}
if (x[i] < out[0]) out[0] = x[i];
if (x[i] > out[1]) out[1] = x[i];
}
return(out);
}
SEXP broom(SEXP d, SEXP f, SEXP dm, SEXP dist, SEXP dw) {
R_len_t i, j, r;
SEXP dis;
int n, nr, nc, down;
double *xd, *xdis, *xf;
double dx, dy, dxy;
dx = REAL(dist)[0];
dy = REAL(dist)[1];
dxy = REAL(dist)[2];
down = INTEGER(dw)[0];
int leftright = 2; //INTEGER(lr)[0];
nr = INTEGER(dm)[0];
nc = INTEGER(dm)[1];
n = nr * nc;
// Rprintf ("n = %i \n", n);
PROTECT(d = coerceVector(d, REALSXP));
PROTECT(f = coerceVector(f, REALSXP));
xd = REAL(d);
xf = REAL(f);
PROTECT( dis = allocVector(REALSXP, n) );
xdis = REAL(dis);
for (i=0; i<n; i++) {
xdis[i] = R_PosInf;
}
if (down) {
//left to right
//r = 0; first row, no row above it, use 'f'
if (leftright >= 1) {
//i = 0; first cell, no cell left of it
if ( R_IsNA(xd[0])) {
xdis[0] = xf[0] + dy;
} else {
xdis[0] = 0;
}
// other cells
for (i=1; i<nc; i++) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(xf[i] + dy, xf[i-1] + dxy), xdis[i-1] + dx);
} else {
xdis[i] = 0;
}
}
//other rows
for (r=1; r<nr; r++) {
i=r*nc;
if (R_IsNA(xd[i])) {
xdis[i] = xdis[i-nc] + dy;
} else {
xdis[i] = 0;
}
for (i=r*nc+1; i<((r+1)*nc); i++) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(xdis[i-1] + dx, xdis[i-nc] + dy), xdis[i-nc-1] + dxy);
} else {
xdis[i] = 0;
}
}
}
}
//right to left
//first row
//first cell
if ((leftright == 0) | (leftright > 1)) {
if ( R_IsNA(xd[nc-1])) {
xdis[nc-1] = min(xdis[nc-1], xf[nc-1] + dy);
} else {
xdis[nc-1] = 0;
}
// other cells
for (i=(nc-2); i > -1; i--) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(min(xdis[i], xf[i] + dy), xf[i+1] + dxy), xdis[i+1] + dx);
} else {
xdis[i] = 0;
}
}
// other rows
for (r=1; r<nr; r++) {
i=(r+1)*nc-1;
if (R_IsNA(xd[i])) {
xdis[i] = min(xdis[i], xdis[i-nc] + dy);
} else {
xdis[i] = 0;
}
for (i=(r+1)*nc-2; i>(r*nc-1); i--) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(min(xdis[i], xdis[i+1] + dx), xdis[i-nc] + dy), xdis[i-nc+1] + dxy);
} else {
xdis[i] = 0;
}
}
}
}
} else {
// bottom to top
// left to right
// first (last) row
if (leftright >= 1) {
r = nr-1;
// first cell
i = r*nc;
if (R_IsNA(xd[i])) {
xdis[i] = min(xdis[i], xf[0] + dy);
} else {
xdis[i] = 0;
}
// other cells
for (i=(r*nc+1); i<n; i++) {
if (R_IsNA(xd[i])) {
j = i - r*nc;
xdis[i] = min(min(min(xdis[i], xf[j] + dy), xf[j-1] + dxy), xdis[i-1] + dx);
} else {
xdis[i] = 0;
}
}
// other rows
for (r=nr-2; r >= 0; r--) {
i=r*nc;
if (R_IsNA(xd[i])) {
xdis[i] = min(xdis[i], xdis[i+nc] + dy);
} else {
xdis[i] = 0;
}
for (i=(r*nc+1); i<((r+1)*nc); i++) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(min(xdis[i], xdis[i-1] + dx), xdis[i+nc] + dy), xdis[i+nc-1] + dxy);
} else {
xdis[i] = 0;
}
}
}
}
if ((leftright == 0) | (leftright > 1)) {
// right to left
// first row
// first cell
if (R_IsNA(xd[n-1])) {
xdis[n-1] = min(xdis[n-1], xf[nc-1] + dy);
} else {
xdis[n-1] = 0;
}
// other cells
r = nr-1;
for (i=n-2; i > (r*nc-1); i--) {
if (R_IsNA(xd[i])) {
j = i - r*nc;
xdis[i] = min(min(min(xdis[i], xf[j] + dx), xf[j+1] + dxy), xdis[i+1] + dx);
} else {
xdis[i] = 0;
}
}
// other rows
for (r=nr-2; r >= 0; r--) {
i=(r+1)*nc-1;
if (R_IsNA(xd[i])) {
xdis[i] = min(xdis[i], xdis[i+nc] + dy);
} else {
xdis[i] = 0;
}
for (i=(r+1)*nc-2; i>(r*nc-1); i--) {
if (R_IsNA(xd[i])) {
xdis[i] = min(min(min(xdis[i], xdis[i+1] + dx), xdis[i+nc] + dy), xdis[i+nc+1] + dxy);
} else {
xdis[i] = 0;
}
}
}
}
}
UNPROTECT(3);
return(dis);
}
bool to_json(SEXP sexp, js::value& result) {
int type = TYPEOF(sexp);
switch (type) {
case NILSXP:
result = js::value();
return true;
case VECSXP: {
SEXP names = Rf_getAttrib(sexp, R_NamesSymbol);
if (Rf_isNull(names)) {
result = js::value(js::array());
list_to_array(sexp, result.get<js::array>());
} else {
result = js::value(js::object());
list_to_object(sexp, names, result.get<js::object>());
}
return true;
}
case ENVSXP:
result = js::value(js::object());
env_to_object(sexp, result.get<js::object>());
return true;
}
if (Rf_length(sexp) == 0) {
result = js::value();
return true;
}
switch (type) {
case LGLSXP: {
at_most_one(sexp);
int x = *LOGICAL(sexp);
result = x == R_NaInt ? js::value() : js::value(x != 0);
break;
}
case INTSXP: {
at_most_one(sexp);
int x = *INTEGER(sexp);
result = x == R_NaInt ? js::value() : js::value(static_cast<double>(x));
break;
}
case REALSXP: {
at_most_one(sexp);
double x = *REAL(sexp);
if (R_IsNA(x)) {
result = js::value();
} else {
if (isinf(x) || isnan(x)) {
json_error(sexp, "+Inf, -Inf and NaN cannot be serialized.");
}
result = js::value(x);
}
break;
}
case STRSXP: {
at_most_one(sexp);
SEXP x = STRING_ELT(sexp, 0);
if (x == R_NaString) {
result = js::value();
} else {
std::string s;
result = strsxp_to_utf8(x, s) ? js::value(s) : js::value();
}
break;
}
default:
json_error(sexp, "Unsupported type - must be one of: NULL; logical, integer, real, character vector; list; environment.");
}
return result != js::value();
}
bool isNA(Type x){
return R_IsNA(asDouble(x));
}
SEXP terrain(SEXP d, SEXP dim, SEXP res, SEXP un, SEXP opt, SEXP lonlat, SEXP geoy) {
R_len_t i, j;
SEXP val;
int nrow, ncol, n, unit, *option;
double *xd, *xval, dx, dy, *gy, *ddx;
double zy, zx;
PROTECT(d = coerceVector(d, REALSXP));
PROTECT(opt = coerceVector(opt, INTSXP));
nrow = INTEGER(dim)[0];
ncol = INTEGER(dim)[1];
n = nrow * ncol;
unit = INTEGER(un)[0];
dx = REAL(res)[0];
dy = REAL(res)[1];
option = INTEGER(opt);
int nopt = 0;
for (i =0; i<8; i++) {
nopt += option[i];
}
int geo = INTEGER(lonlat)[0];
PROTECT(geoy = coerceVector(geoy, REALSXP));
gy = REAL(geoy);
if (geo) {
double r = 6378137;
ddx=(double *) malloc(nrow*sizeof(double));
for (i=0; i<nrow; i++) {
ddx[i] = distHav(-dx, gy[i], dx, gy[i], r) / 2 ;
}
} else {
// to avoid a warning about ddx perhaps not being initialized
ddx=(double *) malloc(sizeof(double));
ddx[0] = 1;
}
PROTECT( val = allocVector(REALSXP, n*nopt) );
xd = REAL(d);
xval = REAL(val);
int add=0;
int addn=0;
if (option[0]) {
// terrain ruggedness
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i] = (fabs(xd[i-1-ncol]-xd[i]) + fabs(xd[i-1]-xd[i]) + fabs(xd[i-1+ncol]-xd[i]) + fabs(xd[i-ncol]-xd[i]) +
fabs(xd[i+ncol]-xd[i]) + fabs(xd[i+1-ncol]-xd[i]) + fabs(xd[i+1]-xd[i]) + fabs(xd[i+1+ncol]-xd[i])) / 8;
}
add++;
}
if (option[1]) {
addn = add * n;
// topograhic position
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = xd[i] - (xd[i-1-ncol] + xd[i-1] + xd[i-1+ncol] + xd[i-ncol]
+ xd[i+ncol] + xd[i+1-ncol] + xd[i+1] + xd[i+1+ncol]) / 8;
}
add++;
}
if (option[2]) {
// roughness
addn = add * n;
int a[9] = { -1-ncol, -1, -1+ncol, -ncol, 0, ncol, 1-ncol, 1, 1+ncol };
double min, max, v;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
min = xd[i + a[0]];
max = xd[i + a[0]];
for (j = 1; j < 9; j++) {
v = xd[i + a[j]];
if (v > max) {
max = v;
} else if (v < min) {
min = v;
}
}
xval[i+addn] = max - min;
}
add++;
}
if (option[3]) {
// slope 4 neighbors
addn = add * n;
if (geo) {
int k, q;
double xwi[2] = {-1,1};
double xw[2] = {0,0};
double yw[2] = {-1,1};
for (i=0; i<2; i++) {
yw[i] = yw[i] / (2 * dy);
}
for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
if (i % ncol == 0) {
q = i / ncol;
for (k=0; k<2; k++) {
xw[k] = xwi[k] / (-2 * ddx[q]);
}
}
zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) ) ;
}
} else {
double xw[2] = {-1,1};
double yw[2] = {-1,1};
for (i=0; i<2; i++) {
xw[i] = xw[i] / (-2 * dx);
yw[i] = yw[i] / (2 * dy);
}
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) );
}
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = atan(xval[i+addn]) * adj;
}
} else if (unit == 1) {
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = atan(xval[i+addn]);
}
}
add++;
}
if (option[4]) {
// aspect 4 neighbors
addn = add * n;
if (geo) {
int k, q;
double xwi[2] = {-1,1};
double xw[2] = {0,0};
double yw[2] = {-1,1};
for (i=0; i<2; i++) {
yw[i] = yw[i] / (2 * dy);
}
for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
if (i % ncol == 0) {
q = i / ncol;
for (k=0; k<2; k++) {
xw[k] = xwi[k] / (-2 * ddx[q]);
}
}
zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
zx = atan2(zy, zx);
xval[i+addn] = mod( M_PI_2 - zx, M_2PI);
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = xval[i+addn] * adj;
}
}
} else {
double xw[2] = {-1,1};
double yw[2] = {-1,1};
for (i=0; i<2; i++) {
xw[i] = xw[i] / (-2 * dx);
yw[i] = yw[i] / (2 * dy);
}
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
zx = xd[i-1] * xw[0] + xd[i+1] * xw[1];
zy = xd[i-ncol] * yw[0] + xd[i+ncol] * yw[1];
zx = atan2(zy, zx);
xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = xval[i+addn] * adj;
}
}
}
add++;
}
if (option[5]) {
// slope 8 neighbors
addn = add * n;
if (geo) {
int k, q;
double xwi[6] = {-1,-2,-1,1,2,1};
double xw[6] = {0,0,0,0,0,0};
double yw[6] = {-1,1,-2,2,-1,1};
for (i=0; i<6; i++) {
yw[i] = yw[i] / (8 * dy);
}
for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
if (i % ncol == 0) {
q = i / ncol;
for (k=0; k<6; k++) {
xw[k] = xwi[k] / (8 * ddx[q]);
}
}
zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) );
}
} else {
double xw[6] = {-1,-2,-1,1,2,1};
double yw[6] = {-1,1,-2,2,-1,1};
for (i=0; i<6; i++) {
xw[i] = xw[i] / (-8 * dx);
yw[i] = yw[i] / (8 * dy);
}
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
xval[i+addn] = sqrt( pow(zy, 2) + pow(zx, 2) );
}
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = atan(xval[i+addn]) * adj;
}
} else if (unit == 1) {
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = atan(xval[i+addn]);
}
}
add++;
}
if (option[6]) {
// aspect 8 neighbors
addn = add * n;
if (geo) {
int k, q;
double xwi[6] = {-1,-2,-1,1,2,1};
double xw[6] = {0,0,0,0,0,0};
double yw[6] = {-1,1,-2,2,-1,1};
for (i=0; i<6; i++) {
yw[i] = yw[i] / (8 * dy);
}
for (i = ncol; i < (ncol * (nrow-1)-1); i++) {
if (i % ncol == 0) {
q = i / ncol;
for (k=0; k<6; k++) {
xw[k] = xwi[k] / (-8 * ddx[q]);
}
}
zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
zx = atan2(zy, zx);
xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = xval[i+addn] * adj;
}
}
} else {
double xw[6] = {-1,-2,-1,1,2,1};
double yw[6] = {-1,1,-2,2,-1,1};
for (i=0; i<6; i++) {
xw[i] = xw[i] / (-8 * dx);
yw[i] = yw[i] / (8 * dy);
}
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
zx = xd[i-1-ncol] * xw[0] + xd[i-1] * xw[1] + xd[i-1+ncol] * xw[2]
+ xd[i+1-ncol] * xw[3] + xd[i+1] * xw[4] + xd[i+1+ncol] * xw[5];
zy = xd[i-1-ncol] * yw[0] + xd[i-1+ncol] * yw[1] + xd[i-ncol] * yw[2]
+ xd[i+ncol] * yw[3] + xd[i+1-ncol] * yw[4] + xd[i+1+ncol] * yw[5];
zx = atan2(zy, zx);
xval[i+addn] = mod( M_PI_2 -zx, M_2PI);
}
if (unit == 0) {
double adj = 180 / M_PI;
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
xval[i+addn] = xval[i+addn] * adj;
}
}
}
add++;
} if (option[7]) {
// flow direction
addn = add * n;
int v;
double d[8] = {0,0,0,0,0,0,0,0};
double p[8] = {1,2,4,8,16,32,64,128}; // pow(2, j)
double dxy = sqrt(dx * dx + dy * dy);
double dmin;
GetRNGstate();
for (i = ncol+1; i < (ncol * (nrow-1)-1); i++) {
if (R_IsNA(xd[i])) {
xval[i+addn] = R_NaReal;
} else {
d[0] = (xd[i] - xd[i+1]) / dx;
d[1] = (xd[i] - xd[i+1+ncol]) / dxy;
d[2] = (xd[i] - xd[i+ncol]) / dy;
d[3] = (xd[i] - xd[i-1+ncol]) / dxy;
d[4] = (xd[i] - xd[i-1]) / dx;
d[5] = (xd[i] - xd[i-1-ncol]) / dxy;
d[6] = (xd[i] - xd[i-ncol]) / dy;
d[7] = (xd[i] - xd[i+1-ncol]) / dxy;
// using the lowest neighbor, even if it is higher than the focal cell.
dmin = d[0];
v = 0;
for (j=1; j<8; j++) {
if (d[j] > dmin) {
dmin = d[j];
v = j;
} else if (d[j] == dmin) {
if (unif_rand() > 0.5) {
dmin = d[j];
v = j;
}
}
}
xval[i+addn] = p[v];
}
}
PutRNGstate();
add++;
}
// Set edges to NA
// first row
for (j=0; j<add; j++) {
int jn = j * n;
for (i = 0; i < ncol; i++) {
xval[i+jn] = R_NaReal;
}
// last row
for (i = ncol * (nrow-1); i < n; i++) {
xval[i+jn] = R_NaReal;
}
// first and last columns
for (i = 1; i < nrow; i++) {
xval[i * ncol + jn] = R_NaReal;
xval[i * ncol - 1 + jn] = R_NaReal;
}
}
free(ddx);
UNPROTECT(4);
return(val);
}
SEXP v_elsa_vector(SEXP v, SEXP nb, SEXP nclass) {
int nProtected=0;
int ncl, n, a, q, ngb;
double e, w, s, qq, count,xi;
R_len_t i, j, c;
SEXP ans;
double *xans, *xv;
ncl=INTEGER(nclass)[0];
n=length(v);
PROTECT(v = coerceVector(v, REALSXP));
++nProtected;
PROTECT(ans = allocVector(REALSXP, n));
++nProtected;
xans=REAL(ans);
xv=REAL(v);
for (c=0;c < n;c++) {
R_CheckUserInterrupt();
xi=xv[c];
if (!R_IsNA(xi)) {
ngb = length(VECTOR_ELT(nb,c));
double xn[ngb+1];
q=-1;
for (i=0;i < ngb;i++) {
a=xv[INTEGER_POINTER(VECTOR_ELT(nb,c))[i] - 1];
if (!R_IsNA(a)) {
q+=1;
xn[i]=a;
}
}
q+=1;
xn[q]=xi;
// sort
for (i=0;i <= (q-1);i++) {
for (j=i+1;j <= q;j++) {
if (xn[i] > xn[j]) {
a=xn[i];
xn[i]=xn[j];
xn[j]=a;
}
}
}
//------
a=xn[0];
count=1;
e=0;
qq=q+1;
for (i=1;i <= q;i++) {
if (xn[i] != a) {
e = e + ((count / qq) * log2(count / qq));
a=xn[i];
count=1;
} else {
count+=1;
}
}
e = e + ((count / qq) * log2(count / qq));
w=0;
for (i=0; i <= q;i++) {
w = w + fabs(xn[i] - xi);
}
w = w / ((qq - 1) * (ncl - 1));
if (qq > ncl) {
s = log2(ncl);
} else {
s = log2(qq);
}
xans[c] = (-e * w) / s;
} else {
xans[c]=R_NaReal;
}
}
UNPROTECT(nProtected);
return(ans);
}
SEXP elsa(SEXP v, SEXP nc, SEXP nr, SEXP nclass, SEXP rr, SEXP cc) {
int nProtected=0;
int c, row, col, ngb, q, nnr, nnc, nrow, ncol, cellnr, ncl, n;
double e, w, s, xi, qq, count, a;
R_len_t i, j;
SEXP ans;
PROTECT(ans = NEW_LIST(2));
++nProtected;
int *xrr, *xcc;
double *xv;
nrow=INTEGER(nr)[0];
ncol=INTEGER(nc)[0];
ncl=INTEGER(nclass)[0];
n=length(v);
SET_VECTOR_ELT(ans, 0, NEW_NUMERIC(n));
SET_VECTOR_ELT(ans, 1, NEW_NUMERIC(n));
PROTECT(v = coerceVector(v, REALSXP));
++nProtected;
PROTECT(rr = coerceVector(rr, INTSXP));
++nProtected;
PROTECT(cc = coerceVector(cc, INTSXP));
++nProtected;
ngb=length(rr);
xv=REAL(v);
xrr=INTEGER(rr);
xcc=INTEGER(cc);
for (c=0;c < n;c++) {
R_CheckUserInterrupt();
xi=xv[c];
if (!R_IsNA(xi)) {
row = (c / ncol) + 1;
col = (c + 1) - ((row - 1) * ncol);
double xn[ngb];
q=-1;
for (i=0; i < ngb; i++) {
nnr= row + xrr[i];
nnc = col + xcc[i];
if ((nnr > 0) & (nnr <= nrow) & (nnc > 0) & (nnc <= ncol)) {
cellnr = ((nnr - 1) * ncol) + nnc;
if (!R_IsNA(xv[(cellnr-1)])) {
q+=1;
xn[q]=xv[(cellnr-1)];
}
}
}
// sort
for (i=0;i <= (q-1);i++) {
for (j=i+1;j <= q;j++) {
if (xn[i] > xn[j]) {
a=xn[i];
xn[i]=xn[j];
xn[j]=a;
}
}
}
//------
a=xn[0];
count=1;
e=0;
qq=q+1;
for (i=1;i <= q;i++) {
if (xn[i] != a) {
e = e + ((count / qq) * log2(count / qq));
a=xn[i];
count=1;
} else {
count+=1;
}
}
e = e + ((count / qq) * log2(count / qq));
w=0;
for (i=0; i <= q;i++) {
w = w + fabs(xn[i] - xi);
}
w = w / ((qq - 1) * (ncl - 1));
if (qq > ncl) {
s = log2(ncl);
} else {
s = log2(qq);
}
NUMERIC_POINTER(VECTOR_ELT(ans, 0))[c] = -e / s;
//xans[c] = (-e * w) / s;
NUMERIC_POINTER(VECTOR_ELT(ans, 1))[c] = w;
} else {
//xans[c]=R_NaReal;
NUMERIC_POINTER(VECTOR_ELT(ans, 0))[c] = R_NaReal;
NUMERIC_POINTER(VECTOR_ELT(ans, 1))[c] = R_NaReal;
}
}
UNPROTECT(nProtected);
return(ans);
}
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;
}
SEXP v_elsa_cell(SEXP v, SEXP nc, SEXP nr, SEXP nclass, SEXP rr, SEXP cc, SEXP cells) {
int nProtected=0;
int c, row, col, ngb, q, nnr, nnc, nrow, ncol, cellnr, ncl, n, cn;
double e, w, s, xi, qq, a, count;
R_len_t i, j;
SEXP ans;
double *xans, *xv;
int *xrr, *xcc, *xcells;
nrow=INTEGER(nr)[0];
ncol=INTEGER(nc)[0];
ncl=INTEGER(nclass)[0];
n=length(cells);
PROTECT(v = coerceVector(v, REALSXP));
++nProtected;
PROTECT(ans = allocVector(REALSXP, n));
++nProtected;
PROTECT(rr = coerceVector(rr, INTSXP));
++nProtected;
PROTECT(cc = coerceVector(cc, INTSXP));
++nProtected;
PROTECT(cells = coerceVector(cells, INTSXP));
++nProtected;
ngb=length(rr);
xans=REAL(ans);
xv=REAL(v);
xrr=INTEGER(rr);
xcc=INTEGER(cc);
xcells=INTEGER(cells);
for (c=0;c < n;c++) {
R_CheckUserInterrupt();
cn=xcells[c]-1;
xi=xv[cn];
if (!R_IsNA(xi)) {
row = (cn / ncol) + 1;
col = (cn + 1) - ((row - 1) * ncol);
double xn[ngb];
q=-1;
for (i=0; i < ngb; i++) {
nnr= row + xrr[i];
nnc = col + xcc[i];
if ((nnr > 0) & (nnr <= nrow) & (nnc > 0) & (nnc <= ncol)) {
cellnr = ((nnr - 1) * ncol) + nnc;
if (!R_IsNA(xv[(cellnr-1)])) {
q+=1;
xn[q]=xv[(cellnr-1)];
}
}
}
// sort
for (i=0;i <= (q-1);i++) {
for (j=i+1;j <= q;j++) {
if (xn[i] > xn[j]) {
a=xn[i];
xn[i]=xn[j];
xn[j]=a;
}
}
}
//------
a=xn[0];
count=1;
e=0;
qq=q+1;
for (i=1;i <= q;i++) {
if (xn[i] != a) {
e = e + ((count / qq) * log2(count / qq));
a=xn[i];
count=1;
} else {
count+=1;
}
}
e = e + ((count / qq) * log2(count / qq));
w=0;
for (i=0; i <= q;i++) {
w = w + fabs(xn[i] - xi);
}
w = w / ((qq - 1) * (ncl - 1));
if (qq > ncl) {
s = log2(ncl);
} else {
s = log2(qq);
}
xans[c] = (-e * w) / s;
} else {
xans[c]=R_NaReal;
}
}
UNPROTECT(nProtected);
return(ans);
}
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;
}
inline bool IsNA<double>::operator()(const double& t) const
{
return R_IsNA(t);
}
