static msg_t check_matrix_dims(SEXP x, SEXP min_rows, SEXP min_cols, SEXP rows, SEXP cols) {
if (!isNull(min_rows) || !isNull(rows)) {
R_len_t xrows = get_nrows(x);
if (!isNull(min_rows)) {
R_len_t cmp = asCount(min_rows, "min.rows");
if (xrows < cmp)
return make_msg("Must have at least %i rows, but has %i rows", cmp, xrows);
}
if (!isNull(rows)) {
R_len_t cmp = asCount(rows, "rows");
if (xrows != cmp)
return make_msg("Must have exactly %i rows, but has %i rows", cmp, xrows);
}
}
if (!isNull(min_cols) || !isNull(cols)) {
R_len_t xcols = get_ncols(x);
if (!isNull(min_cols)) {
R_len_t cmp = asCount(min_cols, "min.cols");
if (xcols < cmp)
return make_msg("Must have at least %i cols, but has %i cols", cmp, xcols);
}
if (!isNull(cols)) {
R_len_t cmp = asCount(cols, "cols");
if (xcols != cmp)
return make_msg("Must have exactly %i cols, but has %i cols", cmp, xcols);
}
}
return MSGT;
}
void kjg_fpca_XTXA (
const gsl_matrix *A1,
gsl_matrix *B,
gsl_matrix *A2) {
size_t m = get_ncols();
size_t n = get_nrows();
size_t i, r; // row index
double *Y = malloc(sizeof(double) * n * KJG_FPCA_ROWS); // normalized
gsl_matrix_view Bi, Xi;
gsl_matrix_set_zero(A2);
for (i = 0; i < m; i += KJG_FPCA_ROWS) {
r = kjg_geno_get_normalized_rows(i, KJG_FPCA_ROWS, Y);
Xi = gsl_matrix_view_array(Y, r, n);
Bi = gsl_matrix_submatrix(B, i, 0, r, B->size2);
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1, &Xi.matrix, A1, 0,
&Bi.matrix);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1, &Xi.matrix, &Bi.matrix,
1, A2);
}
free(Y);
}
/**
* Function used to make a cell the first visible one.
*/
static int adjust_origin(TCells* obj, char* attr) {
char buffer[ 15 ];
int lin = -9, col = -9;
/* Scanning the origin */
iupStrToIntInt(attr, &lin, &col, ':');
/* If the origin line is a non-scrollable one, the scrollbar position is
* set to zero. Otherwise, the sum of the previous widths will be
* set to the scrollbar position. This algorithm is applied to both
* scrollbars */
if (lin <= obj->non_scrollable_lins) {
IupSetAttribute(obj->self, IUP_POSY, "0");
}
else if (lin <= get_nlines(obj)) {
int ymin_sum = get_ranged_height(obj, obj->non_scrollable_lins+1, lin-1);
sprintf(buffer, "%d", ymin_sum);
IupStoreAttribute(obj->self, IUP_POSY, buffer);
}
/* As said before... */
if (col <= obj->non_scrollable_cols) {
IupSetAttribute(obj->self, IUP_POSX, "0");
}
else if (col <= get_ncols(obj)) {
int xmin_sum = get_ranged_width(obj, obj->non_scrollable_cols+1, col-1);
sprintf(buffer, "%d", xmin_sum);
IupStoreAttribute(obj->self, IUP_POSX, buffer);
}
return 1;
}
/** Function used to get the cells groups virtual size
* @param obj pointer to internal object handle
* @param wi a reference to virtual width in pixels
* @param he a reference to virtual height in pixels
* @return references written [wi, he]
*/
static void get_virtual_size(TCells* obj, int* wi, int* he) {
int i, j;
/* Initializing the return values */
*wi = 0; *he = 0;
/* Looping through all lines and columns, adding its width and heights
* to the return values. So, the cells virtual size is computed */
for (i = 1; i <= get_nlines(obj); i++) *he = *he + get_height(obj, i);
for (j = 1; j <= get_ncols(obj); j++) *wi = *wi + get_width(obj, j);
}
/**
* Recalculation of first visible column.
* @param obj then iupcells internal struct object.
* @return column number
*/
static int get_first_col(TCells* obj) {
int i, j;
int ncols = get_ncols(obj);
int nlines = get_nlines(obj);
if (obj->non_scrollable_cols >= ncols) return 1;
/* Looping the columns until a visible one is found */
for (j = 1; j <= ncols; j++) {
for (i = 1; i <= nlines; i++) {
if (get_cell_limit(obj, i, j, NULL, NULL, NULL, NULL)) return j;
}
}
return IUP_OUT;
}
/**
* Repaint function for all cells
* (assume that the canvas is already activated)
*/
static void repaint_cells(TCells* obj) {
int sline = obj->non_scrollable_lins;
int scol = obj->non_scrollable_cols;
int nlines = get_nlines(obj);
int ncols = get_ncols(obj);
/* Repainting the four parts of the cells: common cells, non-scrollable
* columns, non-scrollable lines, and non-scrollable margin
* (line and column) */
repaint_ranged_cells(obj, sline+1, nlines, scol+1, ncols);
repaint_ranged_cells(obj, sline+1, nlines, 1, scol);
repaint_ranged_cells(obj, 1, sline, scol+1, ncols);
repaint_ranged_cells(obj, 1, sline, 1, scol);
}
void kjg_fpca_XTB (
const gsl_matrix *B,
gsl_matrix *A) {
size_t n = get_nrows();
size_t m = get_ncols();
size_t i, r;
double *Y = malloc(sizeof(double) * n * KJG_FPCA_ROWS);
gsl_matrix_view Xmat;
gsl_matrix_set_zero(A);
for (i = 0; i < m; i += KJG_FPCA_ROWS) {
r = kjg_geno_get_normalized_rows(i, KJG_FPCA_ROWS, Y);
Xmat = gsl_matrix_view_array(Y, r, n);
gsl_matrix_const_view Hmat = gsl_matrix_const_submatrix(B, i, 0, r,
B->size2);
gsl_blas_dgemm(CblasTrans, CblasNoTrans, 1, &Xmat.matrix, &Hmat.matrix,
1, A);
}
free(Y);
}
/**
* Function used to calculate the cell coordinates
*/
static int get_coord(TCells* obj, int x, int y, int* lin, int* col) {
int pck = 0;
int sline = obj->non_scrollable_lins;
int scol = obj->non_scrollable_cols;
int nlines = get_nlines(obj);
int ncols = get_ncols(obj);
/* Trying to pick a cell (raster coordinates) at the four
* parts of the cells (reverse order of the repainting):
* non-scrollable margin (line and column), non-scrollable
* columns, non-scrollable lines, and common cells. */
pck = get_ranged_coord(obj, x, y, lin, col, 1, sline, 1, scol);
if (pck) return 1;
pck = get_ranged_coord(obj, x, y, lin, col, 1, sline, scol+1, ncols);
if (pck) return 1;
pck = get_ranged_coord(obj, x, y, lin, col, sline+1, nlines, 1, scol);
if (pck) return 1;
pck = get_ranged_coord(obj, x, y, lin, col, 1, nlines, 1, ncols);
return pck;
}
void kjg_fpca (
size_t K,
size_t L,
size_t I,
double* eval,
double* evec) {
struct timespec x, y, d;
clock_gettime(CLOCK_REALTIME, &x);
fprintf(stderr, "Started fastPCA: ");
print_time(&x);
fprintf(stderr, "\n");
if (K >= L) exit(1);
if (I == 0) exit(1);
size_t m = get_ncols();
size_t n = get_nrows();
// PART A - compute Q such that X ~ Q * (Q^T) * X
gsl_matrix* G1 = gsl_matrix_alloc(n, L);
gsl_matrix* G2 = gsl_matrix_alloc(n, L);
gsl_matrix* Q = gsl_matrix_alloc(m, (I + 1) * L);
gsl_matrix* Gswap;
gsl_rng *r = kjg_gsl_rng_init();
kjg_gsl_ran_ugaussian_matrix(r, G1);
gsl_rng_free(r);
size_t i;
for (i = 0; i < I; i++) {
gsl_matrix_view Qi = gsl_matrix_submatrix(Q, 0, i * L, m, L);
// do the multiplication
kjg_fpca_XTXA(G1, &Qi.matrix, G2);
// orthonormalize (Gram-Schmidt equivalent)
kjg_gsl_matrix_QR(G2);
Gswap = G2;
G2 = G1;
G1 = Gswap;
}
gsl_matrix_view Qi = gsl_matrix_submatrix(Q, 0, I * L, m, L);
kjg_fpca_XA(G1, &Qi.matrix);
{
gsl_matrix* V = gsl_matrix_alloc(Q->size2, Q->size2);
gsl_vector* S = gsl_vector_alloc(Q->size2);
kjg_gsl_SVD(Q, V, S);
gsl_matrix_free(V);
gsl_vector_free(S);
}
// kjg_gsl_matrix_QR(Q); // QR decomposition is less accurate than SVD
gsl_matrix_free(G1);
gsl_matrix_free(G2);
// PART B - compute B matrix, take SVD and return
gsl_matrix* B = gsl_matrix_alloc(n, (I + 1) * L);
kjg_fpca_XTB(Q, B);
gsl_matrix* Utilda = gsl_matrix_alloc((I + 1) * L, (I + 1) * L);
gsl_vector* Stilda = gsl_vector_alloc((I + 1) * L);
kjg_gsl_SVD(B, Utilda, Stilda);
gsl_matrix_view Vk = gsl_matrix_submatrix(B, 0, 0, n, K);
gsl_matrix_view evec_view = gsl_matrix_view_array(evec, n, K);
gsl_matrix_memcpy(&evec_view.matrix, &Vk.matrix);
gsl_vector_view Sk = gsl_vector_subvector(Stilda, 0, K);
gsl_vector_view eval_view = gsl_vector_view_array(eval, K);
gsl_vector_mul(&Sk.vector, &Sk.vector);
gsl_vector_scale(&Sk.vector, 1.0 / m);
gsl_vector_memcpy(&eval_view.vector, &Sk.vector);
gsl_matrix_free(Q);
gsl_matrix_free(B);
gsl_matrix_free(Utilda);
gsl_vector_free(Stilda);
clock_gettime(CLOCK_REALTIME, &y);
fprintf(stderr, "Finished fastPCA: ");
print_time(&y);
fprintf(stderr, "\n");
diff_time(&y, &x, &d);
fprintf(stderr, "Elapsed fastPCA: ");
print_time(&d);
fprintf(stderr, "\n");
}