SEXP CProdColmain(SEXP matType, SEXP bigMatrixAddr, SEXP col, SEXP narm) { mainsetup(); casesetup(double, NEW_NUMERIC, NUMERIC_DATA); switch (mt) { case 1: { CProdCol<char, double>(bigMatrixAddr, pRet, pCols, nCols, narm, NA_CHAR); } break; case 2: { CProdCol<short, double>(bigMatrixAddr, pRet, pCols, nCols, narm, NA_SHORT); } break; case 4: { CProdCol<int, double>(bigMatrixAddr, pRet, pCols, nCols, narm, NA_INTEGER); } break; case 8: { CProdCol<double, double>(bigMatrixAddr, pRet, pCols, nCols, narm, NA_REAL); } break; } Rf_unprotect(1); return(ret); }
void UNPROTECT_DEBUG(int n, const char *fun, const char *file, int line) { Rprintf("[%s()][%d -> %d] UNPROTECT() at %s:%d\n", fun, stack_counter, stack_counter - n, file, line); stack_counter -= n; Rf_unprotect(n); }/*UNPROTECT_DEBUG*/
void plot::save_snapshot_variable() { rhost::util::errors_to_exceptions([&] { pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc); SEXP snapshot = Rf_protect(GEcreateSnapshot(ge_dev_desc)); SEXP klass = Rf_protect(Rf_mkString("recordedplot")); Rf_classgets(snapshot, klass); Rf_defineVar(Rf_install(_snapshot_varname.c_str()), snapshot, R_GlobalEnv); Rf_unprotect(2); }); }
void plot::set_snapshot(const rhost::util::protected_sexp& snapshot) { // Ignore if we already created a snapshot if (_snapshot_varname.empty()) { _snapshot_varname = get_snapshot_varname(); } rhost::util::errors_to_exceptions([&] { SEXP klass = Rf_protect(Rf_mkString("recordedplot")); Rf_classgets(snapshot.get(), klass); SEXP duplicated_snapshot = Rf_protect(Rf_duplicate(snapshot.get())); Rf_defineVar(Rf_install(_snapshot_varname.c_str()), duplicated_snapshot, R_GlobalEnv); Rf_unprotect(2); }); }
SEXP audio_player(SEXP source, SEXP rate) { float fRate = -1.0; if (!current_driver) load_default_audio_driver(0); if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP) fRate = (float) Rf_asReal(rate); audio_instance_t *p = current_driver->create_player(source, fRate, 0); if (!p) Rf_error("cannot start audio driver"); p->driver = current_driver; p->kind = AI_PLAYER; SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue); Rf_protect(ptr); R_RegisterCFinalizer(ptr, audio_instance_destructor); Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance")); Rf_unprotect(1); return ptr; }
SEXP audio_drivers_list() { int n = 0; SEXP res = Rf_allocVector(VECSXP, 3), sName, sDesc, /* sCopy, */ sCurr, sLN, sRN; audio_driver_list_t *l = &audio_drivers; if (!current_driver) load_default_audio_driver(1); Rf_protect(res); if (l->driver) { while (l) { n++; l = l->next; } } sName = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 0, sName); sDesc = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 1, sDesc); sCurr = Rf_allocVector(LGLSXP, n); SET_VECTOR_ELT(res, 2, sCurr); /* sCopy = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 3, sCopy); */ if (n) { n = 0; l = &audio_drivers; while (l) { const char *s = l->driver->name; SET_STRING_ELT(sName, n, Rf_mkChar(s ? s : "")); s = l->driver->descr; SET_STRING_ELT(sDesc, n, Rf_mkChar(s ? s : "")); s = l->driver->copyright; /* SET_STRING_ELT(sCopy, n, Rf_mkChar(s ? s : "")); */ LOGICAL(sCurr)[n] = (l->driver == current_driver) ? 1 : 0; l = l->next; n++; } } sLN = Rf_allocVector(STRSXP, 3); Rf_setAttrib(res, R_NamesSymbol, sLN); SET_STRING_ELT(sLN, 0, Rf_mkChar("name")); SET_STRING_ELT(sLN, 1, Rf_mkChar("description")); SET_STRING_ELT(sLN, 2, Rf_mkChar("current")); /* SET_STRING_ELT(sLN, 3, Rf_mkChar("author")); */ sRN = Rf_allocVector(INTSXP, 2); Rf_setAttrib(res, R_RowNamesSymbol, sRN); INTEGER(sRN)[0] = R_NaInt; INTEGER(sRN)[1] = -n; Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("data.frame")); Rf_unprotect(1); return res; }
void plot::render_from_snapshot() { auto xdd = reinterpret_cast<ide_device*>(_device_desc->deviceSpecific); xdd->output_and_kill_file_device(); try { rhost::util::errors_to_exceptions([&] { auto snapshot = Rf_findVar(Rf_install(_snapshot_varname.c_str()), R_GlobalEnv); if (snapshot != R_UnboundValue && snapshot != R_NilValue) { Rf_protect(snapshot); pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc); GEplaySnapshot(snapshot, ge_dev_desc); Rf_unprotect(1); } else { Rf_error("Plot snapshot is missing. Plot history may be corrupted. You should restart your session."); } }); } catch (rhost::util::r_error&) { render_empty(); } }
SEXP audio_recorder(SEXP source, SEXP rate, SEXP channels) { float fRate = -1.0; int chs = Rf_asInteger(channels); if (!current_driver) load_default_audio_driver(0); if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP) fRate = (float) Rf_asReal(rate); if (chs < 1) chs = 1; if (!current_driver->create_recorder) Rf_error("the currently used audio driver doesn't support recording"); audio_instance_t *p = current_driver->create_recorder(source, fRate, chs, 0); if (!p) Rf_error("cannot start audio driver"); p->driver = current_driver; p->kind = AI_RECORDER; SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue); Rf_protect(ptr); R_RegisterCFinalizer(ptr, audio_instance_destructor); Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance")); Rf_unprotect(1); return ptr; }
SEXP kmeansMatrixEuclid(MatrixType x, index_type n, index_type m, SEXP pcen, SEXP pclust, SEXP pclustsizes, SEXP pwss, SEXP itermax) { index_type j, col, nchange; int maxiters = Rf_asInteger(itermax); SEXP Riter; Rf_protect(Riter = Rf_allocVector(INTSXP, 1)); int *iter = INTEGER(Riter); iter[0] = 0; BigMatrix *pcent = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(pcen)); MatrixAccessor<double> cent(*pcent); BigMatrix *Pclust = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(pclust)); MatrixAccessor<int> clust(*Pclust); BigMatrix *Pclustsizes = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(pclustsizes)); MatrixAccessor<double> clustsizes(*Pclustsizes); BigMatrix *Pwss = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(pwss)); MatrixAccessor<double> ss(*Pwss); int k = (int) pcent->nrow(); // number of clusters int cl, bestcl, oldcluster, newcluster; int done = 0; double temp; vector<double> d(k); // Vector of distances, internal only. vector<double> temp1(k); vector<vector<double> > tempcent(m, temp1); // For copy of global centroids k x m // At this point I can use [][] to access things, with ss[0][cl] // being used for the vectors, for example. // Before starting the loop, we only have cent (centers) as passed into the function. // Calculate clust and clustsizes, then update cent as centroids. for (cl=0; cl<k; cl++) clustsizes[0][cl] = 0.0; for (j=0; j<n; j++) { bestcl = 0; for (cl=0; cl<k; cl++) { d[cl] = 0.0; for (col=0; col<m; col++) { temp = (double)x[col][j] - cent[col][cl]; d[cl] += temp * temp; } if (d[cl]<d[bestcl]) bestcl = cl; } clust[0][j] = bestcl + 1; // Saving the R cluster number, not the C index. clustsizes[0][bestcl]++; for (col=0; col<m; col++) tempcent[col][bestcl] += (double)x[col][j]; } for (cl=0; cl<k; cl++) for (col=0; col<m; col++) cent[col][cl] = tempcent[col][cl] / clustsizes[0][cl]; do { nchange = 0; for (j=0; j<n; j++) { // For each of my points, this is offset from hash position oldcluster = clust[0][j] - 1; bestcl = 0; for (cl=0; cl<k; cl++) { // Consider each of the clusters d[cl] = 0.0; // We'll get the distance to this cluster. for (col=0; col<m; col++) { // Loop over the dimension of the data temp = (double)x[col][j] - cent[col][cl]; d[cl] += temp * temp; } if (d[cl]<d[bestcl]) bestcl = cl; } // End of looking over the clusters for this j if (d[bestcl] < d[oldcluster]) { // MADE A CHANGE! newcluster = bestcl; clust[0][j] = newcluster + 1; nchange++; clustsizes[0][newcluster]++; clustsizes[0][oldcluster]--; for (col=0; col<m; col++) { cent[col][oldcluster] += ( cent[col][oldcluster] - (double)x[col][j] ) / clustsizes[0][oldcluster]; cent[col][newcluster] += ( (double)x[col][j] - cent[col][newcluster] ) / clustsizes[0][newcluster]; } } } // End of this pass over my points. iter[0]++; if ( (nchange==0) || (iter[0]>=maxiters) ) done = 1; } while (done==0); // Collect the sums of squares now that we're done. for (cl=0; cl<k; cl++) ss[0][cl] = 0.0; for (j=0; j<n; j++) { for (col=0; col<m; col++) { cl = clust[0][j]-1; temp = (double)x[col][j] - cent[col][cl]; ss[0][cl] += temp * temp; } } Rf_unprotect(1); return(Riter); }