SEXP dgCMatrix_matrix_solve(SEXP Ap, SEXP b, SEXP give_sparse)
// FIXME: add 'keep_dimnames' as argument
{
Rboolean sparse = asLogical(give_sparse);
if(sparse) {
// FIXME: implement this
error(_("dgCMatrix_matrix_solve(.., sparse=TRUE) not yet implemented"));
/* Idea: in the for(j = 0; j < nrhs ..) loop below, build the *sparse* result matrix
* ----- *column* wise -- which is perfect for dgCMatrix
* --> build (i,p,x) slots "increasingly" [well, allocate in batches ..]
*
* --> maybe first a protoype in R
*/
}
SEXP ans = PROTECT(dup_mMatrix_as_dgeMatrix(b)),
lu, qslot;
CSP L, U;
int *bdims = INTEGER(GET_SLOT(ans, Matrix_DimSym)), *p, *q;
int j, n = bdims[0], nrhs = bdims[1];
double *x, *ax = REAL(GET_SLOT(ans, Matrix_xSym));
C_or_Alloca_TO(x, n, double);
if (isNull(lu = get_factors(Ap, "LU"))) {
install_lu(Ap, /* order = */ 1, /* tol = */ 1.0, /* err_sing = */ TRUE,
/* keep_dimnames = */ TRUE);
lu = get_factors(Ap, "LU");
}
qslot = GET_SLOT(lu, install("q"));
L = AS_CSP__(GET_SLOT(lu, install("L")));
U = AS_CSP__(GET_SLOT(lu, install("U")));
R_CheckStack();
if (U->n != n)
error(_("Dimensions of system to be solved are inconsistent"));
if(nrhs >= 1 && n >= 1) {
p = INTEGER(GET_SLOT(lu, Matrix_pSym));
q = LENGTH(qslot) ? INTEGER(qslot) : (int *) NULL;
for (j = 0; j < nrhs; j++) {
cs_pvec(p, ax + j * n, x, n); /* x = b(p) */
cs_lsolve(L, x); /* x = L\x */
cs_usolve(U, x); /* x = U\x */
if (q) /* r(q) = x , hence
r = Q' U{^-1} L{^-1} P b = A^{-1} b */
cs_ipvec(q, x, ax + j * n, n);
else
Memcpy(ax + j * n, x, n);
}
}
if(n >= SMALL_4_Alloca) Free(x);
UNPROTECT(1);
return ans;
}
IMPATOM_BEGIN_NAMESPACE
Float LennardJonesPairScore::evaluate_index(kernel::Model *m,
const kernel::ParticleIndexPair &p,
DerivativeAccumulator *da) const {
LennardJones lj0(m, p[0]);
LennardJones lj1(m, p[1]);
algebra::Vector3D delta = lj0.get_coordinates() - lj1.get_coordinates();
double distsqr = delta.get_squared_magnitude();
double dist = std::sqrt(distsqr);
double dist6 = distsqr * distsqr * distsqr;
double dist12 = dist6 * dist6;
double A, B;
get_factors(lj0, lj1, A, B);
double repulsive = A / dist12;
double attractive = B / dist6;
double score = repulsive - attractive;
if (da) {
DerivativePair d = (*smoothing_function_)(
score, (6.0 * attractive - 12.0 * repulsive) / dist, dist);
algebra::Vector3D deriv = d.second * delta / dist;
lj0.add_to_derivatives(deriv, *da);
lj1.add_to_derivatives(-deriv, *da);
return d.first;
} else {
return (*smoothing_function_)(score, dist);
}
}
SEXP dgeMatrix_LU_(SEXP x, Rboolean warn_sing)
{
SEXP val = get_factors(x, "LU");
int *dims, npiv, info;
if (val != R_NilValue) /* nothing to do if it's there in 'factors' slot */
return val;
dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
if (dims[0] < 1 || dims[1] < 1)
error(_("Cannot factor a matrix with zero extents"));
npiv = (dims[0] <dims[1]) ? dims[0] : dims[1];
val = PROTECT(NEW_OBJECT(MAKE_CLASS("denseLU")));
slot_dup(val, x, Matrix_xSym);
slot_dup(val, x, Matrix_DimSym);
F77_CALL(dgetrf)(dims, dims + 1, REAL(GET_SLOT(val, Matrix_xSym)),
dims,
INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv)),
&info);
if (info < 0)
error(_("Lapack routine %s returned error code %d"), "dgetrf", info);
else if (info > 0 && warn_sing)
warning(_("Exact singularity detected during LU decomposition."));
UNPROTECT(1);
return set_factors(x, val, "LU");
}
inline std::vector<T> get_divisors(T nbr)
{
std::vector<T> res(get_factors(nbr));
std::vector<T> aux;
int len;
do
{
len = res.size();
aux.clear();
for (auto it=res.begin()+1; it!=res.end(); ++it)
{
for (auto it_int=it; it_int!=res.end(); ++it_int)
{
T mul{*it * *it_int};
if (mul<nbr && nbr%mul==0)
aux.push_back(mul);
}
}
std::copy(aux.begin(), aux.end(), std::back_inserter(res));
std::sort(res.begin(), res.end());
res.erase(std::unique(res.begin(), res.end()), res.end());
} while (len!=res.size());
return res;
}
SEXP dgCMatrix_LU(SEXP Ap, SEXP orderp, SEXP tolp, SEXP error_on_sing)
{
SEXP ans;
Rboolean err_sing = asLogical(error_on_sing);
/* FIXME: dgCMatrix_LU should check ans for consistency in
* permutation type with the requested value - Should have two
* classes or two different names in the factors list for LU with
* permuted columns or not.
* OTOH, currently (order, tol) === (1, 1) always.
* It is true that length(LU@q) does flag the order argument.
*/
if (!isNull(ans = get_factors(Ap, "LU")))
return ans;
install_lu(Ap, asInteger(orderp), asReal(tolp), err_sing);
return get_factors(Ap, "LU");
}
SEXP dsyMatrix_trf(SEXP x)
{
SEXP val = get_factors(x, "BunchKaufman"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
int *dims = INTEGER(dimP), *perm, info;
int lwork = -1, n = dims[0];
const char *uplo = CHAR(STRING_ELT(uploP, 0));
double tmp, *vx, *work;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT_OF_CLASS("BunchKaufman"));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
perm = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, n));
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, &tmp, &lwork, &info);
lwork = (int) tmp;
C_or_Alloca_TO(work, lwork, double);
F77_CALL(dsytrf)(uplo, &n, vx, &n, perm, work, &lwork, &info);
if(lwork >= SMALL_4_Alloca) Free(work);
if (info) error(_("Lapack routine dsytrf returned error code %d"), info);
UNPROTECT(1);
return set_factors(x, val, "BunchKaufman");
}
SEXP dpoMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "Cholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
int n = dims[0];
double *vx;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
if (n > 0) {
F77_CALL(dpotrf)(uplo, &n, vx, &n, &info);
if (info) {
if(info > 0)
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpotrf", info);
}
}
UNPROTECT(1);
return set_factors(x, val, "Cholesky");
}
SEXP dppMatrix_chol(SEXP x)
{
SEXP val = get_factors(x, "pCholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
const char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("pCholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
slot_dup(val, x, Matrix_xSym);
F77_CALL(dpptrf)(uplo, dims, REAL(GET_SLOT(val, Matrix_xSym)), &info);
if (info) {
if(info > 0) /* e.g. x singular */
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpptrf", info);
}
UNPROTECT(1);
return set_factors(x, val, "pCholesky");
}
void Correct(){
/*Takes individual offsets, and makes a correction to the on-chip
dac to bring all channels as close to the mean as possible.
DAC has range 0-63.
*/
double av1lo,av1hi,av2lo,av2hi;
int i,n;
get_factors();
av1lo=0;
av1hi=0;
av2lo=0;
av2hi=0;
n=0;
for(i=0;i<NCH;i++){
if(dis[i]==0){
n+=1;
/* av1lo+=fits[0][i][1];
av1hi+=fits[1][i][1];
av2lo+=fits[2][i][1];
av2hi+=fits[3][i][1]; */
av1lo+=fits[0][i][1];
av1hi+=fits[1][i][1];
av1lo+=fits[2][i][1];
av1hi+=fits[3][i][1];
}
}
av1lo=av1lo/(double)n/2.0;
av1hi=av1hi/(double)n/2.0;
/*av2lo=av2lo/(double)n;
av2hi=av2hi/(double)n;*/
for (i=0;i<NCH;i++){
v1_l[i]=(int)((fits[0][i][1]-av1lo)*factor[0][i])+32;
if(v1_l[i]<=0) v1_l[i]=0;
if(v1_l[i]>=63) v1_l[i]=63;
v1_h[i]=(int)((fits[1][i][1]-av1hi)*factor[1][i])+32;
if(v1_h[i]<=0) v1_h[i]=0;
if(v1_h[i]>=63) v1_h[i]=63;
v2_l[i]=(int)((fits[2][i][1]-av1lo)*factor[2][i])+32;
if(v2_l[i]<=0) v2_l[i]=0;
if(v2_l[i]>=63) v2_l[i]=63;
v2_h[i]=(int)((fits[3][i][1]-av1hi)*factor[3][i])+32;
if(v2_h[i]<=0) v2_h[i]=0;
if(v2_h[i]>=63) v2_h[i]=63;
}
ezcaPut("det1.TR1",ezcaByte,NCH,v1_l);
ezcaPut("det1.TR2",ezcaByte,NCH,v1_h);
ezcaPut("det1.TR3",ezcaByte,NCH,v2_l);
ezcaPut("det1.TR4",ezcaByte,NCH,v2_h);
if(save_dacs()) printf("save fits error\n");
}
inline std::vector<std::size_t> create_dim(std::size_t nlocals, std::size_t dim)
{
if(dim == 1)
{
return std::vector<std::size_t>(1, nlocals);
}
std::vector<std::size_t> primes = get_primes(nlocals);
std::vector<std::size_t> factors = get_factors(nlocals, primes);
return assign_locals(dim, primes, factors);
}
int main() {
int orz = 1;
int64 value = 10;
for (; orz <= 14; ++orz, value *= 10) {
cerr << 1. * pmpi[orz] / estimate_pmpi(value) << endl;
}
init_primes();
// factorize
auto f = factorize(303741899);
foreach (it, f)
cerr << it.first << " " << it.second << endl;
auto fs = get_factors(65700);
sort(all(fs));
foreach (it, fs)
cerr << it << endl;
// prime test
volatile int now = clock();
int cnt = 0;
for (int i = 10000; i >= 2; --i) {
int u = is_prime(i);
int v = is_prime_ex(i);
if (u != v) {
cerr << "error:\t";
dbg(i);
}
// cerr << i << " " << is_prime(i) << " " << is_prime_ex(i) << endl;
cnt += is_prime(i);
}
dbg(cnt);
cerr << "a\t" << clock() - now << endl;
cnt = 0;
now = clock();
for (int i = 100001; i <= 10000000; ++i) {
cnt += is_prime_ex(i);
}
dbg(cnt);
cerr << "b\t" << clock() - now << endl;
// random number generator
srand(time(NULL));
auto gen = make_uniform_generator(rand(), -7, 10);
for (int i = 0; i < 20; ++i) cerr << gen() << " ";
cerr << endl;
return 0;
}
SEXP dsCMatrix_Cholesky(SEXP Ap, SEXP permP, SEXP LDLp, SEXP superP)
{
char *fname = strdup("spdCholesky"); /* template for factorization name */
int perm = asLogical(permP),
LDL = asLogical(LDLp),
super = asLogical(superP);
SEXP Chol;
cholmod_sparse *A;
cholmod_factor *L;
int sup, ll;
if (super) fname[0] = 'S';
if (perm) fname[1] = 'P';
if (LDL) fname[2] = 'D';
Chol = get_factors(Ap, "fname");
if (Chol != R_NilValue) return Chol;
A = as_cholmod_sparse(Ap);
sup = c.supernodal;
ll = c.final_ll;
if (!A->stype) error("Non-symmetric matrix passed to dsCMatrix_chol");
c.final_ll = !LDL; /* leave as LL' or form LDL' */
c.supernodal = super ? CHOLMOD_SUPERNODAL : CHOLMOD_SIMPLICIAL;
if (perm) {
L = cholmod_analyze(A, &c); /* get fill-reducing permutation */
} else { /* require identity permutation */
int nmethods = c.nmethods, ord0 = c.method[0].ordering,
postorder = c.postorder;
c.nmethods = 1;
c.method[0].ordering = CHOLMOD_NATURAL;
c.postorder = FALSE;
L = cholmod_analyze(A, &c);
c.nmethods = nmethods; c.method[0].ordering = ord0;
c.postorder = postorder;
}
c.supernodal = sup; /* restore previous setting */
c.final_ll = ll;
if (!cholmod_factorize(A, L, &c))
error(_("Cholesky factorization failed"));
Free(A);
Chol = set_factors(Ap, chm_factor_to_SEXP(L, 1), fname);
free(fname); /* note, this must be free, not Free */
return Chol;
}
int main()
{
ulong fac[10000];
int len, i, j;
ulong nums[] = {3, 120, 1024, 2UL*2*2*2*3*3*3*5*5*7*11*13*17*19 };
sieve();
for (i = 0; i < 4; i++) {
len = get_factors(nums[i], fac);
printf("%lu:", nums[i]);
for (j = 0; j < len; j++)
printf(" %lu", fac[j]);
printf("\n");
}
return 0;
}
int main(int argc, char **argv){
if (argc == 2){
std::string aString = argv[1];
if (isInt(aString)){
int a = toInt(aString);
std::vector<int> vector_divisors;
get_divisors(vector_divisors, a);
std::cout << "Divisors of " << a << ":\n\t";
print_vector(vector_divisors);
std::vector<int> vector_factors;
std::cout << "Factors of " << a << ":\n\t";
get_factors(vector_factors, a);
print_vector(vector_factors);
}
}
else{
std::cout << "It need one integer number to work" << std::endl;
}
return 0;
}
SEXP magma_dgeMatrix_LU_(SEXP x, Rboolean warn_sing)
{
#ifdef HIPLAR_WITH_MAGMA
SEXP val = get_factors(x, "LU");
int *dims, npiv, info;
if (val != R_NilValue) {
// R_ShowMessage("already in slot"); /* nothing to do if it's there in 'factors' slot */
return val;
}
dims = INTEGER(GET_SLOT(x, Matrix_DimSym));
if (dims[0] < 1 || dims[1] < 1)
error(_("Cannot factor a matrix with zero extents"));
npiv = (dims[0] < dims[1]) ? dims[0] : dims[1];
val = PROTECT(NEW_OBJECT(MAKE_CLASS("denseLU")));
slot_dup(val, x, Matrix_xSym);
slot_dup(val, x, Matrix_DimSym);
double *h_R = REAL(GET_SLOT(val, Matrix_xSym));
int *ipiv = INTEGER(ALLOC_SLOT(val, Matrix_permSym, INTSXP, npiv));
if(GPUFlag == 0){
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: LU decomposition using dgetrf;");
#endif
F77_CALL(dgetrf)(dims, dims + 1, h_R,
dims,
ipiv,
&info);
}
else if(GPUFlag == 1 && Interface == 0){
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: LU decomposition using magma_dgetrf;");
#endif
magma_dgetrf(dims[0], dims[1], h_R, dims[0], ipiv, &info);
}
else if(GPUFlag == 1 && Interface == 1) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: LU decomposition using magma_dgetrf_gpu;");
#endif
double *d_A;
int N2 = dims[0] * dims[1];
cublasStatus retStatus;
cublasAlloc( N2 , sizeof(double), (void**)&d_A);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Memory Allocation"));
/********************************************/
cublasSetVector(N2, sizeof(double), h_R, 1, d_A, 1);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Date Transfer to Device"));
/********************************************/
magma_dgetrf_gpu(dims[0],dims[1], d_A, dims[0], ipiv, &info);
cublasGetVector( N2, sizeof(double), d_A, 1, h_R, 1);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Date Transfer from Device"));
/********************************************/
cublasFree(d_A);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error freeing data"));
/********************************************/
}
else
error(_("MAGMA/LAPACK/Interface Flag not defined correctly"));
if (info < 0)
error(_("Lapack routine %s returned error code %d"), "dgetrf", info);
else if (info > 0 && warn_sing)
warning(_("Exact singularity detected during LU decomposition: %s, i=%d."),
"U[i,i]=0", info);
UNPROTECT(1);
return set_factors(x, val, "LU");
#endif
return R_NilValue;
}
SEXP magma_dpoMatrix_chol(SEXP x)
{
#ifdef HIPLAR_WITH_MAGMA
SEXP val = get_factors(x, "Cholesky"),
dimP = GET_SLOT(x, Matrix_DimSym),
uploP = GET_SLOT(x, Matrix_uploSym);
const char *uplo = CHAR(STRING_ELT(uploP, 0));
int *dims = INTEGER(dimP), info;
int n = dims[0];
double *vx;
cublasStatus retStatus;
if (val != R_NilValue) return val;
dims = INTEGER(dimP);
val = PROTECT(NEW_OBJECT(MAKE_CLASS("Cholesky")));
SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
SET_SLOT(val, Matrix_diagSym, mkString("N"));
SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
vx = REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, n * n));
AZERO(vx, n * n);
//we could put in magmablas_dlacpy but it only
//copies all of the matrix
F77_CALL(dlacpy)(uplo, &n, &n, REAL(GET_SLOT(x, Matrix_xSym)), &n, vx, &n);
if (n > 0) {
if(GPUFlag == 0){
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Cholesky decomposition using dpotrf;");
#endif
F77_CALL(dpotrf)(uplo, &n, vx, &n, &info);
}
else if(GPUFlag == 1 && Interface == 0){
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Cholesky decomposition using magma_dpotrf;");
#endif
int nrows, ncols;
nrows = ncols = n;
magma_int_t lda;
lda = nrows;
magma_dpotrf(uplo[0], ncols, vx, lda, &info);
/* Error Checking */
retStatus = cudaGetLastError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in magma_dpotrf"));
/********************************************/
}
else if(GPUFlag == 1 && Interface == 1) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Cholesky decomposition using magma_dpotrf_gpu;");
#endif
double *d_c;
int nrows, ncols;
nrows = ncols = n;
int N2 = nrows * ncols;
magma_int_t lda;
lda = nrows;
cublasAlloc(lda * ncols, sizeof(double), (void**)&d_c);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Memory Allocation"));
/********************************************/
cublasSetVector(N2, sizeof(double), vx, 1, d_c, 1);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Date Transfer to Device"));
/********************************************/
magma_dpotrf_gpu(uplo[0], ncols, d_c, lda, &info);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in magma_dpotrf_gpu"));
/********************************************/
cublasGetVector(nrows * ncols, sizeof(double), d_c, 1, vx, 1);
/* Error Checking */
retStatus = cublasGetError ();
if (retStatus != CUBLAS_STATUS_SUCCESS)
error(_("CUBLAS: Error in Date Transfer from Device"));
/********************************************/
cublasFree(d_c);
}
else
error(_("MAGMA/LAPACK/Interface Flag not defined correctly"));
}
if (info) {
if(info > 0)
error(_("the leading minor of order %d is not positive definite"),
info);
else /* should never happen! */
error(_("Lapack routine %s returned error code %d"), "dpotrf", info);
}
UNPROTECT(1);
return set_factors(x, val, "Cholesky");
#endif
return R_NilValue;
}
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;
}
std::vector<int> get_proper_factors(const int& n){
std::vector<int> factors = get_factors(n);
factors.pop_back();
return factors;
}
