SCM

SCM Repository

[matrix] Diff of /pkg/src/Mutils.h
ViewVC logotype

Diff of /pkg/src/Mutils.h

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

revision 2104, Sat Jan 12 16:09:01 2008 UTC revision 2298, Fri Oct 17 13:45:12 2008 UTC
# Line 7  Line 7 
7    
8  #include <ctype.h>  #include <ctype.h>
9  #include <R.h>  /* includes Rconfig.h */  #include <R.h>  /* includes Rconfig.h */
10    #include <Rversion.h>
11  #include <Rdefines.h> /* Rinternals.h + GET_SLOT etc */  #include <Rdefines.h> /* Rinternals.h + GET_SLOT etc */
12    
13  #ifdef ENABLE_NLS  #ifdef ENABLE_NLS
# Line 19  Line 20 
20  #ifdef __GNUC__  #ifdef __GNUC__
21  # undef alloca  # undef alloca
22  # define alloca(x) __builtin_alloca((x))  # define alloca(x) __builtin_alloca((x))
23  #else  #elif defined(__sun) || defined(_AIX)
24  /* this is necessary (and sufficient) for Solaris 10: */  /* this is necessary (and sufficient) for Solaris 10 and AIX 6: */
 #ifdef __sun  
25  # include <alloca.h>  # include <alloca.h>
26  #endif  #endif
 #endif  
