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 3018, Sat Oct 11 17:52:10 2014 UTC revision 3023, Sat Dec 20 22:29:49 2014 UTC
# Line 210  Line 210 
210                                 GET_SLOT(x, Matrix_DimNamesSym));                                 GET_SLOT(x, Matrix_DimNamesSym));
211  }  }
212    
213    SEXP Csparse_to_tCsparse(SEXP x, SEXP uplo, SEXP diag)
214    {
215        CHM_SP chxs = AS_CHM_SP__(x);
216        int Rkind = (chxs->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
217        R_CheckStack();
218        return chm_sparse_to_SEXP(chxs, /* dofree = */ 0,
219                                  /* uploT = */ (*CHAR(asChar(uplo)) == 'U')? 1: -1,
220                                   Rkind, /* diag = */ CHAR(STRING_ELT(diag, 0)),
221                                   GET_SLOT(x, Matrix_DimNamesSym));
222    }
223    
224    SEXP Csparse_to_tTsparse(SEXP x, SEXP uplo, SEXP diag)
225    {
226        CHM_SP chxs = AS_CHM_SP__(x);
227        CHM_TR chxt = cholmod_sparse_to_triplet(chxs, &c);
228        int Rkind = (chxs->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
229        R_CheckStack();
230        return chm_triplet_to_SEXP(chxt, 1,
231                                  /* uploT = */ (*CHAR(asChar(uplo)) == 'U')? 1: -1,
232                                   Rkind, /* diag = */ CHAR(STRING_ELT(diag, 0)),
233                                   GET_SLOT(x, Matrix_DimNamesSym));
234    }
235    
236    
237  /* this used to be called  sCMatrix_to_gCMatrix(..)   [in ./dsCMatrix.c ]: */  /* this used to be called  sCMatrix_to_gCMatrix(..)   [in ./dsCMatrix.c ]: */
238  SEXP Csparse_symmetric_to_general(SEXP x)  SEXP Csparse_symmetric_to_general(SEXP x)
239  {  {
# Line 233  Line 257 
257          return R_NilValue; /* -Wall */          return R_NilValue; /* -Wall */
258      }      }
259      CHM_SP chx = AS_CHM_SP__(x), chgx;      CHM_SP chx = AS_CHM_SP__(x), chgx;
260      int uploT = (*CHAR(STRING_ELT(uplo,0)) == 'U') ? 1 : -1;      int uploT = (*CHAR(asChar(uplo)) == 'U') ? 1 : -1;
261      int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;      int Rkind = (chx->xtype != CHOLMOD_PATTERN) ? Real_kind(x) : 0;
262      R_CheckStack();      R_CheckStack();
263      chgx = cholmod_copy(chx, /* stype: */ uploT, chx->xtype, &c);      chgx = cholmod_copy(chx, /* stype: */ uploT, chx->xtype, &c);
264    
265        /* need _symmetric_ dimnames */
266        SEXP dns = PROTECT(duplicate(GET_SLOT(x, Matrix_DimNamesSym))),
267            nms_dns = getAttrib(dns, R_NamesSymbol);
268        if(!equal_string_vectors(VECTOR_ELT(dns, 0),
269                                 VECTOR_ELT(dns, 1))) {
270            if(uploT == 1)
271                SET_VECTOR_ELT(dns, 0, VECTOR_ELT(dns,1));
272            else
273                SET_VECTOR_ELT(dns, 1, VECTOR_ELT(dns,0));
274        }
275        if(!isNull(nms_dns) &&  // names(dimnames(.)) :
276           !R_compute_identical(STRING_ELT(nms_dns, 0),
277                                STRING_ELT(nms_dns, 1), 15)) {
278            if(uploT == 1)
279                SET_STRING_ELT(nms_dns, 0, STRING_ELT(nms_dns,1));
280            else
281                SET_STRING_ELT(nms_dns, 1, STRING_ELT(nms_dns,0));
282            setAttrib(dns, R_NamesSymbol, nms_dns);
283        }
284    
285        UNPROTECT(1);
286      /* xtype: pattern, "real", complex or .. */      /* xtype: pattern, "real", complex or .. */
287      return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "",      return chm_sparse_to_SEXP(chgx, 1, 0, Rkind, "", dns);
                               GET_SLOT(x, Matrix_DimNamesSym));  
288  }  }
289    
290  SEXP Csparse_transpose(SEXP x, SEXP tri)  SEXP Csparse_transpose(SEXP x, SEXP tri)
# Line 256  Line 301 
301      tmp = VECTOR_ELT(dn, 0);    /* swap the dimnames */      tmp = VECTOR_ELT(dn, 0);    /* swap the dimnames */
302      SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));      SET_VECTOR_ELT(dn, 0, VECTOR_ELT(dn, 1));
303      SET_VECTOR_ELT(dn, 1, tmp);      SET_VECTOR_ELT(dn, 1, tmp);
304        if(!isNull(tmp = getAttrib(dn, R_NamesSymbol))) { // swap names(dimnames(.)):
305            SEXP nms_dns = PROTECT(allocVector(VECSXP, 2));
306            SET_VECTOR_ELT(nms_dns, 1, STRING_ELT(tmp, 0));
307            SET_VECTOR_ELT(nms_dns, 0, STRING_ELT(tmp, 1));
308            setAttrib(dn, R_NamesSymbol, nms_dns);
309            UNPROTECT(1);
310        }
311      UNPROTECT(1);      UNPROTECT(1);
312      return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */      return chm_sparse_to_SEXP(chxt, 1, /* SWAP 'uplo' for triangular */
313                                tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,                                tr ? ((*uplo_P(x) == 'U') ? -1 : 1) : 0,

Legend:
Removed from v.3018  
changed lines
  Added in v.3023

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