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 melt_dataframe( SEXP x, SEXP id_ind_, SEXP val_ind_, SEXP variable_name, SEXP value_name ) { if (length(x) == 0) { error("Can't melt a data.frame with 0 columns"); } if (length(VECTOR_ELT(x, 0)) == 0) { error("Can't melt a data.frame with 0 rows"); } int* id_ind = INTEGER(id_ind_); int* val_ind = INTEGER(val_ind_); int nColStack = length(id_ind_); int nColRep = length(val_ind_); int nRow = length( VECTOR_ELT(x, 0) ); int out_nRow = nRow * nColRep; int out_nCol = nColStack + 2; char mt = max_type(x, val_ind_); if (mt > STRSXP) { error("Error: cannot melt data.frames w/ elements of type '%s'", CHAR(type2str(mt))); } if (diff_types(x, val_ind_)) { warning("Coercing type of 'value' variables to '%s'", CHAR(type2str(mt))); } SEXP out; PROTECT(out = allocVector( VECSXP, out_nCol )); // populate the value array SEXP value_SEXP; #define HANDLE_CASE( RTYPE, CTYPE ) \ case RTYPE: { \ PROTECT( value_SEXP = allocVector( RTYPE, value_len ) ); \ SEXP tmp; \ for( int i=0; i < nColRep; ++i ) { \ if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \ tmp = PROTECT( coerceVector( VECTOR_ELT(x, val_ind[i]), mt ) ); \ } else { \ tmp = VECTOR_ELT(x, val_ind[i]); \ } \ memcpy( \ (char*) DATAPTR(value_SEXP) + (i*nRow*sizeof(CTYPE)), \ (char*) DATAPTR(tmp), \ nRow * sizeof(CTYPE) \ ); \ if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { \ UNPROTECT(1); \ } \ } \ break; \ } \ int value_len = nColRep * nRow; int value_type = mt; switch( value_type ) { HANDLE_CASE( INTSXP, int ); HANDLE_CASE( REALSXP, double ); HANDLE_CASE( LGLSXP, int ); case STRSXP: { int counter = 0; SEXP* curr_str_vec_ptr; SEXP tmp; PROTECT( value_SEXP = allocVector( STRSXP, value_len ) ); for( int i=0; i < nColRep; ++i ) { #define curr_str_vec (VECTOR_ELT(x, val_ind[i])) if (TYPEOF(curr_str_vec) != STRSXP) { if (isFactor(curr_str_vec)) { PROTECT(tmp = asCharacterFactor(curr_str_vec)); } else { PROTECT(tmp = coerceVector(curr_str_vec, STRSXP)); } curr_str_vec_ptr = STRING_PTR(tmp); } else { curr_str_vec_ptr = STRING_PTR(curr_str_vec); } #undef curr_str_vec SEXP* value_SEXP_ptr = STRING_PTR( value_SEXP ); for( int j=0; j < nRow; ++j ) { value_SEXP_ptr[counter] = curr_str_vec_ptr[j]; ++counter; } if (TYPEOF( VECTOR_ELT(x, val_ind[i]) ) != mt) { UNPROTECT(1); } } break; } default: error("Unsupported RTYPE encountered"); } #undef HANDLE_CASE // generate the id variables, and assign them on generation // we need to convert factors if necessary for( int i=0; i < nColStack; ++i ) { SET_VECTOR_ELT( out, i, stack_vector( VECTOR_ELT( x, id_ind[i] ), nColRep )); if (isFactor( VECTOR_ELT(x, id_ind[i]) )) { setAttrib( VECTOR_ELT(out, i), R_ClassSymbol, mkString("factor") ); setAttrib( VECTOR_ELT(out, i), R_LevelsSymbol, getAttrib( VECTOR_ELT(x, id_ind[i]), R_LevelsSymbol ) ); } } // assign the names, values SET_VECTOR_ELT( out, nColStack, rep_each_char( getAttrib( x, R_NamesSymbol ), val_ind_, nRow ) ); SET_VECTOR_ELT( out, nColStack+1, value_SEXP ); UNPROTECT(1); // value_SEXP // set the row names SEXP row_names; PROTECT( row_names = allocVector(INTSXP, out_nRow) ); int* row_names_ptr = INTEGER(row_names); for( int i=0; i < out_nRow; ++i ) { row_names_ptr[i] = i+1; } setAttrib( out, R_RowNamesSymbol, row_names ); UNPROTECT(1); // row_names // set the class to data.frame setAttrib(out, R_ClassSymbol, mkString("data.frame")); // set the names SEXP names = getAttrib(x, R_NamesSymbol); SEXP names_out; PROTECT(names_out = allocVector( STRSXP, out_nCol )); SEXP* names_ptr = STRING_PTR(names); SEXP* names_out_ptr = STRING_PTR(names_out); for (int i=0; i < nColStack; ++i) { names_out_ptr[i] = names_ptr[ id_ind[i] ]; } SET_STRING_ELT( names_out, nColStack, STRING_ELT(variable_name, 0) ); SET_STRING_ELT( names_out, nColStack+1, STRING_ELT(value_name, 0) ); setAttrib( out, R_NamesSymbol, names_out ); UNPROTECT(1); // names_out UNPROTECT(1); // out return out; }
SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) { SEXP result, index, new_index; int nrs, nrsx, i, ii, jj, first, last; nrsx = nrows(x); first = asInteger(first_)-1; last = asInteger(last_)-1; /* nrs = offset_end - offset_start - 1; */ nrs = last - first + 1; PROTECT(result = allocVector(TYPEOF(x), nrs * length(j))); switch(TYPEOF(x)) { case REALSXP: for(i=0; i<length(j); i++) { /* Rprintf("j + i*nrs + first=%i\n", (int)(INTEGER(j)[i]-1 + i*nrs + first)); Rprintf("i=%i, j=%i, nrs=%i, first=%i\n", i, INTEGER(j)[i]-1, nrs, first); */ if(INTEGER(j)[i] == NA_INTEGER) { for(ii=0; ii < nrs; ii++) { REAL(result)[(i*nrs) + ii] = NA_REAL; } } else { memcpy(&(REAL(result)[i*nrs]), &(REAL(x)[(INTEGER(j)[i]-1)*nrsx + first]), nrs*sizeof(double)); } } break; case INTSXP: for(i=0; i<length(j); i++) { if(INTEGER(j)[i] == NA_INTEGER) { for(ii=0; ii < nrs; ii++) { INTEGER(result)[(i*nrs) + ii] = NA_INTEGER; } } else { memcpy(&(INTEGER(result)[i*nrs]), &(INTEGER(x)[(INTEGER(j)[i]-1)*nrsx + first]), nrs*sizeof(int)); } } break; case LGLSXP: for(i=0; i<length(j); i++) { if(INTEGER(j)[i] == NA_INTEGER) { for(ii=0; ii < nrs; ii++) { LOGICAL(result)[(i*nrs) + ii] = NA_LOGICAL; } } else { memcpy(&(LOGICAL(result)[i*nrs]), &(LOGICAL(x)[(INTEGER(j)[i]-1)*nrsx + first]), nrs*sizeof(int)); } } break; case CPLXSXP: for(i=0; i<length(j); i++) { if(INTEGER(j)[i] == NA_INTEGER) { for(ii=0; ii < nrs; ii++) { COMPLEX(result)[(i*nrs) + ii].r = NA_REAL; COMPLEX(result)[(i*nrs) + ii].i = NA_REAL; } } else { memcpy(&(COMPLEX(result)[i*nrs]), &(COMPLEX(x)[(INTEGER(j)[i]-1)*nrsx + first]), nrs*sizeof(Rcomplex)); } } break; case RAWSXP: for(i=0; i<length(j); i++) { if(INTEGER(j)[i] == NA_INTEGER) { for(ii=0; ii < nrs; ii++) { RAW(result)[(i*nrs) + ii] = 0; } } else { memcpy(&(RAW(result)[i*nrs]), &(RAW(x)[(INTEGER(j)[i]-1)*nrsx + first]), nrs*sizeof(Rbyte)); } } break; case STRSXP: for(jj=0; jj<length(j); jj++) { if(INTEGER(j)[jj] == NA_INTEGER) { for(i=0; i< nrs; i++) SET_STRING_ELT(result, i+jj*nrs, NA_STRING); } else { for(i=0; i< nrs; i++) SET_STRING_ELT(result, i+jj*nrs, STRING_ELT(x, i+(INTEGER(j)[jj]-1)*nrsx+first)); } } break; default: error("unsupported type"); } if(nrs != nrows(x)) { copyAttributes(x, result); /* subset index */ index = getAttrib(x, xts_IndexSymbol); PROTECT(new_index = allocVector(TYPEOF(index), nrs)); if(TYPEOF(index) == REALSXP) { memcpy(REAL(new_index), &(REAL(index)[first]), nrs*sizeof(double)); } else { /* INTSXP */ memcpy(INTEGER(new_index), &(INTEGER(index)[first]), nrs*sizeof(int)); } copyMostAttrib(index, new_index); setAttrib(result, xts_IndexSymbol, new_index); UNPROTECT(1); } else { copyMostAttrib(x, result); /* need an xts/zoo equal that skips 'index' */ } if(!asLogical(drop)) { /* keep dimension and dimnames */ SEXP dim; PROTECT(dim = allocVector(INTSXP, 2)); INTEGER(dim)[0] = nrs; INTEGER(dim)[1] = length(j); setAttrib(result, R_DimSymbol, dim); UNPROTECT(1); 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, VECTOR_ELT(currentnames,0)); if(!isNull(VECTOR_ELT(currentnames,1))) { /* if colnames isn't NULL set */ for(i=0; i<length(j); i++) { if(INTEGER(j)[i] == NA_INTEGER) { SET_STRING_ELT(newnames, i, NA_STRING); } else { SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), INTEGER(j)[i]-1)); } } SET_VECTOR_ELT(dimnames, 1, newnames); } else { /* else set to NULL */ SET_VECTOR_ELT(dimnames, 1, R_NilValue); } setAttrib(result, R_DimNamesSymbol, dimnames); } UNPROTECT(2); } UNPROTECT(1); 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); }
SEXP entropy_loss(SEXP fitted, SEXP orig_data, SEXP by_sample, SEXP keep, SEXP debug) { int i = 0, k = 0, ndata = 0, nnodes = LENGTH(fitted), nlevels = 0, type = 0; int *configs = NULL, *debuglevel = LOGICAL(debug), *by = LOGICAL(by_sample); int *to_keep = NULL; double *res = 0, *res_sample = NULL, **columns = 0, cur_loss = 0; const char *class = NULL; SEXP data, cur_node, nodes, result, result_sample, coefs, sd, parents, try; /* get the node labels. */ nodes = getAttrib(fitted, R_NamesSymbol); /* rearrange the columns of the data to match the network. */ PROTECT(data = c_dataframe_column(orig_data, nodes, FALSE, TRUE)); /* get the sample size. */ ndata = LENGTH(VECTOR_ELT(data, 0)); /* allocate and initialize the return value. */ PROTECT(result = allocVector(REALSXP, 1)); res = REAL(result); *res = 0; /* allocate the sample's contributions if needed. */ if (*by > 0) { PROTECT(result_sample = allocVector(REALSXP, ndata)); res_sample = REAL(result_sample); memset(res_sample, '\0', ndata * sizeof(double)); }/*THEN*/ /* find out which nodes to use in computing the entropy loss. */ PROTECT(try = match(nodes, keep, 0)); to_keep = INTEGER(try); R_isort(to_keep, LENGTH(try)); /* determine the class of the fitted network. */ class = CHAR(STRING_ELT(getAttrib(VECTOR_ELT(fitted, 0), R_ClassSymbol), 0)); if (strcmp(class, "bn.fit.gnode") == 0) { /* dereference the data set's columns. */ columns = (double **) alloc1dpointer(nnodes); for (i = 0; i < nnodes; i++) columns[i] = REAL(VECTOR_ELT(data, i)); type = GAUSSIAN; }/*THEN*/ else if ((strcmp(class, "bn.fit.dnode") == 0) || (strcmp(class, "bn.fit.onode") == 0)) { /* allocate an array for parents' configurations. */ configs = alloc1dcont(ndata); type = DISCRETE; }/*THEN*/ /* iterate over the nodes. */ for (i = 0; i < nnodes; i++) { if (i == to_keep[k] - 1) { k++; }/*THEN*/ else { if (*debuglevel > 0) Rprintf(" > skipping node %s.\n", NODE(i)); continue; }/*ELSE*/ /* get the current node. */ cur_node = VECTOR_ELT(fitted, i); /* get the parents of the node. */ parents = getListElement(cur_node, "parents"); /* get the parameters (regression coefficients and residuals' standard * deviation for Gaussian nodes, conditional probabilities for discrete * nodes), and compute the loss. */ switch(type) { case GAUSSIAN: coefs = getListElement(cur_node, "coefficients"); sd = getListElement(cur_node, "sd"); cur_loss = c_gloss(&i, parents, REAL(coefs), REAL(sd), columns, nodes, ndata, res_sample); break; case DISCRETE: coefs = getListElement(cur_node, "prob"); nlevels = INT(getAttrib(coefs, R_DimSymbol)); cur_loss = c_dloss(&i, parents, configs, REAL(coefs), data, nodes, ndata, nlevels, res_sample); break; }/*SWITCH*/ if (*debuglevel > 0) Rprintf(" > log-likelihood loss for node %s is %lf.\n", NODE(i), cur_loss); /* add the node contribution to the return value. */ *res += cur_loss; }/*FOR*/ if (*by > 0) { UNPROTECT(4); return result_sample; }/*THEN*/ else { UNPROTECT(3); return result; }/*ELSE*/ }/*ENTROPY_LOSS*/
/** * Callback if the remote host requires authentication in order to * connect to it * * @param cred The newly created credential object. * @param url The resource for which we are demanding a credential. * @param user_from_url The username that was embedded in a "user@host" * remote url, or NULL if not included. * @param allowed_types A bitmask stating which cred types are OK to return. * @param payload The payload provided when specifying this callback. * @return 0 on success, else -1. */ int git2r_cred_acquire_cb( git_cred **cred, const char *url, const char *username_from_url, unsigned int allowed_types, void *payload) { int err = -1; SEXP credentials = (SEXP)payload; GIT_UNUSED(url); if (R_NilValue != credentials) { SEXP class_name; class_name = getAttrib(credentials, R_ClassSymbol); if (0 == strcmp(CHAR(STRING_ELT(class_name, 0)), "cred_ssh_key")) { if (GIT_CREDTYPE_SSH_KEY & allowed_types) { SEXP slot; const char *publickey; const char *privatekey = NULL; const char *passphrase = NULL; publickey = CHAR(STRING_ELT( GET_SLOT(credentials, Rf_install("publickey")), 0)); privatekey = CHAR(STRING_ELT( GET_SLOT(credentials, Rf_install("privatekey")), 0)); slot = GET_SLOT(credentials, Rf_install("passphrase")); if (length(slot)) { if (NA_STRING != STRING_ELT(slot, 0)) passphrase = CHAR(STRING_ELT(slot, 0)); } err = git_cred_ssh_key_new( cred, username_from_url, publickey, privatekey, passphrase); } } else if (0 == strcmp(CHAR(STRING_ELT(class_name, 0)), "cred_plaintext")) { if (GIT_CREDTYPE_USERPASS_PLAINTEXT & allowed_types) { const char *username; const char *password; username = CHAR(STRING_ELT( GET_SLOT(credentials, Rf_install("username")), 0)); password = CHAR(STRING_ELT( GET_SLOT(credentials, Rf_install("password")), 0)); err = git_cred_userpass_plaintext_new(cred, username, password); } } } else if (GIT_CREDTYPE_SSH_KEY & allowed_types) { err = git_cred_ssh_key_from_agent(cred, username_from_url); } return err; }
SEXP impliedLinearity(SEXP m, SEXP h) { GetRNGstate(); if (! isMatrix(m)) error("'m' must be matrix"); if (! isLogical(h)) error("'h' must be logical"); if (LENGTH(h) != 1) error("'h' must be scalar"); if (! isString(m)) error("'m' must be character"); SEXP m_dim; PROTECT(m_dim = getAttrib(m, R_DimSymbol)); int nrow = INTEGER(m_dim)[0]; int ncol = INTEGER(m_dim)[1]; UNPROTECT(1); if (nrow <= 1) error("no use if only one row"); if (ncol <= 3) error("no use if only one col"); for (int i = 0; i < nrow; i++) { const char *foo = CHAR(STRING_ELT(m, i)); if (strlen(foo) != 1) error("column one of 'm' not zero-or-one valued"); if (! (foo[0] == '0' || foo[0] == '1')) error("column one of 'm' not zero-or-one valued"); } if (! LOGICAL(h)[0]) for (int i = nrow; i < 2 * nrow; i++) { const char *foo = CHAR(STRING_ELT(m, i)); if (strlen(foo) != 1) error("column two of 'm' not zero-or-one valued"); if (! (foo[0] == '0' || foo[0] == '1')) error("column two of 'm' not zero-or-one valued"); } dd_set_global_constants(); /* note actual type of "value" is mpq_t (defined in cddmp.h) */ mytype value; dd_init(value); dd_MatrixPtr mf = dd_CreateMatrix(nrow, ncol - 1); /* note our matrix has one more column than Fukuda's */ /* representation */ if(LOGICAL(h)[0]) mf->representation = dd_Inequality; else mf->representation = dd_Generator; mf->numbtype = dd_Rational; /* linearity */ for (int i = 0; i < nrow; i++) { const char *foo = CHAR(STRING_ELT(m, i)); if (foo[0] == '1') set_addelem(mf->linset, i + 1); /* note conversion from zero-origin to one-origin indexing */ } /* matrix */ for (int j = 1, k = nrow; j < ncol; j++) for (int i = 0; i < nrow; i++, k++) { const char *rat_str = CHAR(STRING_ELT(m, k)); if (mpq_set_str(value, rat_str, 10) == -1) { dd_FreeMatrix(mf); dd_clear(value); dd_free_global_constants(); error("error converting string to GMP rational"); } mpq_canonicalize(value); dd_set(mf->matrix[i][j - 1], value); /* note our matrix has one more column than Fukuda's */ } dd_ErrorType err = dd_NoError; dd_rowset out = dd_ImplicitLinearityRows(mf, &err); if (err != dd_NoError) { rr_WriteErrorMessages(err); set_free(out); dd_FreeMatrix(mf); dd_clear(value); dd_free_global_constants(); error("failed"); } SEXP foo; PROTECT(foo = rr_set_fwrite(out)); set_free(out); dd_FreeMatrix(mf); dd_clear(value); dd_free_global_constants(); PutRNGstate(); UNPROTECT(1); return foo; }
void ListLoader::startTag(const string& name, StringPairList& attribs, bool simple) { if(inListing) { if(name == sFile) { const string& n = getAttrib(attribs, sName, 0); if(n.empty()) return; const string& s = getAttrib(attribs, sSize, 1); if(s.empty()) return; const string& h = getAttrib(attribs, sTTH, 2); if(h.empty()) { return; } DirectoryListing::File* f = new DirectoryListing::File(cur, n, Util::toInt64(s), h); cur->files.push_back(f); } else if(name == sDirectory) { const string& n = getAttrib(attribs, sName, 0); if(n.empty()) { throw SimpleXMLException(_("Directory missing name attribute")); } bool incomp = getAttrib(attribs, sIncomplete, 1) == "1"; DirectoryListing::Directory* d = NULL; if(updating) { for(DirectoryListing::Directory::Iter i = cur->directories.begin(); i != cur->directories.end(); ++i) { if((*i)->getName() == n) { d = *i; if(!d->getComplete()) d->setComplete(!incomp); break; } } } if(d == NULL) { d = new DirectoryListing::Directory(cur, n, false, !incomp); cur->directories.push_back(d); } cur = d; if(simple) { // To handle <Directory Name="..." /> endTag(name, Util::emptyString); } } } else if(name == sFileListing) { const string& b = getAttrib(attribs, sBase, 2); if(b.size() >= 1 && b[0] == '/' && b[b.size()-1] == '/') { base = b; } StringList sl = StringTokenizer<string>(base.substr(1), '/').getTokens(); for(StringIter i = sl.begin(); i != sl.end(); ++i) { DirectoryListing::Directory* d = NULL; for(DirectoryListing::Directory::Iter j = cur->directories.begin(); j != cur->directories.end(); ++j) { if((*j)->getName() == *i) { d = *j; break; } } if(d == NULL) { d = new DirectoryListing::Directory(cur, *i, false, false); cur->directories.push_back(d); } cur = d; } cur->setComplete(true); inListing = true; if(simple) { // To handle <Directory Name="..." /> endTag(name, Util::emptyString); } } }
//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; } //}}}
// the common-scale can be profiled out (easily) under certain circumstances // // in general, the objective function looks like: // (sigma^2)^(-df/2) * exp(-0.5 * (1 / sigma^2) * stuff) // // what determines whether or not it can be profiled is the functional form of the // exponentiated term. For this, we have the following: // // powers: -1 -2 1 2 - estimating equation // prsnt : 0 X 0 0 - linear in sigma^2 (default scenario) // 0 X 0 X - quadratic in sigma^2 // X X 0 0 - quadratic in sigma // 0 X X 0 - cubic in sigma // // everything else is even worse // // finally, we also have two trumps. if the common scale has a point prior, that is that. // In addition, if the unmodeled coefficients aren't placed on the common scale, no polynomial // equation is possible static commonScaleOptimization_t getCommonScaleOptimizationType(SEXP regression) { int isLinearModel = !(MUETA_SLOT(regression) || V_SLOT(regression)); if (!isLinearModel) return(CSOT_NA); // question doesn't apply if is !lmm int* dims = DIMS_SLOT(regression); SEXP csPrior = GET_SLOT(regression, blme_commonScalePriorSym); SEXP ucPrior = GET_SLOT(regression, blme_unmodeledCoefficientPriorSym); SEXP cvPriorList = GET_SLOT(regression, blme_covariancePriorSym); priorType_t csPriorType = PRIOR_TYPE_SLOT(csPrior); priorType_t ucPriorType = PRIOR_TYPE_SLOT(ucPrior); priorType_t cvPriorType; priorFamily_t family; priorPosteriorScale_t posteriorScale; priorCommonScale_t onCommonScale; // handle the two trumps first if (csPriorType == PRIOR_TYPE_DIRECT && PRIOR_FAMILIES_SLOT(csPrior)[0] == PRIOR_FAMILY_POINT) { return(CSOT_NA); } if (ucPriorType == PRIOR_TYPE_DIRECT) { family = PRIOR_FAMILIES_SLOT(ucPrior)[0]; onCommonScale = getCommonScaleBit(PRIOR_SCALES_SLOT(ucPrior)[0]); if (family != PRIOR_FAMILY_FLAT && (family != PRIOR_FAMILY_GAUSSIAN || !onCommonScale)) return(CSOT_BRUTE_FORCE); } // catalog whether or not certain powers are present int mOneInExp = 0; // purposefully using 0/1 instead of false/true as we will do some math with them at the end int oneInExp = 0; int twoInExp = 0; if (csPriorType == PRIOR_TYPE_DIRECT) { family = PRIOR_FAMILIES_SLOT(csPrior)[0]; posteriorScale = getPosteriorScaleBit(PRIOR_SCALES_SLOT(csPrior)[0]); if (family == PRIOR_FAMILY_GAMMA) { if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) oneInExp = 1; else twoInExp = 1; } else if (family == PRIOR_FAMILY_INVGAMMA) { if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) mOneInExp = 1; } else { // huh? Shouldn't happen. caught point priors above... return(CSOT_BRUTE_FORCE); } } // now for the covariance priors; have to loop over factors and over dimensions within SEXP stList = GET_SLOT(regression, lme4_STSym); int numFactors = dims[nt_POS]; for (int i = 0; i < numFactors; ++i) { SEXP cvPrior = VECTOR_ELT(cvPriorList, i); SEXP stMatrix = VECTOR_ELT(stList, i); int factorDimension = INTEGER(getAttrib(stMatrix, R_DimSymbol))[0]; cvPriorType = PRIOR_TYPE_SLOT(cvPrior); priorFamily_t* families; int* scales; switch (cvPriorType) { case PRIOR_TYPE_DIRECT: onCommonScale = getCommonScaleBit(PRIOR_SCALES_SLOT(cvPrior)[0]); if (onCommonScale) continue; family = PRIOR_FAMILIES_SLOT(cvPrior)[0]; posteriorScale = getPosteriorScaleBit(PRIOR_SCALES_SLOT(cvPrior)[0]); switch (family) { case PRIOR_FAMILY_GAMMA: if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) oneInExp = 1; else twoInExp = 1; break; case PRIOR_FAMILY_INVGAMMA: if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) mOneInExp = 1; break; case PRIOR_FAMILY_WISHART: twoInExp = 1; break; default: break; } case PRIOR_TYPE_CORRELATION: families = PRIOR_FAMILIES_SLOT(cvPrior); scales = PRIOR_SCALES_SLOT(cvPrior); for (int j = 0; j < factorDimension; ++j) { onCommonScale = getCommonScaleBit(scales[j]); if (onCommonScale) continue; family = families[j]; switch (family) { case PRIOR_FAMILY_GAMMA: oneInExp = 1; break; case PRIOR_FAMILY_INVGAMMA: mOneInExp = 1; break; default: break; } } family = families[factorDimension]; onCommonScale = getCommonScaleBit(scales[factorDimension]); if (onCommonScale) continue; switch (family) { case PRIOR_FAMILY_WISHART: oneInExp = 1; break; case PRIOR_FAMILY_INVWISHART: mOneInExp = 1; break; default: break; } case PRIOR_TYPE_SPECTRAL: families = PRIOR_FAMILIES_SLOT(cvPrior); scales = PRIOR_SCALES_SLOT(cvPrior); for (int j = 0; j < factorDimension; ++j) { onCommonScale = getCommonScaleBit(scales[j]); if (onCommonScale) continue; family = families[j]; posteriorScale = getPosteriorScaleBit(scales[j]); switch (family) { case PRIOR_FAMILY_GAMMA: if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) oneInExp = 1; else twoInExp = 1; break; case PRIOR_FAMILY_INVGAMMA: if (posteriorScale == PRIOR_POSTERIOR_SCALE_SD) mOneInExp = 1; break; default: break; } } default: break; } // switch (cvPriorType) } // for (int i = 0; i < numFactors; ++i) int numPowers = mOneInExp + oneInExp + twoInExp; if (numPowers == 0) return(CSOT_LINEAR); if (numPowers > 1) return(CSOT_BRUTE_FORCE); if (mOneInExp) return(CSOT_QUADRATIC_SIGMA); if (twoInExp) return(CSOT_QUADRATIC_SIGMA_SQ); return(CSOT_BRUTE_FORCE); }
/* Peter Langfelder's modifications: * byrow: 0 => rank columns, !0 => rank rows * tiesMethod: 1: maximum, 2: average, 3:minimum * The returned rank is a REAL matrix to accomodate average ranks */ SEXP rowRanksWithTies(SEXP x, SEXP tiesMethod, SEXP byRow) { int tiesmethod, byrow; SEXP dim, ans = NULL; int nrow, ncol; /* Argument 'x': */ if (!isMatrix(x)) error("Argument 'x' must be a matrix."); /* Argument 'tiesMethod': */ tiesmethod = INTEGER(tiesMethod)[0]; if (tiesmethod < 1 || tiesmethod > 3) { error("Argument 'tiesMethod' is out of range [1,3]: %d", tiesmethod); } /* Argument 'byRow': */ byrow = INTEGER(byRow)[0]; /* Get dimensions for 'ans' (from 'x') */ PROTECT(dim = getAttrib(x, R_DimSymbol)); nrow = INTEGER(dim)[0]; ncol = INTEGER(dim)[1]; UNPROTECT(1); /* Double matrices are more common to use. */ if (isReal(x)) { if (byrow) { switch (tiesmethod) { case 1: ans = rowRanks_Real_tiesMax(x, nrow, ncol, 1); break; case 2: ans = rowRanks_Real_tiesAverage(x, nrow, ncol, 1); break; case 3: ans = rowRanks_Real_tiesMin(x, nrow, ncol, 1); break; } } else { switch (tiesmethod) { case 1: ans = colRanks_Real_tiesMax(x, nrow, ncol, 0); break; case 2: ans = colRanks_Real_tiesAverage(x, nrow, ncol, 0); break; case 3: ans = colRanks_Real_tiesMin(x, nrow, ncol, 0); break; } } } else if (isInteger(x)) { if (byrow) { switch (tiesmethod) { case 1: ans = rowRanks_Integer_tiesMax(x, nrow, ncol, 1); break; case 2: ans = rowRanks_Integer_tiesAverage(x, nrow, ncol, 1); break; case 3: ans = rowRanks_Integer_tiesMin(x, nrow, ncol, 1); break; } } else { switch (tiesmethod) { case 1: ans = colRanks_Integer_tiesMax(x, nrow, ncol, 0); break; case 2: ans = colRanks_Integer_tiesAverage(x, nrow, ncol, 0); break; case 3: ans = colRanks_Integer_tiesMin(x, nrow, ncol, 0); break; } } } else { error("Argument 'x' must be numeric."); } return(ans); } // rowRanksWithTies()
SEXP PartitionedLeaping(SEXP pre, SEXP post, SEXP h, SEXP M, SEXP T, SEXP delta, SEXP runs, SEXP place, SEXP transition, SEXP ect, SEXP rho) { int k; double dTmp; #ifdef RB_TIME clock_t c0, c1; c0 = clock(); #endif // Get dimensions of pre int *piTmp = INTEGER(getAttrib(pre, R_DimSymbol)); int iTransitions = piTmp[0], iPlaces = piTmp[1]; int *piPre = INTEGER(pre), *piPost = INTEGER(post); SEXP sexpTmp; int iTransition, iPlace, iTransitionPtr, iPlacePtr, iTransition2, iPlace2, iTransitionPtr2, iPlacePtr2; // Find out which elements of h are doubles and which functions SEXP sexpFunction; PROTECT(sexpFunction = allocVector(VECSXP, iTransitions)); double *pdH = (double *) R_alloc(iTransitions, sizeof(double)); DL_FUNC *pCFunction = (DL_FUNC *) R_alloc(iTransitions, sizeof(DL_FUNC *)); int *piHzType = (int *) R_alloc(iTransitions, sizeof(int)); for (iTransition = 0; iTransition < iTransitions; iTransition++) { if (inherits(sexpTmp = VECTOR_ELT(h, iTransition), "NativeSymbol")) { pCFunction[iTransition] = (void *) R_ExternalPtrAddr(sexpTmp); piHzType[iTransition] = HZ_CFUNCTION; } else if (isNumeric(sexpTmp)){ pdH[iTransition] = REAL(sexpTmp)[0]; piHzType[iTransition] = HZ_DOUBLE; } else if (isFunction(sexpTmp)) { SET_VECTOR_ELT(sexpFunction, iTransition, lang1(sexpTmp)); piHzType[iTransition] = HZ_RFUNCTION; } else { error("Unrecongnized transition function type\n"); } } // Setup Matrix S int *piS = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); int *piSSATransition = (int *) R_alloc(iTransitions, sizeof(int)); int *piTauLeapTransition = (int *) R_alloc(iTransitions, sizeof(int)); int *piCLETransition = (int *) R_alloc(iTransitions, sizeof(int)); int *piDetermTransition = (int *) R_alloc(iTransitions, sizeof(int)); int iSSATransitions, iTauLeapTransitions, iCLETransitions, iDetermTransitions; int *piSlowTransition = (int *) R_alloc(iTransitions, sizeof(int)); int *piFastTransition = (int *) R_alloc(iTransitions, sizeof(int)); int iSlowTransitions = 0, iFastTransitions = 0; // Position of non zero cells in pre per transition int *piPreNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); // Totals of non zero cells in pre per transition int *piPreNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int)); // Position of non zero cells in S per transition int *piSNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); // Totals of non zero cells in S per transition int *piSNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int)); int *piOrderedTransition = (int *) R_alloc(iTransitions, sizeof(int *)); for (iTransition = 0; iTransition < iTransitions; iTransition++) { int iPreNZxRow_col = 0; int iSNZxRow_col = 0; for (iPlace = 0; iPlace < iPlaces; iPlace++) { if (piPre[iTransition + iTransitions * iPlace]) { piPreNZxRow[iTransition + iTransitions * iPreNZxRow_col++] = iPlace; } if ((piS[iTransition + iTransitions * iPlace] = piPost[iTransition + iTransitions * iPlace] - piPre[iTransition + iTransitions * iPlace])) { piSNZxRow[iTransition + iTransitions * iSNZxRow_col++] = iPlace; } } piPreNZxRowTot[iTransition] = iPreNZxRow_col; piSNZxRowTot[iTransition] = iSNZxRow_col; } int *piSNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); int *piSNZxColTot = (int *) R_alloc(iPlaces, sizeof(int)); int *piPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); int *piPreNZxColTot = (int *) R_alloc(iTransitions, sizeof(int)); for (iPlace = 0; iPlace < iPlaces; iPlace++) { int iSNZxCol_row = 0; int iPreNZxCol_row = 0; for (iTransition = 0; iTransition < iTransitions; iTransition++) { if(piS[iTransition + iTransitions * iPlace]) { piSNZxCol[iSNZxCol_row++ + iTransitions * iPlace] = iTransition; } if(piPre[iTransition + iTransitions * iPlace]) { piPreNZxCol[iPreNZxCol_row++ + iTransitions * iPlace] = iTransition; } } piSNZxColTot[iPlace] = iSNZxCol_row; piPreNZxColTot[iPlace] = iPreNZxCol_row; } double *pdG = (double *) R_alloc(iPlaces, sizeof(double)); for (iPlace = 0; iPlace < iPlaces; iPlace++) { int iHOR = 0; pdG[iPlace] = 0; for(iTransitionPtr = 0; iTransitionPtr < piPreNZxColTot[iPlace]; iTransitionPtr++) { iTransition = piPreNZxCol[iTransitionPtr + iTransitions * iPlace]; int iThisHOR = 0, iThisHORPlace = 0; for(iPlacePtr2 = 0; iPlacePtr2 < piPreNZxRowTot[iTransition]; iPlacePtr2++) { iPlace2 = piPreNZxRow[iTransition + iTransitions * iPlacePtr2]; iThisHOR += piPre[iTransition + iTransitions * iPlace2]; if (iPlace2 == iPlace) iThisHORPlace = piPre[iTransition + iTransitions * iPlace2]; } if (iThisHOR >= iHOR) { double dThisG = 0; switch (iThisHOR) { case 0: // dThisG = 0; break; case 1: dThisG = 1; break; case 2: if (iThisHORPlace == 1) dThisG = 2; else if (iThisHORPlace == 2) dThisG = 3; else error("G: case not considered\n"); break; case 3: if (iThisHORPlace == 1) dThisG = 3; else if (iThisHORPlace == 2) dThisG = 9./2.; else if (iThisHORPlace == 3) dThisG = 11./2.; else error("G: case not considered\n"); break; default: error("G: case not considered\n"); } iHOR = iThisHOR; if (dThisG > pdG[iPlace]) pdG[iPlace] = dThisG; } } } int *piSlowPlace = (int *) R_alloc(iPlaces, sizeof(int)); int *piFastPlace = (int *) R_alloc(iPlaces, sizeof(int)); int iSlowPlaces = 0, iFastPlaces = 0; // Position of non zero cells in S per place int *piFastSNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); // Totals of non zero cells in S per place int *piFastSNZxColTot = (int *) R_alloc(iPlaces, sizeof(int)); // Position of non zero cells in pre per transition int *piSlowPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int)); // Totals of non zero cells in pre per transition int *piSlowPreNZxColTot = (int *) R_alloc(iTransitions, sizeof(int)); for (iPlace = 0; iPlace < iPlaces; iPlace++) { int iFastSNZxCol_row = 0; int iFastPlace = FALSE; for (iTransitionPtr = 0; iTransitionPtr < iFastTransitions; iTransitionPtr++) { iTransition = piFastTransition[iTransitionPtr]; if(piS[iTransition + iTransitions * iPlace]) { iFastPlace = TRUE; piFastSNZxCol[iFastSNZxCol_row++ + iTransitions * iPlace] = iTransition; } } piFastSNZxColTot[iPlace] = iFastSNZxCol_row; if (iFastPlace) piFastPlace[iFastPlaces++] = iPlace; int iSlowPreNZxCol_row = 0; int iSlowPlace = FALSE; for (iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) { iTransition = piSlowTransition[iTransitionPtr]; if(piPre[iTransition + iTransitions * iPlace]) { iSlowPlace = TRUE; piSlowPreNZxCol[iSlowPreNZxCol_row++ + iTransitions * iPlace] = iTransition; } } piSlowPreNZxColTot[iPlace] = iSlowPreNZxCol_row; if (iSlowPlace) piSlowPlace[iSlowPlaces++] = iPlace; } // Hazards that need to be recalculated if a given transition has happened int *piHazardsToModxRow = (int *) R_alloc((iTransitions + 2) * iTransitions, sizeof(int)); // Totals of hazards to recalculate for each transition that has happened int *piHazardsToModxRowTot = (int *) R_alloc(iTransitions + 2, sizeof(int)); piHazardsToModxRowTot[iTransitions + 1] = 0; for (iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) { iTransition = piSlowTransition[iTransitionPtr]; int iSlowTransitionHazardUpdatedByFastPlace = FALSE; int iHazardToCompTot = 0; for(iPlace = 0; iPlace < iPlaces; iPlace++) { if (piS[iTransition + iTransitions * iPlace]) { // Identify the transitions that need the hazards recalculated for(iTransitionPtr2 = 0; iTransitionPtr2 < piSlowPreNZxColTot[iPlace]; iTransitionPtr2++) { iTransition2 = piSlowPreNZxCol[iTransitionPtr2 + iTransitions * iPlace]; int iAddThis = TRUE; for (k = 0; k < iHazardToCompTot; k++) { if(piHazardsToModxRow[iTransition + (iTransitions + 2) * k] == iTransition2) { iAddThis = FALSE; break; } } if (iAddThis) piHazardsToModxRow[iTransition + (iTransitions + 2) * iHazardToCompTot++] = iTransition2; } } // Which slow transitions hazard have to be recalculated after updating the fast places. if (!iSlowTransitionHazardUpdatedByFastPlace && piPre[iTransition + iTransitions * iPlace]) { for(iPlacePtr2 = 0; iPlacePtr2 < iFastPlaces; iPlacePtr2++) { iPlace2 = piFastPlace[iPlacePtr2]; if (iPlace2 == iPlace) { iSlowTransitionHazardUpdatedByFastPlace = TRUE; piHazardsToModxRow[iTransitions + 1 + (iTransitions + 2) * piHazardsToModxRowTot[iTransitions + 1]++] = iTransition; break; } } } } piHazardsToModxRowTot[iTransition] = iHazardToCompTot; } // For the initial calculation of all hazards... for(iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) { iTransition = piSlowTransition[iTransitionPtr]; piHazardsToModxRow[iTransitions + (iTransitions + 2) * iTransitionPtr] = iTransition; } piHazardsToModxRowTot[iTransitions] = iSlowTransitions; SEXP sexpTmpCrntMarking; PROTECT(sexpTmpCrntMarking = allocVector(REALSXP, iPlaces)); double *pdTmpCrntMarking = REAL(sexpTmpCrntMarking); SEXP sexpCrntMarking; PROTECT(sexpCrntMarking = allocVector(REALSXP, iPlaces)); double *pdCrntMarking = REAL(sexpCrntMarking); double *pdBakCrntMarking = (double *) R_alloc(iPlaces, sizeof(double)); double dDelta = *REAL(delta); int iTotalSteps, iSectionSteps; double dT = 0; void *pCManage_time = 0; SEXP sexpRManage_time = 0; if (inherits(T, "NativeSymbol")) { pCManage_time = (void *) R_ExternalPtrAddr(T); dT = ((double(*)(double, double *)) pCManage_time)(-1, pdCrntMarking); } else if (isNumeric(T)){ dT = *REAL(T); } else if (isFunction(T)) { PROTECT(sexpRManage_time = lang1(T)); defineVar(install("y"), sexpCrntMarking, rho); PROTECT(sexpTmp = allocVector(REALSXP, 1)); *REAL(sexpTmp) = -1; defineVar(install("StartTime"), sexpTmp, rho); UNPROTECT_PTR(sexpTmp); dT = *REAL(VECTOR_ELT(eval(sexpRManage_time, rho),0)); } else { error("Unrecognized time function type\n"); } iTotalSteps = iSectionSteps = (int)(dT / dDelta) + 1; int iRun, iRuns = *INTEGER(runs); // Hazard vector double *pdHazard = (double *) R_alloc(iTransitions, sizeof(double)); SEXP sexpRun; PROTECT(sexpRun = allocVector(VECSXP, iRuns)); int iTotalUsedRandomNumbers = 0; // DiscTime Vector SEXP sexpD_time; PROTECT(sexpD_time = allocVector(REALSXP, iTotalSteps)); double *pdDiscTime = REAL(sexpD_time); dTmp = 0; for (k = 0; k < iTotalSteps; k++) { pdDiscTime[k] = dTmp; dTmp += dDelta; } SEXP sexpMarkingRowNames; PROTECT(sexpMarkingRowNames = allocVector(INTSXP, iTotalSteps)); piTmp = INTEGER(sexpMarkingRowNames); for (k = 0; k < iTotalSteps; k++) piTmp[k] = k+1; double **ppdMarking = (double **) R_alloc(iPlaces, sizeof(double *)); #ifdef RB_SAVE_INCR_INFO double *pdIncr = (double *) R_alloc(INCR_TO_SAVE, sizeof(double)); double *pdIncrTime = (double *) R_alloc(INCR_TO_SAVE, sizeof(double)); double *pdAcumHazard = (double *) R_alloc(INCR_TO_SAVE, sizeof(double)); double *pdIntHazard = (double *) R_alloc(INCR_TO_SAVE, sizeof(double)); double *pdIntHazardTime = (double *) R_alloc(INCR_TO_SAVE, sizeof(double)); #endif double *pdSSARescaling = (double *) R_alloc(iTransitions, sizeof(double)); double *pdSSATau = (double *) R_alloc(iTransitions, sizeof(double)); double dEpsilon = 0.03; double dApproxEqualOne = 3; double dGreaterGreaterOne = 100; GetRNGstate(); for (iRun = 0; iRun < iRuns; iRun++) { #ifdef RB_SAVE_INCR_INFO int iTotIntHazardTime = 0, iTotIncrTime = 0; #endif int iUsedRandomNumbers = 0; Rprintf("%d ", iRun+1); // Totals for kind of transition vector SEXP sexpTotXTransition; PROTECT(sexpTotXTransition = allocVector(INTSXP, iTransitions)); int *piTotTransitions = INTEGER(sexpTotXTransition); for(iTransition = 0; iTransition < iTransitions; iTransition++) { piTotTransitions[iTransition] = 0; pdSSARescaling[iTransition] = -1; } for(iTransitionPtr = 0; iTransitionPtr < iSlowTransitions; iTransitionPtr++) { piOrderedTransition[iTransitionPtr] = piSlowTransition[iTransitionPtr]; } SEXP sexpMarking; PROTECT(sexpMarking = allocVector(VECSXP, iPlaces)); //setAttrib(sexpMarking, R_NamesSymbol, place); //setAttrib(sexpMarking, R_RowNamesSymbol, sexpMarkingRowNames); //setAttrib(sexpMarking, R_ClassSymbol, ScalarString(mkChar("data.frame"))); // Setup initial state double *pdTmp = REAL(M); for (iPlace = 0; iPlace < iPlaces; iPlace++) { SET_VECTOR_ELT(sexpMarking, iPlace, sexpTmp = allocVector(REALSXP, iTotalSteps)); ppdMarking[iPlace] = REAL(sexpTmp); pdCrntMarking[iPlace] = pdBakCrntMarking[iPlace] = pdTmp[iPlace]; } double dTime, dTarget = 0; int iTotTransitions = 0; int iStep = 0; int iInterruptCnt = 10000000; double dNewHazard = 0; do { if (iStep) { --iStep; for(iPlace = 0; iPlace < iPlaces; iPlace++) { pdCrntMarking[iPlace] = ppdMarking[iPlace][iStep]; } } if (pCManage_time || sexpRManage_time) { double dEnd = 0; if (pCManage_time) { dEnd = ((double(*)(double, double *)) pCManage_time)(dTarget, pdCrntMarking); } else { defineVar(install("y"), sexpCrntMarking, rho); PROTECT(sexpTmp = allocVector(REALSXP, 1)); *REAL(sexpTmp) = dTarget; defineVar(install("StartTime"), sexpTmp, rho); UNPROTECT_PTR(sexpTmp); sexpTmp = eval(sexpRManage_time, rho); dEnd = *REAL(VECTOR_ELT(sexpTmp,0)); for(iPlace = 0; iPlace < iPlaces; iPlace++) { pdCrntMarking[iPlace] = REAL(VECTOR_ELT(sexpTmp,1))[iPlace]; } } iSectionSteps = (int)(dEnd / dDelta) + 1; } for(iPlace = 0; iPlace < iPlaces; iPlace++) { pdBakCrntMarking[iPlace] = pdTmpCrntMarking[iPlace] = pdCrntMarking[iPlace]; } dTime = dTarget; for(iTransition = 0; iTransition < iTransitions; iTransition++) { pdHazard[iTransition] = 0; } do { // Get hazards for all transitions. for(iTransition = 0; iTransition < iTransitions; iTransition++) { switch(piHzType[iTransition]) { case HZ_DOUBLE: dNewHazard = pdH[iTransition]; for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr]; for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++) dNewHazard *= (pdCrntMarking[iPlace] - k) / (double)(k+1); } break; case HZ_CFUNCTION: dNewHazard = ((double(*)(double *)) pCFunction[iTransition])(pdCrntMarking); break; default: // case HZ_RFUNCTION: defineVar(install("y"), sexpCrntMarking, rho); dNewHazard = REAL(eval(VECTOR_ELT(sexpFunction, iTransition), rho))[0]; break; } // dAcumHazard += dNewHazard - pdHazard[iTransition]; pdHazard[iTransition] = dNewHazard; } for(iPlace = 0; iPlace < iPlaces; iPlace++) // Save Marking pdBakCrntMarking[iPlace] = pdCrntMarking[iPlace]; double dTau = DBL_MAX; // Initial value of Tau for (iPlace = 0; iPlace < iPlaces; iPlace++) { double dMHat = 0, dSigmaHatSq = 0; for(iTransitionPtr = 0; iTransitionPtr < piSNZxColTot[iPlace]; iTransitionPtr++) { iTransition = piSNZxCol[iTransitionPtr + iTransitions * iPlace]; dMHat += (dTmp = piS[iTransition + iTransitions * iPlace] * pdHazard[iTransition]); dSigmaHatSq += dTmp * piS[iTransition + iTransitions * iPlace]; } double dE; if ((dE = dEpsilon * pdCrntMarking[iPlace] / pdG[iPlace]) < 1) dE = 1; double dTLeap; if ((dTLeap = dE/fabs(dMHat)) > (dTmp = dE*dE/dSigmaHatSq)) dTLeap = dTmp; if (dTLeap < dTau) dTau = dTLeap; } //double dLogRandom = -log(unif_rand()); //double dSSATau = DBL_MAX; int iNextSSATransition; int iLoop = TRUE; while (iLoop) { // Classify transitions iSSATransitions = iTauLeapTransitions = iCLETransitions = iDetermTransitions = 0; // dAcumHazard = 0; iNextSSATransition = -1; double dSSATau = DBL_MAX; for(iTransition = 0; iTransition < iTransitions; iTransition++) { if (pdHazard[iTransition] < ZERO) continue; if ((dTmp = pdHazard[iTransition] * dTau) < dApproxEqualOne) { piSSATransition[iSSATransitions++] = iTransition; // dAcumHazard += pdHazard[iTransition]; if (pdSSARescaling[iTransition] > 0) // Rescale pdSSATau[iTransition] = pdSSARescaling[iTransition] / pdHazard[iTransition]; else { // Need to generate random number pdSSATau[iTransition] = -log(unif_rand()) / pdHazard[iTransition]; pdSSARescaling[iTransition] = pdHazard[iTransition] * pdSSATau[iTransition]; } if (pdSSATau[iTransition] < dSSATau) { iNextSSATransition = iTransition; dSSATau = pdSSATau[iTransition]; } } else if (dTmp < dGreaterGreaterOne) { piTauLeapTransition[iTauLeapTransitions++] = iTransition; } else if (sqrt(dTmp) < dGreaterGreaterOne) { piCLETransition[iCLETransitions++] = iTransition; } else { piDetermTransition[iDetermTransitions++] = iTransition; } } if (iNextSSATransition >= 0) { // dSSATau = dLogRandom / dAcumHazard; if (iSSATransitions && !(iTauLeapTransitions + iCLETransitions + iDetermTransitions)) // If all (possible) transitions are SSA dTau = dSSATau; else if (dSSATau < dTau) { // If SSA fired before dTau dTau = dSSATau; continue; // Go back to see if anything changed } } if (dSSATau == dTau) { // If an SSA transition fired iTransition = iNextSSATransition; for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr]; // Update the state pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace]; } /* double dPartialAcumHazard = 0; // Find out which transition happened double dRnd = runif(0, dAcumHazard); for(iTransitionPtr = 0; iTransitionPtr < iSSATransitions; iTransitionPtr++) { iTransition = piSSATransition[iTransitionPtr]; if (dRnd < (dPartialAcumHazard += pdHazard[iTransition])) { for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr]; // Update the state pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace]; } break; } } */ } int iTransitionFires; // Account for Tau Leaping reactions for(iTransitionPtr = 0; iTransitionPtr < iTauLeapTransitions; iTransitionPtr++) { iTransition = piTauLeapTransition[iTransitionPtr]; if ((iTransitionFires = rpois(pdHazard[iTransition] * dTau))) { for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr]; // Update the state pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace]; } } } // Account for CLE reactions for(iTransitionPtr = 0; iTransitionPtr < iTauLeapTransitions; iTransitionPtr++) { iTransition = piTauLeapTransition[iTransitionPtr]; if ((iTransitionFires = fround(pdHazard[iTransition] * dTau + sqrt(pdHazard[iTransition] * dTau) * norm_rand(),0))) { for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr]; // Update the state pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace]; } } } // Account for deterministic reactions for(iTransitionPtr = 0; iTransitionPtr < iDetermTransitions; iTransitionPtr++) { iTransition = piDetermTransition[iTransitionPtr]; if ((iTransitionFires = fround(pdHazard[iTransition] * dTau,0))) { for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) { iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr]; // Update the state pdCrntMarking[iPlace] += iTransitionFires * piS[iTransition + iTransitions * iPlace]; } } } // Check no negative places have been generated for(iPlace = 0; iPlace < iPlaces; iPlace++) // Save Marking if (pdCrntMarking[iPlace] < 0) break; if (iPlace < iPlaces) { // At least one Place is negative. Rollback and reduce Tau by half dTau *= .5; for(iPlace = 0; iPlace < iPlaces; iPlace++) pdCrntMarking[iPlace] = pdBakCrntMarking[iPlace]; } else // Everything is OK. Leave the loop. iLoop = FALSE; } // Advance the clock dTime += dTau; // Rescale SSA transitions that didn't fire for(iTransitionPtr = 0; iTransitionPtr < iSSATransitions; iTransitionPtr++) { iTransition = piSSATransition[iTransitionPtr]; if (iTransition != iNextSSATransition) { pdSSARescaling[iTransition] = pdHazard[iTransition] * (pdSSATau[iTransition] - dTau); } else { pdSSARescaling[iTransition] = -1; } } while (dTime >= dTarget) { // Update the state for the fixed incremented time. for(iPlace = 0; iPlace < iPlaces; iPlace++) { ppdMarking[iPlace][iStep] = pdBakCrntMarking[iPlace]; } if (++iStep >= iSectionSteps) goto EXIT_LOOP; dTarget += dDelta; // Force check if user interrupted iInterruptCnt = 1; } if (! --iInterruptCnt) { // Allow user interruption R_CheckUserInterrupt(); iInterruptCnt = 10000000; } } while (++iTotTransitions); EXIT_LOOP:; Rprintf("."); } while (iSectionSteps < iTotalSteps); iTotalUsedRandomNumbers += iUsedRandomNumbers; Rprintf("\t%d\t%d\t%d", iTotTransitions, iUsedRandomNumbers, iTotalUsedRandomNumbers); #ifdef RB_SUBTIME c1 = clock(); Rprintf ("\t To go: "); PrintfTime((double) (c1 - c0)/CLOCKS_PER_SEC/(iRun+1)*(iRuns-iRun-1)); #endif Rprintf ("\n"); SEXP sexpTotTransitions; PROTECT(sexpTotTransitions = allocVector(INTSXP, 1)); INTEGER(sexpTotTransitions)[0] = iTotTransitions; SEXP sexpUsedRandomNumbers; PROTECT(sexpUsedRandomNumbers = allocVector(INTSXP, 1)); INTEGER(sexpUsedRandomNumbers)[0] = iUsedRandomNumbers; SEXP sexpThisRun; #ifdef RB_SAVE_INCR_INFO if (iRun >= 10) PROTECT(sexpThisRun = allocVector(VECSXP, 4)); else PROTECT(sexpThisRun = allocVector(VECSXP, 9)); #else PROTECT(sexpThisRun = allocVector(VECSXP, 4)); #endif SET_VECTOR_ELT(sexpThisRun, 0, sexpMarking); UNPROTECT_PTR(sexpMarking); SET_VECTOR_ELT(sexpThisRun, 1, sexpTotXTransition); UNPROTECT_PTR(sexpTotXTransition); SET_VECTOR_ELT(sexpThisRun, 2, sexpTotTransitions); UNPROTECT_PTR(sexpTotTransitions); SET_VECTOR_ELT(sexpThisRun, 3, sexpUsedRandomNumbers); UNPROTECT_PTR(sexpUsedRandomNumbers); #ifdef RB_SAVE_INCR_INFO if (iRun < 10) { SEXP sexpTmp; PROTECT(sexpTmp = allocVector(REALSXP, iTotIncrTime)); pdTmp = REAL(sexpTmp); int i; for (i = 0; i < iTotIncrTime; i++) pdTmp[i] = pdIncr[i]; SET_VECTOR_ELT(sexpThisRun, 4, sexpTmp); UNPROTECT_PTR(sexpTmp); PROTECT(sexpTmp = allocVector(REALSXP, iTotIncrTime)); pdTmp = REAL(sexpTmp); for (i = 0; i < iTotIncrTime; i++) pdTmp[i] = pdIncrTime[i]; SET_VECTOR_ELT(sexpThisRun, 5, sexpTmp); UNPROTECT_PTR(sexpTmp); PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime)); pdTmp = REAL(sexpTmp); for (i = 0; i < iTotIntHazardTime; i++) pdTmp[i] = pdAcumHazard[i]; SET_VECTOR_ELT(sexpThisRun, 6, sexpTmp); UNPROTECT_PTR(sexpTmp); PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime)); pdTmp = REAL(sexpTmp); for (i = 0; i < iTotIntHazardTime; i++) pdTmp[i] = pdIntHazard[i]; SET_VECTOR_ELT(sexpThisRun, 7, sexpTmp); UNPROTECT_PTR(sexpTmp); PROTECT(sexpTmp = allocVector(REALSXP, iTotIntHazardTime)); pdTmp = REAL(sexpTmp); for (i = 0; i < iTotIntHazardTime; i++) pdTmp[i] = pdIntHazardTime[i]; SET_VECTOR_ELT(sexpThisRun, 8, sexpTmp); UNPROTECT_PTR(sexpTmp); } #endif SEXP sexpNames; #ifdef RB_SAVE_INCR_INFO if (iRun >= 10) PROTECT(sexpNames = allocVector(VECSXP, 4)); else PROTECT(sexpNames = allocVector(VECSXP, 9)); #else PROTECT(sexpNames = allocVector(VECSXP, 4)); #endif SET_VECTOR_ELT(sexpNames, 0, mkChar("M")); SET_VECTOR_ELT(sexpNames, 1, mkChar("transitions")); SET_VECTOR_ELT(sexpNames, 2, mkChar("tot.transitions")); SET_VECTOR_ELT(sexpNames, 3, mkChar("tot.rnd")); #ifdef RB_SAVE_INCR_INFO if (iRun < 10) { SET_VECTOR_ELT(sexpNames, 4, mkChar("incr")); SET_VECTOR_ELT(sexpNames, 5, mkChar("incr.time")); SET_VECTOR_ELT(sexpNames, 6, mkChar("hazard")); SET_VECTOR_ELT(sexpNames, 7, mkChar("int.hazard")); SET_VECTOR_ELT(sexpNames, 8, mkChar("int.hazard.time")); } #endif setAttrib(sexpThisRun, R_NamesSymbol, sexpNames); UNPROTECT_PTR(sexpNames); SET_VECTOR_ELT(sexpRun, iRun, sexpThisRun); UNPROTECT_PTR(sexpThisRun); } PutRNGstate(); SEXP sexpAns; PROTECT(sexpAns = allocVector(VECSXP, 4)); SET_VECTOR_ELT(sexpAns, 0, place); SET_VECTOR_ELT(sexpAns, 1, transition); SET_VECTOR_ELT(sexpAns, 2, sexpD_time); UNPROTECT_PTR(sexpD_time); SET_VECTOR_ELT(sexpAns, 3, sexpRun); UNPROTECT_PTR(sexpRun); SEXP sexpNames; PROTECT(sexpNames = allocVector(VECSXP, 4)); SET_VECTOR_ELT(sexpNames, 0, mkChar("place")); SET_VECTOR_ELT(sexpNames, 1, mkChar("transition")); SET_VECTOR_ELT(sexpNames, 2, mkChar("dt")); SET_VECTOR_ELT(sexpNames, 3, mkChar("run")); setAttrib(sexpAns, R_NamesSymbol, sexpNames); UNPROTECT_PTR(sexpNames); #ifdef RB_TIME c1 = clock(); double dCpuTime = (double) (c1 - c0)/CLOCKS_PER_SEC; Rprintf ("Elapsed CPU time: "); PrintfTime(dCpuTime); Rprintf ("\t(%fs)\n", dCpuTime); #endif if (sexpRManage_time) UNPROTECT_PTR(sexpRManage_time); UNPROTECT_PTR(sexpFunction); UNPROTECT_PTR(sexpMarkingRowNames); UNPROTECT_PTR(sexpTmpCrntMarking); UNPROTECT_PTR(sexpCrntMarking); UNPROTECT_PTR(sexpAns); return(sexpAns); }
void ListLoader::startTag(const string& name, StringPairList& attribs, bool simple) { #ifdef _DEBUG static size_t g_max_attribs_size = 0; if (g_max_attribs_size != attribs.size()) { g_max_attribs_size = attribs.size(); // dcdebug("ListLoader::startTag g_max_attribs_size = %d , attribs.capacity() = %d\n", g_max_attribs_size, attribs.capacity()); } #endif if (ClientManager::isBeforeShutdown()) { throw AbortException("ListLoader::startTag - ClientManager::isBeforeShutdown()"); } if (m_list->getAbort()) { throw AbortException("ListLoader::startTag - " + STRING(ABORT_EM)); } if (m_is_in_listing) { if (name == g_SFile) { dcassert(attribs.size() >= 3); // Иногда есть Shared - 4-тый атрибут. // это тэг от грея. его тоже можно обработать и записать в TS. хотя там 64 битное время const string& l_name = getAttrib(attribs, g_SName, 0); if (l_name.empty()) { dcassert(0); return; } const string& l_s = getAttrib(attribs, g_SSize, 1); if (l_s.empty()) { dcassert(0); return; } const auto l_size = Util::toInt64(l_s); const string& l_h = getAttrib(attribs, g_STTH, 2); if (l_h.empty() || (m_is_own_list == false && l_h.compare(0, 39, "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA", 39) == 0)) { //dcassert(0); return; } const TTHValue l_tth(l_h); /// @todo verify validity? dcassert(l_tth != TTHValue()); if (m_is_updating) { // just update the current file if it is already there. for (auto i = m_cur->m_files.cbegin(); i != m_cur->m_files.cend(); ++i) { auto& file = **i; /// @todo comparisons should be case-insensitive but it takes too long - add a cache if (file.getName() == l_name || file.getTTH() == l_tth) { file.setName(l_name); file.setSize(l_size); file.setTTH(l_tth); return; } } } // [+] FlylinkDC std::shared_ptr<CFlyMediaInfo> l_mediaXY; uint32_t l_i_ts = 0; int l_i_hit = 0; string l_hit; #ifdef FLYLINKDC_USE_DIRLIST_FILE_EXT_STAT auto& l_item = DirectoryListing::g_ext_stat[Util::getFileExtWithoutDot(Text::toLower(l_name))]; l_item.m_count++; if (l_size > l_item.m_max_size) l_item.m_max_size = l_size; if (l_size < l_item.m_min_size) l_item.m_min_size = l_size; #endif if (attribs.size() >= 4) // 3 - стандартный DC++, 4 - GreyLinkDC++ { if (attribs.size() == 4 || attribs.size() >= 11) // Хитрый расширенный формат от http://p2p.toom.su/fs/hms/FCYECUWQ7F5A2FABW32UTMCT6MEMI3GPXBZDQCQ/) { const string l_sharedGL = getAttrib(attribs, g_SShared, 4); if (!l_sharedGL.empty()) { const int64_t tmp_ts = _atoi64(l_sharedGL.c_str()) - 116444736000000000L ; if (tmp_ts <= 0L) l_i_ts = 0; else l_i_ts = uint32_t(tmp_ts / 10000000L); } } string l_ts; if (l_i_ts == 0) { l_ts = getAttrib(attribs, g_STS, 3); // TODO проверить attribs.size() >= 4 если = 4 или 3 то TS нет и можно не искать } if (!m_is_first_check_mediainfo_list) { m_is_first_check_mediainfo_list = true; m_is_mediainfo_list = !l_ts.empty(); } if (!l_ts.empty() // Extended tags - exists only FlylinkDC++ or StrongDC++ sqlite or clones || l_i_ts // Грейлинк - время расшаривания ) { if (!l_ts.empty()) { l_i_ts = atoi(l_ts.c_str()); } if (attribs.size() > 4) // TODO - собрать комбинации всех случаев { l_hit = getAttrib(attribs, g_SHit, 3); const std::string& l_audio = getAttrib(attribs, g_SMAudio, 3); const std::string& l_video = getAttrib(attribs, g_SMVideo, 3); if (!l_audio.empty() || !l_video.empty()) { const string& l_br = getAttrib(attribs, g_SBR, 4); l_mediaXY = std::make_shared<CFlyMediaInfo>(getAttrib(attribs, g_SWH, 3), atoi(l_br.c_str()), l_audio, l_video ); } } #if 0 if (attribs.size() > 4) // TODO - собрать комбинации всех случаев { CFlyMediainfoRAW l_media_item; { l_media_item.m_audio = getAttrib(attribs, g_SMAudio, 3); const size_t l_pos = l_media_item.m_audio.find('|', 0); if (l_pos != string::npos && l_pos) { if (l_pos + 2 < l_media_item.m_audio.length()) { l_media_item.m_audio = l_media_item.m_audio.substr(l_pos + 2); } } } l_media_item.m_video = getAttrib(attribs, g_SMVideo, 3); l_hit = getAttrib(attribs, g_SHit, 3); l_media_item.m_WH = getAttrib(attribs, g_SWH, 3); if (!l_media_item.m_audio.empty() || !l_media_item.m_video.empty()) { l_media_item.m_br = getAttrib(attribs, g_SBR, 4); auto& l_find_mi = g_cache_mediainfo[l_media_item]; if (!l_find_mi) { l_find_mi = std::make_shared<CFlyMediaInfo>(l_media_item.m_WH, atoi(l_media_item.m_br.c_str()), l_media_item.m_audio, l_media_item.m_video ); l_mediaXY = l_find_mi; } } } #endif } l_i_hit = l_hit.empty() ? 0 : atoi(l_hit.c_str()); } auto f = new DirectoryListing::File(m_cur, l_name, l_size, l_tth, l_i_hit, l_i_ts, l_mediaXY); m_cur->m_virus_detect.add(l_name, l_size); m_cur->m_files.push_back(f); if (l_size) { if (m_is_own_list)//[+] FlylinkDC++ { f->setFlag(DirectoryListing::FLAG_SHARED_OWN); // TODO - убить FLAG_SHARED_OWN } else { if (ShareManager::isTTHShared(f->getTTH())) { f->setFlag(DirectoryListing::FLAG_SHARED); } else { if (QueueManager::is_queue_tth(f->getTTH())) { f->setFlag(DirectoryListing::FLAG_QUEUE); } // TODO if(l_size >= 100 * 1024 *1024) { if (!CFlyServerConfig::isParasitFile(f->getName())) // TODO - опимизнуть по расширениям { f->setFlag(DirectoryListing::FLAG_NOT_SHARED); const auto l_status_file = CFlylinkDBManager::getInstance()->get_status_file(f->getTTH()); // TODO - унести в отдельную нитку? if (l_status_file & CFlylinkDBManager::PREVIOUSLY_DOWNLOADED) f->setFlag(DirectoryListing::FLAG_DOWNLOAD); if (l_status_file & CFlylinkDBManager::VIRUS_FILE_KNOWN) f->setFlag(DirectoryListing::FLAG_VIRUS_FILE); if (l_status_file & CFlylinkDBManager::PREVIOUSLY_BEEN_IN_SHARE) f->setFlag(DirectoryListing::FLAG_OLD_TTH); } } } }//[+] FlylinkDC++ } } else if (name == g_SDirectory) { string l_file_name = getAttrib(attribs, g_SName, 0); if (l_file_name.empty()) { // throw SimpleXMLException("Directory missing name attribute"); l_file_name = "empty_file_name_" + Util::toString(++m_empty_file_name_counter); } const bool incomp = getAttrib(attribs, sIncomplete, 1) == "1"; DirectoryListing::Directory* d = nullptr; if (m_is_updating) { for (auto i = m_cur->directories.cbegin(); i != m_cur->directories.cend(); ++i) { /// @todo comparisons should be case-insensitive but it takes too long - add a cache if ((*i)->getName() == l_file_name) { d = *i; if (!d->getComplete()) { d->setComplete(!incomp); } break; } } } if (d == nullptr) { d = new DirectoryListing::Directory(m_list, m_cur, l_file_name, false, !incomp, isMediainfoList()); m_cur->directories.push_back(d); } m_cur = d; if (simple) { // To handle <Directory Name="..." /> endTag(name, Util::emptyString); } } } else if (name == sFileListing) { const string& b = getAttrib(attribs, sBase, 2); if (b.size() >= 1 && b[0] == '/' && b[b.size() - 1] == '/') { m_base = b; } if (m_base.size() > 1) // [+]PPA fix for [4](("Version", "1"),("CID", "EDI7OWB6TZWH6X6L2D3INC6ORQSG6RQDJ6AJ5QY"),("Base", "/"),("Generator", "DC++ 0.785")) { const StringTokenizer<string> sl(m_base.substr(1), '/'); for (auto i = sl.getTokens().cbegin(); i != sl.getTokens().cend(); ++i) { DirectoryListing::Directory* d = nullptr; for (auto j = m_cur->directories.cbegin(); j != m_cur->directories.cend(); ++j) { if ((*j)->getName() == *i) { d = *j; break; } } if (d == nullptr) { d = new DirectoryListing::Directory(m_list, m_cur, *i, false, false, isMediainfoList()); m_cur->directories.push_back(d); } m_cur = d; } } m_cur->setComplete(true); // [+] IRainman Delayed loading (dclst support) const string& l_cidStr = getAttrib(attribs, sCID, 2); if (l_cidStr.size() == 39) { const CID l_CID(l_cidStr); if (!l_CID.isZero()) { if (!m_user) { m_user = ClientManager::createUser(l_CID, "", 0); m_list->setHintedUser(HintedUser(m_user, Util::emptyString)); } } } const string& l_getIncludeSelf = getAttrib(attribs, sIncludeSelf, 2); m_list->setIncludeSelf(l_getIncludeSelf == "1"); // [~] IRainman Delayed loading (dclst support) m_is_in_listing = true; if (simple) { // To handle <Directory Name="..." /> endTag(name, Util::emptyString); } } }
SEXP mixtureloglikelihood(SEXP param, SEXP mixturesample){ int nprotect = 0; int * dim; dim = INTEGER(getAttrib(param, R_DimSymbol)); int nbparam = dim[0]; SEXP results; PROTECT(results = allocVector(REALSXP, nbparam)); nprotect ++; int dimparam = dim[1]; int nbcomponents = (dimparam - 1) / 3; //printf("n compo: %d\n", nbcomponents); double *p_param, *p_sample; PROTECT(param = coerceVector(param, REALSXP)); nprotect ++; p_param = REAL(param); PROTECT(mixturesample = coerceVector(mixturesample, REALSXP)); nprotect ++; p_sample = REAL(mixturesample); int samplesize = length(mixturesample); //printf("sample size: %d\n", samplesize); //printf("first element: %f\n", p_sample[0]); float SumOfWeights = 0.; float centeredobs = 0.; float samplesquared = 0.; float mixturedensity = 0.; //SEXP uw, prec, sqrt; /* double *unnormalizedweights, *precisions, *sqrtprecisions; unnormalizedweights = allocVector(REALSXP, nbcomponents); precisions = allocVector(REALSXP, nbcomponents); sqrtprecisions = allocVector(REALSXP, nbcomponents); */ for (int iparam = 0; iparam < nbparam; iparam++){ //printf("param #%d\n", iparam); REAL(results)[iparam] = 0.; SumOfWeights = 0.; for (int icomponent = 0; icomponent < nbcomponents; icomponent++){ //unnormalizedweights[icomponent] = exp(p_param[nbparam * icomponent + iparam]); //printf("%f\n", unnormalizedweights[icomponent]); SumOfWeights += UW; //precisions[icomponent] = exp(p_param[nbparam * (2 * nbcomponents + icomponent) + iparam]); //sqrtprecisions[icomponent] = exp(0.5 * p_param[nbparam * (2 * nbcomponents + icomponent) + iparam]); } for (int isample = 0; isample < samplesize; isample ++){ //printf("sample #%d\n", isample); mixturedensity = 0.; for (int icomponent = 0; icomponent < nbcomponents; icomponent++){ //printf("component #%d\n", icomponent); centeredobs = (p_sample[isample] - p_param[nbparam * (nbcomponents + icomponent) + iparam]); samplesquared = centeredobs * centeredobs; mixturedensity += 0.3989423 * (UW / SumOfWeights) * SQPR * exp(-0.5 * PR * samplesquared); /* mixturedensity += 0.3989423 * unnormalizedweights[icomponent] / SumOfWeights * sqrtprecisions[icomponent] * exp(-0.5 * precisions[icomponent] * samplesquared); */ } REAL(results)[iparam] += log(mixturedensity); } //printf("result param %d: %f\n", iparam, REAL(results)[iparam]); } UNPROTECT(nprotect); return results; }
SEXP attribute_hidden do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans, dims, dimnames, indx, subs, x; int i, ndims, nsubs; int drop = 1, pok, exact = -1; int named_x; R_xlen_t offset = 0; PROTECT(args); ExtractDropArg(args, &drop); /* Is partial matching ok? When the exact arg is NA, a warning is issued if partial matching occurs. */ exact = ExtractExactArg(args); if (exact == -1) pok = exact; else pok = !exact; x = CAR(args); /* This code was intended for compatibility with S, */ /* but in fact S does not do this. Will anyone notice? */ if (x == R_NilValue) { UNPROTECT(1); return x; } /* Get the subscripting and dimensioning information */ /* and check that any array subscripting is compatible. */ subs = CDR(args); if(0 == (nsubs = length(subs))) errorcall(call, _("no index specified")); dims = getAttrib(x, R_DimSymbol); ndims = length(dims); if(nsubs > 1 && nsubs != ndims) errorcall(call, _("incorrect number of subscripts")); /* code to allow classes to extend environment */ if(TYPEOF(x) == S4SXP) { x = R_getS4DataSlot(x, ANYSXP); if(x == R_NilValue) errorcall(call, _("this S4 class is not subsettable")); } /* split out ENVSXP for now */ if( TYPEOF(x) == ENVSXP ) { if( nsubs != 1 || !isString(CAR(subs)) || length(CAR(subs)) != 1 ) errorcall(call, _("wrong arguments for subsetting an environment")); ans = findVarInFrame(x, install(translateChar(STRING_ELT(CAR(subs), 0)))); if( TYPEOF(ans) == PROMSXP ) { PROTECT(ans); ans = eval(ans, R_GlobalEnv); UNPROTECT(1); } else SET_NAMED(ans, 2); UNPROTECT(1); if(ans == R_UnboundValue) return(R_NilValue); if (NAMED(ans)) SET_NAMED(ans, 2); return ans; } /* back to the regular program */ if (!(isVector(x) || isList(x) || isLanguage(x))) errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x))); named_x = NAMED(x); /* x may change below; save this now. See PR#13411 */ if(nsubs == 1) { /* vector indexing */ SEXP thesub = CAR(subs); int len = length(thesub); if (len > 1) x = vectorIndex(x, thesub, 0, len-1, pok, call); offset = get1index(thesub, getAttrib(x, R_NamesSymbol), xlength(x), pok, len > 1 ? len-1 : -1, call); if (offset < 0 || offset >= xlength(x)) { /* a bold attempt to get the same behaviour for $ and [[ */ if (offset < 0 && (isNewList(x) || isExpression(x) || isList(x) || isLanguage(x))) { UNPROTECT(1); return R_NilValue; } else errorcall(call, R_MSG_subs_o_b); } } else { /* matrix indexing */ /* Here we use the fact that: */ /* CAR(R_NilValue) = R_NilValue */ /* CDR(R_NilValue) = R_NilValue */ int ndn; /* Number of dimnames. Unlikely to be anything but 0 or nsubs, but just in case... */ PROTECT(indx = allocVector(INTSXP, nsubs)); dimnames = getAttrib(x, R_DimNamesSymbol); ndn = length(dimnames); for (i = 0; i < nsubs; i++) { INTEGER(indx)[i] = (int) get1index(CAR(subs), (i < ndn) ? VECTOR_ELT(dimnames, i) : R_NilValue, INTEGER(indx)[i], pok, -1, call); subs = CDR(subs); if (INTEGER(indx)[i] < 0 || INTEGER(indx)[i] >= INTEGER(dims)[i]) errorcall(call, R_MSG_subs_o_b); } offset = 0; for (i = (nsubs - 1); i > 0; i--) offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1]; offset += INTEGER(indx)[0]; UNPROTECT(1); } if(isPairList(x)) { #ifdef LONG_VECTOR_SUPPORT if (offset > R_SHORT_LEN_MAX) error("invalid subscript for pairlist"); #endif ans = CAR(nthcdr(x, (int) offset)); if (named_x > NAMED(ans)) SET_NAMED(ans, named_x); } else if(isVectorList(x)) { /* did unconditional duplication before 2.4.0 */ ans = VECTOR_ELT(x, offset); if (named_x > NAMED(ans)) SET_NAMED(ans, named_x); } else { ans = allocVector(TYPEOF(x), 1); switch (TYPEOF(x)) { case LGLSXP: case INTSXP: INTEGER(ans)[0] = INTEGER(x)[offset]; break; case REALSXP: REAL(ans)[0] = REAL(x)[offset]; break; case CPLXSXP: COMPLEX(ans)[0] = COMPLEX(x)[offset]; break; case STRSXP: SET_STRING_ELT(ans, 0, STRING_ELT(x, offset)); break; case RAWSXP: RAW(ans)[0] = RAW(x)[offset]; break; default: UNIMPLEMENTED_TYPE("do_subset2", x); } } UNPROTECT(1); return ans; }
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; }
/* check neighbourhood sets and markov blanets for consistency.. */ SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP filter, SEXP debug) { int i = 0, j = 0, k = 0, n = 0, counter = 0; short int *checklist = NULL, err = 0; int debuglevel = isTRUE(debug), checkmb = isTRUE(mb), *flt = INTEGER(filter); SEXP temp, temp2, nodes, elnames = NULL, fixed; /* get the names of the nodes. */ nodes = getAttrib(bn, R_NamesSymbol); n = length(nodes); /* allocate and initialize the checklist. */ checklist = allocstatus(UPTRI_MATRIX(n)); if (debuglevel > 0) { Rprintf("----------------------------------------------------------------\n"); if (checkmb) Rprintf("* checking consistency of markov blankets.\n"); else Rprintf("* checking consistency of neighbourhood sets.\n"); }/*THEN*/ /* scan the structure to determine the number of arcs. */ for (i = 0; i < n; i++) { if (debuglevel > 0) Rprintf(" > checking node %s.\n", NODE(i)); /* get the entry for the (neighbours|elements of the markov blanket) of the node.*/ temp = getListElement(bn, (char *)NODE(i)); if (!checkmb) temp = getListElement(temp, "nbr"); /* check each element of the array and identify which variable it corresponds to. */ for (j = 0; j < length(temp); j++) { for (k = 0; k < n; k++) { /* increment the right element of checklist. */ if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j)))) checklist[UPTRI(i + 1, k + 1, n)]++; }/*FOR*/ }/*FOR*/ }/*FOR*/ /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in * the checklist array must be equal to either zero (if the corresponding * nodes are not neighbours) or two (if the corresponding nodes are neighbours). * Any other value (typically one) is caused by an incorrect (i.e. asymmetric) * neighbourhood structure. The same logic holds for the markov blankets. */ for (i = 0; i < n; i++) for (j = i; j < n; j++) { if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) && (checklist[UPTRI(i + 1, j + 1, n)] != 2)) { if (debuglevel > 0) { if (checkmb) Rprintf("@ asymmetry in the markov blankets for %s and %s.\n", NODE(i), NODE(j)); else Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n", NODE(i), NODE(j)); }/*THEN*/ err = 1; }/*THEN*/ }/*FOR*/ /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric; * otherwise throw either an error or a warning according to the value of the * strict parameter. */ if (!err) { return bn; }/*THEN*/ else if (isTRUE(strict)) { if (checkmb) error("markov blankets are not symmetric.\n"); else error("neighbourhood sets are not symmetric.\n"); }/*THEN*/ /* build a correct structure to return. */ PROTECT(fixed = allocVector(VECSXP, n)); setAttrib(fixed, R_NamesSymbol, nodes); /* allocate colnames. */ if (!checkmb) PROTECT(elnames = mkStringVec(2, "mb", "nbr")); for (i = 0; i < n; i++) { if (!checkmb) { /* allocate the "mb" and "nbr" elements of the node. */ PROTECT(temp = allocVector(VECSXP, 2)); SET_VECTOR_ELT(fixed, i, temp); setAttrib(temp, R_NamesSymbol, elnames); /* copy the "mb" part from the old structure. */ temp2 = getListElement(bn, (char *)NODE(i)); temp2 = getListElement(temp2, "mb"); SET_VECTOR_ELT(temp, 0, temp2); }/*THEN*/ /* rescan the checklist. */ for (j = 0; j < n; j++) if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt) if (i != j) counter++; /* allocate and fill the "nbr" element. */ PROTECT(temp2 = allocVector(STRSXP, counter)); for (j = 0; j < n; j++) if (checklist[UPTRI(i + 1, j + 1, n)] == *flt) if (i != j) SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j)); if (checkmb) { SET_VECTOR_ELT(fixed, i, temp2); UNPROTECT(1); }/*THEN*/ else { SET_VECTOR_ELT(temp, 1, temp2); UNPROTECT(2); }/*ELSE*/ }/*FOR*/ if (checkmb) UNPROTECT(1); else UNPROTECT(2); return fixed; }/*BN_RECOVERY*/
SEXP Rgraphviz_buildEdgeList(SEXP nodes, SEXP edgeL, SEXP edgeMode, SEXP subGList, SEXP edgeNames, SEXP removedEdges, SEXP edgeAttrs, SEXP defAttrs) { int x, y, curEle = 0; SEXP from; SEXP peList; SEXP peClass, curPE; SEXP curAttrs, curFrom, curTo, curWeights = R_NilValue; SEXP attrNames; SEXP tmpToSTR, tmpWtSTR, tmpW; SEXP curSubG, subGEdgeL, subGEdges, subGNodes, elt; SEXP recipAttrs, newRecipAttrs, recipAttrNames, newRecipAttrNames; SEXP goodEdgeNames; SEXP toName; SEXP recipPE; char *edgeName, *recipName; int i, j, k, nSubG; int nEdges = length(edgeNames); if (length(edgeL) == 0) return(allocVector(VECSXP, 0)); PROTECT(peClass = MAKE_CLASS("pEdge")); PROTECT(peList = allocVector(VECSXP, nEdges - length(removedEdges))); PROTECT(goodEdgeNames = allocVector(STRSXP, nEdges - length(removedEdges))); PROTECT(curAttrs = allocVector(VECSXP, 3)); PROTECT(attrNames = allocVector(STRSXP, 3)); /* TODO: get rid of attrs "arrowhead"/"arrowtail", "dir" is sufficient */ SET_STRING_ELT(attrNames, 0, mkChar("arrowhead")); SET_STRING_ELT(attrNames, 1, mkChar("weight")); SET_STRING_ELT(attrNames, 2, mkChar("dir")); setAttrib(curAttrs, R_NamesSymbol, attrNames); PROTECT(from = getAttrib(edgeL, R_NamesSymbol)); nSubG = length(subGList); /* For each edge, create a new object of class pEdge */ /* and then assign the 'from' and 'to' strings as */ /* as well as the default attrs (arrowhead & weight) */ for (x = 0; x < length(from); x++) { PROTECT(curFrom = allocVector(STRSXP, 1)); SET_STRING_ELT(curFrom, 0, STRING_ELT(from, x)); if (length(VECTOR_ELT(edgeL, x)) == 0) error("Invalid edgeList element given to buildEdgeList in Rgraphviz, is NULL"); PROTECT(curTo = coerceVector(VECTOR_ELT(VECTOR_ELT(edgeL, x), 0), INTSXP)); if (length(VECTOR_ELT(edgeL, x)) > 1) { curWeights = VECTOR_ELT(VECTOR_ELT(edgeL, x), 1); } if (curWeights == R_NilValue || (length(curWeights) != length(curTo))) { curWeights = allocVector(REALSXP, length(curTo)); for (i = 0; i < length(curWeights); i++) REAL(curWeights)[i] = 1; } PROTECT(curWeights); for (y = 0; y < length(curTo); y++) { PROTECT(toName = STRING_ELT(from, INTEGER(curTo)[y]-1)); edgeName = (char *)malloc((strlen(STR(curFrom))+ strlen(CHAR(toName)) + 2) * sizeof(char)); sprintf(edgeName, "%s~%s", STR(curFrom), CHAR(toName)); /* See if this edge is a removed edge */ for (i = 0; i < length(removedEdges); i++) { if (strcmp(CHAR(STRING_ELT(edgeNames, INTEGER(removedEdges)[i]-1)), edgeName) == 0) break; } if (i < length(removedEdges)) { /* This edge is to be removed */ if (strcmp(STR(edgeMode), "directed") == 0) { /* Find the recip and add 'open' to tail */ recipName = (char *)malloc((strlen(STR(curFrom))+ strlen(CHAR(toName)) + 2) * sizeof(char)); sprintf(recipName, "%s~%s", CHAR(toName), STR(curFrom)); for (k = 0; k < curEle; k++) { if (strcmp(CHAR(STRING_ELT(goodEdgeNames, k)), recipName) == 0) break; } free(recipName); PROTECT(recipPE = VECTOR_ELT(peList, k)); recipAttrs = GET_SLOT(recipPE, Rf_install("attrs")); recipAttrNames = getAttrib(recipAttrs, R_NamesSymbol); /* We need to add this to the current set of recipAttrs, so create a new list which is one element longer and copy everything over, adding the new element */ PROTECT(newRecipAttrs = allocVector(VECSXP, length(recipAttrs)+1)); PROTECT(newRecipAttrNames = allocVector(STRSXP, length(recipAttrNames)+1)); for (j = 0; j < length(recipAttrs); j++) { if ( !strcmp(CHAR(STRING_ELT(recipAttrNames, j)), "dir") ) SET_VECTOR_ELT(newRecipAttrs, j, mkString("both")); else SET_VECTOR_ELT(newRecipAttrs, j, VECTOR_ELT(recipAttrs, j)); SET_STRING_ELT(newRecipAttrNames, j, STRING_ELT(recipAttrNames, j)); } SET_VECTOR_ELT(newRecipAttrs, j, mkString("open")); SET_STRING_ELT(newRecipAttrNames, j, mkChar("arrowtail")); setAttrib(newRecipAttrs, R_NamesSymbol, newRecipAttrNames); SET_SLOT(recipPE, Rf_install("attrs"), newRecipAttrs); SET_VECTOR_ELT(peList, k, recipPE); UNPROTECT(3); } UNPROTECT(1); continue; } PROTECT(tmpToSTR = allocVector(STRSXP, 1)); PROTECT(curPE = NEW_OBJECT(peClass)); SET_SLOT(curPE, Rf_install("from"), curFrom); SET_STRING_ELT(tmpToSTR, 0, toName); SET_SLOT(curPE, Rf_install("to"), tmpToSTR); if (strcmp(STR(edgeMode), "directed") == 0) { SET_VECTOR_ELT(curAttrs, 0, mkString("open")); SET_VECTOR_ELT(curAttrs, 2, mkString("forward")); } else { SET_VECTOR_ELT(curAttrs, 0, mkString("none")); SET_VECTOR_ELT(curAttrs, 2, mkString("none")); } PROTECT(tmpWtSTR = allocVector(STRSXP, 1)); PROTECT(tmpW = Rf_ScalarReal(REAL(curWeights)[y])); SET_STRING_ELT(tmpWtSTR, 0, asChar(tmpW)); UNPROTECT(1); SET_VECTOR_ELT(curAttrs, 1, tmpWtSTR); SET_SLOT(curPE, Rf_install("attrs"), curAttrs); SET_STRING_ELT(goodEdgeNames, curEle, mkChar(edgeName)); SET_VECTOR_ELT(peList, curEle, curPE); curEle++; for (i = 0; i < nSubG; i++) { curSubG = getListElement(VECTOR_ELT(subGList, i), "graph"); subGEdgeL = GET_SLOT(curSubG, Rf_install("edgeL")); subGNodes = GET_SLOT(curSubG, Rf_install("nodes")); elt = getListElement(subGEdgeL, STR(curFrom)); if (elt == R_NilValue) continue; /* Extract out the edges */ subGEdges = VECTOR_ELT(elt, 0); for (j = 0; j < length(subGEdges); j++) { int subGIdx = INTEGER(subGEdges)[j]-1; int graphIdx = INTEGER(curTo)[y]-1; if(strcmp(CHAR(STRING_ELT(subGNodes, subGIdx)),CHAR(STRING_ELT(nodes, graphIdx))) == 0) break; } if (j == length(subGEdges)) continue; /* If we get here, then this edge is in subG 'i' */ SET_SLOT(curPE, Rf_install("subG"), Rf_ScalarInteger(i+1)); /* Only one subgraph per edge */ break; } free(edgeName); UNPROTECT(4); } UNPROTECT(3); } setAttrib(peList, R_NamesSymbol, goodEdgeNames); peList = assignAttrs(edgeAttrs, peList, defAttrs); UNPROTECT(6); return(peList); }
static SEXP CdqrlsShapeQTL(SEXP x, SEXP y, SEXP tol, SEXP chk) { SEXP ans; SEXP qr, coefficients, residuals, effects, pivot, qraux; int n, ny = 0, p, rank, nprotect = 4, pivoted = 0; double rtol = asReal(tol), *work; Rboolean check = asLogical(chk); ans = getAttrib(x, R_DimSymbol); if(check && length(ans) != 2) error(_("'x' is not a matrix")); int *dims = INTEGER(ans); n = dims[0]; p = dims[1]; if(n) ny = (int)(XLENGTH(y)/n); /* y : n x ny, or an n - vector */ if(check && n * ny != XLENGTH(y)) error(_("dimensions of 'x' (%d,%d) and 'y' (%d) do not match"), n,p, XLENGTH(y)); /* These lose attributes, so do after we have extracted dims */ if (TYPEOF(x) != REALSXP) { PROTECT(x = coerceVector(x, REALSXP)); nprotect++; } if (TYPEOF(y) != REALSXP) { PROTECT(y = coerceVector(y, REALSXP)); nprotect++; } double *rptr = REAL(x); for (R_xlen_t i = 0 ; i < XLENGTH(x) ; i++) if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "x"); rptr = REAL(y); for (R_xlen_t i = 0 ; i < XLENGTH(y) ; i++) if(!R_FINITE(rptr[i])) error(_("NA/NaN/Inf in '%s'"), "y"); const char *ansNms[] = {"qr", "coefficients", "residuals", "effects", "rank", "pivot", "qraux", "tol", "pivoted", ""}; PROTECT(ans = mkNamed(VECSXP, ansNms)); SET_VECTOR_ELT(ans, 0, qr = duplicate(x)); coefficients = (ny > 1) ? allocMatrix(REALSXP, p, ny) : allocVector(REALSXP, p); PROTECT(coefficients); SET_VECTOR_ELT(ans, 1, coefficients); SET_VECTOR_ELT(ans, 2, residuals = duplicate(y)); SET_VECTOR_ELT(ans, 3, effects = duplicate(y)); PROTECT(pivot = allocVector(INTSXP, p)); int *ip = INTEGER(pivot); for(int i = 0; i < p; i++) ip[i] = i+1; SET_VECTOR_ELT(ans, 5, pivot); PROTECT(qraux = allocVector(REALSXP, p)); SET_VECTOR_ELT(ans, 6, qraux); SET_VECTOR_ELT(ans, 7, tol); work = (double *) R_alloc(2 * p, sizeof(double)); F77_CALL(dqrls)(REAL(qr), &n, &p, REAL(y), &ny, &rtol, REAL(coefficients), REAL(residuals), REAL(effects), &rank, INTEGER(pivot), REAL(qraux), work); SET_VECTOR_ELT(ans, 4, ScalarInteger(rank)); for(int i = 0; i < p; i++) if(ip[i] != i+1) { pivoted = 1; break; } SET_VECTOR_ELT(ans, 8, ScalarLogical(pivoted)); UNPROTECT(nprotect); return ans; }
/* used in eval.c */ SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call) { SEXP y, nlist; size_t slen; PROTECT(x); PROTECT(input); /* Optimisation to prevent repeated recalculation */ slen = strlen(translateChar(input)); /* The mechanism to allow a class extending "environment" */ if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){ x = R_getS4DataSlot(x, ANYSXP); if(x == R_NilValue) errorcall(call, "$ operator not defined for this S4 class"); } /* If this is not a list object we return NULL. */ if (isPairList(x)) { SEXP xmatch = R_NilValue; int havematch; UNPROTECT(2); havematch = 0; for (y = x ; y != R_NilValue ; y = CDR(y)) { switch(pstrmatch(TAG(y), input, slen)) { case EXACT_MATCH: y = CAR(y); if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x)); return y; case PARTIAL_MATCH: havematch++; xmatch = y; break; case NO_MATCH: break; } } if (havematch == 1) { /* unique partial match */ if(R_warn_partial_match_dollar) { const char *st = ""; SEXP target = TAG(y); switch (TYPEOF(target)) { case SYMSXP: st = CHAR(PRINTNAME(target)); break; case CHARSXP: st = translateChar(target); break; } warningcall(call, _("partial match of '%s' to '%s'"), translateChar(input), st); } y = CAR(xmatch); if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x)); return y; } return R_NilValue; } else if (isVectorList(x)) { R_xlen_t i, n, imatch = -1; int havematch; nlist = getAttrib(x, R_NamesSymbol); UNPROTECT(2); n = xlength(nlist); havematch = 0; for (i = 0 ; i < n ; i = i + 1) { switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) { case EXACT_MATCH: y = VECTOR_ELT(x, i); if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x)); return y; case PARTIAL_MATCH: havematch++; if (havematch == 1) { /* partial matches can cause aliasing in eval.c:evalseq This is overkill, but alternative ways to prevent the aliasing appear to be even worse */ y = VECTOR_ELT(x,i); SET_NAMED(y,2); SET_VECTOR_ELT(x,i,y); } imatch = i; break; case NO_MATCH: break; } } if(havematch == 1) { /* unique partial match */ if(R_warn_partial_match_dollar) { const char *st = ""; SEXP target = STRING_ELT(nlist, imatch); switch (TYPEOF(target)) { case SYMSXP: st = CHAR(PRINTNAME(target)); break; case CHARSXP: st = translateChar(target); break; } warningcall(call, _("partial match of '%s' to '%s'"), translateChar(input), st); } y = VECTOR_ELT(x, imatch); if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x)); return y; } return R_NilValue; } else if( isEnvironment(x) ){ y = findVarInFrame(x, install(translateChar(input))); if( TYPEOF(y) == PROMSXP ) { PROTECT(y); y = eval(y, R_GlobalEnv); UNPROTECT(1); } UNPROTECT(2); if( y != R_UnboundValue ) { if (NAMED(y)) SET_NAMED(y, 2); else if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x)); return(y); } return R_NilValue; } else if( isVectorAtomic(x) ){ errorcall(call, "$ operator is invalid for atomic vectors"); } else /* e.g. a function */ errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x))); UNPROTECT(2); return R_NilValue; }
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); }
/* 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 R_handle_setopt(SEXP ptr, SEXP keys, SEXP values){ CURL *handle = get_handle(ptr); SEXP prot = R_ExternalPtrProtected(ptr); SEXP optnames = PROTECT(getAttrib(values, R_NamesSymbol)); if(!isInteger(keys)) error("keys` must be an integer"); if(!isVector(values)) error("`values` must be a list"); for(int i = 0; i < length(keys); i++){ int key = INTEGER(keys)[i]; const char* optname = CHAR(STRING_ELT(optnames, i)); SEXP val = VECTOR_ELT(values, i); if(val == R_NilValue){ assert(curl_easy_setopt(handle, key, NULL)); #ifdef HAS_XFERINFOFUNCTION } else if (key == CURLOPT_XFERINFOFUNCTION) { if (TYPEOF(val) != CLOSXP) error("Value for option %s (%d) must be a function.", optname, key); assert(curl_easy_setopt(handle, CURLOPT_XFERINFOFUNCTION, (curl_progress_callback) R_curl_callback_xferinfo)); assert(curl_easy_setopt(handle, CURLOPT_XFERINFODATA, val)); assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0)); SET_VECTOR_ELT(prot, 1, val); //protect gc #endif } else if (key == CURLOPT_PROGRESSFUNCTION) { if (TYPEOF(val) != CLOSXP) error("Value for option %s (%d) must be a function.", optname, key); assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION, (curl_progress_callback) R_curl_callback_progress)); assert(curl_easy_setopt(handle, CURLOPT_PROGRESSDATA, val)); assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0)); SET_VECTOR_ELT(prot, 2, val); //protect gc } else if (key == CURLOPT_READFUNCTION) { if (TYPEOF(val) != CLOSXP) error("Value for option %s (%d) must be a function.", optname, key); assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION, (curl_read_callback) R_curl_callback_read)); assert(curl_easy_setopt(handle, CURLOPT_READDATA, val)); SET_VECTOR_ELT(prot, 3, val); //protect gc } else if (key == CURLOPT_DEBUGFUNCTION) { if (TYPEOF(val) != CLOSXP) error("Value for option %s (%d) must be a function.", optname, key); assert(curl_easy_setopt(handle, CURLOPT_DEBUGFUNCTION, (curl_debug_callback) R_curl_callback_debug)); assert(curl_easy_setopt(handle, CURLOPT_DEBUGDATA, val)); SET_VECTOR_ELT(prot, 4, val); //protect gc } else if (key == CURLOPT_URL) { /* always use utf-8 for urls */ const char * url_utf8 = translateCharUTF8(STRING_ELT(val, 0)); assert(curl_easy_setopt(handle, CURLOPT_URL, url_utf8)); } else if (opt_is_linked_list(key)) { error("Option %s (%d) not supported.", optname, key); } else if(key < 10000){ if(!isNumeric(val) || length(val) != 1) { error("Value for option %s (%d) must be a number.", optname, key); } assert(curl_easy_setopt(handle, key, (long) asInteger(val))); } else if(key < 20000){ switch (TYPEOF(val)) { case RAWSXP: if(key == CURLOPT_POSTFIELDS || key == CURLOPT_COPYPOSTFIELDS) assert(curl_easy_setopt(handle, CURLOPT_POSTFIELDSIZE_LARGE, (curl_off_t) Rf_length(val))); assert(curl_easy_setopt(handle, key, RAW(val))); break; case STRSXP: if (length(val) != 1) error("Value for option %s (%d) must be length-1 string", optname, key); assert(curl_easy_setopt(handle, key, CHAR(STRING_ELT(val, 0)))); break; default: error("Value for option %s (%d) must be a string or raw vector.", optname, key); } } else if(key >= 30000 && key < 40000){ if(!isNumeric(val) || length(val) != 1) { error("Value for option %s (%d) must be a number.", optname, key); } assert(curl_easy_setopt(handle, key, (curl_off_t) asReal(val))); } else { error("Option %s (%d) not supported.", optname, key); } } UNPROTECT(1); return ScalarLogical(1); }
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; }
double castelo_prior(SEXP beta, SEXP target, SEXP parents, SEXP children, int debuglevel) { int i = 0, k = 0, t = 0, nnodes = 0, cur_arc = 0; int nbeta = length(VECTOR_ELT(beta, 0)); int *temp = NULL, *aid = INTEGER(VECTOR_ELT(beta, 2)); double prior = 0, result = 0; double *bkwd = REAL(VECTOR_ELT(beta, 4)), *fwd = REAL(VECTOR_ELT(beta, 3)); short int *adjacent = NULL; SEXP nodes, try; /* get the node labels. */ nodes = getAttrib(beta, BN_NodesSymbol); nnodes = length(nodes); /* match the target node. */ PROTECT(try = match(nodes, target, 0)); t = INT(try); UNPROTECT(1); /* find out which nodes are parents and which nodes are children. */ adjacent = allocstatus(nnodes); PROTECT(try = match(nodes, parents, 0)); temp = INTEGER(try); for (i = 0; i < length(try); i++) adjacent[temp[i] - 1] = PARENT; UNPROTECT(1); PROTECT(try = match(nodes, children, 0)); temp = INTEGER(try); for (i = 0; i < length(try); i++) adjacent[temp[i] - 1] = CHILD; UNPROTECT(1); /* prior probabilities table lookup. */ for (i = t + 1; i <= nnodes; i++) { /* compute the arc id. */ cur_arc = UPTRI3(t, i, nnodes); /* look up the prior probability. */ for (/*k,*/ prior = ((double)1/3); k < nbeta; k++) { /* arcs are ordered, so we can stop early in the lookup. */ if (aid[k] > cur_arc) break; if (aid[k] == cur_arc) { switch(adjacent[i - 1]) { case PARENT: prior = bkwd[k]; break; case CHILD: prior = fwd[k]; break; default: prior = fmax2(0, 1 - bkwd[k] - fwd[k]); }/*SWITCH*/ break; }/*THEN*/ }/*FOR*/ if (debuglevel > 0) { switch(adjacent[i - 1]) { case PARENT: Rprintf(" > found arc %s -> %s, prior pobability is %lf.\n", NODE(i - 1), NODE(t - 1), prior); break; case CHILD: Rprintf(" > found arc %s -> %s, prior probability is %lf.\n", NODE(t - 1), NODE(i - 1), prior); break; default: Rprintf(" > no arc between %s and %s, prior probability is %lf.\n", NODE(t - 1), NODE(i - 1), prior); }/*SWITCH*/ }/*THEN*/ /* move to log-scale and divide by the non-informative log(1/3), so that * the contribution of each arc whose prior has not been specified by the * user is zero; overflow is likely otherwise. */ result += log(prior / ((double)1/3)); }/*FOR*/ return result; }/*CASTELO_PRIOR*/ /* complete a prior as per Castelo & Siebes. */ SEXP castelo_completion(SEXP prior, SEXP nodes, SEXP learning) { int i = 0, k = 0, cur = 0, narcs1 = 0, narcs2 = 0, nnodes = length(nodes); int *m1 = NULL, *m2 = NULL, *und = NULL, *aid = NULL, *poset = NULL, *id = NULL; double *d1 = NULL, *d2 = NULL, *p = NULL; SEXP df, arc_id, undirected, a1, a2, match1, match2, prob; SEXP result, from, to, nid, dir1, dir2; /* compute numeric IDs for the arcs. */ a1 = VECTOR_ELT(prior, 0); a2 = VECTOR_ELT(prior, 1); narcs1 = length(a1); PROTECT(match1 = match(nodes, a1, 0)); PROTECT(match2 = match(nodes, a2, 0)); m1 = INTEGER(match1); m2 = INTEGER(match2); PROTECT(arc_id = allocVector(INTSXP, narcs1)); aid = INTEGER(arc_id); c_arc_hash(narcs1, nnodes, m1, m2, aid, NULL, FALSE); /* duplicates correspond to undirected arcs. */ PROTECT(undirected = dupe(arc_id)); und = INTEGER(undirected); /* extract the components from the prior. */ prob = VECTOR_ELT(prior, 2); p = REAL(prob); /* count output arcs. */ for (i = 0; i < narcs1; i++) narcs2 += 2 - und[i]; narcs2 /= 2; /* allocate the columns of the return value. */ PROTECT(from = allocVector(STRSXP, narcs2)); PROTECT(to = allocVector(STRSXP, narcs2)); PROTECT(nid = allocVector(INTSXP, narcs2)); id = INTEGER(nid); PROTECT(dir1 = allocVector(REALSXP, narcs2)); d1 = REAL(dir1); PROTECT(dir2 = allocVector(REALSXP, narcs2)); d2 = REAL(dir2); /* sort the strength coefficients. */ poset = alloc1dcont(narcs1); for (k = 0; k < narcs1; k++) poset[k] = k; R_qsort_int_I(aid, poset, 1, narcs1); for (i = 0, k = 0; i < narcs1; i++) { cur = poset[i]; #define ASSIGN(A1, A2, D1, D2) \ SET_STRING_ELT(from, k, STRING_ELT(A1, cur)); \ SET_STRING_ELT(to, k, STRING_ELT(A2, cur)); \ id[k] = aid[i]; \ D1[k] = p[cur]; \ if ((und[cur] == TRUE) && (i < narcs1 - 1)) \ D2[k] = p[poset[++i]]; \ else \ D2[k] = (1 - D1[k])/2; /* copy the node labels. */ if (m1[cur] < m2[cur]) { ASSIGN(a1, a2, d1, d2); }/*THEN*/ else { ASSIGN(a2, a1, d2, d1); }/*ELSE*/ /* check the probabilities do not exceed 1; fail only for large errors. */ if (d1[k] + d2[k] > 1) { if (d1[k] + d2[k] < 1 + 2 * MACHINE_TOL) { d1[k] = d1[k] / (d1[k] + d2[k]); d2[k] = d2[k] / (d1[k] + d2[k]); }/*THEN*/ else { UNPROTECT(9); error("the probabilities for arc %s -> %s sum to %lf.", CHAR(STRING_ELT(from, k)), CHAR(STRING_ELT(to, k)), d1[k] + d2[k]); }/*ELSE*/ }/*THEN*/ /* bound the probability of not including an arc away from zero, structure * learning otherwise fails when starting from the empty graph and gets * stuck very easily in general. */ if (isTRUE(learning) && (fabs(1 - d1[k] - d2[k]) < MACHINE_TOL)) { d1[k] = d1[k] - MACHINE_TOL; d2[k] = d2[k] - MACHINE_TOL; }/*THEN*/ /* move to the next arc. */ k++; }/*FOR*/ /* set up the return value. */ PROTECT(result = allocVector(VECSXP, 5)); SET_VECTOR_ELT(result, 0, from); SET_VECTOR_ELT(result, 1, to); SET_VECTOR_ELT(result, 2, nid); SET_VECTOR_ELT(result, 3, dir1); SET_VECTOR_ELT(result, 4, dir2); setAttrib(result, R_NamesSymbol, mkStringVec(5, "from", "to", "aid", "fwd", "bkwd")); PROTECT(df = minimal_data_frame(result)); UNPROTECT(11); return df; }/*CASTELO_COMPLETION*/
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop) { int k, mode; SEXP dimnames, dimnamesnames, p, q, r, result, xdims; const void *vmaxsave = vmaxget(); mode = TYPEOF(x); xdims = getAttrib(x, R_DimSymbol); k = length(xdims); /* k is now the number of dims */ int **subs = (int**)R_alloc(k, sizeof(int*)); int *indx = (int*)R_alloc(k, sizeof(int)); int *bound = (int*)R_alloc(k, sizeof(int)); R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t)); /* Construct a vector to contain the returned values. */ /* Store its extents. */ R_xlen_t n = 1; r = s; for (int i = 0; i < k; i++) { SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call)); bound[i] = LENGTH(CAR(r)); n *= bound[i]; r = CDR(r); } PROTECT(result = allocVector(mode, n)); r = s; for (int i = 0; i < k; i++) { indx[i] = 0; subs[i] = INTEGER(CAR(r)); r = CDR(r); } offset[0] = 1; for (int i = 1; i < k; i++) offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1]; /* Transfer the subset elements from "x" to "a". */ for (R_xlen_t i = 0; i < n; i++) { R_xlen_t ii = 0; for (int j = 0; j < k; j++) { int jj = subs[j][indx[j]]; if (jj == NA_INTEGER) { ii = NA_INTEGER; goto assignLoop; } if (jj < 1 || jj > INTEGER(xdims)[j]) errorcall(call, R_MSG_subs_o_b); ii += (jj - 1) * offset[j]; } assignLoop: switch (mode) { case LGLSXP: if (ii != NA_INTEGER) LOGICAL(result)[i] = LOGICAL(x)[ii]; else LOGICAL(result)[i] = NA_LOGICAL; break; case INTSXP: if (ii != NA_INTEGER) INTEGER(result)[i] = INTEGER(x)[ii]; else INTEGER(result)[i] = NA_INTEGER; break; case REALSXP: if (ii != NA_INTEGER) REAL(result)[i] = REAL(x)[ii]; else REAL(result)[i] = NA_REAL; break; case CPLXSXP: if (ii != NA_INTEGER) { COMPLEX(result)[i] = COMPLEX(x)[ii]; } else { COMPLEX(result)[i].r = NA_REAL; COMPLEX(result)[i].i = NA_REAL; } break; case STRSXP: if (ii != NA_INTEGER) SET_STRING_ELT(result, i, STRING_ELT(x, ii)); else SET_STRING_ELT(result, i, NA_STRING); break; case VECSXP: if (ii != NA_INTEGER) SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii)); else SET_VECTOR_ELT(result, i, R_NilValue); break; case RAWSXP: if (ii != NA_INTEGER) RAW(result)[i] = RAW(x)[ii]; else RAW(result)[i] = (Rbyte) 0; break; default: errorcall(call, _("array subscripting not handled for this type")); break; } if (n > 1) { int j = 0; while (++indx[j] >= bound[j]) { indx[j] = 0; j = (j + 1) % k; } } } PROTECT(xdims = allocVector(INTSXP, k)); for(int i = 0 ; i < k ; i++) INTEGER(xdims)[i] = bound[i]; setAttrib(result, R_DimSymbol, xdims); UNPROTECT(1); /* The array elements have been transferred. */ /* Now we need to transfer the attributes. */ /* Most importantly, we need to subset the */ /* dimnames of the returned value. */ dimnames = getAttrib(x, R_DimNamesSymbol); dimnamesnames = getAttrib(dimnames, R_NamesSymbol); if (dimnames != R_NilValue) { int j = 0; PROTECT(xdims = allocVector(VECSXP, k)); if (TYPEOF(dimnames) == VECSXP) { r = s; for (int i = 0; i < k ; i++) { if (bound[i] > 0) { SET_VECTOR_ELT(xdims, j++, ExtractSubset(VECTOR_ELT(dimnames, i), allocVector(STRSXP, bound[i]), CAR(r), call)); } else { /* 0-length dims have NULL dimnames */ SET_VECTOR_ELT(xdims, j++, R_NilValue); } r = CDR(r); } } else { p = dimnames; q = xdims; r = s; for(int i = 0 ; i < k; i++) { SETCAR(q, allocVector(STRSXP, bound[i])); SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call)); p = CDR(p); q = CDR(q); r = CDR(r); } } setAttrib(xdims, R_NamesSymbol, dimnamesnames); setAttrib(result, R_DimNamesSymbol, xdims); UNPROTECT(1); } /* This was removed for matrices in 1998 copyMostAttrib(x, result); */ /* Free temporary memory */ vmaxset(vmaxsave); if (drop) DropDims(result); UNPROTECT(1); return result; }
/* reduce multiple boostrap strength R objects. */ SEXP bootstrap_reduce(SEXP x) { int i = 0, j = 0, reps = length(x), nrow = 0; double *str = NULL, *dir = NULL, *temp = NULL; SEXP result, df, strength, direction; /* allocate return value. */ PROTECT(result = allocVector(VECSXP, 4)); /* extract the first data frame from the list. */ df = VECTOR_ELT(x, 0); /* copy data frame column names. */ setAttrib(result, R_NamesSymbol, getAttrib(df, R_NamesSymbol)); /* copy the first two columns. */ SET_VECTOR_ELT(result, 0, VECTOR_ELT(df, 0)); SET_VECTOR_ELT(result, 1, VECTOR_ELT(df, 1)); /* get the number of rows. */ nrow = length(VECTOR_ELT(df, 0)); /* allocate the remaining two columns. */ PROTECT(strength = allocVector(REALSXP, nrow)); str = REAL(strength); PROTECT(direction = allocVector(REALSXP, nrow)); dir = REAL(direction); /* just copy over strength and direction. */ memcpy(str, REAL(VECTOR_ELT(df, 2)), nrow * sizeof(double)); memcpy(dir, REAL(VECTOR_ELT(df, 3)), nrow * sizeof(double)); for (i = 1; i < reps; i++) { /* extract the data frame from the list. */ df = VECTOR_ELT(x, i); /* accumulate strength. */ temp = REAL(VECTOR_ELT(df, 2)); for (j = 0; j < nrow; j++) str[j] += temp[j]; /* accumulate direction. */ temp = REAL(VECTOR_ELT(df, 3)); for (j = 0; j < nrow; j++) dir[j] += temp[j]; }/*FOR*/ /* normalize dividing by the number of data frames. */ for (j = 0; j < nrow; j++) { str[j] /= reps; dir[j] /= reps; }/*FOR*/ /* set the last two columns. */ SET_VECTOR_ELT(result, 2, strength); SET_VECTOR_ELT(result, 3, direction); /* make the return value a real data frame. */ minimal_data_frame(result); UNPROTECT(3); return result; }/*BOOTSTRAP_REDUCE*/
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans, ax, px, x, subs; int drop, i, nsubs, type; /* By default we drop extents of length 1 */ /* Handle cases of extracting a single element from a simple vector or matrix directly to improve speed for these simple cases. */ SEXP cdrArgs = CDR(args); SEXP cddrArgs = CDR(cdrArgs); if (cdrArgs != R_NilValue && cddrArgs == R_NilValue && TAG(cdrArgs) == R_NilValue) { /* one index, not named */ SEXP x = CAR(args); if (ATTRIB(x) == R_NilValue) { SEXP s = CAR(cdrArgs); R_xlen_t i = scalarIndex(s); switch (TYPEOF(x)) { case REALSXP: if (i >= 1 && i <= XLENGTH(x)) return ScalarReal( REAL(x)[i-1] ); break; case INTSXP: if (i >= 1 && i <= XLENGTH(x)) return ScalarInteger( INTEGER(x)[i-1] ); break; case LGLSXP: if (i >= 1 && i <= XLENGTH(x)) return ScalarLogical( LOGICAL(x)[i-1] ); break; default: break; } } } else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue && TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) { /* two indices, not named */ SEXP x = CAR(args); SEXP attr = ATTRIB(x); if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) { /* only attribute of x is 'dim' */ SEXP dim = CAR(attr); if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) { /* x is a matrix */ SEXP si = CAR(cdrArgs); SEXP sj = CAR(cddrArgs); R_xlen_t i = scalarIndex(si); R_xlen_t j = scalarIndex(sj); int nrow = INTEGER(dim)[0]; int ncol = INTEGER(dim)[1]; if (i > 0 && j > 0 && i <= nrow && j <= ncol) { /* indices are legal scalars */ R_xlen_t k = i - 1 + nrow * (j - 1); switch (TYPEOF(x)) { case REALSXP: if (k < LENGTH(x)) return ScalarReal( REAL(x)[k] ); break; case INTSXP: if (k < LENGTH(x)) return ScalarInteger( INTEGER(x)[k] ); break; case LGLSXP: if (k < LENGTH(x)) return ScalarLogical( LOGICAL(x)[k] ); break; default: break; } } } } } PROTECT(args); drop = 1; ExtractDropArg(args, &drop); x = CAR(args); /* This was intended for compatibility with S, */ /* but in fact S does not do this. */ /* FIXME: replace the test by isNull ... ? */ if (x == R_NilValue) { UNPROTECT(1); return x; } subs = CDR(args); nsubs = length(subs); /* Will be short */ type = TYPEOF(x); /* Here coerce pair-based objects into generic vectors. */ /* All subsetting takes place on the generic vector form. */ ax = x; if (isVector(x)) PROTECT(ax); else if (isPairList(x)) { SEXP dim = getAttrib(x, R_DimSymbol); int ndim = length(dim); if (ndim > 1) { PROTECT(ax = allocArray(VECSXP, dim)); setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol)); } else { PROTECT(ax = allocVector(VECSXP, length(x))); setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol)); } for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px)) SET_VECTOR_ELT(ax, i++, CAR(px)); } else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x))); /* This is the actual subsetting code. */ /* The separation of arrays and matrices is purely an optimization. */ if(nsubs < 2) { SEXP dim = getAttrib(x, R_DimSymbol); int ndim = length(dim); PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg), call)); /* one-dimensional arrays went through here, and they should have their dimensions dropped only if the result has length one and drop == TRUE */ if(ndim == 1) { SEXP attr, attrib, nattrib; int len = length(ans); if(!drop || len > 1) { PROTECT(attr = allocVector(INTSXP, 1)); INTEGER(attr)[0] = length(ans); setAttrib(ans, R_DimSymbol, attr); UNPROTECT(1); if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) { /* reinstate dimnames, include names of dimnames */ PROTECT(nattrib = duplicate(attrib)); SET_VECTOR_ELT(nattrib, 0, getAttrib(ans, R_NamesSymbol)); setAttrib(ans, R_DimNamesSymbol, nattrib); setAttrib(ans, R_NamesSymbol, R_NilValue); UNPROTECT(1); } } } } else { if (nsubs != length(getAttrib(x, R_DimSymbol))) errorcall(call, _("incorrect number of dimensions")); if (nsubs == 2) ans = MatrixSubset(ax, subs, call, drop); else ans = ArraySubset(ax, subs, call, drop); PROTECT(ans); } /* Note: we do not coerce back to pair-based lists. */ /* They are "defunct" in this version of R. */ if (type == LANGSXP) { ax = ans; PROTECT(ans = allocList(LENGTH(ax))); if ( LENGTH(ax) > 0 ) SET_TYPEOF(ans, LANGSXP); for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px)) SETCAR(px, VECTOR_ELT(ax, i++)); setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol)); setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol)); setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol)); SET_NAMED(ans, NAMED(ax)); /* PR#7924 */ } else { PROTECT(ans); } if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */ setAttrib(ans, R_TspSymbol, R_NilValue); #ifdef _S4_subsettable if(!IS_S4_OBJECT(x)) #endif setAttrib(ans, R_ClassSymbol, R_NilValue); } UNPROTECT(4); return ans; }
apop_data *apop_data_from_frame(SEXP in){ apop_data *out; if (TYPEOF(in)==NILSXP) return NULL; PROTECT(in); assert(TYPEOF(in)==VECSXP); //I should write a check for this on the R side. int total_cols=LENGTH(in); int total_rows=LENGTH(VECTOR_ELT(in,0)); int char_cols = 0; for (int i=0; i< total_cols; i++){ SEXP this_col = VECTOR_ELT(in, i); char_cols += (TYPEOF(this_col)==STRSXP); } SEXP rl, cl; //const char *rn, *cn; //GetMatrixDimnames(in, &rl, &cl, &rn, &cn); PROTECT(cl = getAttrib(in, R_NamesSymbol)); PROTECT(rl = getAttrib(in, R_RowNamesSymbol)); int current_numeric_col=0, current_text_col=0, found_vector=0; if(cl !=R_NilValue && TYPEOF(cl)==STRSXP) //just check for now. for (int ndx=0; ndx < LENGTH(cl) && !found_vector; ndx++) if (!strcmp(translateChar(STRING_ELT(cl, ndx)), "Vector")) found_vector++; int matrix_cols= total_cols-char_cols-found_vector; out= apop_data_alloc((found_vector?total_rows:0), (matrix_cols?total_rows:0), matrix_cols); if (char_cols) out=apop_text_alloc(out, total_rows, char_cols); if(rl !=R_NilValue) for (int ndx=0; ndx < LENGTH(rl); ndx++) if (TYPEOF(rl)==STRSXP) apop_name_add(out->names, translateChar(STRING_ELT(rl, ndx)), 'r'); else //let us guess that it's a numeric list and hope the R Project one day documents this stuff. {char *ss; asprintf(&ss, "%i", ndx); apop_name_add(out->names, ss, 'r'); free(ss);} for (int i=0; i< total_cols; i++){ const char *colname = NULL; if(cl !=R_NilValue) colname = translateChar(STRING_ELT(cl, i)); SEXP this_col = VECTOR_ELT(in, i); if (TYPEOF(this_col) == STRSXP){ //could this be via aliases instead of copying? //printf("col %i is chars\n", i); if(colname) apop_name_add(out->names, colname, 't'); for (int j=0; j< total_rows; j++) apop_text_add(out, j, current_text_col, (STRING_ELT(this_col,j)==NA_STRING ? apop_opts.nan_string : translateChar(STRING_ELT(this_col, j)))); current_text_col++; continue; } else { //plain old matrix data. int col_in_question = current_numeric_col; if (colname && !strcmp(colname, "Vector")) { out->vector = gsl_vector_alloc(total_rows); col_in_question = -1; } else {current_numeric_col++;} Apop_col_v(out, col_in_question, onecol); if (TYPEOF(this_col) == INTSXP){ //printf("col %i is ints\n", i); int *vals = INTEGER(this_col); for (int j=0; j< onecol->size; j++){ //printf("%i\n",vals[j]); gsl_vector_set(onecol, j, (vals[j]==NA_INTEGER ? GSL_NAN : vals[j])); } } else { double *vals = REAL(this_col); for (int j=0; j< onecol->size; j++) gsl_vector_set(onecol, j, (ISNAN(vals[j])||ISNA(vals[j]) ? GSL_NAN : vals[j])); } if(colname && col_in_question > -1) apop_name_add(out->names, colname, 'c'); else apop_name_add(out->names, colname, 'v'); //which is "vector". } //Factors SEXP ls = getAttrib(this_col, R_LevelsSymbol); if (ls){ apop_data *end;//find last page for adding factors. for(end=out; end->more!=NULL; end=end->more); end->more = get_factors(ls, colname); } } UNPROTECT(3); return out; }
static SEXP lbinary(SEXP call, SEXP op, SEXP args) { /* logical binary : "&" or "|" */ SEXP x, y, dims, tsp, klass, xnames, ynames; R_xlen_t mismatch, nx, ny; int xarray, yarray, xts, yts; mismatch = 0; x = CAR(args); y = CADR(args); if (isRaw(x) && isRaw(y)) { } else if (!isNumber(x) || !isNumber(y)) errorcall(call, _("operations are possible only for numeric, logical or complex types")); tsp = R_NilValue; /* -Wall */ klass = R_NilValue; /* -Wall */ xarray = isArray(x); yarray = isArray(y); xts = isTs(x); yts = isTs(y); if (xarray || yarray) { if (xarray && yarray) { if (!conformable(x, y)) error(_("binary operation on non-conformable arrays")); PROTECT(dims = getAttrib(x, R_DimSymbol)); } else if (xarray) { PROTECT(dims = getAttrib(x, R_DimSymbol)); } else /*(yarray)*/ { PROTECT(dims = getAttrib(y, R_DimSymbol)); } PROTECT(xnames = getAttrib(x, R_DimNamesSymbol)); PROTECT(ynames = getAttrib(y, R_DimNamesSymbol)); } else { PROTECT(dims = R_NilValue); PROTECT(xnames = getAttrib(x, R_NamesSymbol)); PROTECT(ynames = getAttrib(y, R_NamesSymbol)); } nx = XLENGTH(x); ny = XLENGTH(y); if(nx > 0 && ny > 0) { if(nx > ny) mismatch = nx % ny; else mismatch = ny % nx; } if (xts || yts) { if (xts && yts) { if (!tsConform(x, y)) errorcall(call, _("non-conformable time series")); PROTECT(tsp = getAttrib(x, R_TspSymbol)); PROTECT(klass = getAttrib(x, R_ClassSymbol)); } else if (xts) { if (XLENGTH(x) < XLENGTH(y)) ErrorMessage(call, ERROR_TSVEC_MISMATCH); PROTECT(tsp = getAttrib(x, R_TspSymbol)); PROTECT(klass = getAttrib(x, R_ClassSymbol)); } else /*(yts)*/ { if (XLENGTH(y) < XLENGTH(x)) ErrorMessage(call, ERROR_TSVEC_MISMATCH); PROTECT(tsp = getAttrib(y, R_TspSymbol)); PROTECT(klass = getAttrib(y, R_ClassSymbol)); } } if(mismatch) warningcall(call, _("longer object length is not a multiple of shorter object length")); if (isRaw(x) && isRaw(y)) { PROTECT(x = binaryLogic2(PRIMVAL(op), x, y)); } else { if (!isNumber(x) || !isNumber(y)) errorcall(call, _("operations are possible only for numeric, logical or complex types")); x = SETCAR(args, coerceVector(x, LGLSXP)); y = SETCADR(args, coerceVector(y, LGLSXP)); PROTECT(x = binaryLogic(PRIMVAL(op), x, y)); } if (dims != R_NilValue) { setAttrib(x, R_DimSymbol, dims); if(xnames != R_NilValue) setAttrib(x, R_DimNamesSymbol, xnames); else if(ynames != R_NilValue) setAttrib(x, R_DimNamesSymbol, ynames); } else { if(XLENGTH(x) == XLENGTH(xnames)) setAttrib(x, R_NamesSymbol, xnames); else if(XLENGTH(x) == XLENGTH(ynames)) setAttrib(x, R_NamesSymbol, ynames); } if (xts || yts) { setAttrib(x, R_TspSymbol, tsp); setAttrib(x, R_ClassSymbol, klass); UNPROTECT(2); } UNPROTECT(4); return x; }