template <typename T, typename X> void core_solver_pretty_printer<T, X>::init_column_widths() {
for (unsigned i = 0; i < ncols(); i++) {
m_column_widths[i] = get_column_width(i);
}
}
SEXP superSubset(SEXP x, SEXP y, SEXP fuz, SEXP vo, SEXP nec) {
int i, j, k, index;
double *p_x, *p_incovpri, *p_vo, min, max, so = 0.0, sumx_min, sumx_max, sumpmin_min, sumpmin_max, prisum_min, prisum_max, temp1, temp2;
int xrows, xcols, yrows, *p_y, *p_fuz, *p_nec;
SEXP usage = PROTECT(allocVector(VECSXP, 5));
SET_VECTOR_ELT(usage, 0, x = coerceVector(x, REALSXP));
SET_VECTOR_ELT(usage, 1, y = coerceVector(y, INTSXP));
SET_VECTOR_ELT(usage, 2, fuz = coerceVector(fuz, INTSXP));
SET_VECTOR_ELT(usage, 3, vo = coerceVector(vo, REALSXP));
SET_VECTOR_ELT(usage, 4, nec = coerceVector(nec, INTSXP));
xrows = nrows(x);
yrows = nrows(y);
xcols = ncols(x);
double copyline[xcols];
p_x = REAL(x);
p_y = INTEGER(y);
p_fuz = INTEGER(fuz);
p_vo = REAL(vo);
p_nec = INTEGER(nec);
// create the list to be returned to R
SEXP incovpri = PROTECT(allocMatrix(REALSXP, 6, yrows));
p_incovpri = REAL(incovpri);
// sum of the outcome variable
for (i = 0; i < length(vo); i++) {
so += p_vo[i];
}
min = 1000;
max = 0;
for (k = 0; k < yrows; k++) { // loop for every line of the truth table matrix
sumx_min = 0;
sumx_max = 0;
sumpmin_min = 0;
sumpmin_max = 0;
prisum_min = 0;
prisum_max = 0;
for (i = 0; i < xrows; i++) { // loop over every line of the data matrix
for (j = 0; j < xcols; j++) { // loop over each column of the data matrix
copyline[j] = p_x[i + xrows * j];
index = k + yrows * j;
if (p_fuz[j] == 1) { // for the fuzzy variables, invert those who have the 3k value equal to 1 ("onex3k" in R)
if (p_y[index] == 1) {
copyline[j] = 1 - copyline[j];
}
}
else {
if (p_y[index] != (copyline[j] + 1)) {
copyline[j] = 0;
}
else {
copyline[j] = 1;
}
}
if (p_y[index] != 0) {
if (copyline[j] < min) {
min = copyline[j];
}
if (copyline[j] > max) {
max = copyline[j];
}
}
} // end of j loop, over columns
sumx_min += min;
sumx_max += max;
sumpmin_min += (min < p_vo[i])?min:p_vo[i];
sumpmin_max += (max < p_vo[i])?max:p_vo[i];
temp1 = (min < p_vo[i])?min:p_vo[i];
temp2 = p_nec[0]?(1 - min):(1 - p_vo[i]);
prisum_min += (temp1 < temp2)?temp1:temp2;
temp1 = (max < p_vo[i])?max:p_vo[i];
temp2 = 1 - max;
prisum_max += (temp1 < temp2)?temp1:temp2;
min = 1000; // re-initialize min and max values
max = 0;
} // end of i loop
p_incovpri[k*6] = (sumpmin_min == 0 && sumx_min == 0)?0:(sumpmin_min/sumx_min);
p_incovpri[k*6 + 1] = (sumpmin_min == 0 && so == 0)?0:(sumpmin_min/so);
p_incovpri[k*6 + 2] = (sumpmin_max == 0 && sumx_max == 0)?0:(sumpmin_max/sumx_max);
p_incovpri[k*6 + 3] = (sumpmin_max == 0 && so == 0)?0:(sumpmin_max/so);
temp1 = sumpmin_min - prisum_min;
temp2 = p_nec[0]?so:sumx_min - prisum_min;
p_incovpri[k*6 + 4] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
temp1 = sumpmin_max - prisum_max;
temp2 = so - prisum_max;
p_incovpri[k*6 + 5] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
} // end of k loop
UNPROTECT(2);
return(incovpri);
}
SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
{
SEXP attr, result, dim;
int nr, nc, nrs, ncs;
int i, j, ii, jj, ij, iijj;
int mode;
int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL;
double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL;
nr = nrows(x);
nc = ncols(x);
if( length(x)==0 )
return x;
dim = getAttrib(x, R_DimSymbol);
nrs = LENGTH(sr);
ncs = LENGTH(sc);
int *int_sr=NULL, *int_sc=NULL;
int_sr = INTEGER(sr);
int_sc = INTEGER(sc);
mode = TYPEOF(x);
result = allocVector(mode, nrs*ncs);
PROTECT(result);
if( mode==INTSXP ) {
int_x = INTEGER(x);
int_result = INTEGER(result);
} else
if( mode==REALSXP ) {
real_x = REAL(x);
real_result = REAL(result);
}
/* code to handle index of xts object efficiently */
SEXP index, newindex;
int indx;
index = getAttrib(x, install("index"));
PROTECT(index);
if(TYPEOF(index) == INTSXP) {
newindex = allocVector(INTSXP, LENGTH(sr));
PROTECT(newindex);
int_newindex = INTEGER(newindex);
int_index = INTEGER(index);
for(indx = 0; indx < nrs; indx++) {
int_newindex[indx] = int_index[ (int_sr[indx])-1];
}
copyAttributes(index, newindex);
setAttrib(result, install("index"), newindex);
UNPROTECT(1);
}
if(TYPEOF(index) == REALSXP) {
newindex = allocVector(REALSXP, LENGTH(sr));
PROTECT(newindex);
real_newindex = REAL(newindex);
real_index = REAL(index);
for(indx = 0; indx < nrs; indx++) {
real_newindex[indx] = real_index[ (int_sr[indx])-1 ];
}
copyAttributes(index, newindex);
setAttrib(result, install("index"), newindex);
UNPROTECT(1);
}
for (i = 0; i < nrs; i++) {
ii = int_sr[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
error("i is out of range\n");
ii--;
}
/* Begin column loop */
for (j = 0; j < ncs; j++) {
//jj = INTEGER(sc)[j];
jj = int_sc[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
error("j is out of range\n");
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch ( mode ) {
case REALSXP:
real_result[ij] = NA_REAL;
break;
case LGLSXP:
case INTSXP:
int_result[ij] = NA_INTEGER;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
error("xts subscripting not handled for this type");
break;
}
}
else {
iijj = ii + jj * nr;
switch ( mode ) {
case REALSXP:
real_result[ij] = real_x[iijj];
break;
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
int_result[ij] = int_x[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
error("matrix subscripting not handled for this type");
break;
}
}
} /* end of column loop */
} /* end of row loop */
if(nrs >= 0 && ncs >= 0 && !isNull(dim)) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0 && !isNull(dim)) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
xtsExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr));
SET_VECTOR_ELT(newdimnames, 1,
xtsExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
xtsExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr));
SET_VECTOR_ELT(newdimnames, 1,
xtsExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
copyAttributes(x, result);
if(ncs == 1 && LOGICAL(drop)[0])
setAttrib(result, R_DimSymbol, R_NilValue);
UNPROTECT(2);
return result;
}
void CRInterface::get_char_string_list(TString<char>*& strings, int32_t& num_str, int32_t& max_string_len)
{
SEXP strs=get_arg_increment();
if (strs == R_NilValue || TYPEOF(strs) != STRSXP)
SG_ERROR("Expected String List as argument %d\n", m_rhs_counter);
SG_DEBUG("nrows=%d ncols=%d Rf_length=%d\n", nrows(strs), ncols(strs), Rf_length(strs));
if (nrows(strs) && ncols(strs)!=1)
{
num_str = ncols(strs);
max_string_len = nrows(strs);
strings=new TString<char>[num_str];
ASSERT(strings);
for (int32_t i=0; i<num_str; i++)
{
char* dst=new char[max_string_len+1];
for (int32_t j=0; j<max_string_len; j++)
{
SEXPREC* s= STRING_ELT(strs,i*max_string_len+j);
if (LENGTH(s)!=1)
SG_ERROR("LENGTH(s)=%d != 1, nrows(strs)=%d ncols(strs)=%d\n", LENGTH(s), nrows(strs), ncols(strs));
dst[j]=CHAR(s)[0];
}
strings[i].string=dst;
strings[i].string[max_string_len]='\0';
strings[i].length=max_string_len;
}
}
else
{
max_string_len=0;
num_str=Rf_length(strs);
strings=new TString<char>[num_str];
ASSERT(strings);
for (int32_t i=0; i<num_str; i++)
{
SEXPREC* s= STRING_ELT(strs,i);
char* c= (char*) CHAR(s);
int32_t len=LENGTH(s);
if (len && c)
{
char* dst=new char[len+1];
strings[i].string=(char*) memcpy(dst, c, len*sizeof(char));
strings[i].string[len]='\0';
strings[i].length=len;
max_string_len=CMath::max(max_string_len, len);
}
else
{
SG_WARNING( "string with index %d has zero length\n", i+1);
strings[i].string=0;
strings[i].length=0;
}
}
}
}
SEXP bnstruct_heom_dist( SEXP sexp_vec, SEXP sexp_mat, SEXP sexp_num_var, SEXP sexp_num_var_range )
{
// inputs
int i,j;
int nvar = ncols(sexp_mat);
int nrow = nrows(sexp_mat);
double * vec = REAL(sexp_vec);
double * mat = REAL(sexp_mat);
int * num_var = INTEGER(sexp_num_var);
double * num_var_range = REAL(sexp_num_var_range);
// allocate output and copy input
SEXP result;
PROTECT( result = allocVector(REALSXP, nrow) );
double * res = REAL(result);
for( i = 0; i < nrow; i++ )
res[i] = 0;
// internal structure
int num_var_ind[nvar];
double num_var_range_ind[nvar];
for( i = 0; i < nvar; i++ )
{
num_var_ind[i] = 0;
num_var_range_ind[i] = 0;
}
for( i = 0; i < length(sexp_num_var); i++ )
{
num_var_ind[ num_var[i] - 1 ] = 1;
num_var_range_ind[ num_var[i] - 1 ] = num_var_range[i];
}
// compute distances
for( i = 0; i < nvar; i++ )
{
if( ISNA(vec[i]) )
for( j = 0; j < nrow; j++ )
res[j] += 1;
else if( num_var_ind[i] )
for( j = 0; j < nrow; j++ )
if( ISNA(mat[j + i*nrow]) )
res[j] += 1;
else
res[j] += pow( (vec[i] - mat[j + i*nrow]) / num_var_range_ind[i], 2 );
else
for( j = 0; j < nrow; j++ )
if( ISNA(mat[j + i*nrow]) )
res[j] += 1;
else
res[j] += ( vec[i] != mat[j + i*nrow] );
}
for( i = 0; i < nrow; i++ )
res[i] = sqrt(res[i]);
UNPROTECT(1);
return( result );
}
SEXP predkda(SEXP s_test, SEXP s_learn, SEXP s_grouping, SEXP s_wf, SEXP s_bw, SEXP s_k, SEXP s_env)
{
const R_len_t p = ncols(s_test); // dimensionality
const R_len_t N_learn = nrows(s_learn); // # training observations
const R_len_t N_test = nrows(s_test); // # test observations
const R_len_t K = nlevels(s_grouping); // # classes
double *test = REAL(s_test); // pointer to test data set
double *learn = REAL(s_learn); // pointer to training data set
int *g = INTEGER(s_grouping); // pointer to class labels
const int k = INTEGER(s_k)[0]; // number of nearest neighbors
double *bw = REAL(s_bw); // bandwidth
/*Rprintf("k %u\n", k);
Rprintf("bw %f\n", *bw);
*/
SEXP s_posterior; // initialize posteriors
PROTECT(s_posterior = allocMatrix(REALSXP, N_test, K));
double *posterior = REAL(s_posterior);
SEXP s_dist; // initialize distances to test observation
PROTECT(s_dist = allocVector(REALSXP, N_learn));
double *dist = REAL(s_dist);
SEXP s_weights; // initialize weight vector
PROTECT(s_weights = allocVector(REALSXP, N_learn));
double *weights = REAL(s_weights);
int nas = 0;
int i, j, l, n; // indices
// select weight function
typedef void (*wf_ptr_t) (double*, double*, int, double*, int);// *weights, *dist, N, *bw, k
wf_ptr_t wf = NULL;
if (isInteger(s_wf)) {
const int wf_nr = INTEGER(s_wf)[0];
//Rprintf("wf_nr %u\n", wf_nr);
wf_ptr_t wfs[] = {biweight1, cauchy1, cosine1, epanechnikov1, exponential1, gaussian1,
optcosine1, rectangular1, triangular1, biweight2, cauchy2, cosine2, epanechnikov2,
exponential2, gaussian2, optcosine2, rectangular2, triangular2, biweight3, cauchy3,
cosine3, epanechnikov3, exponential3, gaussian3, optcosine3, rectangular3,
triangular3, cauchy4, exponential4, gaussian4};
wf = wfs[wf_nr - 1];
}
// loop over all test observations
for(n = 0; n < N_test; n++) {
// 0. check for NAs in test
nas = 0;
for (j = 0; j < p; j++) {
nas += ISNA(test[n + N_test * j]);
}
if (nas > 0) { // NAs in n-th test observation
warning("NAs in test observation %u", n+1);
// set posterior to NA
for (l = 0; l < K; l++) {
posterior[n + N_test * l] = NA_REAL;
}
} else {
// 1. calculate distances to n-th test observation
for (i = 0; i < N_learn; i++) {
dist[i] = 0;
for (j = 0; j < p; j++) {
dist[i] += pow(learn[i + N_learn * j] - test[n + N_test * j], 2);
}
dist[i] = sqrt(dist[i]);
weights[i] = 0; // important because some weights are 0
//Rprintf("dist %f\n", dist[i]);
}
// 2. calculate observation weights
if (isInteger(s_wf)) {
// case 1: wf is integer
// calculate weights by reading number and calling corresponding C function
wf(weights, dist, N_learn, bw, k);
} else if (isFunction(s_wf)) {
// case 2: wf is R function
// calculate weights by calling R function
SEXP R_fcall;
PROTECT(R_fcall = lang2(s_wf, R_NilValue)); //R_NilValue = NULL??? NILSXP = NULL
SETCADR(R_fcall, s_dist); // SETCADR: cadr list = (car (cdr list))
weights = REAL(eval(R_fcall, s_env));
UNPROTECT(1); // R_fcall
}
/*for(i = 0; i < N_learn; i++) {
Rprintf("weights %f\n", weights[i]);
}*/
// 3. calculate posterior probabilities as class wise sum of weights
for (l = 0; l < K; l++) {
posterior[n + N_test * l] = 0;
for (i = 0; i < N_learn; i++) {
if (g[i] == l + 1) {
posterior[n + N_test * l] += weights[i];
}
}
}
}
}
// end loop over test observations
// 4. set dimnames of s_posterior
SEXP dimnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(getAttrib(s_test, R_DimNamesSymbol), 0));
SET_VECTOR_ELT(dimnames, 1, getAttrib(s_grouping, R_LevelsSymbol));
setAttrib(s_posterior, R_DimNamesSymbol, dimnames);
//void R_max_col (double* matrix, int* nr, int* nc, int* maxes)
// maxes initialisieren
//R_max_col (posterior, &N_test, &K, int* maxes)
UNPROTECT(4); // dimnames, s_dist, s_weights, s_posterior
return(s_posterior);
}
SEXP hitrun(SEXP alpha, SEXP initial, SEXP nbatch, SEXP blen, SEXP nspac,
SEXP origin, SEXP basis, SEXP amat, SEXP bvec, SEXP outmat, SEXP debug)
{
if (! isReal(alpha))
error("argument \"alpha\" must be type double");
if (! isReal(initial))
error("argument \"initial\" must be type double");
if (! isInteger(nbatch))
error("argument \"nbatch\" must be type integer");
if (! isInteger(blen))
error("argument \"blen\" must be type integer");
if (! isInteger(nspac))
error("argument \"nspac\" must be type integer");
if (! isReal(origin))
error("argument \"origin\" must be type double");
if (! isReal(basis))
error("argument \"basis\" must be type double");
if (! isReal(amat))
error("argument \"amat\" must be type double");
if (! isReal(bvec))
error("argument \"bvec\" must be type double");
if (! (isNull(outmat) | isReal(outmat)))
error("argument \"outmat\" must be type double or NULL");
if (! isLogical(debug))
error("argument \"debug\" must be logical");
if (! isMatrix(basis))
error("argument \"basis\" must be matrix");
if (! isMatrix(amat))
error("argument \"amat\" must be matrix");
if (! (isNull(outmat) | isMatrix(outmat)))
error("argument \"outmat\" must be matrix or NULL");
int dim_oc = LENGTH(alpha);
int dim_nc = LENGTH(initial);
int ncons = nrows(amat);
if (LENGTH(nbatch) != 1)
error("argument \"nbatch\" must be scalar");
if (LENGTH(blen) != 1)
error("argument \"blen\" must be scalar");
if (LENGTH(nspac) != 1)
error("argument \"nspac\" must be scalar");
if (LENGTH(origin) != dim_oc)
error("length(origin) != length(alpha)");
if (nrows(basis) != dim_oc)
error("nrow(basis) != length(alpha)");
if (ncols(basis) != dim_nc)
error("ncol(basis) != length(initial)");
if (ncols(amat) != dim_nc)
error("ncol(amat) != length(initial)");
if (LENGTH(bvec) != ncons)
error("length(bvec) != nrow(amat)");
if (LENGTH(debug) != 1)
error("argument \"debug\" must be scalar");
int dim_out = dim_oc;
if (! isNull(outmat)) {
dim_out = nrows(outmat);
if (ncols(outmat) != dim_oc)
error("ncol(outmat) != length(alpha)");
}
int int_nbatch = INTEGER(nbatch)[0];
int int_blen = INTEGER(blen)[0];
int int_nspac = INTEGER(nspac)[0];
int int_debug = LOGICAL(debug)[0];
double *dbl_star_alpha = REAL(alpha);
double *dbl_star_initial = REAL(initial);
double *dbl_star_origin = REAL(origin);
double *dbl_star_basis = REAL(basis);
double *dbl_star_amat = REAL(amat);
double *dbl_star_bvec = REAL(bvec);
int has_outmat = isMatrix(outmat);
double *dbl_star_outmat = 0;
if (has_outmat)
dbl_star_outmat = REAL(outmat);
if (int_nbatch <= 0)
error("argument \"nbatch\" must be positive");
if (int_blen <= 0)
error("argument \"blen\" must be positive");
if (int_nspac <= 0)
error("argument \"nspac\" must be positive");
check_finite(dbl_star_alpha, dim_oc, "alpha");
check_positive(dbl_star_alpha, dim_oc, "alpha");
check_finite(dbl_star_initial, dim_nc, "initial");
check_finite(dbl_star_origin, dim_oc, "origin");
check_finite(dbl_star_basis, dim_oc * dim_nc, "basis");
check_finite(dbl_star_amat, ncons * dim_nc, "amat");
check_finite(dbl_star_bvec, ncons, "bvec");
if (has_outmat)
check_finite(dbl_star_outmat, dim_out * dim_oc, "outmat");
double *state = (double *) R_alloc(dim_nc, sizeof(double));
double *proposal = (double *) R_alloc(dim_nc, sizeof(double));
double *batch_buffer = (double *) R_alloc(dim_out, sizeof(double));
double *out_buffer = (double *) R_alloc(dim_out, sizeof(double));
memcpy(state, dbl_star_initial, dim_nc * sizeof(double));
logh_setup(dbl_star_alpha, dbl_star_origin, dbl_star_basis, dim_oc, dim_nc);
double current_log_dens = logh(state);
out_setup(dbl_star_origin, dbl_star_basis, dbl_star_outmat, dim_oc, dim_nc,
dim_out, has_outmat);
SEXP result, resultnames, path, save_initial, save_final;
if (! int_debug) {
PROTECT(result = allocVector(VECSXP, 3));
PROTECT(resultnames = allocVector(STRSXP, 3));
} else {
PROTECT(result = allocVector(VECSXP, 11));
PROTECT(resultnames = allocVector(STRSXP, 11));
}
PROTECT(path = allocMatrix(REALSXP, dim_out, int_nbatch));
SET_VECTOR_ELT(result, 0, path);
PROTECT(save_initial = duplicate(initial));
SET_VECTOR_ELT(result, 1, save_initial);
UNPROTECT(2);
SET_STRING_ELT(resultnames, 0, mkChar("batch"));
SET_STRING_ELT(resultnames, 1, mkChar("initial"));
SET_STRING_ELT(resultnames, 2, mkChar("final"));
if (int_debug) {
SEXP spath, ppath, zpath, u1path, u2path, s1path, s2path, gpath;
int nn = int_nbatch * int_blen * int_nspac;
PROTECT(spath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 3, spath);
PROTECT(ppath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 4, ppath);
PROTECT(zpath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 5, zpath);
PROTECT(u1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 6, u1path);
PROTECT(u2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 7, u2path);
PROTECT(s1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 8, s1path);
PROTECT(s2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 9, s2path);
PROTECT(gpath = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 10, gpath);
UNPROTECT(8);
SET_STRING_ELT(resultnames, 3, mkChar("current"));
SET_STRING_ELT(resultnames, 4, mkChar("proposal"));
SET_STRING_ELT(resultnames, 5, mkChar("z"));
SET_STRING_ELT(resultnames, 6, mkChar("u1"));
SET_STRING_ELT(resultnames, 7, mkChar("u2"));
SET_STRING_ELT(resultnames, 8, mkChar("s1"));
SET_STRING_ELT(resultnames, 9, mkChar("s2"));
SET_STRING_ELT(resultnames, 10, mkChar("log.green"));
}
namesgets(result, resultnames);
UNPROTECT(1);
GetRNGstate();
if (current_log_dens == R_NegInf)
error("log unnormalized density -Inf at initial state");
for (int ibatch = 0, k = 0; ibatch < int_nbatch; ibatch++) {
for (int i = 0; i < dim_out; i++)
batch_buffer[i] = 0.0;
for (int jbatch = 0; jbatch < int_blen; jbatch++) {
double proposal_log_dens;
for (int ispac = 0; ispac < int_nspac; ispac++) {
/* Note: should never happen! */
if (current_log_dens == R_NegInf)
error("log density -Inf at current state");
double u1 = R_NaReal;
double u2 = R_NaReal;
double smax = R_NaReal;
double smin = R_NaReal;
double z[dim_nc];
propose(state, proposal, dbl_star_amat, dbl_star_bvec,
dim_nc, ncons, z, &smax, &smin, &u1);
proposal_log_dens = logh(proposal);
int accept = FALSE;
if (proposal_log_dens != R_NegInf) {
if (proposal_log_dens >= current_log_dens) {
accept = TRUE;
} else {
double green = exp(proposal_log_dens
- current_log_dens);
u2 = unif_rand();
accept = u2 < green;
}
}
if (int_debug) {
int l = ispac + int_nspac * (jbatch + int_blen * ibatch);
int lbase = l * dim_nc;
SEXP spath = VECTOR_ELT(result, 3);
SEXP ppath = VECTOR_ELT(result, 4);
SEXP zpath = VECTOR_ELT(result, 5);
SEXP u1path = VECTOR_ELT(result, 6);
SEXP u2path = VECTOR_ELT(result, 7);
SEXP s1path = VECTOR_ELT(result, 8);
SEXP s2path = VECTOR_ELT(result, 9);
SEXP gpath = VECTOR_ELT(result, 10);
for (int lj = 0; lj < dim_nc; lj++) {
REAL(spath)[lbase + lj] = state[lj];
REAL(ppath)[lbase + lj] = proposal[lj];
REAL(zpath)[lbase + lj] = z[lj];
}
REAL(u1path)[l] = u1;
REAL(u2path)[l] = u2;
REAL(s1path)[l] = smin;
REAL(s2path)[l] = smax;
REAL(gpath)[l] = proposal_log_dens - current_log_dens;
}
if (accept) {
memcpy(state, proposal, dim_nc * sizeof(double));
current_log_dens = proposal_log_dens;
}
} /* end of inner loop (one iteration) */
outfun(state, out_buffer);
for (int j = 0; j < dim_out; j++)
batch_buffer[j] += out_buffer[j];
} /* end of middle loop (one batch) */
for (int j = 0; j < dim_out; j++, k++)
REAL(path)[k] = batch_buffer[j] / int_blen;
} /* end of outer loop */
PutRNGstate();
PROTECT(save_final = allocVector(REALSXP, dim_nc));
memcpy(REAL(save_final), state, dim_nc * sizeof(double));
SET_VECTOR_ELT(result, 2, save_final);
UNPROTECT(5);
return result;
}
SEXP na_locf (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
/* only works on univariate data *
* of type LGLSXP, INTSXP and REALSXP. */
SEXP result;
int i, ii, nr, _first, P=0;
double gap, maxgap, limit;
_first = firstNonNA(x);
if(_first == nrows(x))
return(x);
int *int_x=NULL, *int_result=NULL;
double *real_x=NULL, *real_result=NULL;
if(ncols(x) > 1)
error("na.locf.xts only handles univariate, dimensioned data");
nr = nrows(x);
maxgap = asReal(coerceVector(_maxgap,REALSXP));
limit = asReal(coerceVector(_limit ,REALSXP));
gap = 0;
PROTECT(result = allocVector(TYPEOF(x), nrows(x))); P++;
switch(TYPEOF(x)) {
case LGLSXP:
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(!LOGICAL(fromLast)[0]) {
/* copy leading NAs */
for(i=0; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i-1];
gap++;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_LOGICAL;
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
int_result[nr-1] = int_x[nr-1];
for(i=nr-2; i>=0; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i+1];
gap++;
}
}
}
break;
case INTSXP:
int_x = INTEGER(x);
int_result = INTEGER(result);
if(!LOGICAL(fromLast)[0]) {
/* copy leading NAs */
for(i=0; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
int_result[nr-1] = int_x[nr-1];
for(i=nr-2; i>=0; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
}
break;
case REALSXP:
real_x = REAL(x);
real_result = REAL(result);
if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */
for(i=0; i < (_first+1); i++) {
real_result[i] = real_x[i];
}
for(i=_first+1; i<nr; i++) {
real_result[i] = real_x[i];
if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
} else { /* fromLast=TRUE */
real_result[nr-1] = real_x[nr-1];
for(i=nr-2; i>=0; i--) {
real_result[i] = real_x[i];
if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
}
break;
default:
error("unsupported type");
break;
}
if(isXts(x)) {
setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
copy_xtsCoreAttributes(x, result);
copy_xtsAttributes(x, result);
}
UNPROTECT(P);
return(result);
}
SEXP na_locf_col (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
{
/* version of na_locf that works on multivariate data
* of type LGLSXP, INTSXP and REALSXP. */
SEXP result;
int i, ii, j, nr, nc, _first=0, P=0;
double gap, maxgap, limit;
int *int_x=NULL, *int_result=NULL;
double *real_x=NULL, *real_result=NULL;
nr = nrows(x);
nc = ncols(x);
maxgap = asReal(_maxgap);
limit = asReal(_limit);
gap = 0;
if(firstNonNA(x) == nr)
return(x);
PROTECT(result = allocMatrix(TYPEOF(x), nr, nc)); P++;
switch(TYPEOF(x)) {
case LGLSXP:
int_x = LOGICAL(x);
int_result = LOGICAL(result);
if(!LOGICAL(fromLast)[0]) {
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i-1];
gap++;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_LOGICAL;
}
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
for(j=0; j < nc; j++) {
int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_LOGICAL && gap < maxgap) {
int_result[i] = int_result[i+1];
gap++;
}
}
}
}
break;
case INTSXP:
int_x = INTEGER(x);
int_result = INTEGER(result);
if(!LOGICAL(fromLast)[0]) {
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
int_result[i] = int_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
int_result[ii] = NA_INTEGER;
}
}
}
} else {
/* nr-2 is first position to fill fromLast=TRUE */
for(j=0; j < nc; j++) {
int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
int_result[i] = int_x[i];
if(int_result[i] == NA_INTEGER) {
if(limit > gap)
int_result[i] = int_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
int_result[ii] = NA_INTEGER;
}
}
}
}
break;
case REALSXP:
real_x = REAL(x);
real_result = REAL(result);
if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */
for(j=0; j < nc; j++) {
/* copy leading NAs */
_first = firstNonNACol(x, j);
//if(_first+1 == nr) continue;
for(i=0+j*nr; i < (_first+1); i++) {
real_result[i] = real_x[i];
}
/* result[_first] now has first value fromLast=FALSE */
for(i=_first+1; i<nr+j*nr; i++) {
real_result[i] = real_x[i];
if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i-1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */
for(ii = i-1; ii > i-gap-1; ii--) {
real_result[ii] = NA_REAL;
}
}
}
} else { /* fromLast=TRUE */
for(j=0; j < nc; j++) {
real_result[nr-1+j*nr] = real_x[nr-1+j*nr];
for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
real_result[i] = real_x[i];
if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
if(limit > gap)
real_result[i] = real_result[i+1];
gap++;
} else {
if((int)gap > (int)maxgap) {
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
gap=0;
}
}
if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */
for(ii = i+1; ii < i+gap+1; ii++) {
real_result[ii] = NA_REAL;
}
}
}
}
break;
default:
error("unsupported type");
break;
}
if(isXts(x)) {
setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
copy_xtsCoreAttributes(x, result);
copy_xtsAttributes(x, result);
}
UNPROTECT(P);
return(result);
}
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
SEXP attr, result, sr, sc, dim;
int nr, nc, nrs, ncs;
R_xlen_t i, j, ii, jj, ij, iijj;
nr = nrows(x);
nc = ncols(x);
/* Note that "s" is protected on entry. */
/* The following ensures that pointers remain protected. */
dim = getAttrib(x, R_DimSymbol);
sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));
sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
nrs = LENGTH(sr);
ncs = LENGTH(sc);
/* Check this does not overflow: currently only possible on 32-bit */
if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
error(_("dimensions would exceed maximum size of array"));
PROTECT(sr);
PROTECT(sc);
result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);
PROTECT(result);
for (i = 0; i < nrs; i++) {
ii = INTEGER(sr)[i];
if (ii != NA_INTEGER) {
if (ii < 1 || ii > nr)
errorcall(call, R_MSG_subs_o_b);
ii--;
}
for (j = 0; j < ncs; j++) {
jj = INTEGER(sc)[j];
if (jj != NA_INTEGER) {
if (jj < 1 || jj > nc)
errorcall(call, R_MSG_subs_o_b);
jj--;
}
ij = i + j * nrs;
if (ii == NA_INTEGER || jj == NA_INTEGER) {
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
INTEGER(result)[ij] = NA_INTEGER;
break;
case REALSXP:
REAL(result)[ij] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(result)[ij].r = NA_REAL;
COMPLEX(result)[ij].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(result, ij, NA_STRING);
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, R_NilValue);
break;
case RAWSXP:
RAW(result)[ij] = (Rbyte) 0;
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
else {
iijj = ii + jj * nr;
switch (TYPEOF(x)) {
case LGLSXP:
LOGICAL(result)[ij] = LOGICAL(x)[iijj];
break;
case INTSXP:
INTEGER(result)[ij] = INTEGER(x)[iijj];
break;
case REALSXP:
REAL(result)[ij] = REAL(x)[iijj];
break;
case CPLXSXP:
COMPLEX(result)[ij] = COMPLEX(x)[iijj];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
break;
case VECSXP:
SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
break;
case RAWSXP:
RAW(result)[ij] = RAW(x)[iijj];
break;
default:
errorcall(call, _("matrix subscripting not handled for this type"));
break;
}
}
}
}
if(nrs >= 0 && ncs >= 0) {
PROTECT(attr = allocVector(INTSXP, 2));
INTEGER(attr)[0] = nrs;
INTEGER(attr)[1] = ncs;
setAttrib(result, R_DimSymbol, attr);
UNPROTECT(1);
}
/* The matrix elements have been transferred. Now we need to */
/* transfer the attributes. Most importantly, we need to subset */
/* the dimnames of the returned value. */
if (nrs >= 0 && ncs >= 0) {
SEXP dimnames, dimnamesnames, newdimnames;
dimnames = getAttrib(x, R_DimNamesSymbol);
dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
if (!isNull(dimnames)) {
PROTECT(newdimnames = allocVector(VECSXP, 2));
if (TYPEOF(dimnames) == VECSXP) {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(VECTOR_ELT(dimnames, 0),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(VECTOR_ELT(dimnames, 1),
allocVector(STRSXP, ncs), sc, call));
}
else {
SET_VECTOR_ELT(newdimnames, 0,
ExtractSubset(CAR(dimnames),
allocVector(STRSXP, nrs), sr, call));
SET_VECTOR_ELT(newdimnames, 1,
ExtractSubset(CADR(dimnames),
allocVector(STRSXP, ncs), sc, call));
}
setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
setAttrib(result, R_DimNamesSymbol, newdimnames);
UNPROTECT(1);
}
}
/* Probably should not do this:
copyMostAttrib(x, result); */
if (drop)
DropDims(result);
UNPROTECT(3);
return result;
}
SEXP coxfit6(SEXP maxiter2, SEXP time2, SEXP status2,
SEXP covar2, SEXP offset2, SEXP weights2,
SEXP strata2, SEXP method2, SEXP eps2,
SEXP toler2, SEXP ibeta, SEXP doscale2) {
int i,j,k, person;
double **covar, **cmat, **imat; /*ragged arrays */
double **imatCopy; /* Naras add */
double wtave;
double *a, *newbeta;
double *a2, **cmat2;
double *scale;
double denom=0, zbeta, risk;
double temp, temp2;
int ndead; /* number of death obs at a time point */
double tdeath=0; /* ndead= total at a given time point, tdeath= all */
double newlk=0;
double dtime, d2;
double deadwt; /*sum of case weights for the deaths*/
double efronwt; /* sum of weighted risk scores for the deaths*/
int halving; /*are we doing step halving at the moment? */
int nrisk; /* number of subjects in the current risk set */
double *maxbeta;
/* copies of scalar input arguments */
int nused, nvar, maxiter;
int method;
double eps, toler;
int doscale;
/* vector inputs */
double *time, *weights, *offset;
int *status, *strata;
/* returned objects */
SEXP imat2, means2, beta2, u2, loglik2;
SEXP imatCopy2; /* Naras add */
double *beta, *u, *loglik, *means;
SEXP sctest2, flag2, iter2;
double *sctest;
int *flag, *iter;
SEXP rlist, rlistnames;
int nprotect; /* number of protect calls I have issued */
/* get local copies of some input args */
nused = LENGTH(offset2);
nvar = ncols(covar2);
method = asInteger(method2);
maxiter = asInteger(maxiter2);
eps = asReal(eps2); /* convergence criteria */
toler = asReal(toler2); /* tolerance for cholesky */
doscale = asInteger(doscale2);
time = REAL(time2);
weights = REAL(weights2);
offset= REAL(offset2);
status = INTEGER(status2);
strata = INTEGER(strata2);
/*
** Set up the ragged arrays and scratch space
** Normally covar2 does not need to be duplicated, even though
** we are going to modify it, due to the way this routine was
** was called. In this case NAMED(covar2) will =0
*/
nprotect =0;
if (NAMED(covar2)>0) {
PROTECT(covar2 = duplicate(covar2));
nprotect++;
}
covar= dmatrix(REAL(covar2), nused, nvar);
PROTECT(imat2 = allocVector(REALSXP, nvar*nvar));
nprotect++;
imat = dmatrix(REAL(imat2), nvar, nvar);
/* Naras add */
PROTECT(imatCopy2 = allocVector(REALSXP, nvar*nvar));
nprotect++;
imatCopy = dmatrix(REAL(imatCopy2), nvar, nvar);
/* Naras add end */
a = (double *) R_alloc(2*nvar*nvar + 5*nvar, sizeof(double));
newbeta = a + nvar;
a2 = newbeta + nvar;
maxbeta = a2 + nvar;
scale = maxbeta + nvar;
cmat = dmatrix(scale + nvar, nvar, nvar);
cmat2= dmatrix(scale + nvar +nvar*nvar, nvar, nvar);
/*
** create output variables
*/
PROTECT(beta2 = duplicate(ibeta));
beta = REAL(beta2);
PROTECT(means2 = allocVector(REALSXP, nvar));
means = REAL(means2);
PROTECT(u2 = allocVector(REALSXP, nvar));
u = REAL(u2);
PROTECT(loglik2 = allocVector(REALSXP, 2));
loglik = REAL(loglik2);
PROTECT(sctest2 = allocVector(REALSXP, 1));
sctest = REAL(sctest2);
PROTECT(flag2 = allocVector(INTSXP, 1));
flag = INTEGER(flag2);
PROTECT(iter2 = allocVector(INTSXP, 1));
iter = INTEGER(iter2);
nprotect += 7;
/*
** Subtract the mean from each covar, as this makes the regression
** much more stable.
*/
tdeath=0; temp2=0;
for (i=0; i<nused; i++) {
temp2 += weights[i];
tdeath += weights[i] * status[i];
}
for (i=0; i<nvar; i++) {
temp=0;
for (person=0; person<nused; person++)
temp += weights[person] * covar[i][person];
temp /= temp2;
means[i] = temp;
for (person=0; person<nused; person++) covar[i][person] -=temp;
if (doscale==1) { /* and also scale it */
temp =0;
for (person=0; person<nused; person++) {
temp += weights[person] * fabs(covar[i][person]);
}
if (temp > 0) temp = temp2/temp; /* scaling */
else temp=1.0; /* rare case of a constant covariate */
scale[i] = temp;
for (person=0; person<nused; person++) covar[i][person] *= temp;
}
}
if (doscale==1) {
for (i=0; i<nvar; i++) beta[i] /= scale[i]; /*rescale initial betas */
}
else {
for (i=0; i<nvar; i++) scale[i] = 1.0;
}
/*
** do the initial iteration step
*/
strata[nused-1] =1;
loglik[1] =0;
for (i=0; i<nvar; i++) {
u[i] =0;
a2[i] =0;
for (j=0; j<nvar; j++) {
imat[i][j] =0 ;
cmat2[i][j] =0;
}
}
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) {
nrisk =0 ;
denom = 0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
ndead =0; /*number of deaths at this time point */
deadwt =0; /* sum of weights for the deaths */
efronwt=0; /* sum of weighted risks for the deaths */
while(person >=0 &&time[person]==dtime) {
/* walk through the this set of tied times */
nrisk++;
zbeta = offset[person]; /* form the term beta*z (vector mult) */
for (i=0; i<nvar; i++)
zbeta += beta[i]*covar[i][person];
risk = exp(zbeta) * weights[person];
denom += risk;
/* a is the vector of weighted sums of x, cmat sums of squares */
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
efronwt += risk;
loglik[1] += weights[person]*zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person]*covar[i][person];
if (method==1) { /* Efron */
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*ties don't cross strata */
}
if (ndead >0) { /* we need to add to the main terms */
if (method==0) { /* Breslow */
loglik[1] -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += deadwt*(cmat[i][j] - temp2*a[j])/denom;
}
}
else { /* Efron */
/*
** If there are 3 deaths we have 3 terms: in the first the
** three deaths are all in, in the second they are 2/3
** in the sums, and in the last 1/3 in the sum. Let k go
** from 0 to (ndead -1), then we will sequentially use
** denom - (k/ndead)*efronwt as the denominator
** a - (k/ndead)*a2 as the "a" term
** cmat - (k/ndead)*cmat2 as the "cmat" term
** and reprise the equations just above.
*/
for (k=0; k<ndead; k++) {
temp = (double)k/ ndead;
wtave = deadwt/ndead;
d2 = denom - temp*efronwt;
loglik[1] -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave *temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2) *
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) {
a2[i]=0;
for (j=0; j<nvar; j++) cmat2[i][j]=0;
}
}
}
} /* end of accumulation loop */
loglik[0] = loglik[1]; /* save the loglik for iter 0 */
/*
** Use the initial variance matrix to set a maximum coefficient
** (The matrix contains the variance of X * weighted number of deaths)
*/
for (i=0; i<nvar; i++)
maxbeta[i] = 20* sqrt(imat[i][i]/tdeath);
/* am I done?
** update the betas and test for convergence
*/
for (i=0; i<nvar; i++) /*use 'a' as a temp to save u0, for the score test*/
a[i] = u[i];
*flag= cholesky2(imat, nvar, toler);
chsolve2(imat,nvar,a); /* a replaced by a *inverse(i) */
temp=0;
for (i=0; i<nvar; i++)
temp += u[i]*a[i];
*sctest = temp; /* score test */
/*
** Never, never complain about convergence on the first step. That way,
** if someone HAS to they can force one iter at a time.
*/
for (i=0; i<nvar; i++) {
newbeta[i] = beta[i] + a[i];
}
if (maxiter==0) {
/* Naras add */
for (i = 0; i < nvar; i++) {
for (j = 0; j < nvar; j++) {
imatCopy[i][j] = imat[i][j];
}
}
/* Naras add end */
chinv2(imat,nvar);
for (i=0; i<nvar; i++) {
beta[i] *= scale[i]; /*return to original scale */
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
imatCopy[i][i] /= (scale[i]*scale[i]);
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
imatCopy[j][i] /= (scale[i]*scale[j]);
imatCopy[i][j] = imatCopy[j][i];
}
}
goto finish;
}
/*
** here is the main loop
*/
halving =0 ; /* =1 when in the midst of "step halving" */
for (*iter=1; *iter<= maxiter; (*iter)++) {
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0;
}
/*
** The data is sorted from smallest time to largest
** Start at the largest time, accumulating the risk set 1 by 1
*/
for (person=nused-1; person>=0; ) {
if (strata[person] == 1) { /* rezero temps for each strata */
denom = 0;
nrisk =0;
for (i=0; i<nvar; i++) {
a[i] = 0;
for (j=0; j<nvar; j++) cmat[i][j] = 0;
}
}
dtime = time[person];
deadwt =0;
ndead =0;
efronwt =0;
while(person>=0 && time[person]==dtime) {
nrisk++;
zbeta = offset[person];
for (i=0; i<nvar; i++)
zbeta += newbeta[i]*covar[i][person];
risk = exp(zbeta) * weights[person];
denom += risk;
for (i=0; i<nvar; i++) {
a[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat[i][j] += risk*covar[i][person]*covar[j][person];
}
if (status[person]==1) {
ndead++;
deadwt += weights[person];
newlk += weights[person] *zbeta;
for (i=0; i<nvar; i++)
u[i] += weights[person] *covar[i][person];
if (method==1) { /* Efron */
efronwt += risk;
for (i=0; i<nvar; i++) {
a2[i] += risk*covar[i][person];
for (j=0; j<=i; j++)
cmat2[i][j] += risk*covar[i][person]*covar[j][person];
}
}
}
person--;
if (strata[person]==1) break; /*tied times don't cross strata*/
}
if (ndead >0) { /* add up terms*/
if (method==0) { /* Breslow */
newlk -= deadwt* log(denom);
for (i=0; i<nvar; i++) {
temp2= a[i]/ denom; /* mean */
u[i] -= deadwt* temp2;
for (j=0; j<=i; j++)
imat[j][i] += (deadwt/denom)*
(cmat[i][j] - temp2*a[j]);
}
}
else { /* Efron */
for (k=0; k<ndead; k++) {
temp = (double)k / ndead;
wtave= deadwt/ ndead;
d2= denom - temp* efronwt;
newlk -= wtave* log(d2);
for (i=0; i<nvar; i++) {
temp2 = (a[i] - temp*a2[i])/ d2;
u[i] -= wtave*temp2;
for (j=0; j<=i; j++)
imat[j][i] += (wtave/d2)*
((cmat[i][j] - temp*cmat2[i][j]) -
temp2*(a[j]-temp*a2[j]));
}
}
for (i=0; i<nvar; i++) { /*in anticipation */
a2[i] =0;
for (j=0; j<nvar; j++) cmat2[i][j] =0;
}
}
}
} /* end of accumulation loop */
/* am I done?
** update the betas and test for convergence
*/
*flag = cholesky2(imat, nvar, toler);
if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
loglik[1] = newlk;
chinv2(imat, nvar); /* invert the information matrix */
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
}
}
goto finish;
}
if (*iter== maxiter) break; /*skip the step halving calc*/
if (newlk < loglik[1]) { /*it is not converging ! */
halving =1;
for (i=0; i<nvar; i++)
newbeta[i] = (newbeta[i] + beta[i]) /2; /*half of old increment */
}
else {
halving=0;
loglik[1] = newlk;
chsolve2(imat,nvar,u);
j=0;
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i];
newbeta[i] = newbeta[i] + u[i];
if (newbeta[i] > maxbeta[i]) newbeta[i] = maxbeta[i];
else if (newbeta[i] < -maxbeta[i]) newbeta[i] = -maxbeta[i];
}
}
} /* return for another iteration */
/*
** We end up here only if we ran out of iterations
*/
loglik[1] = newlk;
/* Naras add */
for (i = 0; i < nvar; i++) {
for (j = 0; j < nvar; j++) {
imatCopy[i][j] = imat[i][j];
}
}
/* Naras add end */
chinv2(imat, nvar);
for (i=0; i<nvar; i++) {
beta[i] = newbeta[i]*scale[i];
u[i] /= scale[i];
imat[i][i] *= scale[i]*scale[i];
imatCopy[i][i] /= (scale[i]*scale[i]);
for (j=0; j<i; j++) {
imat[j][i] *= scale[i]*scale[j];
imat[i][j] = imat[j][i];
imatCopy[j][i] /= (scale[i]*scale[j]);
imatCopy[i][j] = imatCopy[j][i];
}
}
*flag = 1000;
finish:
/*
** create the output list
*/
PROTECT(rlist= allocVector(VECSXP, 9));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, means2);
SET_VECTOR_ELT(rlist, 2, u2);
SET_VECTOR_ELT(rlist, 3, imat2);
SET_VECTOR_ELT(rlist, 4, loglik2);
SET_VECTOR_ELT(rlist, 5, sctest2);
SET_VECTOR_ELT(rlist, 6, iter2);
SET_VECTOR_ELT(rlist, 7, flag2);
SET_VECTOR_ELT(rlist, 8, imatCopy2);
/* add names to the objects */
PROTECT(rlistnames = allocVector(STRSXP, 9));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("means"));
SET_STRING_ELT(rlistnames, 2, mkChar("u"));
SET_STRING_ELT(rlistnames, 3, mkChar("imat"));
SET_STRING_ELT(rlistnames, 4, mkChar("loglik"));
SET_STRING_ELT(rlistnames, 5, mkChar("sctest"));
SET_STRING_ELT(rlistnames, 6, mkChar("iter"));
SET_STRING_ELT(rlistnames, 7, mkChar("flag"));
SET_STRING_ELT(rlistnames, 8, mkChar("imatCopy"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
/* This is for all cases with a single index, including 1D arrays and
matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
R_xlen_t n;
int mode;
R_xlen_t stretch = 1;
SEXP indx, result, attrib, nattrib;
if (s == R_MissingArg) return duplicate(x);
PROTECT(s);
attrib = getAttrib(x, R_DimSymbol);
/* Check to see if we have special matrix subscripting. */
/* If we do, make a real subscript vector and protect it. */
if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
if (isString(s)) {
s = strmat2intmat(s, GetArrayDimnames(x), call);
UNPROTECT(1);
PROTECT(s);
}
if (isInteger(s) || isReal(s)) {
s = mat2indsub(attrib, s, call);
UNPROTECT(1);
PROTECT(s);
}
}
/* Convert to a vector of integer subscripts */
/* in the range 1:length(x). */
PROTECT(indx = makeSubscript(x, s, &stretch, call));
n = XLENGTH(indx);
/* Allocate the result. */
mode = TYPEOF(x);
/* No protection needed as ExtractSubset does not allocate */
result = allocVector(mode, n);
if (mode == VECSXP || mode == EXPRSXP)
/* we do not duplicate the values when extracting the subset,
so to be conservative mark the result as NAMED = 2 */
SET_NAMED(result, 2);
PROTECT(result = ExtractSubset(x, result, indx, call));
if (result != R_NilValue) {
if (
((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
( /* here we might have an array. Use row names if 1D */
isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
(attrib = GetRowNames(attrib)) != R_NilValue
)
) {
nattrib = allocVector(TYPEOF(attrib), n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_NamesSymbol, nattrib);
UNPROTECT(1);
}
if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
TYPEOF(attrib) == VECSXP) {
nattrib = allocVector(VECSXP, n);
PROTECT(nattrib); /* seems unneeded */
nattrib = ExtractSubset(attrib, nattrib, indx, call);
setAttrib(result, R_SrcrefSymbol, nattrib);
UNPROTECT(1);
}
/* FIXME: this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SET_S4_OBJECT(result);
}
#endif
}
UNPROTECT(3);
return result;
}
SEXP rbind_append (SEXP x, SEXP y) {
/*
Provide fast row binding of xts objects if the
left-hand object (binding target) has a last
index value less than the right-hand object
(object to bind). This is an optimization to allow
for real-time updating of objects without having to
do much more than a memcpy of the two in coordinated
fashion
*/
/*Rprintf("rbind_append called\n");*/
SEXP result;
int nrs_x, nrs_y, ncs_x, ncs_y, nr;
int i;
ncs_x = ncols(x); ncs_y = ncols(y); nrs_x = nrows(x); nrs_y = nrows(y);
if(ncs_x != ncs_y)
error("objects must have the same number of columns"); /* FIXME */
PROTECT(result = allocVector(TYPEOF(x), (nrs_x + nrs_y) * ncs_x));
nr = nrs_x + nrs_y;
switch(TYPEOF(x)) {
case REALSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(REAL(result)[i*nr]),
&(REAL(x)[i*nrs_x]),
nrs_x*sizeof(double));
memcpy(&(REAL(result)[i*nr + nrs_x]),
&(REAL(y)[i*nrs_y]),
nrs_y*sizeof(double));
}
break;
case INTSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(INTEGER(result)[i*nr]),
&(INTEGER(x)[i*nrs_x]),
nrs_x*sizeof(int));
memcpy(&(INTEGER(result)[i*nr + nrs_x]),
&(INTEGER(y)[i*nrs_y]),
nrs_y*sizeof(int));
}
break;
case LGLSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(LOGICAL(result)[i*nr]),
&(LOGICAL(x)[i*nrs_x]),
nrs_x*sizeof(int));
memcpy(&(LOGICAL(result)[i*nr + nrs_x]),
&(LOGICAL(y)[i*nrs_y]),
nrs_y*sizeof(int));
}
break;
case CPLXSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(COMPLEX(result)[i*nr]),
&(COMPLEX(x)[i*nrs_x]),
nrs_x*sizeof(Rcomplex));
memcpy(&(COMPLEX(result)[i*nr + nrs_x]),
&(COMPLEX(y)[i*nrs_y]),
nrs_y*sizeof(Rcomplex));
}
break;
case RAWSXP:
for(i=0; i< ncs_x; i++) {
memcpy(&(RAW(result)[i*nr]),
&(RAW(x)[i*nrs_x]),
nrs_x*sizeof(Rbyte));
memcpy(&(RAW(result)[i*nr + nrs_x]),
&(RAW(y)[i*nrs_y]),
nrs_y*sizeof(Rbyte));
}
break;
case STRSXP:
/* this requires an explicit loop like rbind.c and
needs to be left with rbind.c
*/
break;
default:
error("unsupported type");
}
copyAttributes(x, result);
SEXP index, xindex, yindex;
xindex = getAttrib(x,install("index"));
yindex = getAttrib(y,install("index"));
int INDEXTYPE = TYPEOF(xindex);
if(INDEXTYPE != NILSXP) {
PROTECT(index = allocVector(INDEXTYPE, nr));
if(INDEXTYPE==REALSXP) {
memcpy(REAL(index), REAL(xindex), nrs_x * sizeof(double));
memcpy(&(REAL(index)[nrs_x]), REAL(yindex), nrs_y * sizeof(double));
} else
if(INDEXTYPE==INTSXP) {
memcpy(INTEGER(index), INTEGER(xindex), nrs_x * sizeof(int));
memcpy(&(INTEGER(index)[nrs_x]), INTEGER(yindex), nrs_y * sizeof(int));
}
copyMostAttrib(xindex, index);
setAttrib(result, install("index"), index);
UNPROTECT(1);
}
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = nr;
INTEGER(dim)[1] = ncs_x; /* should be the same */
setAttrib(result, R_DimSymbol, dim);
UNPROTECT(1);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
/*
SEXP dimnames, currentnames, newnames;
PROTECT(dimnames = allocVector(VECSXP, 2));
PROTECT(newnames = allocVector(STRSXP, length(j)));
currentnames = getAttrib(x, R_DimNamesSymbol);
if(!isNull(currentnames)) {
SET_VECTOR_ELT(dimnames, 0, R_NilValue);
for(i=0; i<ncs_x; i++) {
SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), i));
}
SET_VECTOR_ELT(dimnames, 1, newnames);
setAttrib(result, R_DimNamesSymbol, dimnames);
}
UNPROTECT(2);
*/
UNPROTECT(1);
return result;
}
//SEXP do_rbind_xts (SEXP x, SEXP y, SEXP env) {{{
SEXP do_rbind_xts (SEXP x, SEXP y, SEXP dup)
{
int nrx, ncx, nry, ncy, truelen, len;
int no_duplicate = LOGICAL(dup)[0];
int i, j, ij, ij_x, ij_y, xp=1, yp=1, add_y=0;
int P=0; // PROTECT counter
int mode;
SEXP result, xindex, yindex, newindex;
int *int_result=NULL, *int_x=NULL, *int_y=NULL;
int *int_newindex=NULL, *int_xindex=NULL, *int_yindex=NULL;
double *real_result=NULL, *real_x=NULL, *real_y=NULL;
double *real_newindex=NULL, *real_xindex=NULL, *real_yindex=NULL;
nrx = nrows(x);
ncx = ncols(x);
nry = nrows(y);
ncy = ncols(y);
truelen = len = nrx + nry;
if( isNull(x) || isNull(y) ) {
/* Handle NULL values by returning non-null object */
if(!isNull(x)) return x;
return y;
}
if( !isXts(x) ) {
PROTECT( x = tryXts(x) ); P++;
}
if( !isXts(y) ) {
PROTECT( y = tryXts(y) ); P++;
}
/* need to convert different types of x and y if needed */
if( TYPEOF(x) != TYPEOF(y) ) {
warning("mismatched types: converting objects to numeric"); // FIXME not working!!!????
PROTECT(x = coerceVector(x, REALSXP)); P++;
PROTECT(y = coerceVector(y, REALSXP)); P++;
}
mode = TYPEOF(x);
if(ncx != ncy)
error("data must have same number of columns to bind by row");
PROTECT(xindex = getAttrib(x, xts_IndexSymbol)); P++;
PROTECT(yindex = getAttrib(y, xts_IndexSymbol)); P++;
if( TYPEOF(xindex) != TYPEOF(yindex) )
{
PROTECT(xindex = coerceVector(xindex, REALSXP)); P++;
PROTECT(yindex = coerceVector(yindex, REALSXP)); P++;
}
#ifdef RBIND_APPEND
if(TYPEOF(xindex)==REALSXP) {
if(REAL(xindex)[length(xindex)-1] < REAL(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
} else
if(TYPEOF(xindex)==INTSXP) {
if(INTEGER(xindex)[length(xindex)-1] < INTEGER(yindex)[0]) {
UNPROTECT(P);
return rbind_append(x,y);
}
}
#endif
PROTECT(newindex = allocVector(TYPEOF(xindex), len)); P++;
PROTECT(result = allocVector(TYPEOF(x), len * ncx)); P++;
copyMostAttrib(xindex, newindex);
switch( TYPEOF(x) ) {
case INTSXP:
int_x = INTEGER(x);
int_y = INTEGER(y);
int_result = INTEGER(result);
break;
case REALSXP:
real_x = REAL(x);
real_y = REAL(y);
real_result = REAL(result);
break;
default:
break;
}
/*
if( TYPEOF(xindex) == REALSXP ) {
if(REAL(xindex)[nrx-1] < REAL(yindex)[0]) {
memcpy(REAL(newindex), REAL(xindex), sizeof(double) * nrx);
memcpy(REAL(newindex)+nrx, REAL(yindex), sizeof(double) * nry);
switch(TYPEOF(x)) {
case INTSXP:
memcpy(INTEGER(result), INTEGER(x), sizeof(int) * (nrx*ncx));
memcpy(INTEGER(result)+(nrx*ncx), INTEGER(y), sizeof(int) * (nry*ncy));
break;
case REALSXP:
memcpy(REAL(result), REAL(x), sizeof(double) * (nrx*ncx));
memcpy(REAL(result)+(nrx*ncx), REAL(y), sizeof(double) * (nry*ncy));
break;
default:
break;
}
UNPROTECT(P);
return(result);
}
} else {
}
*/
/*
The main body of code to follow branches based on the type
of index, removing the need to test at each position.
*/
if( TYPEOF(xindex) == REALSXP ) {
real_newindex = REAL(newindex);
real_xindex = REAL(xindex);
real_yindex = REAL(yindex);
for( i = 0; i < len; i++ ) {
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) {
if( real_xindex[ xp-1 ] < real_xindex[ xp ] )
add_y = 1; /* add y values only if next xindex is new */
if(no_duplicate) {
add_y = 0;
truelen--;
}
real_newindex[ i ] = real_xindex[ xp-1 ];
if(add_y) real_newindex[ i+ 1 ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) {
real_newindex[ i ] = real_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}
}
} else
if( TYPEOF(xindex) == INTSXP ) {
int_newindex = INTEGER(newindex);
int_xindex = INTEGER(xindex);
int_yindex = INTEGER(yindex);
for(i = 0; i < len; i++) {
/*Rprintf("xp:%i, yp:%i, i:%i\n",xp,yp,i);*/
if( i >= truelen ) {
break;
} else
if( xp > nrx ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
} else
if( yp > nry ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) {
if( int_xindex[ xp-1 ] < int_xindex[ xp ] )
add_y = 1;
if(no_duplicate) {
add_y = 0;
truelen--;
}
int_newindex[ i ] = int_xindex[ xp-1 ];
if(add_y) int_newindex[ i+1 ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
if(add_y) int_result[ ij+1 ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
if(add_y) real_result[ ij+1 ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
xp++;
if(no_duplicate || add_y) {
yp++;
if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values
add_y = 0;
}
} else
if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_xindex[ xp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_x = (xp-1) + j * nrx;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ];
break;
case INTSXP:
int_result[ ij ] = int_x[ ij_x ];
break;
case REALSXP:
real_result[ ij ] = real_x[ ij_x ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x));
break;
default:
break;
}
}
xp++;
} else
if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) {
int_newindex[ i ] = int_yindex[ yp-1 ];
for(j = 0; j < ncx; j++) {
ij = i + j * len;
ij_y = (yp-1) + j * nry;
switch( mode ) {
case LGLSXP:
LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ];
break;
case INTSXP:
int_result[ ij ] = int_y[ ij_y ];
break;
case REALSXP:
real_result[ ij ] = real_y[ ij_y ];
break;
case CPLXSXP:
COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ];
break;
case STRSXP:
SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y));
break;
default:
break;
}
}
yp++;
}}
}
if(truelen != len) {
PROTECT(result = lengthgets(result, truelen * ncx)); P++; /* reset length */
}
setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
SEXP dim;
PROTECT(dim = allocVector(INTSXP, 2));
INTEGER(dim)[0] = truelen;
INTEGER(dim)[1] = INTEGER(getAttrib(x, R_DimSymbol))[1];
UNPROTECT(1);
setAttrib(result, R_DimSymbol, dim);
setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
if(truelen != len) {
PROTECT(newindex = lengthgets(newindex, truelen)); P++;
}
setAttrib(result, xts_IndexSymbol, newindex);
setAttrib(result, xts_IndexClassSymbol, getAttrib(x, xts_IndexClassSymbol));
setAttrib(result, xts_IndexTZSymbol, getAttrib(x, xts_IndexTZSymbol));
setAttrib(result, xts_IndexFormatSymbol, getAttrib(x, xts_IndexFormatSymbol));
setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol));
copy_xtsAttributes(x, result);
UNPROTECT(P);
return result;
} //}}}
SEXP coxexact(SEXP maxiter2, SEXP y2,
SEXP covar2, SEXP offset2, SEXP strata2,
SEXP ibeta, SEXP eps2, SEXP toler2) {
int i,j,k;
int iter;
double **covar, **imat; /*ragged arrays */
double *time, *status; /* input data */
double *offset;
int *strata;
int sstart; /* starting obs of current strata */
double *score;
double *oldbeta;
double zbeta;
double newlk=0;
double temp;
int halving; /*are we doing step halving at the moment? */
int nrisk; /* number of subjects in the current risk set */
int dsize, /* memory needed for one coxc0, coxc1, or coxd2 array */
dmemtot, /* amount needed for all arrays */
maxdeath, /* max tied deaths within a strata */
ndeath; /* number of deaths at the current time point */
double dtime; /* time value under current examiniation */
double *dmem0, **dmem1, *dmem2; /* pointers to memory */
double *dtemp; /* used for zeroing the memory */
double *d1; /* current first derivatives from coxd1 */
double d0; /* global sum from coxc0 */
/* copies of scalar input arguments */
int nused, nvar, maxiter;
double eps, toler;
/* returned objects */
SEXP imat2, beta2, u2, loglik2;
double *beta, *u, *loglik;
SEXP rlist, rlistnames;
int nprotect; /* number of protect calls I have issued */
nused = LENGTH(offset2);
nvar = ncols(covar2);
maxiter = asInteger(maxiter2);
eps = asReal(eps2); /* convergence criteria */
toler = asReal(toler2); /* tolerance for cholesky */
/*
** Set up the ragged array pointer to the X matrix,
** and pointers to time and status
*/
covar= dmatrix(REAL(covar2), nused, nvar);
time = REAL(y2);
status = time +nused;
strata = INTEGER(PROTECT(duplicate(strata2)));
offset = REAL(offset2);
/* temporary vectors */
score = (double *) R_alloc(nused+nvar, sizeof(double));
oldbeta = score + nused;
/*
** create output variables
*/
PROTECT(beta2 = duplicate(ibeta));
beta = REAL(beta2);
PROTECT(u2 = allocVector(REALSXP, nvar));
u = REAL(u2);
PROTECT(imat2 = allocVector(REALSXP, nvar*nvar));
imat = dmatrix(REAL(imat2), nvar, nvar);
PROTECT(loglik2 = allocVector(REALSXP, 5)); /* loglik, sctest, flag,maxiter*/
loglik = REAL(loglik2);
nprotect = 5;
strata[0] =1; /* in case the parent forgot */
dsize = 0;
maxdeath =0;
j=0; /* start of the strata */
for (i=0; i<nused;) {
if (strata[i]==1) { /* first obs of a new strata */
if (i>0) {
/* If maxdeath <2 leave the strata alone at it's current value of 1 */
if (maxdeath >1) strata[j] = maxdeath;
j = i;
if (maxdeath*nrisk >dsize) dsize = maxdeath*nrisk;
}
maxdeath =0; /* max tied deaths at any time in this strata */
nrisk=0;
ndeath =0;
}
dtime = time[i];
ndeath =0; /*number tied here */
while (time[i] ==dtime) {
nrisk++;
ndeath += status[i];
i++;
if (i>=nused || strata[i] >0) break; /*tied deaths don't cross strata */
}
if (ndeath > maxdeath) maxdeath=ndeath;
}
if (maxdeath*nrisk >dsize) dsize = maxdeath*nrisk;
if (maxdeath >1) strata[j] = maxdeath;
/* Now allocate memory for the scratch arrays
Each per-variable slice is of size dsize
*/
dmemtot = dsize * ((nvar*(nvar+1))/2 + nvar + 1);
dmem0 = (double *) R_alloc(dmemtot, sizeof(double)); /*pointer to memory */
dmem1 = (double **) R_alloc(nvar, sizeof(double*));
dmem1[0] = dmem0 + dsize; /*points to the first derivative memory */
for (i=1; i<nvar; i++) dmem1[i] = dmem1[i-1] + dsize;
d1 = (double *) R_alloc(nvar, sizeof(double)); /*first deriv results */
/*
** do the initial iteration step
*/
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0 ;
}
for (i=0; i<nused; ) {
if (strata[i] >0) { /* first obs of a new strata */
maxdeath= strata[i];
dtemp = dmem0;
for (j=0; j<dmemtot; j++) *dtemp++ =0.0;
sstart =i;
nrisk =0;
}
dtime = time[i]; /*current unique time */
ndeath =0;
while (time[i] == dtime) {
zbeta= offset[i];
for (j=0; j<nvar; j++) zbeta += covar[j][i] * beta[j];
score[i] = exp(zbeta);
if (status[i]==1) {
newlk += zbeta;
for (j=0; j<nvar; j++) u[j] += covar[j][i];
ndeath++;
}
nrisk++;
i++;
if (i>=nused || strata[i] >0) break;
}
/* We have added up over the death time, now process it */
if (ndeath >0) { /* Add to the loglik */
d0 = coxd0(ndeath, nrisk, score+sstart, dmem0, maxdeath);
R_CheckUserInterrupt();
newlk -= log(d0);
dmem2 = dmem0 + (nvar+1)*dsize; /*start for the second deriv memory */
for (j=0; j<nvar; j++) { /* for each covariate */
d1[j] = coxd1(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
covar[j]+sstart, maxdeath) / d0;
if (ndeath > 3) R_CheckUserInterrupt();
u[j] -= d1[j];
for (k=0; k<= j; k++) { /* second derivative*/
temp = coxd2(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
dmem1[k], dmem2, covar[j] + sstart,
covar[k] + sstart, maxdeath);
if (ndeath > 5) R_CheckUserInterrupt();
imat[k][j] += temp/d0 - d1[j]*d1[k];
dmem2 += dsize;
}
}
}
}
loglik[0] = newlk; /* save the loglik for iteration zero */
loglik[1] = newlk; /* and it is our current best guess */
/*
** update the betas and compute the score test
*/
for (i=0; i<nvar; i++) /*use 'd1' as a temp to save u0, for the score test*/
d1[i] = u[i];
loglik[3] = cholesky2(imat, nvar, toler);
chsolve2(imat,nvar, u); /* u replaced by u *inverse(imat) */
loglik[2] =0; /* score test stored here */
for (i=0; i<nvar; i++)
loglik[2] += u[i]*d1[i];
if (maxiter==0) {
iter =0; /*number of iterations */
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
/*
** Never, never complain about convergence on the first step. That way,
** if someone has to they can force one iter at a time.
*/
for (i=0; i<nvar; i++) {
oldbeta[i] = beta[i];
beta[i] = beta[i] + u[i];
}
halving =0 ; /* =1 when in the midst of "step halving" */
for (iter=1; iter<=maxiter; iter++) {
newlk =0;
for (i=0; i<nvar; i++) {
u[i] =0;
for (j=0; j<nvar; j++)
imat[i][j] =0;
}
for (i=0; i<nused; ) {
if (strata[i] >0) { /* first obs of a new strata */
maxdeath= strata[i];
dtemp = dmem0;
for (j=0; j<dmemtot; j++) *dtemp++ =0.0;
sstart =i;
nrisk =0;
}
dtime = time[i]; /*current unique time */
ndeath =0;
while (time[i] == dtime) {
zbeta= offset[i];
for (j=0; j<nvar; j++) zbeta += covar[j][i] * beta[j];
score[i] = exp(zbeta);
if (status[i]==1) {
newlk += zbeta;
for (j=0; j<nvar; j++) u[j] += covar[j][i];
ndeath++;
}
nrisk++;
i++;
if (i>=nused || strata[i] >0) break;
}
/* We have added up over the death time, now process it */
if (ndeath >0) { /* Add to the loglik */
d0 = coxd0(ndeath, nrisk, score+sstart, dmem0, maxdeath);
R_CheckUserInterrupt();
newlk -= log(d0);
dmem2 = dmem0 + (nvar+1)*dsize; /*start for the second deriv memory */
for (j=0; j<nvar; j++) { /* for each covariate */
d1[j] = coxd1(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
covar[j]+sstart, maxdeath) / d0;
if (ndeath > 3) R_CheckUserInterrupt();
u[j] -= d1[j];
for (k=0; k<= j; k++) { /* second derivative*/
temp = coxd2(ndeath, nrisk, score+sstart, dmem0, dmem1[j],
dmem1[k], dmem2, covar[j] + sstart,
covar[k] + sstart, maxdeath);
if (ndeath > 5) R_CheckUserInterrupt();
imat[k][j] += temp/d0 - d1[j]*d1[k];
dmem2 += dsize;
}
}
}
}
/* am I done?
** update the betas and test for convergence
*/
loglik[3] = cholesky2(imat, nvar, toler);
if (fabs(1-(loglik[1]/newlk))<= eps && halving==0) { /* all done */
loglik[1] = newlk;
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
if (iter==maxiter) break; /*skip the step halving and etc */
if (newlk < loglik[1]) { /*it is not converging ! */
halving =1;
for (i=0; i<nvar; i++)
beta[i] = (oldbeta[i] + beta[i]) /2; /*half of old increment */
}
else {
halving=0;
loglik[1] = newlk;
chsolve2(imat,nvar,u);
for (i=0; i<nvar; i++) {
oldbeta[i] = beta[i];
beta[i] = beta[i] + u[i];
}
}
} /* return for another iteration */
/*
** Ran out of iterations
*/
loglik[1] = newlk;
loglik[3] = 1000; /* signal no convergence */
loglik[4] = iter;
chinv2(imat, nvar);
for (i=1; i<nvar; i++)
for (j=0; j<i; j++) imat[i][j] = imat[j][i];
/* assemble the return objects as a list */
PROTECT(rlist= allocVector(VECSXP, 4));
SET_VECTOR_ELT(rlist, 0, beta2);
SET_VECTOR_ELT(rlist, 1, u2);
SET_VECTOR_ELT(rlist, 2, imat2);
SET_VECTOR_ELT(rlist, 3, loglik2);
/* add names to the list elements */
PROTECT(rlistnames = allocVector(STRSXP, 4));
SET_STRING_ELT(rlistnames, 0, mkChar("coef"));
SET_STRING_ELT(rlistnames, 1, mkChar("u"));
SET_STRING_ELT(rlistnames, 2, mkChar("imat"));
SET_STRING_ELT(rlistnames, 3, mkChar("loglik"));
setAttrib(rlist, R_NamesSymbol, rlistnames);
unprotect(nprotect+2);
return(rlist);
}
SEXP na_omit_xts (SEXP x)
{
SEXP na_index, not_na_index, col_index, result;
int i, j, ij, nr, nc;
int not_NA, NA;
nr = nrows(x);
nc = ncols(x);
not_NA = nr;
int *int_x=NULL, *int_na_index=NULL, *int_not_na_index=NULL;
double *real_x=NULL;
switch(TYPEOF(x)) {
case LGLSXP:
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(LOGICAL(x)[ij] == NA_LOGICAL) {
not_NA--;
break;
}
}
}
break;
case INTSXP:
int_x = INTEGER(x);
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(int_x[ij] == NA_INTEGER) {
not_NA--;
break;
}
}
}
break;
case REALSXP:
real_x = REAL(x);
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(ISNA(real_x[ij]) || ISNAN(real_x[ij])) {
not_NA--;
break;
}
}
}
break;
default:
error("unsupported type");
break;
}
if(not_NA==0) { /* all NAs */
return(allocVector(TYPEOF(x),0));
}
if(not_NA==0 || not_NA==nr)
return(x);
PROTECT(not_na_index = allocVector(INTSXP, not_NA));
PROTECT(na_index = allocVector(INTSXP, nr-not_NA));
/* pointers for efficiency as INTEGER in package code is a function call*/
int_not_na_index = INTEGER(not_na_index);
int_na_index = INTEGER(na_index);
not_NA = NA = 0;
switch(TYPEOF(x)) {
case LGLSXP:
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(LOGICAL(x)[ij] == NA_LOGICAL) {
int_na_index[NA] = i+1;
NA++;
break;
}
if(j==(nc-1)) {
/* make it to end of column, OK*/
int_not_na_index[not_NA] = i+1;
not_NA++;
}
}
}
break;
case INTSXP:
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(int_x[ij] == NA_INTEGER) {
int_na_index[NA] = i+1;
NA++;
break;
}
if(j==(nc-1)) {
/* make it to end of column, OK*/
int_not_na_index[not_NA] = i+1;
not_NA++;
}
}
}
break;
case REALSXP:
for(i=0; i<nr; i++) {
for(j=0; j<nc; j++) {
ij = i + j*nr;
if(ISNA(real_x[ij]) || ISNAN(real_x[ij])) {
int_na_index[NA] = i+1;
NA++;
break;
}
if(j==(nc-1)) {
/* make it to end of column, OK*/
int_not_na_index[not_NA] = i+1;
not_NA++;
}
}
}
break;
default:
error("unsupported type");
break;
}
PROTECT(col_index = allocVector(INTSXP, nc));
for(i=0; i<nc; i++)
INTEGER(col_index)[i] = i+1;
PROTECT(result = do_subset_xts(x, not_na_index, col_index, ScalarLogical(0)));
SEXP class;
PROTECT(class = allocVector(STRSXP, 1));
SET_STRING_ELT(class, 0, mkChar("omit"));
setAttrib(na_index, R_ClassSymbol, class);
UNPROTECT(1);
setAttrib(result, install("na.action"), na_index);
UNPROTECT(4);
return(result);
}
//! Fill all entries of the matrix with the given value.
void
fill (const Scalar value)
{
fill_matrix (nrows(), ncols(), get(), lda(), value);
}
SEXP do_getF(SEXP perms, SEXP E, SEXP QR, SEXP QZ, SEXP first,
SEXP isPartial, SEXP isDB)
{
int i, j, k, ki,
nperm = nrows(perms), nr = nrows(E), nc = ncols(E),
FIRST = asInteger(first), PARTIAL = asInteger(isPartial),
DISTBASED = asInteger(isDB);
double ev1;
SEXP ans = PROTECT(allocMatrix(REALSXP, nperm, 2));
double *rans = REAL(ans);
SEXP Y = PROTECT(duplicate(E));
double *rY = REAL(Y);
/* pointers and new objects to the QR decomposition */
double *qr = REAL(VECTOR_ELT(QR, 0));
int qrank = asInteger(VECTOR_ELT(QR, 1));
double *qraux = REAL(VECTOR_ELT(QR, 2));
double *Zqr, *Zqraux;
int Zqrank;
if (PARTIAL) {
Zqr = REAL(VECTOR_ELT(QZ, 0));
Zqrank = asInteger(VECTOR_ELT(QZ, 1));
Zqraux = REAL(VECTOR_ELT(QZ, 2));
}
double *fitted = (double *) R_alloc(nr * nc, sizeof(double));
/* separate resid needed only in some cases */
double *resid;
if (PARTIAL || FIRST)
resid = (double *) R_alloc(nr * nc, sizeof(double));
/* work array and variables for QR decomposition */
double *qty = (double *) R_alloc(nr, sizeof(double));
double dummy;
int info, qrkind;
/* distance-based methods need to transpose data */
double *transY;
if (DISTBASED)
transY = (double *) R_alloc(nr * nr, sizeof(double));
/* permutation matrix must be duplicated */
SEXP dperms = PROTECT(duplicate(perms));
int *iperm = INTEGER(dperms);
/* permutations to zero base */
for(i = 0; i < nperm * nr; i++)
iperm[i]--;
/* loop over rows of permutation matrix */
for (k = 0; k < nperm; k++) {
/* Y will be permuted data */
for (i = 0; i < nr; i++) {
ki = iperm[k + nperm * i];
for(j = 0; j < nc; j++) {
if (DISTBASED) /* shuffle rows & cols symmetrically */
rY[i + nr*j] = REAL(E)[ki + nr * iperm[k + nperm*j]];
else /* shuffle rows */
rY[i + nr*j] = REAL(E)[ki + nr*j];
}
}
/* Partial model: qr.resid(QZ, Y) with LINPACK */
if (PARTIAL) {
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux, rY + i*nr,
&dummy, qty, &dummy, rY + i*nr, &dummy,
&qrkind, &info);
/* distances need symmetric residuals */
if (DISTBASED) {
transpose(rY, transY, nr, nr);
qrkind = RESID;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(Zqr, &nr, &nr, &Zqrank, Zqraux,
transY + i*nr, &dummy, qty, &dummy,
rY + i*nr, &dummy, &qrkind, &info);
}
}
/* CONSTRAINED COMPONENT */
/* qr.fitted(QR, Y) + qr.resid(QR, Y) with LINPACK */
if (PARTIAL || FIRST)
qrkind = FIT + RESID;
else
qrkind = FIT;
for (i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux, rY + i*nr, &dummy,
qty, &dummy, resid + i*nr, fitted + i*nr,
&qrkind, &info);
/* Eigenvalues: either sum of all or the first If the sum of
* all eigenvalues does not change, we have only ev of CCA
* component in the first column, and the second column is
* rubbish that should be filled in the calling R function
* with the correct value. */
if (FIRST) {
if (DISTBASED) { /* needs symmetric matrix */
transpose(fitted, transY, nr, nr);
qrkind = FIT;
for(i = 0; i < nc; i++)
F77_CALL(dqrsl)(qr, &nr, &nr, &qrank, qraux,
transY + i*nr, &dummy, qty, &dummy,
&dummy, fitted + i*nr, &qrkind, &info);
ev1 = eigenfirst(fitted, nr);
} else {
ev1 = svdfirst(fitted, nr, nc);
ev1 = ev1 * ev1;
}
rans[k] = ev1;
} else {
rans[k] = getEV(fitted, nr, nc, DISTBASED);
}
if (PARTIAL || FIRST)
rans[k + nperm] = getEV(resid, nr, nc, DISTBASED);
} /* end permutation loop */
UNPROTECT(3);
return ans;
}
