1 /***************************************************************************
2 Public methods:
3 SEXP rowMedians(SEXP x, ...)
4
5 Authors: Adopted from rowQuantiles.c by R. Gentleman.
6
7 Copyright Henrik Bengtsson, 2007
8 **************************************************************************/
9 #include <Rdefines.h>
10 #include "000.types.h"
11 #include "rowMedians_lowlevel.h"
12 #include "naming.h"
13
rowMedians(SEXP x,SEXP dim,SEXP rows,SEXP cols,SEXP naRm,SEXP hasNA,SEXP byRow,SEXP useNames)14 SEXP rowMedians(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP naRm, SEXP hasNA, SEXP byRow, SEXP useNames) {
15 int narm, hasna, byrow, usenames;
16 SEXP ans;
17 R_xlen_t nrow, ncol;
18
19 /* Coercion moved down to C */
20 PROTECT(dim = coerceVector(dim, INTSXP));
21
22 /* Argument 'x' and 'dim': */
23 assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x");
24 /* Get dimensions of 'x'. */
25 nrow = asR_xlen_t(dim, 0);
26 ncol = asR_xlen_t(dim, 1);
27
28 /* Argument 'naRm': */
29 narm = asLogicalNoNA(naRm, "na.rm");
30
31 /* Argument 'hasNA': */
32 hasna = asLogicalNoNA(hasNA, "hasNA");
33
34 /* Argument 'rows' and 'cols': */
35 R_xlen_t nrows, ncols;
36 R_xlen_t *crows = validateIndices(rows, nrow, 0, &nrows);
37 R_xlen_t *ccols = validateIndices(cols, ncol, 0, &ncols);
38
39 /* Argument 'byRow': */
40 byrow = asLogical(byRow);
41
42 if (!byrow) {
43 SWAP(R_xlen_t, nrow, ncol);
44 SWAP(R_xlen_t*, crows, ccols);
45 SWAP(R_xlen_t, nrows, ncols);
46 }
47
48 /* R allocate a double vector of length 'nrows'
49 Note that 'nrows' means 'ncols' if byrow=FALSE. */
50 PROTECT(ans = allocVector(REALSXP, nrows));
51
52 /* Double matrices are more common to use. */
53 if (isReal(x)) {
54 rowMedians_dbl(REAL(x), nrow, ncol, crows, nrows, ccols, ncols, narm, hasna, byrow, REAL(ans));
55 } else if (isInteger(x)) {
56 rowMedians_int(INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, narm, hasna, byrow, REAL(ans));
57 }
58
59 /* Argument 'useNames': */
60 usenames = asLogical(useNames);
61
62 if (usenames != NA_LOGICAL && usenames){
63 SEXP dimnames = getAttrib(x, R_DimNamesSymbol);
64 if (dimnames != R_NilValue) {
65 if (byrow) {
66 SEXP namesVec = VECTOR_ELT(dimnames, 0);
67 if (namesVec != R_NilValue) {
68 setNames(ans, namesVec, nrows, crows);
69 }
70 } else {
71 SEXP namesVec = VECTOR_ELT(dimnames, 1);
72 if (namesVec != R_NilValue) {
73 setNames(ans, namesVec, nrows, crows);
74 }
75 }
76 }
77 }
78
79 UNPROTECT(2);
80
81 return(ans);
82 } /* rowMedians() */
83
84
85 /***************************************************************************
86 HISTORY:
87 2015-06-07 [DJ]
88 o Supported subsetted computation.
89 2013-01-13 [HB]
90 o Added argument 'byRow' to rowMedians() and dropped colMedians().
91 o Using internal arguments 'by_row' instead of 'by_column'.
92 2011-12-11 [HB]
93 o BUG FIX: rowMediansReal(..., na.rm=TRUE) did not handle NaN:s, only NA:s.
94 Note that NaN:s does not exist for integers.
95 2011-10-12 [HJ]
96 o Added colMedians().
97 o Now rowMediansInteger/Real() can operate also by columns, cf. argument
98 'by_column'.
99 2007-08-14 [HB]
100 o Added checks for user interrupts every 1000 line.
101 o Added argument 'hasNA' to rowMedians().
102 2005-12-07 [HB]
103 o BUG FIX: When calculating the median of an even number (non-NA) values,
104 the length of the second sort was one element too short, which made the
105 method to freeze, i.e. rPsort(rowData, qq, qq) is now (...qq+1, qq).
106 2005-11-24 [HB]
107 o By implementing a special version for integers, there is no need to
108 coerce to double in R, which would take up twice the amount of memory.
109 o rowMedians() now handles NAs too.
110 o Adopted from rowQuantiles.c in Biobase of Bioconductor.
111 **************************************************************************/
112