27    
28  #define Alloca(n, t)   (t *) alloca( (size_t) ( (n) * sizeof(t) ) )  #define Alloca(n, t)   (t *) alloca( (size_t) ( (n) * sizeof(t) ) )
29    
# Line 50  Line 49 
49  #define LFT CblasLeft  #define LFT CblasLeft
50  #define RGT CblasRight  #define RGT CblasRight
51    
52  char norm_type(const char *typstr);  #if !defined(R_VERSION) || R_VERSION < R_Version(2, 7, 0)
53  char rcond_type(const char *typstr);  char La_norm_type(const char *typstr);
54    char La_rcond_type(const char *typstr);
55    #endif
56    
57  double get_double_by_name(SEXP obj, char *nm);  double get_double_by_name(SEXP obj, char *nm);
58  SEXP set_double_by_name(SEXP obj, double val, char *nm);  SEXP set_double_by_name(SEXP obj, double val, char *nm);
59  SEXP as_det_obj(double val, int log, int sign);  SEXP as_det_obj(double val, int log, int sign);
60  SEXP get_factors(SEXP obj, char *nm);  SEXP get_factors(SEXP obj, char *nm);
61  SEXP set_factors(SEXP obj, SEXP val, char *nm);  SEXP set_factors(SEXP obj, SEXP val, char *nm);
62    
63    #if 0
64  SEXP dgCMatrix_set_Dim(SEXP x, int nrow);  SEXP dgCMatrix_set_Dim(SEXP x, int nrow);
65    #endif  /* unused */
66    
67  /* int csc_unsorted_columns(int ncol, const int p[], const int i[]); */  /* int csc_unsorted_columns(int ncol, const int p[], const int i[]); */
68  /* void csc_sort_columns(int ncol, const int p[], int i[], double x[]); */  /* void csc_sort_columns(int ncol, const int p[], int i[], double x[]); */
69  /* SEXP csc_check_column_sorting(SEXP A); */  /* SEXP csc_check_column_sorting(SEXP A); */
70  SEXP Matrix_make_named(int TYP, char **names);  SEXP Matrix_make_named(int TYP, char **names);
71  SEXP check_scalar_string(SEXP sP, char *vals, char *nm);  SEXP check_scalar_string(SEXP sP, char *vals, char *nm);
72    Rboolean equal_string_vectors(SEXP s1, SEXP s2);
73    
74  void d_packed_getDiag(double *dest, SEXP x, int n);  void d_packed_getDiag(double *dest, SEXP x, int n);
75  void l_packed_getDiag(   int *dest, SEXP x, int n);  void l_packed_getDiag(   int *dest, SEXP x, int n);
76  void tr_d_packed_getDiag(double *dest, SEXP x);  void tr_d_packed_getDiag(double *dest, SEXP x);
# Line 96  Line 103 
103  #define PACKED_LENGTH(n)   ((n) * ((n) + 1))/2  #define PACKED_LENGTH(n)   ((n) * ((n) + 1))/2
104    
105  /* duplicate the slot with name given by sym from src to dest */  /* duplicate the slot with name given by sym from src to dest */
106  /* FIXME: is not yet used */  
107  #define slot_dup(dest, src, sym)  SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))  #define slot_dup(dest, src, sym)  SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
108    
109    /* is not yet used: */
110  #define slot_nonNull_dup(dest, src, sym)                        \  #define slot_nonNull_dup(dest, src, sym)                        \
111      if(GET_SLOT(src, sym) != R_NilValue)                        \      if(GET_SLOT(src, sym) != R_NilValue)                        \
112          SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))          SET_SLOT(dest, sym, duplicate(GET_SLOT(src, sym)))
# Line 115  Line 123 
123  /* should also work for "matrix" matrices: */  /* should also work for "matrix" matrices: */
124  #define Real_KIND(_x_)  (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \  #define Real_KIND(_x_)  (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
125                           (isReal(_x_) ? 0 : (isLogical(_x_) ? 1 : -1)))                           (isReal(_x_) ? 0 : (isLogical(_x_) ? 1 : -1)))
126    /* This one gives '0' also for integer "matrix" :*/
127    #define Real_KIND2(_x_) (IS_S4_OBJECT(_x_) ? Real_kind(_x_) : \
128                             (isLogical(_x_) ? 1 : 0))
129    
130  /* requires 'x' slot: */  /* requires 'x' slot: */
131  #define Real_kind(_x_)  (isReal(GET_SLOT(_x_, Matrix_xSym)) ? 0 :       \  #define Real_kind(_x_)  (isReal(GET_SLOT(_x_, Matrix_xSym)) ? 0 :       \
132                           (isLogical(GET_SLOT(_x_, Matrix_xSym)) ? 1 : -1))                           (isLogical(GET_SLOT(_x_, Matrix_xSym)) ? 1 : -1))
133    
134    #define DECLARE_AND_GET_X_SLOT(__C_TYPE, __SEXP)        \
135        __C_TYPE *xx = __SEXP(GET_SLOT(x, Matrix_xSym))
136    
137    
138  /**  /**
139   * Check for valid length of a packed triangular array and return the   * Check for valid length of a packed triangular array and return the
# Line 188  Line 202 
202      return mj;      return mj;
203  }  }
204    
205    /**
206     * Check if slot(obj, "x") contains any NA (or NaN).
207     *
208     * @param obj   a 'Matrix' object with an 'x' slot.
209     *
210     * @return Rboolean :== any(is.na(slot(obj, "x") )
211     */
212    static R_INLINE
213    Rboolean any_NA(SEXP obj)
214    {
215        double *x = REAL(GET_SLOT(obj, Matrix_xSym));
216        int i, n = LENGTH(GET_SLOT(obj, Matrix_xSym));
217        for(i=0; i < n; i++)
218            if(ISNAN(x[i])) return TRUE;
219        /* else */
220        return FALSE;
221    }
222    
223    
224  void make_d_matrix_triangular(double *x, SEXP from);  void make_d_matrix_triangular(double *x, SEXP from);
225  void make_i_matrix_triangular(   int *x, SEXP from);  void make_i_matrix_triangular(   int *x, SEXP from);
226    
# Line 200  Line 233 
233  SEXP dup_mMatrix_as_geMatrix (SEXP A);  SEXP dup_mMatrix_as_geMatrix (SEXP A);
234    
235  SEXP new_dgeMatrix(int nrow, int ncol);  SEXP new_dgeMatrix(int nrow, int ncol);
236    SEXP m_encodeInd (SEXP ij, SEXP di);
237    SEXP m_encodeInd2(SEXP i, SEXP j, SEXP di);
238    
239    
240  static R_INLINE SEXP  static R_INLINE SEXP
241  mMatrix_as_dgeMatrix(SEXP A)  mMatrix_as_dgeMatrix(SEXP A)
# Line 232  Line 268 
268      }      }
269  }  }
270    
271    
272  #ifdef __cplusplus  #ifdef __cplusplus
273  }  }
274  #endif  #endif

Legend:
Removed from v.2104  
changed lines
  Added in v.2298

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