SEXP colOrderStats(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP which) { SEXP ans = NILSXP; R_xlen_t nrow, ncol, qq; /* Argument 'x' and 'dim': */ assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'which': */ if (length(which) != 1) error("Argument 'which' must be a single number."); if (!isNumeric(which)) error("Argument 'which' must be a numeric number."); /* Argument 'rows' and 'cols': */ R_xlen_t nrows, ncols; int rowsType, colsType; int rowsHasna, colsHasna; void *crows = validateIndicesCheckNA(rows, nrow, 0, &nrows, &rowsType, &rowsHasna); void *ccols = validateIndicesCheckNA(cols, ncol, 0, &ncols, &colsType, &colsHasna); // Check missing rows if (rowsHasna && ncols > 0) { error("Argument 'rows' must not contain missing value"); } // Check missing cols if (colsHasna && nrows > 0) { error("Argument 'cols' must not contain missing value"); } /* Subtract one here, since rPsort does zero based addressing */ qq = asInteger(which) - 1; /* Assert that 'qq' is a valid index */ if (qq < 0 || qq >= nrows) { error("Argument 'which' is out of range."); } /* Double matrices are more common to use. */ if (isReal(x)) { PROTECT(ans = allocVector(REALSXP, ncols)); colOrderStats_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, qq, REAL(ans)); UNPROTECT(1); } else if (isInteger(x)) { PROTECT(ans = allocVector(INTSXP, ncols)); colOrderStats_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, qq, INTEGER(ans)); UNPROTECT(1); } return(ans); } // colOrderStats()
SEXP rowMads(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP constant, SEXP naRm, SEXP hasNA, SEXP byRow) { int narm, hasna, byrow; SEXP ans; R_xlen_t nrow, ncol; double scale; /* Argument 'x' and 'dim': */ assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'constant': */ if (!isNumeric(constant)) error("Argument 'constant' must be a numeric scale."); scale = asReal(constant); /* Argument 'naRm': */ narm = asLogicalNoNA(naRm, "na.rm"); /* Argument 'hasNA': */ hasna = asLogicalNoNA(hasNA, "hasNA"); /* Argument 'rows' and 'cols': */ R_xlen_t nrows, ncols; int rowsType, colsType; void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType); void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType); /* Argument 'byRow': */ byrow = asLogical(byRow); if (!byrow) { SWAP(R_xlen_t, nrow, ncol); SWAP(void*, crows, ccols); SWAP(R_xlen_t, nrows, ncols); SWAP(int, rowsType, colsType); } /* R allocate a double vector of length 'nrow' Note that 'nrow' means 'ncol' if byrow=FALSE. */ PROTECT(ans = allocVector(REALSXP, nrows)); /* Double matrices are more common to use. */ if (isReal(x)) { rowMads_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, scale, narm, hasna, byrow, REAL(ans)); } else if (isInteger(x)) { rowMads_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, scale, narm, hasna, byrow, REAL(ans)); } UNPROTECT(1); return(ans); } /* rowMads() */
SEXP rowCounts(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP value, SEXP what, SEXP naRm, SEXP hasNA) { SEXP ans; int narm, hasna, what2; R_xlen_t nrow, ncol; /* Argument 'x' & 'dim': */ assertArgMatrix(x, dim, (R_TYPE_LGL | R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'value': */ if (length(value) != 1) error("Argument 'value' must be a single value."); if (!isNumeric(value)) error("Argument 'value' must be a numeric value."); /* Argument 'what': */ what2 = asInteger(what); if (what2 < 0 || what2 > 2) error("INTERNAL ERROR: Unknown value of 'what' for rowCounts: %d", what2); /* Argument 'naRm': */ narm = asLogicalNoNA(naRm, "na.rm"); /* Argument 'hasNA': */ hasna = asLogicalNoNA(hasNA, "hasNA"); /* Argument 'rows' and 'cols': */ R_xlen_t nrows, ncols; int rowsType, colsType; void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType); void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType); /* R allocate a double vector of length 'nrow' */ PROTECT(ans = allocVector(INTSXP, nrows)); /* Double matrices are more common to use. */ if (isReal(x)) { rowCounts_Real[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, asReal(value), what2, narm, hasna, INTEGER(ans)); } else if (isInteger(x)) { rowCounts_Integer[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, asInteger(value), what2, narm, hasna, INTEGER(ans)); } else if (isLogical(x)) { rowCounts_Logical[rowsType][colsType](LOGICAL(x), nrow, ncol, crows, nrows, ccols, ncols, asLogical(value), what2, narm, hasna, INTEGER(ans)); } UNPROTECT(1); return(ans); } // rowCounts()
SEXP x_OP_y(SEXP x, SEXP y, SEXP dim, SEXP operator, SEXP xrows, SEXP xcols, SEXP yidxs, SEXP commute, SEXP naRm, SEXP hasNA, SEXP byRow) { SEXP ans = NILSXP; int narm, hasna, byrow, commute2; int op; R_xlen_t nrow, ncol, ny; /* Argument 'x' and 'dim': */ assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'y': */ assertArgVector(y, (R_TYPE_INT | R_TYPE_REAL), "y"); ny = xlength(y); /* Argument 'byRow': */ byrow = asLogicalNoNA(byRow, "byrow"); /* Argument 'commute2': */ commute2 = asLogicalNoNA(commute, "commute"); /* Argument 'naRm': */ narm = asLogicalNoNA(naRm, "na.rm"); /* Argument 'hasNA': */ hasna = asLogicalNoNA(hasNA, "hasNA"); /* Argument 'xrows', 'xcols' and 'yidxs': */ R_xlen_t nxrows, nxcols, nyidxs; int xrowsType, xcolsType, yidxsType; void *cxrows = validateIndices(xrows, nrow, 0, &nxrows, &xrowsType); void *cxcols = validateIndices(xcols, ncol, 0, &nxcols, &xcolsType); void *cyidxs = validateIndices(yidxs, ny, 1, &nyidxs, &yidxsType); /* Argument 'operator': */ op = asInteger(operator); if (op == 1) { /* Addition */ if (isReal(x) || isReal(y)) { PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols)); if (isReal(x) && isReal(y)) { x_OP_y_Add_Real_Real[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isReal(x) && isInteger(y)) { x_OP_y_Add_Real_Integer[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isInteger(x) && isReal(y)) { x_OP_y_Add_Integer_Real[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } UNPROTECT(1); } else { PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols)); x_OP_y_Add_Integer_Integer[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans)); UNPROTECT(1); } } if (op == 2) { /* Subtraction */ if (isReal(x) || isReal(y)) { PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols)); if (isReal(x) && isReal(y)) { x_OP_y_Sub_Real_Real[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isReal(x) && isInteger(y)) { x_OP_y_Sub_Real_Integer[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isInteger(x) && isReal(y)) { x_OP_y_Sub_Integer_Real[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } UNPROTECT(1); } else { PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols)); x_OP_y_Sub_Integer_Integer[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans)); UNPROTECT(1); } } else if (op == 3) { /* Multiplication */ if (isReal(x) || isReal(y)) { PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols)); if (isReal(x) && isReal(y)) { x_OP_y_Mul_Real_Real[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isReal(x) && isInteger(y)) { x_OP_y_Mul_Real_Integer[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isInteger(x) && isReal(y)) { x_OP_y_Mul_Integer_Real[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } UNPROTECT(1); } else { PROTECT(ans = allocMatrix(INTSXP, nxrows, nxcols)); x_OP_y_Mul_Integer_Integer[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, INTEGER(ans), xlength(ans)); UNPROTECT(1); } } else if (op == 4) { /* Division */ PROTECT(ans = allocMatrix(REALSXP, nxrows, nxcols)); if (isReal(x) && isReal(y)) { x_OP_y_Div_Real_Real[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isReal(x) && isInteger(y)) { x_OP_y_Div_Real_Integer[xrowsType][xcolsType][yidxsType]( REAL(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isInteger(x) && isReal(y)) { x_OP_y_Div_Integer_Real[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, REAL(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } else if (isInteger(x) && isInteger(y)) { x_OP_y_Div_Integer_Integer[xrowsType][xcolsType][yidxsType]( INTEGER(x), nrow, ncol, INTEGER(y), ny, cxrows, nxrows, cxcols, nxcols, cyidxs, nyidxs, byrow, commute2, narm, hasna, REAL(ans), xlength(ans)); } UNPROTECT(1); } return(ans); } /* x_OP_y() */
/* Peter Langfelder's modifications: * byrow: 0 => rank columns, !0 => rank rows * tiesMethod: 1: maximum, 2: average, 3:minimum * The returned rank is a REAL matrix to accomodate average ranks */ SEXP rowRanksWithTies(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP tiesMethod, SEXP byRow) { int tiesmethod, byrow; SEXP ans = NILSXP; R_xlen_t nrow, ncol; /* Argument 'x' and 'dim': */ assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'tiesMethod': */ tiesmethod = asInteger(tiesMethod); if (tiesmethod < 1 || tiesmethod > 3) { error("Argument 'tiesMethod' is out of range [1,3]: %d", tiesmethod); } /* Argument 'rows' and 'cols': */ R_xlen_t nrows, ncols; int rowsType, colsType; void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType); void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType); /* Argument 'byRow': */ byrow = asLogical(byRow); /* Double matrices are more common to use. */ if (isReal(x)) { if (byrow) { switch (tiesmethod) { case 1: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); rowRanksWithTies_Max_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; case 2: PROTECT(ans = allocMatrix(REALSXP, nrows, ncols)); rowRanksWithTies_Average_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, REAL(ans)); UNPROTECT(1); break; case 3: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); rowRanksWithTies_Min_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; } /* switch */ } else { switch (tiesmethod) { case 1: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); colRanksWithTies_Max_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; case 2: PROTECT(ans = allocMatrix(REALSXP, nrows, ncols)); colRanksWithTies_Average_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, REAL(ans)); UNPROTECT(1); break; case 3: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); colRanksWithTies_Min_dbl[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; } /* switch */ } } else if (isInteger(x)) { if (byrow) { switch (tiesmethod) { case 1: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); rowRanksWithTies_Max_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; case 2: PROTECT(ans = allocMatrix(REALSXP, nrows, ncols)); rowRanksWithTies_Average_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, REAL(ans)); UNPROTECT(1); break; case 3: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); rowRanksWithTies_Min_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; } /* switch */ } else { switch (tiesmethod) { case 1: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); colRanksWithTies_Max_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; case 2: PROTECT(ans = allocMatrix(REALSXP, nrows, ncols)); colRanksWithTies_Average_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, REAL(ans)); UNPROTECT(1); break; case 3: PROTECT(ans = allocMatrix(INTSXP, nrows, ncols)); colRanksWithTies_Min_int[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, INTEGER(ans)); UNPROTECT(1); break; } /* switch */ } } return(ans); } // rowRanksWithTies()
SEXP colRanges(SEXP x, SEXP dim, SEXP rows, SEXP cols, SEXP what, SEXP naRm, SEXP hasNA) { SEXP ans = NILSXP, ans2 = NILSXP; int *mins, *maxs; double *mins2, *maxs2; int *is_counted, all_counted = 0; int what2, narm, hasna; R_xlen_t nrow, ncol, jj; /* Argument 'x' and 'dim': */ assertArgMatrix(x, dim, (R_TYPE_INT | R_TYPE_REAL), "x"); nrow = asR_xlen_t(dim, 0); ncol = asR_xlen_t(dim, 1); /* Argument 'what': */ if (length(what) != 1) error("Argument 'what' must be a single number."); if (!isNumeric(what)) error("Argument 'what' must be a numeric number."); what2 = asInteger(what); if (what2 < 0 || what2 > 2) error("Invalid value of 'what': %d", what2); /* Argument 'naRm': */ narm = asLogicalNoNA(naRm, "na.rm"); /* Argument 'hasNA': */ hasna = asLogicalNoNA(hasNA, "hasNA"); /* Argument 'rows' and 'cols': */ R_xlen_t nrows, ncols; int rowsType, colsType; void *crows = validateIndices(rows, nrow, 0, &nrows, &rowsType); void *ccols = validateIndices(cols, ncol, 0, &ncols, &colsType); is_counted = (int *) R_alloc(ncols, sizeof(int)); if (isReal(x)) { if (what2 == 2) { PROTECT(ans = allocMatrix(REALSXP, ncols, 2)); } else { PROTECT(ans = allocVector(REALSXP, ncols)); } colRanges_Real[rowsType][colsType](REAL(x), nrow, ncol, crows, nrows, ccols, ncols, what2, narm, hasna, REAL(ans), is_counted); UNPROTECT(1); } else if (isInteger(x)) { if (what2 == 2) { PROTECT(ans = allocMatrix(INTSXP, ncols, 2)); } else { PROTECT(ans = allocVector(INTSXP, ncols)); } colRanges_Integer[rowsType][colsType](INTEGER(x), nrow, ncol, crows, nrows, ccols, ncols, what2, narm, hasna, INTEGER(ans), is_counted); /* Any entries with zero non-missing values? */ all_counted = 1; for (jj=0; jj < ncols; jj++) { if (!is_counted[jj]) { all_counted = 0; break; } } if (!all_counted) { /* Handle zero non-missing values */ /* Instead of return INTSXP, we must return REALSXP (to hold -Inf, and Inf) */ if (what2 == 0) { PROTECT(ans2 = allocVector(REALSXP, ncols)); mins = INTEGER(ans); mins2 = REAL(ans2); for (jj=0; jj < ncols; jj++) { if (is_counted[jj]) { mins2[jj] = (double)mins[jj]; } else { mins2[jj] = R_PosInf; } } UNPROTECT(1); /* ans2 */ } else if (what2 == 1) { PROTECT(ans2 = allocVector(REALSXP, ncols)); maxs = INTEGER(ans); maxs2 = REAL(ans2); for (jj=0; jj < ncols; jj++) { if (is_counted[jj]) { maxs2[jj] = (double)maxs[jj]; } else { maxs2[jj] = R_NegInf; } } UNPROTECT(1); /* ans2 */ } else if (what2 == 2) { PROTECT(ans2 = allocMatrix(REALSXP, ncols, 2)); mins = INTEGER(ans); maxs = &INTEGER(ans)[ncols]; mins2 = REAL(ans2); maxs2 = &REAL(ans2)[ncols]; for (jj=0; jj < ncols; jj++) { if (is_counted[jj]) { mins2[jj] = (double)mins[jj]; maxs2[jj] = (double)maxs[jj]; } else { mins2[jj] = R_PosInf; maxs2[jj] = R_NegInf; } } UNPROTECT(1); /* ans2 */ } ans = ans2; } UNPROTECT(1); /* ans */ } return(ans); } // colRanges()