SCM

SCM Repository

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

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

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

revision 1920, Sat Jun 23 09:43:30 2007 UTC revision 1921, Sat Jun 23 18:08:17 2007 UTC
# Line 14  Line 14 
14  # define gCMatrix_colSums dgCMatrix_colSums  # define gCMatrix_colSums dgCMatrix_colSums
15  # define _DOUBLE_ans  # define _DOUBLE_ans
16  # define _has_x_slot_  # define _has_x_slot_
17  # define Type_x_  double  /*Future? # define _has_x_d_slot_ */
 # define NA_x_    NA_REAL  
18  # undef _dgC_  # undef _dgC_
19    
20  #elif defined (_igC_)  #elif defined (_igC_)
# Line 23  Line 22 
22  # define gCMatrix_colSums igCMatrix_colSums  # define gCMatrix_colSums igCMatrix_colSums
23  # define _DOUBLE_ans  # define _DOUBLE_ans
24  # define _has_x_slot_  # define _has_x_slot_
25  # define Type_x_  int  /*Future? # define _has_x_d_slot_ */
 # define NA_x_    NA_INTEGER  
26  # undef _igC_  # undef _igC_
27    
28  #elif defined (_lgC_)  #elif defined (_lgC_)
# Line 32  Line 30 
30  # define gCMatrix_colSums lgCMatrix_colSums_i  # define gCMatrix_colSums lgCMatrix_colSums_i
31  # define _INT_ans  # define _INT_ans
32  # define _has_x_slot_  # define _has_x_slot_
33  # define Type_x_  int  /*Future? # define _has_x_l_slot_ */
 # define NA_x_    NA_LOGICAL  
34  # undef _lgC_  # undef _lgC_
35    
36  #elif defined (_lgC_mn)  #elif defined (_lgC_mn)
# Line 41  Line 38 
38  # define gCMatrix_colSums lgCMatrix_colSums_d  # define gCMatrix_colSums lgCMatrix_colSums_d
39  # define _DOUBLE_ans  # define _DOUBLE_ans
40  # define _has_x_slot_  # define _has_x_slot_
41  # define Type_x_  int  /*Future? # define _has_x_l_slot_ */
 # define NA_x_    NA_LOGICAL  
