aplCode.c

language: C
license: GPL 2

Code for Snippet:

                
#include <R.h>
#include <Rinternals.h>
#include <stdio.h>
#include <string.h>
 
SEXP            APLDECODE(SEXP, SEXP);
SEXP            APLENCODE(SEXP, SEXP);
SEXP            APLSELECT(SEXP, SEXP, SEXP);
 
SEXP
APLDECODE(SEXP cell, SEXP dims)
{
    int             aux = 1, n = length(dims);
    SEXP            ind;
    PROTECT(ind = allocVector(INTSXP, 1));
    INTEGER(ind)[0] = 1;
    for (int i = 0; i < n; i++) {
        INTEGER(ind)[0] += aux * (INTEGER(cell)[i] - 1);
        aux *= INTEGER(dims)[i];
    }
    UNPROTECT(1);
    return (ind);
}
 
SEXP
APLENCODE(SEXP ind, SEXP dims)
{
    int             n = length(dims), aux = INTEGER(ind)[0], pdim = 1;
    SEXP            cell;
    PROTECT(cell = allocVector(INTSXP, n));
    for (int i = 0; i < n - 1; i++)
        pdim *= INTEGER(dims)[i];
    for (int i = n - 1; i > 0; i--) {
        INTEGER(cell)[i] = (aux - 1) / pdim;
        aux -= pdim * INTEGER(cell)[i];
        pdim /= INTEGER(dims)[i - 1];
        INTEGER(cell)[i] += 1;
    }
    INTEGER(cell)[0] = aux;
    UNPROTECT(1);
    return cell;
}
 
SEXP
APLSELECT(SEXP a, SEXP dima, SEXP list) {
    int             r = length (dima), lz = 1, dimzi, nProtect = 0;
    SEXP            dimz, itel, cell, czll, nind, z;
    PROTECT (dimz = allocVector (INTSXP, r));
    nProtect++;
    PROTECT (cell = allocVector (INTSXP, r));
    nProtect++;
    PROTECT (czll = allocVector (INTSXP, r));
    nProtect++;
    PROTECT (itel = allocVector (INTSXP, 1));
    nProtect++;
     PROTECT (nind = allocVector (INTSXP, 1));
    nProtect++;
    for (int i = 0; i < r; i++) {
        dimzi = length (VECTOR_ELT (list, i));
        INTEGER (dimz)[i] = dimzi;
        lz *= dimzi;
        }
    PROTECT (z = allocVector (REALSXP, lz));
    nProtect++;
    for (int i = 0; i < lz; i++) {
        INTEGER (itel)[0] = i + 1;        
        cell = APLENCODE (itel, dimz);
        for (int j = 0; j < r; j++) {
            INTEGER (czll)[j] = INTEGER (VECTOR_ELT (list, j))[INTEGER(cell)[j] - 1];
            }
        nind = APLDECODE (czll, dima);
        REAL (z)[i] = REAL (a)[INTEGER (nind)[0] - 1];
        }
    UNPROTECT(nProtect);
    return(z);
}
 
SEXP
APLTRANSPOSE(SEXP a, SEXP x, SEXP sa, SEXP sz, SEXP rz)
{
    int i, j, na=1, nz=1, ra = length (sa), lsz = length( sz ), nProtected=0;
    SEXP ivec, jvec, z, itel, nind;
    for( i=0;i<ra ;i++){ na *= INTEGER( sa )[i]; }
    for( i=0;i<lsz;i++){ nz *= INTEGER( sz )[i]; }
    PROTECT(itel = allocVector( INTSXP,              1  ) ); ++nProtected;
    PROTECT(nind = allocVector( INTSXP,              1  ) ); ++nProtected;
    PROTECT(ivec = allocVector( INTSXP,  INTEGER(rz)[0] ) ); ++nProtected;
    PROTECT(jvec = allocVector( INTSXP,             ra  ) ); ++nProtected;
    PROTECT(z    = allocVector( REALSXP,            nz  ) ); ++nProtected;
    for( i = 0; i < nz; i++ ){
        INTEGER( itel )[0] = i + 1;
        ivec = APLENCODE( itel, sz );
        for( j = 0; j < ra; j++ ){
            INTEGER( jvec )[j] = INTEGER( ivec )[INTEGER( x )[j] - 1];
        }
        nind = APLDECODE( jvec, sa );
        REAL( z )[i] = REAL( a )[INTEGER(nind)[0] - 1];
    }
    UNPROTECT( nProtected );
    return z;
}
 
 
 
comments powered by Disqus

Info

Link to this snippet:


Download to Code Collector

To use the direct link to your snippet on CodeCollector.net either copy the html from the above section or drag the Download to Code Collector to where you would like to use it.

More Info:

Times Viewed: 516
Date Added: 2013-03-07 16:47:17
Last Modified: 2013-04-17 22:12:19

Web Analytics