SEXP CBinIt2(MatrixType x, index_type nr, SEXP pcols,
SEXP B1addr, SEXP B2addr)
{
index_type i, j, k;
double *pB1 = NUMERIC_DATA(B1addr);
double *pB2 = NUMERIC_DATA(B2addr);
double min1 = pB1[0];
double min2 = pB2[0];
double max1 = pB1[1];
double max2 = pB2[1];
index_type nbins1 = (index_type) pB1[2];
index_type nbins2 = (index_type) pB2[2];
double *cols = NUMERIC_DATA(pcols);
index_type col1 = (index_type) cols[0] - 1;
index_type col2 = (index_type) cols[1] - 1;
int good;
T *pc1 = x[col1];
T *pc2 = x[col2];
SEXP Rret;
Rret = PROTECT(NEW_NUMERIC(nbins1*nbins2));
double *ret = NUMERIC_DATA(Rret);
for (i=0; i<nbins1; i++) {
for (j=0; j<nbins2; j++) {
ret[j*nbins1+i] = 0.0;
}
}
for (k=0; k<nr; k++) {
if ( !isna(pc1[k]) && !isna(pc2[k]) ){
good = 1;
if ( (((double)pc1[k])>=min1) && (((double)pc1[k])<=max1) ) {
i = (index_type) ( nbins1 * (((double)pc1[k])-min1) / (max1-min1) );
if (i==nbins1) i--;
} else { good = 0; }
if ( (((double)pc2[k])>=min2) & (((double)pc2[k])<=max2) ) {
j = (index_type) ( nbins2 * (((double)pc2[k])-min2) / (max2-min2) );
if (j==nbins2) j--;
} else { good = 0; }
if (good == 1) {
ret[j*nbins1+i]++;
}
} // End only do work in there isn't an NA value
} // End looping over all rows.
UNPROTECT(1);
return(Rret);
}
Rboolean tmean(T *x, index_type n, double *value, Rboolean narm, T NA_VALUE)
{
LDOUBLE s = 0.0;
index_type i;
Rboolean updated = (Rboolean)TRUE;
std::size_t naCount=0;
for (i = 0; i < n; i++) {
if (!isna(static_cast<T>(x[i])))
{
s += x[i];
}
else if (!narm) {
*value = NA_REAL;
return(updated);
}
else
{
++naCount;
}
}
if (n-naCount > 0) s /= (LDOUBLE)(n-naCount);
else s = NA_REAL;
*value = (double) s;
return(updated);
}
Rboolean tprod(T *x, int n, double *value, Rboolean narm, T NA_VALUE)
{
LDOUBLE s = NA_REAL;
bool firstVal=false;
index_type i;
Rboolean updated = (Rboolean)FALSE;
for (i = 0; i < n; i++) {
if (!isna(static_cast<T>(x[i]))) {
if (!firstVal)
{
s = x[i];
firstVal=true;
}
else s *= x[i];
if(!updated) updated = (Rboolean)TRUE;
}
else if (!narm) {
if(!updated) updated = (Rboolean)TRUE;
*value = NA_REAL;
return(updated);
}
}
*value = s;
return(updated);
}
Rboolean tsum(T *x, index_type n, double *value, Rboolean narm, T NA_VALUE)
{
LDOUBLE s = NA_REAL;
index_type i;
Rboolean updated = (Rboolean)TRUE;
bool firstValue=false;
for (i = 0; i < n; i++) {
if (!isna(static_cast<T>(x[i]))) {
if (!firstValue)
{
s = x[i];
firstValue=true;
}
else s += x[i];
} else if (!narm) {
*value = NA_REAL;
return(updated);
}
}
// Note the change from the standard isum, always returning double now.
*value = s;
return(updated);
}
SEXP CBinIt1(MatrixType x, index_type nr, SEXP pcol, SEXP Baddr)
{
index_type i, k;
double *pB = NUMERIC_DATA(Baddr);
double min = pB[0];
double max = pB[1];
index_type nbins = (index_type) pB[2];
index_type col = (index_type) NUMERIC_VALUE(pcol) - 1;
int good;
T *pc = x[col];
SEXP Rret;
Rret = PROTECT(NEW_NUMERIC(nbins));
double *ret = NUMERIC_DATA(Rret);
for (i=0; i<nbins; i++) {
ret[i] = 0.0;
}
for (k=0; k<nr; k++) {
if ( !isna(pc[k]) ){
good = 1;
if ( (((double)pc[k])>=min) && (((double)pc[k])<=max) ) {
i = (index_type) ( nbins * (((double)pc[k])-min) / (max-min) );
if (i==(index_type)nbins) i--;
} else { good = 0; }
if (good == 1) {
ret[i]++;
}
} // End only do work in there isn't an NA value
} // End looping over all rows.
UNPROTECT(1);
return(Rret);
}
Rboolean tmax(T *x, index_type n, int *value, Rboolean narm, T NA_VALUE)
{
index_type i;
int s = NA_INTEGER/* -Wall */;
bool firstVal = false;
Rboolean updated = (Rboolean)TRUE;
for (i = 0; i < n; i++) {
if (!isna(static_cast<T>(x[i]))) {
if (!updated || s < x[i] || !firstVal) {
s = x[i];
if(!updated) updated = (Rboolean)TRUE;
if (!firstVal) firstVal=true;
}
} else if (!narm) {
*value = NA_INTEGER;
return((Rboolean)TRUE);
}
}
*value = s;
return(updated);
}
Rboolean tvar(T *x, index_type n, double *value, Rboolean narm, T NA_VALUE)
{
if (n < 1)
{
*value = NA_REAL;
return (Rboolean)TRUE;
}
tmean(x, n, value, narm, NA_VALUE);
double avg = *value;
index_type i;
Rboolean updated = (Rboolean)TRUE;
index_type naCount=0;
double sum=0.0;
T addNum;
for (i=0; i < n; ++i) {
addNum = static_cast<T>(x[i]);
if (isna(addNum)) {
if ( (Rboolean)narm == TRUE )
{
++naCount;
}
else
{
*value = NA_REAL;
return updated;
}
}
else
{
sum += (static_cast<double>(addNum) - avg) *
(static_cast<double>(addNum) - avg);
}
}
if (n-naCount > 1) *value = sum/((double)(n-naCount)-1.0);
else *value = NA_REAL;
return(updated);
}
SEXP
RS_PostgreSQL_CopyInDataframe(Con_Handle * conHandle, SEXP x, SEXP nrow, SEXP ncol)
{
S_EVALUATOR RS_DBI_connection * con;
int nr, nc, i, j;
const char *cna ="\\N", *tmp=NULL /* -Wall */;
char cdec = '.';
PGconn *my_connection;
int pqretcode;
nr = asInteger(nrow);
nc = asInteger(ncol);
const int buff_threshold = 8000;
con = RS_DBI_getConnection(conHandle);
my_connection = (PGconn *) con->drvConnection;
if(isVectorList(x)) { /* A data frame */
R_StringBuffer rstrbuf = {NULL, 0, 10000};
char *strBuf = Calloc(buff_threshold * 2 + 2, char); /* + 2 for '\t' or '\n' plus '\0'*/
char *strendp = strBuf;
SEXP *levels;
*strendp = '\0';
R_AllocStringBuffer(10000, &rstrbuf);
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
SEXP xj;
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
for(j = 0; j < nc; j++) {
SEXP xj;
xj = VECTOR_ELT(x, j);
if(j > 0){
*strendp++ = '\t';/*need no size count check here*/
}
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We cannot assume factors have integer levels */
if(TYPEOF(xj) == INTSXP){
tmp = EncodeElementS(levels[j], INTEGER(xj)[i] - 1,
&rstrbuf, cdec);
}else if(TYPEOF(xj) == REALSXP){
tmp = EncodeElementS(levels[j], REAL(xj)[i] - 1,
&rstrbuf, cdec);
}else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElementS(xj, i,
&rstrbuf, cdec);
}
}
{
size_t n;
size_t len = strendp - strBuf;
n = strlen(tmp);
if (len + n < buff_threshold){
memcpy(strendp, tmp, n);/* we already know the length */
strendp += n;
}else if(n < buff_threshold){ /*copy and flush*/
memcpy(strendp, tmp, n);/* we already know the length */
pqretcode = PQputCopyData(my_connection, strBuf, len + n);
chkpqcopydataerr(my_connection, pqretcode);
strendp = strBuf;
}else{ /*flush and copy current*/
if(len > 0){
pqretcode = PQputCopyData(my_connection, strBuf, len);
chkpqcopydataerr(my_connection, pqretcode);
strendp = strBuf;
}
pqretcode = PQputCopyData(my_connection, tmp, n);
chkpqcopydataerr(my_connection, pqretcode);
}
}
}
*strendp = '\n'; strendp +=1; *strendp='\0';
}
pqretcode = PQputCopyData(my_connection, strBuf, strendp - strBuf);
chkpqcopydataerr(my_connection, pqretcode);
Free(strBuf);
R_FreeStringBuffer(&rstrbuf);
}
PQputCopyEnd(my_connection, NULL);
return R_NilValue;
}
SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP x, sep, rnames, eol, na, dec, quote, xj;
int nr, nc, i, j, qmethod;
Rboolean wasopen, quote_rn = FALSE, *quote_col;
Rconnection con;
const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */;
char cdec;
SEXP *levels;
R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE};
wt_info wi;
RCNTXT cntxt;
args = CDR(args);
x = CAR(args); args = CDR(args);
/* this is going to be a connection open or openable for writing */
if(!inherits(CAR(args), "connection"))
error(_("'file' is not a connection"));
con = getConnection(asInteger(CAR(args))); args = CDR(args);
if(!con->canwrite)
error(_("cannot write to this connection"));
wasopen = con->isopen;
if(!wasopen) {
strcpy(con->mode, "wt");
if(!con->open(con)) error(_("cannot open the connection"));
}
nr = asInteger(CAR(args)); args = CDR(args);
nc = asInteger(CAR(args)); args = CDR(args);
rnames = CAR(args); args = CDR(args);
sep = CAR(args); args = CDR(args);
eol = CAR(args); args = CDR(args);
na = CAR(args); args = CDR(args);
dec = CAR(args); args = CDR(args);
quote = CAR(args); args = CDR(args);
qmethod = asLogical(CAR(args));
if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr");
if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc");
if(!isNull(rnames) && !isString(rnames))
error(_("invalid '%s' argument"), "rnames");
if(!isString(sep)) error(_("invalid '%s' argument"), "sep");
if(!isString(eol)) error(_("invalid '%s' argument"), "eol");
if(!isString(na)) error(_("invalid '%s' argument"), "na");
if(!isString(dec)) error(_("invalid '%s' argument"), "dec");
if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod");
csep = translateChar(STRING_ELT(sep, 0));
ceol = translateChar(STRING_ELT(eol, 0));
cna = translateChar(STRING_ELT(na, 0));
sdec = translateChar(STRING_ELT(dec, 0));
if(strlen(sdec) != 1)
error(_("'dec' must be a single character"));
cdec = sdec[0];
quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean));
for(j = 0; j < nc; j++) quote_col[j] = FALSE;
for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */
int this = INTEGER(quote)[i];
if(this == 0) quote_rn = TRUE;
if(this > 0) quote_col[this - 1] = TRUE;
}
R_AllocStringBuffer(0, &strBuf);
PrintDefaults();
wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */
wi.con = con;
wi.wasopen = wasopen;
wi.buf = &strBuf;
begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv,
R_NilValue, R_NilValue);
cntxt.cend = &wt_cleanup;
cntxt.cenddata = &wi;
if(isVectorList(x)) { /* A data frame */
/* handle factors internally, check integrity */
levels = (SEXP *) R_alloc(nc, sizeof(SEXP));
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(LENGTH(xj) != nr)
error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1);
if(inherits(xj, "factor")) {
levels[j] = getAttrib(xj, R_LevelsSymbol);
} else levels[j] = R_NilValue;
}
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
xj = VECTOR_ELT(x, j);
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(xj, i)) tmp = cna;
else {
if(!isNull(levels[j])) {
/* We do not assume factors have integer levels,
although they should. */
if(TYPEOF(xj) == INTSXP)
tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1,
quote_col[j], qmethod,
&strBuf, cdec);
else if(TYPEOF(xj) == REALSXP)
tmp = EncodeElement2(levels[j],
(int) (REAL(xj)[i] - 1),
quote_col[j], qmethod,
&strBuf, cdec);
else
error("column %s claims to be a factor but does not have numeric codes", j+1);
} else {
tmp = EncodeElement2(xj, i, quote_col[j], qmethod,
&strBuf, cdec);
}
/* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
} else { /* A matrix */
if(!isVectorAtomic(x))
UNIMPLEMENTED_TYPE("write.table, matrix method", x);
/* quick integrity check */
if(LENGTH(x) != nr * nc)
error(_("corrupt matrix -- dims not not match length"));
for(i = 0; i < nr; i++) {
if(i % 1000 == 999) R_CheckUserInterrupt();
if(!isNull(rnames))
Rconn_printf(con, "%s%s",
EncodeElement2(rnames, i, quote_rn, qmethod,
&strBuf, cdec), csep);
for(j = 0; j < nc; j++) {
if(j > 0) Rconn_printf(con, "%s", csep);
if(isna(x, i + j*nr)) tmp = cna;
else {
tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod,
&strBuf, cdec);
/* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */
}
Rconn_printf(con, "%s", tmp);
}
Rconn_printf(con, "%s", ceol);
}
}
endcontext(&cntxt);
wt_cleanup(&wi);
return R_NilValue;
}
