The R Project SVN R-packages

Rev

Rev 4418 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
1265 bates 1 
#include "dppMatrix.h"
2 
 
3 
SEXP dppMatrix_validate(SEXP obj)
4 
{
5 
/*     int i, n = INTEGER(GET_SLOT(obj, Matrix_DimSym))[0]; */
6 
/*     double *x = REAL(GET_SLOT(obj, Matrix_xSym)); */
7 
 
8 
    /* quick but nondefinitive check on positive definiteness */
9 
/*     for (i = 0; i < n; i++) */
10 
/* 	if (x[i * np1] < 0) */
11 
/* 	    return mkString(_("dppMatrix is not positive definite")); */
3827 maechler 12 
    return dspMatrix_validate(obj);
1265 bates 13 
}
14 
 
15 
SEXP dppMatrix_chol(SEXP x)
16 
{
17 
    SEXP val = get_factors(x, "pCholesky"),
18 
	dimP = GET_SLOT(x, Matrix_DimSym),
19 
	uploP = GET_SLOT(x, Matrix_uploSym);
4418 bates 20 
    const char *uplo = CHAR(STRING_ELT(uploP, 0));
1265 bates 21 
    int *dims = INTEGER(dimP), info;
22 
 
23 
    if (val != R_NilValue) return val;
24 
    dims = INTEGER(dimP);
25 
    val = PROTECT(NEW_OBJECT(MAKE_CLASS("pCholesky")));
26 
    SET_SLOT(val, Matrix_uploSym, duplicate(uploP));
27 
    SET_SLOT(val, Matrix_diagSym, mkString("N"));
28 
    SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
29 
    SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(x, Matrix_xSym)));
30 
    F77_CALL(dpptrf)(uplo, dims, REAL(GET_SLOT(val, Matrix_xSym)), &info);
1877 maechler 31 
    if (info) {
32 
	if(info > 0) /* e.g. x singular */
33 
	    error(_("the leading minor of order %d is not positive definite"),
34 
		    info);
35 
	else /* should never happen! */
36 
	    error(_("Lapack routine %s returned error code %d"), "dpptrf", info);
37 
    }
1265 bates 38 
    UNPROTECT(1);
39 
    return set_factors(x, val, "pCholesky");
40 
}
41 
 
2200 bates 42 
SEXP dppMatrix_rcond(SEXP obj, SEXP type)
1265 bates 43 
{
2200 bates 44 
    SEXP Chol = dppMatrix_chol(obj);
1265 bates 45 
    char typnm[] = {'O', '\0'};	/* always use the one norm */
2200 bates 46 
    int *dims = INTEGER(GET_SLOT(Chol, Matrix_DimSym)), info;
47 
    double anorm = get_norm_sp(obj, typnm), rcond;
1265 bates 48 
 
2200 bates 49 
    F77_CALL(dppcon)(uplo_P(Chol), dims,
50 
		     REAL(GET_SLOT(Chol, Matrix_xSym)), &anorm, &rcond,
51 
		     (double *) R_alloc(3*dims[0], sizeof(double)),
52 
		     (int *) R_alloc(dims[0], sizeof(int)), &info);
53 
    return ScalarReal(rcond);
1265 bates 54 
}
55 
 
56 
SEXP dppMatrix_solve(SEXP x)
57 
{
58 
    SEXP Chol = dppMatrix_chol(x);
59 
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dppMatrix")));
60 
    int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)), info;
61 
 
62 
    SET_SLOT(val, Matrix_uploSym, duplicate(GET_SLOT(Chol, Matrix_uploSym)));
63 
    SET_SLOT(val, Matrix_xSym, duplicate(GET_SLOT(Chol, Matrix_xSym)));
64 
    SET_SLOT(val, Matrix_DimSym, duplicate(GET_SLOT(Chol, Matrix_DimSym)));
1862 maechler 65 
    F77_CALL(dpptri)(uplo_P(val), dims,
66 
		     REAL(GET_SLOT(val, Matrix_xSym)), &info);
1265 bates 67 
    UNPROTECT(1);
68 
    return val;
69 
}
70 
 
3484 maechler 71 
SEXP dppMatrix_matrix_solve(SEXP a, SEXP b)
1265 bates 72 
{
3484 maechler 73 
    SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
3454 bates 74 
    SEXP Chol = dppMatrix_chol(a);
1265 bates 75 
    int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
3454 bates 76 
	*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym));
1282 bates 77 
    int n = bdims[0], nrhs = bdims[1], info;
1265 bates 78 
 
79 
    if (*adims != *bdims || bdims[1] < 1 || *adims < 1)
80 
	error(_("Dimensions of system to be solved are inconsistent"));
1862 maechler 81 
    F77_CALL(dpptrs)(uplo_P(Chol), &n, &nrhs,
82 
		     REAL(GET_SLOT(Chol, Matrix_xSym)),
3454 bates 83 
		     REAL(GET_SLOT(val, Matrix_xSym)), &n, &info);
1265 bates 84 
    UNPROTECT(1);
85 
    return val;
86 
}