SCM

SCM Repository

[matrix] Diff of /pkg/Matrix/src/Csparse.c
ViewVC logotype

Diff of /pkg/Matrix/src/Csparse.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2984, Sat Apr 12 21:37:37 2014 UTC revision 3020, Tue Oct 14 16:14:02 2014 UTC
# Line 233  Line 233 
233          return R_NilValue; /* -Wall */          return R_NilValue; /* -Wall */
234      }      }
235      CHM_SP chx = AS_CHM_SP__(x), chgx;      CHM_SP chx = AS_CHM_SP__(x), chgx;
236      int uploT = (*CHAR(STRING_ELT(uplo,0)) == 'U') ? 1 : -1;      int uploT = (*CHAR(asChar(uplo)) == 'U') ? 1 : -1;
237      int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;      int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
238      R_CheckStack();      R_CheckStack();
239      chgx = cholmod_copy(chx, /* stype: */ uploT, chx->xtype, &c);      chgx = cholmod_copy(chx, /* stype: */ uploT, chx->xtype, &c);
240    
241        /* need _symmetric_ dimnames */
242        SEXP dns = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))),
243            nms_dns = getAttrib(dns, R_NamesSymbol);
244        if(!equal_string_vectors(VECTOR_ELT(dns, 0),
245                                 VECTOR_ELT(dns, 1))) {
246            if(uploT == 1)
247                SET_VECTOR_ELT(dns, 0, VECTOR_ELT(dns,1));
248            else
249                SET_VECTOR_ELT(dns, 1, VECTOR_ELT(dns,0));
250        }
251        if(!isNull(nms_dns) &&  // names(dimnames(.)) :
252           !R_compute_identical(STRING_ELT(nms_dns, 0),
253                                STRING_ELT(nms_dns, 1), 15)) {
254            if(uploT == 1)
255                SET_STRING_ELT(nms_dns, 0, STRING_ELT(nms_dns,1));
256            else
257                SET_STRING_ELT(nms_dns, 1, STRING_ELT(nms_dns,0));
258            setAttrib(dns, R_NamesSymbol, nms_dns);
259        }
260    
261        UNPROTECT(1);
262      /* xtype: pattern, "real", complex or .. */      /* xtype: pattern, "real", complex or .. */
263      return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "",      return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "", dns);
                               GET_SLOT(x, Matrix_DimNamesSym));  