42  # undef _lgC_mn  # undef _lgC_mn
43    
44  #elif defined (_ngC_)  #elif defined (_ngC_)
45    
46  # define gCMatrix_colSums ngCMatrix_colSums_i  # define gCMatrix_colSums ngCMatrix_colSums_i
47  # define _INT_ans  # define _INT_ans
48  # undef  has_x_slot_ /* withOUT 'x' slot */   /* withOUT 'x' slot */
49  # undef _ngC_  # undef _ngC_
50    
51  #elif defined (_ngC_mn)  #elif defined (_ngC_mn)
52    
53  # define gCMatrix_colSums ngCMatrix_colSums_d  # define gCMatrix_colSums ngCMatrix_colSums_d
54  # define _DOUBLE_ans  # define _DOUBLE_ans
55  # undef  has_x_slot_ /* withOUT 'x' slot */   /* withOUT 'x' slot */
56  # undef _ngC_mn  # undef _ngC_mn
57    
58  #elif defined (_zgC_)  #elif defined (_zgC_)
# Line 71  Line 67 
67    
68  /* - - - - - - - - - - - - - - - - - - - - */  /* - - - - - - - - - - - - - - - - - - - - */
69    
70    /* Most of this is maybe for the future,
71     * when cholmod has integer 'x' slot :*/
72    #ifdef _has_x_d_slot_
73    
74    # define Type_x_ double
75    # define STYP_x_ REAL
76    # define _has_x_slot_
77    # undef _has_x_d_slot_
78    
79    #elif defined (_has_x_i_slot_)
80    
81    # define Type_x_ int
82    # define STYP_x_ INTEGER
83    # define _has_x_slot_
84    # undef _has_x_i_slot_
85    
86    #elif defined (_has_x_l_slot_)
87    
88    # define Type_x_ int
89    # define STYP_x_ LOGICAL
90    # define _has_x_slot_
91    # undef _has_x_l_slot_
92    
93    #endif
94    
95    /* - - - - - - - - - - - - - - - - - - - - */
96    
97  #ifdef _DOUBLE_ans  #ifdef _DOUBLE_ans
98    
99  # define SparseResult_class "dsparseVector"  # define SparseResult_class "dsparseVector"
# Line 78  Line 101 
101  # define STYP_ans REAL  # define STYP_ans REAL
102  # define NA_ans NA_REAL  # define NA_ans NA_REAL
103  # define SXP_ans  REALSXP  # define SXP_ans  REALSXP
104    # define COERCED(x) (x)
105  #undef _DOUBLE_ans  #undef _DOUBLE_ans
106    
107  #elif defined (_INT_ans)  #elif defined (_INT_ans)
# Line 87  Line 111 
111  # define STYP_ans INTEGER  # define STYP_ans INTEGER
112  # define NA_ans NA_INTEGER  # define NA_ans NA_INTEGER
113  # define SXP_ans  INTSXP  # define SXP_ans  INTSXP
114    # define COERCED(x) (Type_ans)(x != 0)
115  #undef _INT_ans  #undef _INT_ans
116    
117  #else  #else
# Line 96  Line 121 
121  /* - - - - - - - - - - - - - - - - - - - - */  /* - - - - - - - - - - - - - - - - - - - - */
122    
123  #ifdef _has_x_slot_  #ifdef _has_x_slot_
124    
125    /* currently have x slot always double (cholmod restriction): */
126    # define is_NA_x_(u) ISNAN(u)
127    
128  # define ColSUM_column(_i1_,_i2_,_SUM_)                                 \  # define ColSUM_column(_i1_,_i2_,_SUM_)                                 \
129                  if(mn) dnm = cx->nrow;  /* denominator for means */     \                  if(mn) dnm = cx->nrow;  /* denominator for means */     \
130                  for(i = _i1_, _SUM_ = 0; i < _i2_; i++)                 \                  for(i = _i1_, _SUM_ = 0; i < _i2_; i++) {               \
131                      if (mn && na_rm && xx[i] == NA_x_)                  \                      if (is_NA_x_(xx[i])) {                              \
132                          dnm--; /* skip NAs but decrement denominator*/  \                          if(!na_rm) {                                    \
133                      else _SUM_ += xx[i];                                \                              _SUM_ = NA_ans;                             \
134                                break;                                      \
135                            }                                               \
136                            /* else: na_rm : skip NAs , */                  \
137                            if(mn) /* but decrement denominator */          \
138                                dnm--;                                      \
139                        } else _SUM_ += COERCED(xx[i]);                     \
140                    }                                                       \
141                  if(mn) _SUM_ = (dnm > 0) ? _SUM_/dnm : NA_ans                  if(mn) _SUM_ = (dnm > 0) ? _SUM_/dnm : NA_ans
142    
143  #else /* no 'x' slot */  #else /* no 'x' slot -> no NAs ... */
144    
145  # define ColSUM_column(_i1_,_i2_,_SUM_)         \  # define ColSUM_column(_i1_,_i2_,_SUM_)         \
146                  _SUM_ = _i2_ - _i1_;            \                  _SUM_ = _i2_ - _i1_;            \
147                  if(mn) _SUM_ /= cx->nrow                  if(mn) _SUM_ /= cx->nrow
148  #endif  #endif
149    
150  /* Now comes the template -- which depends on the above macros : */  /* Now the template which depends on the above macros : */
151    
152  SEXP gCMatrix_colSums(SEXP x, SEXP NArm, SEXP spRes, SEXP trans, SEXP means)  SEXP gCMatrix_colSums(SEXP x, SEXP NArm, SEXP spRes, SEXP trans, SEXP means)
153  {  {
154      int mn = asLogical(means), sp = asLogical(spRes), tr = asLogical(trans);      int mn = asLogical(means), sp = asLogical(spRes), tr = asLogical(trans);
155        /* cholmod_sparse: drawback of coercing lgC to double: */
156      cholmod_sparse *cx = as_cholmod_sparse(x);      cholmod_sparse *cx = as_cholmod_sparse(x);
 #ifdef _has_x_slot_  
     int na_rm = asLogical(NArm), i, dnm = 0/*Wall*/;  
     Type_x_ *xx = (Type_x_ *)(cx -> x);  
 #endif  
     int j, n = (tr ? cx->nrow : cx->ncol);  
     int *xp = (int *)(cx->p);  
     SEXP ans = PROTECT(sp ? NEW_OBJECT(MAKE_CLASS(SparseResult_class))  
                           : allocVector(SXP_ans, n));  
   
157      if (tr) {      if (tr) {
158          cholmod_sparse *cxt = cholmod_transpose(cx, 1 /*values*/, &c);          cholmod_sparse *cxt = cholmod_transpose(cx, (int)cx->xtype, &c);
159          Free(cx);          Free(cx);
160          cx = cxt;          cx = cxt;
161      }      }
162        /* everything else *after* the above potential transpose : */
163        int j, nc = cx->ncol;
164        int *xp = (int *)(cx -> p);
165    #ifdef _has_x_slot_
166        int na_rm = asLogical(NArm), i, dnm = 0/*Wall*/;
167        double *xx = (double *)(cx -> x);
168    #endif
169        SEXP ans = PROTECT(sp ? NEW_OBJECT(MAKE_CLASS(SparseResult_class))
170                              : allocVector(SXP_ans, nc));
171    
172      if (sp) { /* sparseResult - never allocating length-n ... */      if (sp) { /* sparseResult - never allocating length-nc ... */
173          int nza, i1, i2, p, *ai;          int nza, i1, i2, p, *ai;
174          Type_ans *ax;          Type_ans *ax;
175    
176          for (j = 0, nza = 0; j < cx->ncol; j++)          for (j = 0, nza = 0; j < nc; j++)
177              if(xp[j] < xp[j + 1])              if(xp[j] < xp[j + 1])
178                  nza++;                  nza++;
179    
180          ai =  INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP,  nza));          ai =  INTEGER(ALLOC_SLOT(ans, Matrix_iSym, INTSXP,  nza));
181          ax = STYP_ans(ALLOC_SLOT(ans, Matrix_xSym, SXP_ans, nza));          ax = STYP_ans(ALLOC_SLOT(ans, Matrix_xSym, SXP_ans, nza));
182    
183          SET_SLOT(ans, Matrix_lengthSym, ScalarInteger(n));          SET_SLOT(ans, Matrix_lengthSym, ScalarInteger(nc));
184    
185          i2 = xp[0];          i2 = xp[0];
186          for (j = 1, p = 0; j <= cx->ncol; j++) {          for (j = 1, p = 0; j <= nc; j++) {
187              /* j' =j+1, since 'i' slot will be 1-based */              /* j' =j+1, since 'i' slot will be 1-based */
188              i1 = i2; i2 = xp[j];              i1 = i2; i2 = xp[j];
189              if(i1 < i2) {              if(i1 < i2) {
# Line 159  Line 197 
197      }      }
198      else { /* "numeric" (non sparse) result */      else { /* "numeric" (non sparse) result */
199          Type_ans *a = STYP_ans(ans);          Type_ans *a = STYP_ans(ans);
200          for (j = 0; j < cx->ncol; j++) {          for (j = 0; j < nc; j++) {
201              ColSUM_column(xp[j], xp[j + 1], a[j]);              ColSUM_column(xp[j], xp[j + 1], a[j]);
202          }          }
203      }      }
# Line 172  Line 210 
210  #undef ColSUM_column  #undef ColSUM_column
211    
212  #undef NA_ans  #undef NA_ans
 #undef NA_x_  
213  #undef STYP_ans  #undef STYP_ans
214  #undef SXP_ans  #undef SXP_ans
215  #undef SparseResult_class  #undef SparseResult_class
216  #undef Type_ans  #undef Type_ans
217    
218    #undef COERCED
219    
220    #ifdef _has_x_slot_
221    # undef NA_x_
222  #undef Type_x_  #undef Type_x_
223    # undef STYP_x_
224  #undef _has_x_slot_  #undef _has_x_slot_
225    #endif
226    
227  #undef gCMatrix_colSums  #undef gCMatrix_colSums

Legend:
Removed from v.1920  
changed lines
  Added in v.1921

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