The R Project SVN R-packages

Rev

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
1534 bates 1 
				/* Sparse triangular logical matrices */
2 
#include "ltCMatrix.h"
3 
 
1776 maechler 4 
/**
1534 bates 5 
 * Check the validity of the slots of an ltCMatrix object
1776 maechler 6 
 *
1534 bates 7 
 * @param x Pointer to an ltCMatrix object
1776 maechler 8 
 *
1534 bates 9 
 * @return an SEXP that is either TRUE or a character string
10 
 * describing the way in which the object failed the validity check
11 
 */
12 
SEXP ltCMatrix_validate(SEXP x)
13 
{
1787 maechler 14 
    SEXP val = triangularMatrix_validate(x);
15 
    if(isString(val))
16 
	return(val);
17 
    else {
18 
	/* FIXME needed? ltC* inherits from lgC* which does this in validate*/
19 
	SEXP pslot = GET_SLOT(x, Matrix_pSym),
20 
	    islot = GET_SLOT(x, Matrix_iSym);
21 
	int
22 
	    ncol = length(pslot) - 1,
23 
	    *xp = INTEGER(pslot),
24 
	    *xi = INTEGER(islot);
1534 bates 25 
 
1787 maechler 26 
	if (csc_unsorted_columns(ncol, xp, xi))
27 
	    csc_sort_columns(ncol, xp, xi, (double *) NULL);
28 
	return ScalarLogical(1);
29 
    }
1534 bates 30 
}
31 
 
1776 maechler 32 
/**
1534 bates 33 
 * Transpose an ltCMatrix
1776 maechler 34 
 *
1534 bates 35 
 * @param x Pointer to an ltCMatrix object
1776 maechler 36 
 *
1534 bates 37 
 * @return the transpose of x.  It represents the same matrix but is
38 
 * stored in the opposite triangle.
39 
 */
40 
SEXP ltCMatrix_trans(SEXP x)
41 
{
42 
    SEXP Xi = GET_SLOT(x, Matrix_iSym),
43 
	ans = PROTECT(NEW_OBJECT(MAKE_CLASS("ltCMatrix"))),
44 
	xdn = GET_SLOT(x, Matrix_DimNamesSym);
45 
    SEXP adn = ALLOC_SLOT(ans, Matrix_DimNamesSym, VECSXP, 2);
46 
    int *adims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2)),
47 
	*xdims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
1862 maechler 48 
	up = uplo_P(x)[0] == 'U';
1534 bates 49 
    int m = xdims[0], n = xdims[1], nz = length(Xi);
50 
    int *xj = expand_cmprPt(n, INTEGER(GET_SLOT(x, Matrix_pSym)),
51 
			    Calloc(nz, int));
52 
 
53 
    adims[0] = n; adims[1] = m;
54 
    SET_VECTOR_ELT(adn, 0, VECTOR_ELT(xdn, 1));
55 
    SET_VECTOR_ELT(adn, 1, VECTOR_ELT(xdn, 0));
56 
    SET_SLOT(ans, Matrix_uploSym, mkString(up ? "L" : "U"));
57 
    SET_SLOT(ans, Matrix_diagSym, duplicate(GET_SLOT(x, Matrix_diagSym)));
58 
    triplet_to_col(n, m, nz, xj, INTEGER(Xi), (double *) NULL,
59 
		   INTEGER(ALLOC_SLOT(ans, Matrix_pSym, INTSXP,  m + 1)),
60 
		   INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP,  nz)),
61 
		   (double *) NULL);
62 
    Free(xj);
63 
    UNPROTECT(1);
64 
    return ans;
65 
}
66 
 
1776 maechler 67 
/**
1534 bates 68 
 * Solve  one  of the matrix equations  op(A)*C = B, or
69 
 * C*op(A) = B where A is a square ltCMatrix and B and C are lgCMatrix
70 
 * objects.
1776 maechler 71 
 *
1534 bates 72 
 * @param side LFT or RGT
73 
 * @param transa TRN or NTR
74 
 * @param A pointer to an ltCMatrix object
75 
 * @param B pointer to an lgCMatrix object
76 
 * @param C pointer to an lgCMatrix object
77 
 */
78 
void
79 
ltClgCsm(enum CBLAS_SIDE side, enum CBLAS_TRANSPOSE transa,
80 
	 SEXP A, SEXP B, SEXP C)
81 
{
82 
    error(_("code not yet written"));
83 
}