264  }  }
265    
266  SEXP Csparse_transpose(SEXP x, SEXP tri)  SEXP Csparse_transpose(SEXP x, SEXP tri)
# Line 256  Line 277 
277      tmp = VECTOR_ELT(dn, 0);    /* swap the dimnames */      tmp = VECTOR_ELT(dn, 0);    /* swap the dimnames */
278      SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));      SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));
279      SET_VECTOR_ELT(dn, 1, tmp);      SET_VECTOR_ELT(dn, 1, tmp);
280        if(!isNull(tmp = getAttrib(dn, R_NamesSymbol))) { // swap names(dimnames(.)):
281            SEXP nms_dns = PROTECT(allocVector(VECSXP, 2));
282            SET_VECTOR_ELT(nms_dns, 1, STRING_ELT(tmp, 0));
283            SET_VECTOR_ELT(nms_dns, 0, STRING_ELT(tmp, 1));
284            setAttrib(dn, R_NamesSymbol, nms_dns);
285            UNPROTECT(1);
286        }
287      UNPROTECT(1);      UNPROTECT(1);
288      return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */      return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */
289                                tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,                                tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,
# Line 345  Line 373 
373  SEXP Csparse_dense_prod(SEXP a, SEXP b)  SEXP Csparse_dense_prod(SEXP a, SEXP b)
374  {  {
375      CHM_SP cha = AS_CHM_SP(a);      CHM_SP cha = AS_CHM_SP(a);
376      SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));      SEXP b_M = PROTECT(mMatrix_as_dgeMatrix2(b, // transpose_if_vector =
377                                                 cha->ncol == 1));
378      CHM_DN chb = AS_CHM_DN(b_M);      CHM_DN chb = AS_CHM_DN(b_M);
379      CHM_DN chc = cholmod_allocate_dense(cha->nrow, chb->ncol, cha->nrow,      CHM_DN chc = cholmod_allocate_dense(cha->nrow, chb->ncol, cha->nrow,
380                                          chb->xtype, &c);                                          chb->xtype, &c);
# Line 376  Line 405 
405  SEXP Csparse_dense_crossprod(SEXP a, SEXP b)  SEXP Csparse_dense_crossprod(SEXP a, SEXP b)
406  {  {
407      CHM_SP cha = AS_CHM_SP(a);      CHM_SP cha = AS_CHM_SP(a);
408      SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));      SEXP b_M = PROTECT(mMatrix_as_dgeMatrix2(b, // transpose_if_vector =
409                                                 cha->nrow == 1));
410      CHM_DN chb = AS_CHM_DN(b_M);      CHM_DN chb = AS_CHM_DN(b_M);
411      CHM_DN chc = cholmod_allocate_dense(cha->ncol, chb->ncol, cha->ncol,      CHM_DN chc = cholmod_allocate_dense(cha->ncol, chb->ncol, cha->ncol,
412                                          chb->xtype, &c);                                          chb->xtype, &c);
# Line 569  Line 599 
599      if (csize >= 0 && !isInteger(j))      if (csize >= 0 && !isInteger(j))
600          error(_("Index j must be NULL or integer"));          error(_("Index j must be NULL or integer"));
601    
602    #define CHM_SUB(_M_, _i_, _j_)                                  \
603        cholmod_submatrix(_M_,                                      \
604                          (rsize < 0) ? NULL : INTEGER(_i_), rsize, \
605                          (csize < 0) ? NULL : INTEGER(_j_), csize, \
606                          TRUE, TRUE, &c)
607        CHM_SP ans;
608      if (!chx->stype) {/* non-symmetric Matrix */      if (!chx->stype) {/* non-symmetric Matrix */
609          return chm_sparse_to_SEXP(cholmod_submatrix(chx,          ans = CHM_SUB(chx, i, j);
                                                     (rsize < 0) ? NULL : INTEGER(i), rsize,  
                                                     (csize < 0) ? NULL : INTEGER(j), csize,  
                                                     TRUE, TRUE, &c),  
                                   1, 0, Rkind, "",  
                                   /* FIXME: drops dimnames */ R_NilValue);  
610      }      }
611        else {
612                                  /* for now, cholmod_submatrix() only accepts "generalMatrix" */                                  /* for now, cholmod_submatrix() only accepts "generalMatrix" */
613      CHM_SP tmp = cholmod_copy(chx, /* stype: */ 0, chx->xtype, &c);      CHM_SP tmp = cholmod_copy(chx, /* stype: */ 0, chx->xtype, &c);
614      CHM_SP ans = cholmod_submatrix(tmp,          ans = CHM_SUB(tmp, i, j);
                                    (rsize < 0) ? NULL : INTEGER(i), rsize,  
                                    (csize < 0) ? NULL : INTEGER(j), csize,  
                                    TRUE, TRUE, &c);  
615      cholmod_free_sparse(&tmp, &c);      cholmod_free_sparse(&tmp, &c);
616      return chm_sparse_to_SEXP(ans, 1, 0, Rkind, "", R_NilValue);      }
617    
618        // "FIXME": currently dropping dimnames, and adding them afterwards in R :
619        /* // dimnames: */
620        /* SEXP x_dns = GET_SLOT(x, Matrix_DimNamesSym), */
621        /*  dn = PROTECT(allocVector(VECSXP, 2)); */
622        return chm_sparse_to_SEXP(ans, 1, 0, Rkind, "", /* dimnames: */ R_NilValue);
623  }  }
624    
625  #define _d_Csp_  #define _d_Csp_

Legend:
Removed from v.2984  
changed lines
  Added in v.3020

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge