/*! \brief Signed Wilcoxon-Mann-Whitney Test
*
* \param matrix: an expression matrix with features in rows and samples in columns
* \param signedIndList: A list of signed gene-set-pairs, each of which is a list of two character vectors, containing positive and negative signatures, respectively
* \param rtype:
* \parblock
* Define f(x)=abs(log10(x))
* 0=p(greater), 1=p(less), 2=p(twoSided), 3=U,
* 4=f(p(greater)),5=p(less),6=f(p(twoSided)), 7=p(greater)<p(less) ? f(p(twoSided)) : -f(p(twoSided))
* \endparblock
*
* This implementation uses normal approximation, which works reasonably well if sample size is large (say N>=20)
*/
extern SEXP signed_wmw_test(SEXP matrix, SEXP signedIndList, SEXP rtype) {
const int type=INTEGER(rtype)[0];
const int m=length(signedIndList);
const int n=NROW(matrix);
int i;
double *matColPtr; // pointer to the current column of the matrix
SEXP res;
double *resPtr;
res=PROTECT(allocMatrix(REALSXP, m, NCOL(matrix)));
resPtr=REAL(res);
matColPtr=REAL(matrix);
#pragma omp parallel for
for(i=0; i<NCOL(matrix);++i) {
signed_wmw_test_list(matColPtr, n,
signedIndList,
resPtr, type);
resPtr+=m;
matColPtr+=n;
}
UNPROTECT(1);
return(res);
}
SEXP graph_bitarray_getEdgeAttrOrder(SEXP _bits, SEXP _from, SEXP _to) {
unsigned char *bits = (unsigned char*) RAW(_bits);
int ns = asInteger(getAttrib(_bits, install("nbitset")));
int len = length(_from);
int *from = INTEGER(_from);
int *to = INTEGER(_to);
int dim = NROW(_bits);
int byteIndex, bitIndex, shft, indx, intIndx, i, j;
int oindx=0, nindx=0, attrIndx=0, setCount=0;
SEXP origRightPos, origLeftPos, newRightPos, newLeftPos, res, namesres;
PROTECT(origRightPos = allocVector(INTSXP, ns)); //index into orig attr
PROTECT(origLeftPos = allocVector(INTSXP, ns));
PROTECT(newRightPos = allocVector(INTSXP, len));
PROTECT(newLeftPos = allocVector(INTSXP, len));
setCount =1;
for(j =0; j < dim ; j ++) {
for(i =0; i < dim; i++){
indx = COORD_TO_INDEX(i, j , dim);
byteIndex = indx / 8;
bitIndex = indx % 8;
shft = 1 << bitIndex;
intIndx = COORD_TO_INDEX(from[attrIndx]-1, to[attrIndx]-1, dim);
if(bits[byteIndex] & (shft) ) {
INTEGER(origRightPos)[oindx] = oindx + 1 ;
INTEGER(origLeftPos)[oindx] = setCount ;
oindx++;
if(intIndx != indx){
setCount++;
}
}
if(intIndx == indx) {
INTEGER(newRightPos)[nindx] = nindx + 1;
INTEGER(newLeftPos)[nindx] = setCount ;
nindx++;
if(attrIndx < len-1){
attrIndx++;
}
setCount++;
}
}
}
SET_LENGTH(newRightPos, nindx);
SET_LENGTH(newLeftPos, nindx);
PROTECT(res = allocVector(VECSXP, 4));
SET_VECTOR_ELT(res, 0, newLeftPos);
SET_VECTOR_ELT(res, 1, newRightPos);
SET_VECTOR_ELT(res, 2, origLeftPos);
SET_VECTOR_ELT(res, 3, origRightPos);
PROTECT(namesres = allocVector(STRSXP, 4));
SET_STRING_ELT(namesres, 0, mkChar("newLeftPos"));
SET_STRING_ELT(namesres, 1, mkChar("newRightPos"));
SET_STRING_ELT(namesres, 2, mkChar("origLeftPos"));
SET_STRING_ELT(namesres, 3, mkChar("origRightPos"));
setAttrib(res, R_NamesSymbol, namesres);
UNPROTECT(6);
return(res);
}
/* Given a bit vector representing directed edges, return a new bit
vector with the underlying undirected edges.
*/
SEXP graph_bitarray_undirect(SEXP bits)
{
int i, j, c = 0, len = length(bits), nrow = NROW(bits);
SEXP tbits = PROTECT(graph_bitarray_transpose(bits)),
ans = PROTECT(duplicate(bits));
unsigned char *bytes = RAW(bits), *tbytes = RAW(tbits), *abytes = RAW(ans);
for (i = 0; i < len; i++) {
unsigned char v;
if (0 != (abytes[i] = bytes[i] | tbytes[i])) {
/* keep track of edge count */
for (v = abytes[i]; v; c++) {
v &= v - 1; /* clear the least significant bit set */
}
}
}
/* zero out lower tri */
for (i = 0; i < nrow; i++) {
for (j = 0; j < nrow; j++) {
if (i > j) {
unsigned char v;
int idx = COORD_TO_INDEX(i, j, nrow);
v = abytes[idx / 8];
if (0 != v) {
if (IS_SET(abytes, idx / 8, idx % 8)) c--;
abytes[idx / 8] &= ~(1 << (idx % 8));
}
}
}
}
INTEGER(getAttrib(ans, install("nbitset")))[0] = c;
UNPROTECT(2);
return ans;
}
static void matrix_prod(Array mat1, Array mat2, int trans1, int trans2, Array ans)
/*
General matrix product between mat1 and mat2. Put answer in ans.
trans1 and trans2 are logical flags which indicate if the matrix is
to be transposed. Normal matrix multiplication has trans1 = trans2 = 0.
*/
{
int i,j,k,K1,K2;
const void *vmax;
double m1, m2;
Array tmp;
/* Test whether everything is a matrix */
assert(DIM_LENGTH(mat1) == 2 &&
DIM_LENGTH(mat2) == 2 && DIM_LENGTH(ans) == 2);
/* Test whether matrices conform. K is the dimension that is
lost by multiplication */
if (trans1) {
assert ( NCOL(mat1) == NROW(ans) );
K1 = NROW(mat1);
}
else {
assert ( NROW(mat1) == NROW(ans) );
K1 = NCOL(mat1);
}
if (trans2) {
assert ( NROW(mat2) == NCOL(ans) );
K2 = NCOL(mat2);
}
else {
assert ( NCOL(mat2) == NCOL(ans) );
K2 = NROW(mat2);
}
assert (K1 == K2);
tmp = init_array();
/* In case ans is the same as mat1 or mat2, we create a temporary
matrix to hold the answer, then copy it to ans
*/
vmax = vmaxget();
tmp = make_zero_matrix(NROW(ans), NCOL(ans));
for (i = 0; i < NROW(tmp); i++) {
for (j = 0; j < NCOL(tmp); j++) {
for(k = 0; k < K1; k++) {
m1 = (trans1) ? MATRIX(mat1)[k][i] : MATRIX(mat1)[i][k];
m2 = (trans2) ? MATRIX(mat2)[j][k] : MATRIX(mat2)[k][j];
MATRIX(tmp)[i][j] += m1 * m2;
}
}
}
copy_array(tmp, ans);
vmaxset(vmax);
}
static double ldet(Array x)
/* Log determinant of square matrix */
{
int i, rank, *pivot, n, p;
const void *vmax;
double ll, tol = 1.0E-7, *qraux, *work;
Array xtmp;
assert(DIM_LENGTH(x) == 2); /* is x a matrix? */
assert(NROW(x) == NCOL(x)); /* is x square? */
vmax = vmaxget();
qraux = (double *) R_alloc(NCOL(x), sizeof(double));
pivot = (int *) R_alloc(NCOL(x), sizeof(int));
work = (double *) R_alloc(2*NCOL(x), sizeof(double));
xtmp = make_zero_matrix(NROW(x), NCOL(x));
copy_array(x, xtmp);
for(i = 0; i < NCOL(x); i++)
pivot[i] = i+1;
p = n = NROW(x);
F77_CALL(dqrdc2)(VECTOR(xtmp), &n, &n, &p, &tol, &rank,
qraux, pivot, work);
if (rank != p)
error(_("Singular matrix in ldet"));
for (i = 0, ll=0.0; i < rank; i++) {
ll += log(fabs(MATRIX(xtmp)[i][i]));
}
vmaxset(vmax);
return ll;
}
static void transpose_matrix(Array mat, Array ans)
{
int i,j;
const void *vmax;
Array tmp;
tmp = init_array();
assert(DIM_LENGTH(mat) == 2 && DIM_LENGTH(ans) == 2);
assert(NCOL(mat) == NROW(ans));
assert(NROW(mat) == NCOL(ans));
vmax = vmaxget();
tmp = make_zero_matrix(NROW(ans), NCOL(ans));
for(i = 0; i < NROW(mat); i++)
for(j = 0; j < NCOL(mat); j++)
MATRIX(tmp)[j][i] = MATRIX(mat)[i][j];
copy_array(tmp, ans);
vmaxset(vmax);
}
static void qr_solve(Array x, Array y, Array coef)
/* Translation of the R function qr.solve into pure C
NB We have to transpose the matrices since the ordering of an array is different in Fortran
NB2 We have to copy x to avoid it being overwritten.
*/
{
int i, info = 0, rank, *pivot, n, p;
const void *vmax;
double tol = 1.0E-7, *qraux, *work;
Array xt, yt, coeft;
assert(NROW(x) == NROW(y));
assert(NCOL(coef) == NCOL(y));
assert(NCOL(x) == NROW(coef));
vmax = vmaxget();
qraux = (double *) R_alloc(NCOL(x), sizeof(double));
pivot = (int *) R_alloc(NCOL(x), sizeof(int));
work = (double *) R_alloc(2*NCOL(x), sizeof(double));
for(i = 0; i < NCOL(x); i++)
pivot[i] = i+1;
xt = make_zero_matrix(NCOL(x), NROW(x));
transpose_matrix(x,xt);
n = NROW(x);
p = NCOL(x);
F77_CALL(dqrdc2)(VECTOR(xt), &n, &n, &p, &tol, &rank,
qraux, pivot, work);
if (rank != p)
error(_("Singular matrix in qr_solve"));
yt = make_zero_matrix(NCOL(y), NROW(y));
coeft = make_zero_matrix(NCOL(coef), NROW(coef));
transpose_matrix(y, yt);
F77_CALL(dqrcf)(VECTOR(xt), &NROW(x), &rank, qraux,
yt.vec, &NCOL(y), coeft.vec, &info);
transpose_matrix(coeft,coef);
vmaxset(vmax);
}
SEXP graph_bitarray_getBitCell(SEXP bits, SEXP _from, SEXP _to)
{
int len = length(_to);
SEXP ans;
PROTECT(ans = allocVector(LGLSXP, len));
unsigned char *bytes = (unsigned char *) RAW(bits);
int *from = INTEGER(_from);
int *to = INTEGER(_to);
int dim = NROW(bits);
int i = 0, val, byteIndex, bitIndex, indx;
for(i =0; i < len; i++) {
indx = COORD_TO_INDEX(from[i]-1, to[i]-1, dim) ;
byteIndex = indx / 8 ;
bitIndex = indx % 8 ;
val = bytes[byteIndex] & (1 << bitIndex);
LOGICAL(ans)[i] = 0;
if (val) {
LOGICAL(ans)[i] = 1;
}
}
UNPROTECT(1);
return(ans);
}
SEXP graph_bitarray_transpose(SEXP bits)
{
SEXP ans;
int nrow, i, j, len = length(bits);
unsigned char *bytes = RAW(bits), *ans_bytes;
ans = PROTECT(duplicate(bits)); /* dup to capture attributes */
ans_bytes = RAW(ans);
memset(ans_bytes, 0, len);
nrow = NROW(bits);
/* FIXME: use a single loop, look at R's array.c */
for (i = 0; i < nrow; i++) {
for (j = 0; j < nrow; j++) {
int idx = COORD_TO_INDEX(i, j, nrow),
tidx = COORD_TO_INDEX(j, i, nrow);
int byteIndex = idx / 8,
bitIndex = idx % 8,
tBitIndex = tidx % 8;
if (IS_SET(bytes, byteIndex, bitIndex))
ans_bytes[tidx / 8] |= (1 << tBitIndex);
}
}
UNPROTECT(1);
return ans;
}
void gaussianScaledPivoting(int N, Matrix& A, Vector& X)
{
//double A[10][11], S[10], X[10];
Vector S(X.size());
double AMAX, XM, SUM, TEMP;
//int NROW[10]; //este creo que es el que reordena; ver la dimension será Nrow[X.size()] ?
std::vector< int > NROW(X.size());
// int NROW[X.size()];
//int N, M, ICHG, I, NN, IMAX, J, JJ, IP, JP, NCOPY, I1, J1, N1, K, N2, LL, KK, OK;
int M, ICHG, I, NN, IMAX, J, JJ, IP, JP, NCOPY, I1, J1, N1, K, N2, LL, KK, OK;
//INPUT(&OK, A, &N);
OK = true;
if (OK) {
M = N + 1;
/* STEP 1 */
for (I = 1; I <= N; I++) {
S[I - 1] = absval(A[I - 1][0]);
/* initialize row pointer */
NROW[I - 1] = I;
for (J = 1; J <= N; J++)
if (absval(A[I - 1][J - 1]) > S[I - 1])
S[I - 1] = absval(A[I - 1][J - 1]);
if (S[I - 1] <= ZERO) OK = false;
}
NN = N - 1;
ICHG = 0;
I = 1;
/* STEP 2 */
/* elimination process */
while (OK && (I <= NN)) {
/* STEP 3 */
IMAX = NROW[I - 1];
AMAX = absval(A[IMAX - 1][I - 1]) / S[IMAX - 1];
IMAX = I;
JJ = I + 1;
for (IP = JJ; IP <= N; IP++) {
JP = NROW[IP - 1];
TEMP = absval(A[JP - 1][I - 1] / S[JP - 1]);
if (TEMP > AMAX) {
AMAX = TEMP;
IMAX = IP;
}
}
/* STEP 4 */
/* system has no unique solution */
if (AMAX <= ZERO) OK = false;
else {
/* STEP 5 */
/* simulate row interchange */
if (NROW[I - 1] != NROW[IMAX - 1]) {
ICHG = ICHG + 1;
NCOPY = NROW[I - 1];
NROW[I - 1] = NROW[IMAX - 1];
NROW[IMAX - 1] = NCOPY;
}
/* STEP 6 */
I1 = NROW[I - 1];
for (J = JJ; J <= N; J++) {
J1 = NROW[J - 1];
/* STEP 7 */
XM = A[J1 - 1][I - 1] / A[I1 - 1][I - 1];
/* STEP 8 */
for (K = JJ; K <= M; K++)
A[J1 - 1][K - 1] = A[J1 - 1][K - 1] - XM * A[I1 - 1][K - 1];
/* Multiplier XM could be saved in A[J1-1][I-1] */
A[J1 - 1][I - 1] = 0.0;
}
}
I++;
}
if (OK) {
/* STEP 9 */
N1 = NROW[N - 1];
if (absval(A[N1 - 1][N - 1]) <= ZERO) OK = false;
/* system has no unique solution */
else {
/* STEP 10 */
/* start backward substitution */
X[N - 1] = A[N1 - 1][M - 1] / A[N1 - 1][N - 1];
/* STEP 11 */
for (K = 1; K <= NN; K++) {
I = NN - K + 1;
JJ = I + 1;
N2 = NROW[I - 1];
SUM = 0.0;
for (KK = JJ; KK <= N; KK++) {
SUM = SUM - A[N2 - 1][KK - 1] * X[KK - 1];
}
X[I - 1] = (A[N2 - 1][N] + SUM) / A[N2 - 1][I - 1];
}
/* STEP 12 */
/* procedure completed successfully */
// OUTPUT(N, M, ICHG, NROW, X, A);
}
}
if (!OK) printf("System has no unique solution\n");
}
//return 0;
}
/*******************************************************************************
*
* Name: elm_rotor_3D
*
* Purpose: Compute rotor of given quantity for volume elements.
*
* Parameters:
*
* Input:
*
* Output:
*
* Return value: void
*
******************************************************************************/
VARIABLE *elm_rotor_3D( VARIABLE *A )
{
static double RotorX[ELM_MAX_ELEMENT_NODES];
static double RotorY[ELM_MAX_ELEMENT_NODES];
static double RotorZ[ELM_MAX_ELEMENT_NODES];
static double FX[ELM_MAX_ELEMENT_NODES];
static double FY[ELM_MAX_ELEMENT_NODES];
static double FZ[ELM_MAX_ELEMENT_NODES];
element_type_t *elmt;
element_t *elm;
element_model_t *model = CurrentObject->ElementModel; /*** TODO: FIX ***/
unsigned char *References = (unsigned char *)malloc( model->NofNodes*sizeof(unsigned char) );
int i,j,k,n, cols;
double *ax = &M(A,0,0);
double *ay = &M(A,1,0);
double *az = &M(A,2,0);
VARIABLE *res;
double *rx, *ry, *rz;
cols = NCOL(A) / model->NofNodes;
if ( NROW(A) != 3 )
{
free( References );
error( "curl: vector variable needed as input.\n" );
}
res = var_temp_new( TYPE_DOUBLE, 3, cols*model->NofNodes );
rx = &M(res,0,0);
ry = &M(res,1,0);
rz = &M(res,2,0);
for( k=0; k<cols; k++ )
{
for( j=0; j<model->NofNodes; j++ )
{
n = k*model->NofNodes + j;
rx[n] = 0.0;
ry[n] = 0.0;
rz[n] = 0.0;
References[j] = 0;
}
for( i=0; i<model->NofElements; i++ )
{
elm = &model->Elements[i];
elmt = elm->ElementType;
if ( elmt->ElementCode <500 ) continue;
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = k*model->NofNodes + elm->Topology[j];
FX[j] = ax[n];
FY[j] = ay[n];
FZ[j] = az[n];
}
if ( !elm_element_rotor_3D( model,elm,FX,FY,FZ,RotorX,RotorY,RotorZ ) )
{
fprintf( stderr, "ELEMENT [%d]: Jacobian is singular.\n",i );
continue;
}
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = elm->Topology[j];
References[n]++;
n += k*model->NofNodes;
rx[n] += RotorX[j];
ry[n] += RotorY[j];
rz[n] += RotorZ[j];
}
}
for( j=0; j<model->NofNodes; j++ )
{
if ( References[j] != 0 )
{
n = k*model->NofNodes + j;
rx[n] /= References[j];
ry[n] /= References[j];
rz[n] /= References[j];
}
}
}
free( References );
return res;
}
/*******************************************************************************
*
* Name: elm_gradient
*
* Purpose: Compute gradient vector of given quantity.
*
* Parameters:
*
* Input:
*
* Output:
*
* Return value: void
*
******************************************************************************/
VARIABLE *elm_gradient( VARIABLE *A )
{
static double dFdX[ELM_MAX_ELEMENT_NODES];
static double dFdY[ELM_MAX_ELEMENT_NODES];
static double dFdZ[ELM_MAX_ELEMENT_NODES];
static double F[ELM_MAX_ELEMENT_NODES];
element_type_t *elmt;
element_t *elm;
element_model_t *model = CurrentObject->ElementModel; /*** TODO: FIX ***/
unsigned char *References = (unsigned char *)malloc( model->NofNodes*sizeof(unsigned char) );
double *af = MATR( A );
int i,j,k,n,status,dim, cols;
VARIABLE *res;
double *rx, *ry, *rz;
cols = NCOL(A) / model->NofNodes;
if ( NROW(A) != 1 )
{
free( References );
error( "I can only compute the gradient of a scalar variable\n" );
}
res = (VARIABLE *)var_temp_new( TYPE_DOUBLE, 3, cols*model->NofNodes );
rx = &M(res,0,0);
ry = &M(res,1,0);
rz = &M(res,2,0);
dim = 1;
for( k=0; k<model->NofElements; k++ )
if ( model->Elements[k].ElementType->ElementCode>=500 ) {
dim=3;
break;
} else if ( model->Elements[k].ElementType->ElementCode>=300 )
dim=2;
for( k=0; k<cols; k++ )
{
for( j=0; j<model->NofNodes; j++ )
{
n = k*model->NofNodes + j;
rx[n] = 0.0;
ry[n] = 0.0;
rz[n] = 0.0;
References[j] = 0;
}
for( i=0; i<model->NofElements; i++ )
{
elm = &model->Elements[i];
elmt = elm->ElementType;
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = k*model->NofNodes + elm->Topology[j];
F[j] = af[n];
dFdX[j] = af[n];
dFdY[j] = af[n];
dFdZ[j] = af[n];
}
if ( dim==3 && elmt->PartialW )
status = elm_element_gradient_3D(
model, elm,F,dFdX,dFdY,dFdZ,elmt->NumberOfNodes,elmt->NodeU,elmt->NodeV,elmt->NodeW
);
else if ( dim==2 && elmt->PartialV )
status = elm_element_gradient_2D(
model, elm,F,dFdX,dFdY,dFdZ,elmt->NumberOfNodes,elmt->NodeU,elmt->NodeV
);
else continue;
if ( !status )
{
fprintf( stderr, "ELEMENT [%d]: Jacobian is singular.\n",i );
continue;
}
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = elm->Topology[j];
References[n]++;
n += k*model->NofNodes;
rx[n] += dFdX[j];
ry[n] += dFdY[j];
rz[n] += dFdZ[j];
}
}
for( j=0; j<model->NofNodes; j++ )
{
if ( References[j] != 0 )
{
n = k*model->NofNodes + j;
rx[n] /= References[j];
ry[n] /= References[j];
rz[n] /= References[j];
}
}
}
free( References );
return res;
}
/*******************************************************************************
*
* Name: elm_divergence
*
* Purpose: Compute divergence of given quantity.
*
* Parameters:
*
* Input:
*
* Output:
*
* Return value: void
*
******************************************************************************/
VARIABLE *elm_divergence( VARIABLE *A )
{
static double FX[ELM_MAX_ELEMENT_NODES];
static double FY[ELM_MAX_ELEMENT_NODES];
static double FZ[ELM_MAX_ELEMENT_NODES];
static double D[ELM_MAX_ELEMENT_NODES];
element_type_t *elmt;
element_t *elm;
element_model_t *model = CurrentObject->ElementModel; /*** TODO: FIX ***/
unsigned char *References = (unsigned char *)malloc( model->NofNodes*sizeof(unsigned char) );
int i,j,k,n,status,dim,cols;
double *ax = &M(A,0,0);
double *ay = &M(A,1,0);
double *az = &M(A,2,0);
VARIABLE *res;
double *rf;
cols = NCOL(A) / model->NofNodes;
if ( NROW(A) != 3 )
{
free( References );
error( "div: vector variable needed as input.\n" );
}
dim = 1;
for( k=0; k<model->NofElements; k++ )
if ( model->Elements[k].ElementType->ElementCode>=500 ) {
dim=3;
break;
} else if ( model->Elements[k].ElementType->ElementCode>=300 )
dim=2;
res = var_temp_new( TYPE_DOUBLE, 1, model->NofNodes*cols );
rf = MATR(res);
for( k=0; k<cols; k++ )
{
for( j=0; j<model->NofNodes; j++ )
{
rf[k*model->NofNodes+j] = 0.0;
References[j] = 0;
}
for( i=0; i<model->NofElements; i++ )
{
elm = &model->Elements[i];
elmt = elm->ElementType;
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = k*model->NofNodes + elm->Topology[j];
FX[j] = ax[n];
FY[j] = ay[n];
FZ[j] = az[n];
}
if ( dim==3 && elmt->PartialW )
status = elm_element_divergence_3D( model,elm,FX,FY,FZ,D );
else if ( dim==2 && elmt->PartialV )
status = elm_element_divergence_2D( model,elm,FX,FY,FZ,D );
else continue;
if ( !status )
{
fprintf( stderr, "ELEMENT [%d]: Jacobian is singular.\n",i );
continue;
}
for( j=0; j<elmt->NumberOfNodes; j++ )
{
n = elm->Topology[j];
References[n]++;
rf[k*model->NofNodes + n] += D[j];
}
}
for( j=0; j<model->NofNodes; j++ )
{
if ( References[j] != 0 )
{
n = k*model->NofNodes + j;
rf[n] /= References[j];
}
}
}
free( References );
return res;
}
static void burg2(Array ss_ff, Array ss_bb, Array ss_fb, Array E,
Array KA, Array KB)
/*
Estimate partial correlation by minimizing (1/2)*log(det(s)) where
"s" is the the sum of the forward and backward prediction errors.
In the multivariate case, the forward (KA) and backward (KB) partial
correlation coefficients are related by
KA = solve(E) %*% t(KB) %*% E
where E is the prediction variance.
*/
{
int i, j, k, l, nser = NROW(ss_ff);
int iter;
Array ss_bf;
Array s, tmp, d1;
Array D1, D2, THETA, THETAOLD, THETADIFF, TMP;
Array obj;
Array e, f, g, h, sg, sh;
Array theta;
ss_bf = make_zero_matrix(nser,nser);
transpose_matrix(ss_fb, ss_bf);
s = make_zero_matrix(nser, nser);
tmp = make_zero_matrix(nser, nser);
d1 = make_zero_matrix(nser, nser);
e = make_zero_matrix(nser, nser);
f = make_zero_matrix(nser, nser);
g = make_zero_matrix(nser, nser);
h = make_zero_matrix(nser, nser);
sg = make_zero_matrix(nser, nser);
sh = make_zero_matrix(nser, nser);
theta = make_zero_matrix(nser, nser);
D1 = make_zero_matrix(nser*nser, 1);
D2 = make_zero_matrix(nser*nser, nser*nser);
THETA = make_zero_matrix(nser*nser, 1); /* theta in vector form */
THETAOLD = make_zero_matrix(nser*nser, 1);
THETADIFF = make_zero_matrix(nser*nser, 1);
TMP = make_zero_matrix(nser*nser, 1);
obj = make_zero_matrix(1,1);
/* utility matrices e,f,g,h */
qr_solve(E, ss_bf, e);
qr_solve(E, ss_fb, f);
qr_solve(E, ss_bb, tmp);
transpose_matrix(tmp, tmp);
qr_solve(E, tmp, g);
qr_solve(E, ss_ff, tmp);
transpose_matrix(tmp, tmp);
qr_solve(E, tmp, h);
for(iter = 0; iter < BURG_MAX_ITER; iter++)
{
/* Forward and backward partial correlation coefficients */
transpose_matrix(theta, tmp);
qr_solve(E, tmp, tmp);
transpose_matrix(tmp, KA);
qr_solve(E, theta, tmp);
transpose_matrix(tmp, KB);
/* Sum of forward and backward prediction errors ... */
set_array_to_zero(s);
/* Forward */
array_op(s, ss_ff, '+', s);
matrix_prod(KA, ss_bf, 0, 0, tmp);
array_op(s, tmp, '-', s);
transpose_matrix(tmp, tmp);
array_op(s, tmp, '-', s);
matrix_prod(ss_bb, KA, 0, 1, tmp);
matrix_prod(KA, tmp, 0, 0, tmp);
array_op(s, tmp, '+', s);
/* Backward */
array_op(s, ss_bb, '+', s);
matrix_prod(KB, ss_fb, 0, 0, tmp);
array_op(s, tmp, '-', s);
transpose_matrix(tmp, tmp);
array_op(s, tmp, '-', s);
matrix_prod(ss_ff, KB, 0, 1, tmp);
matrix_prod(KB, tmp, 0, 0, tmp);
array_op(s, tmp, '+', s);
matrix_prod(s, f, 0, 0, d1);
matrix_prod(e, s, 1, 0, tmp);
array_op(d1, tmp, '+', d1);
/*matrix_prod(g,s,0,0,sg);*/
matrix_prod(s,g,0,0,sg);
matrix_prod(s,h,0,0,sh);
for (i = 0; i < nser; i++) {
for (j = 0; j < nser; j++) {
MATRIX(D1)[nser*i+j][0] = MATRIX(d1)[i][j];
for (k = 0; k < nser; k++)
for (l = 0; l < nser; l++) {
MATRIX(D2)[nser*i+j][nser*k+l] =
(i == k) * MATRIX(sg)[j][l] +
MATRIX(sh)[i][k] * (j == l);
}
}
}
copy_array(THETA, THETAOLD);
qr_solve(D2, D1, THETA);
for (i = 0; i < vector_length(theta); i++)
VECTOR(theta)[i] = VECTOR(THETA)[i];
matrix_prod(D2, THETA, 0, 0, TMP);
array_op(THETAOLD, THETA, '-', THETADIFF);
matrix_prod(D2, THETADIFF, 0, 0, TMP);
matrix_prod(THETADIFF, TMP, 1, 0, obj);
if (VECTOR(obj)[0] < BURG_TOL)
break;
}
if (iter == BURG_MAX_ITER)
error(_("Burg's algorithm failed to find partial correlation"));
}
static void burg0(int omax, Array resid_f, Array resid_b, Array *A, Array *B,
Array P, Array V, int vmethod)
{
int i, j, m, n = NCOL(resid_f), nser=NROW(resid_f);
Array ss_ff, ss_bb, ss_fb;
Array resid_f_tmp, resid_b_tmp;
Array KA, KB, E;
Array id, tmp;
ss_ff = make_zero_matrix(nser, nser);
ss_fb = make_zero_matrix(nser, nser);
ss_bb = make_zero_matrix(nser, nser);
resid_f_tmp = make_zero_matrix(nser, n);
resid_b_tmp = make_zero_matrix(nser, n);
id = make_identity_matrix(nser);
tmp = make_zero_matrix(nser, nser);
E = make_zero_matrix(nser, nser);
KA = make_zero_matrix(nser, nser);
KB = make_zero_matrix(nser, nser);
set_array_to_zero(A[0]);
set_array_to_zero(B[0]);
copy_array(id, subarray(A[0],0));
copy_array(id, subarray(B[0],0));
matrix_prod(resid_f, resid_f, 0, 1, E);
scalar_op(E, n, '/', E);
copy_array(E, subarray(V,0));
for (m = 0; m < omax; m++) {
for(i = 0; i < nser; i++) {
for (j = n - 1; j > m; j--) {
MATRIX(resid_b)[i][j] = MATRIX(resid_b)[i][j-1];
}
MATRIX(resid_f)[i][m] = 0.0;
MATRIX(resid_b)[i][m] = 0.0;
}
matrix_prod(resid_f, resid_f, 0, 1, ss_ff);
matrix_prod(resid_b, resid_b, 0, 1, ss_bb);
matrix_prod(resid_f, resid_b, 0, 1, ss_fb);
burg2(ss_ff, ss_bb, ss_fb, E, KA, KB); /* Update K */
for (i = 0; i <= m + 1; i++) {
matrix_prod(KA, subarray(B[m], m + 1 - i), 0, 0, tmp);
array_op(subarray(A[m], i), tmp, '-', subarray(A[m+1], i));
matrix_prod(KB, subarray(A[m], m + 1 - i), 0, 0, tmp);
array_op(subarray(B[m], i), tmp, '-', subarray(B[m+1], i));
}
matrix_prod(KA, resid_b, 0, 0, resid_f_tmp);
matrix_prod(KB, resid_f, 0, 0, resid_b_tmp);
array_op(resid_f, resid_f_tmp, '-', resid_f);
array_op(resid_b, resid_b_tmp, '-', resid_b);
if (vmethod == 1) {
matrix_prod(KA, KB, 0, 0, tmp);
array_op(id, tmp, '-', tmp);
matrix_prod(tmp, E, 0, 0, E);
}
else if (vmethod == 2) {
matrix_prod(resid_f, resid_f, 0, 1, E);
matrix_prod(resid_b, resid_b, 0, 1, tmp);
array_op(E, tmp, '+', E);
scalar_op(E, 2.0*(n - m - 1), '/', E);
}
else error(_("Invalid vmethod"));
copy_array(E, subarray(V,m+1));
copy_array(KA, subarray(P,m+1));
}
}
void multi_burg(int *pn, double *x, int *pomax, int *pnser, double *coef,
double *pacf, double *var, double *aic, int *porder, int *useaic,
int *vmethod)
{
int i, j, m, omax = *pomax, n = *pn, nser=*pnser, order=*porder;
int dim1[3];
double aicmin;
Array xarr, resid_f, resid_b, resid_f_tmp;
Array *A, *B, P, V;
dim1[0] = omax+1; dim1[1] = dim1[2] = nser;
A = (Array *) R_alloc(omax+1, sizeof(Array));
B = (Array *) R_alloc(omax+1, sizeof(Array));
for (i = 0; i <= omax; i++) {
A[i] = make_zero_array(dim1, 3);
B[i] = make_zero_array(dim1, 3);
}
P = make_array(pacf, dim1, 3);
V = make_array(var, dim1, 3);
xarr = make_matrix(x, nser, n);
resid_f = make_zero_matrix(nser, n);
resid_b = make_zero_matrix(nser, n);
set_array_to_zero(resid_b);
copy_array(xarr, resid_f);
copy_array(xarr, resid_b);
resid_f_tmp = make_zero_matrix(nser, n);
burg0(omax, resid_f, resid_b, A, B, P, V, *vmethod);
/* Model order selection */
for (i = 0; i <= omax; i++) {
aic[i] = n * ldet(subarray(V,i)) + 2 * i * nser * nser;
}
if (*useaic) {
order = 0;
aicmin = aic[0];
for (i = 1; i <= omax; i++) {
if (aic[i] < aicmin) {
aicmin = aic[i];
order = i;
}
}
}
else order = omax;
*porder = order;
for(i = 0; i < vector_length(A[order]); i++)
coef[i] = VECTOR(A[order])[i];
if (*useaic) {
/* Recalculate residuals for chosen model */
set_array_to_zero(resid_f);
set_array_to_zero(resid_f_tmp);
for (m = 0; m <= order; m++) {
for (i = 0; i < NROW(resid_f_tmp); i++) {
for (j = 0; j < NCOL(resid_f_tmp) - order; j++) {
MATRIX(resid_f_tmp)[i][j + order] = MATRIX(xarr)[i][j + order - m];
}
}
matrix_prod(subarray(A[order],m), resid_f_tmp, 0, 0, resid_f_tmp);
array_op(resid_f_tmp, resid_f, '+', resid_f);
}
}
copy_array(resid_f, xarr);
}