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);
}
