/*! \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);
}
void Seuillage(IMAGE *image, IMAGE *imres, int seuil)
{
POINT *point = NULL, *pointv=NULL, *pointvv=NULL; /* point courant et point voisin */
short i,j; /* variables indices ligne et colonne du voisinage */
if(crea_POINT(point) == NULL) /* creation des points */
{
fprintf(stderr,"Erreur d'Allocation Memoire du Point : Median \n");
exit (0);
}
if(crea_POINT(pointv) == NULL)
{
fprintf(stderr,"Erreur d'Allocation Memoire du Point Voisin : Median \n");
exit (0);
}
if(crea_POINT(pointvv) == NULL)
{
fprintf(stderr,"Erreur d'Allocation Memoire du Point Voisin suivant : Median \n");
exit (0);
}
/* --- Initialisation des Bords :
on recopie l'image originale --- */
for(POINT_X(point) = 0; POINT_X(point) < NCOL(image);
POINT_X(point)++)
{
POINT_Y(point) = 0; /* premiere ligne */
PIXEL(imres, point) = PIXEL(image, point);
POINT_Y(point) = NLIG(image) - 1;/* derniere ligne */
PIXEL(imres, point) = PIXEL(image, point);
} /*--- fin recopiage 1er et derniere ligne --- */
for(POINT_Y(point) = 0; POINT_Y(point) < NLIG(image);
POINT_Y(point)++)
{
POINT_X(point) = 0;/* premiere colonne */
PIXEL(imres, point) = PIXEL(image, point);
POINT_X(point) = NCOL(image) - 1;/* derniere colonne */
PIXEL(imres, point) = PIXEL(image, point);
}
for(POINT_Y(point) = 0; POINT_Y(point) < NLIG(image); POINT_Y(point)++)
for(POINT_X(point) = 0; POINT_X(point) < NCOL(image); POINT_X(point)++)
{
PIXEL(imres,point) = PIXEL(image,point) < seuil? (short)0 : (short)255;
}
}
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 VARIABLE *matc_element( VARIABLE *ptr )
{
double *num = MATR(ptr);
char *str = NULL;
int i,j,n,maxn=0;
VARIABLE *res = NULL;
element_t *elem = CurrentObject->ElementModel->Elements;
if ( NEXT(ptr) ) str = var_to_string( NEXT(ptr) );
if ( CurrentObject->ElementModel->NofElements <= 0 ) error( "element: no elements present.\n" );
for( i=0; i<NCOL(ptr); i++ )
{
n = num[i];
if ( n < 0 || n >= CurrentObject->ElementModel->NofElements )
{
error( "element: Envalid element index: [%d].\n",n );
}
maxn = MAX( maxn,elem[n].ElementType->NumberOfNodes );
}
res = var_temp_new( TYPE_DOUBLE, NCOL(ptr), maxn );
for( i=0; i<NCOL(ptr); i++ )
{
n = num[i];
for( j=0; j<elem[n].ElementType->NumberOfNodes; j++ )
{
M(res,i,j) = elem[n].Topology[j];
}
}
if ( str ) FREEMEM( str );
return res;
}
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 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;
}
/*******************************************************************************
*
* 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 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);
}
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);
}
