17 int *pdim = INTEGER(dim), m = pdim[0], n = pdim[1], r = (m < n) ? m : n;
21 SEXP perm = PROTECT(allocVector(INTSXP, r)),
23 y = PROTECT(allocVector(TYPEOF(x), XLENGTH(x)));
24 int *pperm = INTEGER(perm), info;
25#ifdef MATRIX_ENABLE_ZMATRIX
26 if (TYPEOF(x) == CPLXSXP) {
27 Rcomplex *px = COMPLEX(x), *py = COMPLEX(y);
29 F77_CALL(zgetrf)(&m, &n, py, &m, pperm, &info);
33 double *px = REAL(x), *py = REAL(y);
35 F77_CALL(dgetrf)(&m, &n, py, &m, pperm, &info);
37#ifdef MATRIX_ENABLE_ZMATRIX
51 SEXP val = PROTECT(
newObject(
"BunchKaufman")),
55 int n = INTEGER(dim)[1];
56 char ul = *CHAR(STRING_ELT(uplo, 0));
61 SEXP perm = PROTECT(allocVector(INTSXP, n)),
63 y = PROTECT(allocVector(TYPEOF(x), XLENGTH(x)));
64 int *pperm = INTEGER(perm), info, lwork = -1;
65#ifdef MATRIX_ENABLE_ZMATRIX
66 if (TYPEOF(x) == CPLXSXP) {
67 Rcomplex *px = COMPLEX(x), *py = COMPLEX(y), tmp, *work;
69 F77_CALL(zlacpy)(&ul, &n, &n, px, &n, py, &n
FCONE);
70 F77_CALL(zsytrf)(&ul, &n, py, &n, pperm, &tmp, &lwork, &info
FCONE);
73 F77_CALL(zsytrf)(&ul, &n, py, &n, pperm, work, &lwork, &info
FCONE);
78 double *px = REAL(x), *py = REAL(y), tmp, *work;
80 F77_CALL(dlacpy)(&ul, &n, &n, px, &n, py, &n
FCONE);
81 F77_CALL(dsytrf)(&ul, &n, py, &n, pperm, &tmp, &lwork, &info
FCONE);
84 F77_CALL(dsytrf)(&ul, &n, py, &n, pperm, work, &lwork, &info
FCONE);
87#ifdef MATRIX_ENABLE_ZMATRIX
101 SEXP val = PROTECT(
newObject(
"pBunchKaufman")),
105 int n = INTEGER(dim)[1];
106 char ul = *CHAR(STRING_ELT(uplo, 0));
111 SEXP perm = PROTECT(allocVector(INTSXP, n)),
113 y = PROTECT(allocVector(TYPEOF(x), XLENGTH(x)));
114 int *pperm = INTEGER(perm), info;
115#ifdef MATRIX_ENABLE_ZMATRIX
116 if (TYPEOF(x) == CPLXSXP) {
117 Rcomplex *px = COMPLEX(x), *py = COMPLEX(y);
119 F77_CALL(zsptrf)(&ul, &n, py, pperm, &info
FCONE);
123 double *px = REAL(x), *py = REAL(y);
125 F77_CALL(dsptrf)(&ul, &n, py, pperm, &info
FCONE);
127#ifdef MATRIX_ENABLE_ZMATRIX
141 SEXP val = PROTECT(
newObject(
"Cholesky")),
145 int n = INTEGER(dim)[1];
146 char ul = *CHAR(STRING_ELT(uplo, 0));
152 y = PROTECT(allocVector(TYPEOF(x), XLENGTH(x)));
154#ifdef MATRIX_ENABLE_ZMATRIX
155 if (TYPEOF(x) == CPLXSXP) {
156 Rcomplex *px = COMPLEX(x), *py = COMPLEX(y);
158 F77_CALL(zlacpy)(&ul, &n, &n, px, &n, py, &n
FCONE);
160 F77_CALL(zpotrf)(&ul, &n, py, &n, &info
FCONE);
163 SEXP perm = PROTECT(allocVector(INTSXP, n));
164 int *pperm = INTEGER(perm), rank;
165 Rcomplex *work = (Rcomplex *) R_alloc((
size_t) 2 * n,
sizeof(Rcomplex));
166 F77_CALL(zpstrf)(&ul, &n, py, &n, pperm, &rank, &tol, work, &info
FCONE);
170 py += (R_xlen_t) rank * n + rank;
171 for (j = rank; j < n; ++j) {
181 double *px = REAL(x), *py = REAL(y);
183 F77_CALL(dlacpy)(&ul, &n, &n, px, &n, py, &n
FCONE);
185 F77_CALL(dpotrf)(&ul, &n, py, &n, &info
FCONE);
188 SEXP perm = PROTECT(allocVector(INTSXP, n));
189 int *pperm = INTEGER(perm), rank;
190 double *work = (
double *) R_alloc((
size_t) 2 * n,
sizeof(double));
191 F77_CALL(dpstrf)(&ul, &n, py, &n, pperm, &rank, &tol, work, &info
FCONE);
195 py += (R_xlen_t) rank * n + rank;
196 for (j = rank; j < n; ++j) {
204#ifdef MATRIX_ENABLE_ZMATRIX
217 SEXP val = PROTECT(
newObject(
"pCholesky")),
221 int n = INTEGER(dim)[1];
222 char ul = *CHAR(STRING_ELT(uplo, 0));
228 y = PROTECT(allocVector(TYPEOF(x), XLENGTH(x)));
230#ifdef MATRIX_ENABLE_ZMATRIX
231 if (TYPEOF(x) == CPLXSXP) {
232 Rcomplex *px = COMPLEX(x), *py = COMPLEX(y);
234 F77_CALL(zpptrf)(&ul, &n, py, &info
FCONE);
238 double *px = REAL(x), *py = REAL(y);
240 F77_CALL(dpptrf)(&ul, &n, py, &info
FCONE);
242#ifdef MATRIX_ENABLE_ZMATRIX
287 int pivot_ = asLogical(pivot);
288 SEXP val =
get_factor(obj, (pivot_) ?
"Cholesky~" :
"Cholesky");
290 double tol_ = asReal(tol);
291 PROTECT(val =
dpoMatrix_trf_(obj, asInteger(warn), pivot_, tol_));
292 set_factor(obj, (pivot_) ?
"Cholesky~" :
"Cholesky", val);
312 int *dims, n, vecs = asLogical(vectors), is_dge = asLogical(isDGE),
313 info, izero = 0, lwork = -1, nprot = 1;
318 dims = INTEGER(getAttrib(x, R_DimSymbol));
320 x = PROTECT(coerceVector(x, REALSXP));
325 const char *nms[] = {
"WR",
"WI",
"T",
"Z",
""};
326 SEXP val = PROTECT(Rf_mkNamed(VECSXP, nms));
329 if (n != dims[1] || n < 1)
330 error(
_(
"dgeMatrix_Schur: argument x must be a non-null square matrix"));
331 const R_xlen_t n2 = ((R_xlen_t)n) * n;
333 SET_VECTOR_ELT(val, 0, allocVector(REALSXP, n));
334 SET_VECTOR_ELT(val, 1, allocVector(REALSXP, n));
335 SET_VECTOR_ELT(val, 2, allocMatrix(REALSXP, n, n));
336 Memcpy(REAL(VECTOR_ELT(val, 2)),
339 SET_VECTOR_ELT(val, 3, allocMatrix(REALSXP, vecs ? n : 0, vecs ? n : 0));
340 F77_CALL(dgees)(vecs ?
"V" :
"N",
"N", NULL, dims, (
double *) NULL, dims, &izero,
341 (
double *) NULL, (
double *) NULL, (
double *) NULL, dims,
342 &tmp, &lwork, (
int *) NULL, &info
FCONE FCONE);
343 if (info) error(
_(
"dgeMatrix_Schur: first call to dgees failed"));
347 F77_CALL(dgees)(vecs ?
"V" :
"N",
"N", NULL, dims, REAL(VECTOR_ELT(val, 2)), dims,
348 &izero, REAL(VECTOR_ELT(val, 0)), REAL(VECTOR_ELT(val, 1)),
349 REAL(VECTOR_ELT(val, 3)), dims, work, &lwork,
352 if (info) error(
_(
"dgeMatrix_Schur: dgees returned code %d"), info);
357#define DO_FREE(_A_, _S_, _N_) \
360 _A_ = Matrix_cs_spfree(_A_); \
362 _S_ = Matrix_cs_sfree (_S_); \
364 _N_ = Matrix_cs_nfree (_N_); \
367#define DO_SORT(_A_) \
369 Matrix_cs_dropzeros(_A_); \
370 T = Matrix_cs_transpose(_A_, 1); \
372 DO_FREE(T, *S, *N); \
375 _A_ = Matrix_cs_spfree(_A_); \
376 _A_ = Matrix_cs_transpose(T, 1); \
378 DO_FREE(T, *S, *N); \
381 T = Matrix_cs_spfree(T); \
386 int order,
double tol)
401 double tol_ = asReal(tol);
403 error(
_(
"'%s' is not a number"),
"tol");
405 int order_ = asInteger(order);
406 if (order_ == NA_INTEGER)
407 order_ = (tol_ == 1.0) ? 2 : 1;
408 else if (order_ < 0 || order_ > 3)
411 SEXP val =
get_factor(obj, (order_) ?
"sparseLU~" :
"sparseLU");
424 error(
_(
"LU factorization of m-by-n %s requires m == n"),
432 if (asLogical(doError))
433 error(
_(
"LU factorization of %s failed: out of memory or near-singular"),
437 return ScalarLogical(NA_LOGICAL);
448 SEXP L = PROTECT(
CXS2M(N->
L, 1,
't')),
449 U = PROTECT(
CXS2M(N->
U, 1,
't')),
450 uplo = PROTECT(mkString(
"L"));
456 SEXP p = PROTECT(allocVector(INTSXP, A->
m));
461 SEXP q = PROTECT(allocVector(INTSXP, A->
n));
471 set_factor(obj, (order_) ?
"sparseLU~" :
"sparseLU", val);
493 int order_ = asInteger(order);
494 if (order_ < 0 || order_ > 3)
497 SEXP val =
get_factor(obj, (order_) ?
"sparseQR~" :
"sparseQR");
510 error(
_(
"QR factorization of m-by-n %s requires m >= n"),
518 if (asLogical(doError))
519 error(
_(
"QR factorization of %s failed: out of memory"),
523 return ScalarLogical(NA_LOGICAL);
534 SEXP V = PROTECT(
CXS2M(N->
L, 1,
'g')),
535 R = PROTECT(
CXS2M(N->
U, 1,
'g'));
540 SEXP beta = PROTECT(allocVector(REALSXP, A->
n));
545 SEXP p = PROTECT(allocVector(INTSXP, S->
m2));
550 SEXP q = PROTECT(allocVector(INTSXP, A->
n));
560 set_factor(obj, (order_) ?
"sparseQR~" :
"sparseQR", val);
570 int perm,
int ldl,
int super,
double mult)
581 c.method[0].ordering = CHOLMOD_NATURAL;
585 c.supernodal = (super == NA_LOGICAL) ? CHOLMOD_AUTO :
586 ((super != 0) ? CHOLMOD_SUPERNODAL : CHOLMOD_SIMPLICIAL);
588 *L = cholmod_analyze(A, &
c);
591 if (super == NA_LOGICAL)
592 super = (*L)->is_super;
597 c.final_super = super != 0;
598 c.final_ll = ldl == 0;
600 c.final_monotonic = 1;
605 int res = cholmod_factorize_p(A, beta, NULL, 0, *L, &
c);
613 SEXP perm, SEXP ldl, SEXP super, SEXP mult)
615 int perm_ = asLogical(perm), ldl_ = asLogical(ldl),
616 super_ = asLogical(super);
617 double mult_ = asReal(mult);
618 if (!R_FINITE(mult_))
619 error(
_(
"'%s' is not a number or not finite"),
"mult");
621 SEXP trf = R_NilValue;
622 char nm[] =
"spdCholesky";
625 if (super_ != NA_LOGICAL && super_ != 0)
627 if (super_ == NA_LOGICAL || super_ == 0) {
632 if (isNull(trf) && (super_ == NA_LOGICAL || super_ != 0)) {
638 int cached = !isNull(trf);
639 if (cached && mult_ == 0.0)
643 PROTECT_WITH_INDEX(trf, &pid);
644 cholmod_sparse *A =
M2CHS(obj, 1);
645 cholmod_factor *L = NULL;
648 char ul = *CHAR(STRING_ELT(uplo, 0));
649 A->stype = (ul ==
'U') ? 1 : -1;
653 L = cholmod_copy_factor(L, &
c);
657 if (super_ == NA_LOGICAL) {
658 nm[0] = (L->is_super) ?
'S' :
's';
659 nm[2] = (L->is_ll ) ?
'd' :
'D';
662 REPROTECT(trf =
CHF2M(L, 1), pid);
663 cholmod_free_factor(&L, &
c);
669 if (!cached && mult_ == 0.0)
681 int i, j, s, n = INTEGER(dim)[0];
682 R_xlen_t n1a = (R_xlen_t) n + 1;
691 int upper = *CHAR(STRING_ELT(uplo, 0)) ==
'U';
698 SEXP diag = PROTECT(mkString(
"U"));
703 D_p = PROTECT(allocVector(INTSXP, n1a));
704 int *ppivot = INTEGER(pivot), *D_pp = INTEGER(D_p),
705 b = n, dp = (upper) ? 1 : 2;
710 D_pp[j+1] = D_pp[j] + 1;
713 D_pp[j+1] = D_pp[j] + dp;
714 D_pp[j+2] = D_pp[j] + 3;
722 SEXP P, P_perm, T, T_p, T_i, T_x,
723 D_i = PROTECT(allocVector(INTSXP, D_pp[n])),
724 D_x = PROTECT(allocVector(REALSXP, D_pp[n])),
726 int *P_pperm, *T_pp, *T_pi, *D_pi = INTEGER(D_i);
727 double *T_px, *D_px = REAL(D_x), *px = REAL(x);
729 int unpacked = !asLogical(packed);
731 R_xlen_t len = (R_xlen_t) 2 * b + 1, k = (upper) ? len - 2 : 0;
732 SEXP res = PROTECT(allocVector(VECSXP, len));
736 s = (ppivot[j] > 0) ? 1 : 2;
737 dp = (upper) ? j : n - j - s;
739 PROTECT(P = duplicate(P_));
740 PROTECT(P_perm = allocVector(INTSXP, n));
741 PROTECT(T = duplicate(T_));
742 PROTECT(T_p = allocVector(INTSXP, n1a));
743 PROTECT(T_i = allocVector(INTSXP, (R_xlen_t) s * dp));
744 PROTECT(T_x = allocVector(REALSXP, (R_xlen_t) s * dp));
746 P_pperm = INTEGER(P_perm);
752 for (i = 0; i < j; ++i) {
756 for (i = j; i < j+s; ++i) {
757 T_pp[i+1] = T_pp[i] + dp;
760 for (i = j+s; i < n; ++i) {
766 P_pperm[j] = ppivot[j];
767 P_pperm[ppivot[j]-1] = j + 1;
769 P_pperm[j] = -ppivot[j];
770 P_pperm[-ppivot[j]-1] = j + 1;
772 P_pperm[j+1] = -ppivot[j];
773 P_pperm[-ppivot[j]-1] = j + 2;
777 for (i = 0; i < j; ++i) {
787 for (i = 0; i < j-1; ++i) {
805 for (i = j+2; i < n; ++i) {
815 for (i = j+1; i < n; ++i) {
830 SET_VECTOR_ELT(res, k-1, P);
831 SET_VECTOR_ELT(res, k , T);
834 SET_VECTOR_ELT(res, k , P);
835 SET_VECTOR_ELT(res, k+1, T);
843 SET_VECTOR_ELT(res, len-1, D_);
851 cholmod_factor *L =
M2CHF(obj, 1);
852 int n = (int) L->n, square_ = asLogical(square);
853 SEXP y = PROTECT(allocVector(REALSXP, n));
854 double *py = REAL(y);
857 nsuper = (int) L->nsuper,
858 *psuper = (
int *) L->super,
859 *ppi = (
int *) L->pi,
860 *ppx = (
int *) L->px;
861 double *px = (
double *) L->x, *px_;
863 for (k = 0; k < nsuper; ++k) {
864 nc = psuper[k+1] - psuper[k];
865 nr1a = (R_xlen_t) (ppi[k+1] - ppi[k]) + 1;
867 for (j = 0; j < nc; ++j) {
876 square_ = square_ && L->is_ll;
877 int j, *pp = (
int *) L->p;
878 double *px = (
double *) L->x;
879 for (j = 0; j < n; ++j) {
895 double mult_ = asReal(mult);
896 if (!R_FINITE(mult_))
897 error(
_(
"'%s' is not a number or not finite"),
"mult");
899 cholmod_factor *L = cholmod_copy_factor(
M2CHF(obj, 1), &
c);
900 cholmod_sparse *A =
M2CHS(parent, 1);
903 char ul = *CHAR(STRING_ELT(uplo, 0));
904 A->stype = (ul ==
'U') ? 1 : -1;
909 SEXP res = PROTECT(
CHF2M(L, 1));
910 cholmod_free_factor(&L, &
c);
925 cholmod_factor *L = cholmod_copy_factor(
M2CHF(obj, 1), &
c);
926 cholmod_sparse *A =
M2CHS(parent, 1);
929 char ul = *CHAR(STRING_ELT(uplo, 0));
930 A->stype = (ul ==
'U') ? 1 : -1;
933 cholmod_updown(asLogical(update) != 0, A, L, &
c);
935 SEXP res = PROTECT(
CHF2M(L, 1));
936 cholmod_free_factor(&L, &
c);
#define ERROR_LAPACK_4(_ROUTINE_, _INFO_, _RANK_, _WARN_)
#define ERROR_LAPACK_3(_ROUTINE_, _INFO_, _WARN_, _NPROTECT_)
#define ERROR_LAPACK_2(_ROUTINE_, _INFO_, _WARN_, _LETTER_)
#define Matrix_Free(_VAR_, _N_)
#define SET_SLOT(x, what, value)
#define GET_SLOT(x, what)
#define Matrix_Calloc(_VAR_, _N_, _CTYPE_)
SEXP newObject(const char *)
void set_symmetrized_DimNames(SEXP obj, SEXP dn, int J)
void R_cholmod_common_envset(void)
void R_cholmod_common_envget(void)
cholmod_factor * M2CHF(SEXP obj, int values)
cholmod_sparse * M2CHS(SEXP obj, int values)
SEXP CHF2M(cholmod_factor *L, int values)
Matrix_csn * Matrix_cs_lu(const Matrix_cs *A, const Matrix_css *S, double tol)
void * Matrix_cs_free(void *p)
Matrix_csn * Matrix_cs_qr(const Matrix_cs *A, const Matrix_css *S)
SEXP CXS2M(Matrix_cs *A, int values, char shape)
Matrix_css * Matrix_cs_sfree(Matrix_css *S)
int * Matrix_cs_pinv(const int *p, int n)
Matrix_css * Matrix_cs_sqr(int order, const Matrix_cs *A, int qr)
Matrix_cs * M2CXS(SEXP obj, int values)
Matrix_csn * Matrix_cs_nfree(Matrix_csn *N)
#define MCS_XTYPE_SET(_VALUE_)
SEXP BunchKaufman_expand(SEXP obj, SEXP packed)
static SEXP dsyMatrix_trf_(SEXP obj, int warn)
SEXP dgCMatrix_orf(SEXP obj, SEXP order, SEXP doError)
SEXP dgeMatrix_sch(SEXP x, SEXP vectors, SEXP isDGE)
static int dgCMatrix_orf_(const Matrix_cs *A, Matrix_css **S, Matrix_csn **N, int order)
#define DO_FREE(_A_, _S_, _N_)
SEXP CHMfactor_updown(SEXP obj, SEXP parent, SEXP update)
SEXP dppMatrix_trf(SEXP obj, SEXP warn)
SEXP dpoMatrix_trf(SEXP obj, SEXP warn, SEXP pivot, SEXP tol)
void set_factor(SEXP, const char *, SEXP)
static int dpCMatrix_trf_(cholmod_sparse *A, cholmod_factor **L, int perm, int ldl, int super, double mult)
static SEXP dspMatrix_trf_(SEXP obj, int warn)
static SEXP dppMatrix_trf_(SEXP obj, int warn)
SEXP dpCMatrix_trf(SEXP obj, SEXP perm, SEXP ldl, SEXP super, SEXP mult)
SEXP CHMfactor_update(SEXP obj, SEXP parent, SEXP mult)
static SEXP dpoMatrix_trf_(SEXP obj, int warn, int pivot, double tol)
static SEXP dgeMatrix_trf_(SEXP obj, int warn)
SEXP dsyMatrix_trf(SEXP obj, SEXP warn)
SEXP get_factor(SEXP, const char *)
SEXP dgeMatrix_trf(SEXP obj, SEXP warn)
SEXP dgCMatrix_trf(SEXP obj, SEXP order, SEXP tol, SEXP doError)
SEXP dspMatrix_trf(SEXP obj, SEXP warn)
static int dgCMatrix_trf_(const Matrix_cs *A, Matrix_css **S, Matrix_csn **N, int order, double tol)
SEXP CHMfactor_diag_get(SEXP obj, SEXP square)
char Matrix_shape(SEXP obj)
void * Matrix_memset(void *dest, int ch, R_xlen_t length, size_t size)
void * Matrix_memcpy(void *dest, const void *src, R_xlen_t length, size_t size)