src/appl/maxcol.c

/*
 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 2007-2019  The R Core Team
 *  Copyright (C) 1994-9 W. N. Venables and B. D. Ripley
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */

/* Original (by permission) from
 * MASS/MASS.c by W. N. Venables and B. D. Ripley

 * Find maximum column: designed for probabilities.
 * Uses reservoir sampling to break ties at random.
 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include <R_ext/Arith.h>	/* NA handling */
#include <Rmath.h>		/* fmax2 */
#include <R_ext/Random.h>	/* ..RNGstate */

#include <R_ext/Applic.h>	/* NA handling */

#define RELTOL 1e-5

void R_max_col(double *matrix, int *nr, int *nc, int *maxes, int *ties_meth)
{
    int	 c, m;
    size_t  n_r = *nr; // for indexing like r + c * n_r
    double a, b, large;
    Rboolean isna, used_random = FALSE, do_rand = *ties_meth == 1;

    for (size_t r = 0; r < n_r; r++) {
	/* first check row for any NAs and find the largest abs(entry) */
	large = 0.0;
	isna = TRUE;
	for (c = 0; c < *nc; c++) {
	    a = matrix[r + c * n_r];
	    if (ISNAN(a)) { isna = TRUE; break; }
	    else if(isna) isna = FALSE;
	    if (!R_FINITE(a)) continue;
	    if (do_rand) large = fmax2(large, fabs(a));
	}
	if (isna) { maxes[r] = NA_INTEGER; continue; }

	m = 0;
	a = matrix[r];
	if (do_rand) {
	    double tol = RELTOL * large;
	    int ntie = 1;
	    for (c = 1; c < *nc; c++) {
		b = matrix[r + c * n_r];
		if (b > a + tol) { /* tol could be zero */
		    a = b; m = c;
		    ntie = 1;
		} else if (b >= a - tol) { /* b ~= current max. a */
		    ntie++;
		    if (!used_random) { GetRNGstate(); used_random = TRUE; }
		    if (ntie * unif_rand() < 1.) m = c;
		}
	    }
	} else {
	    if(*ties_meth == 2) /* return the *first* max if there are ties */
		for (c = 1; c < *nc; c++) {
		    b = matrix[r + c * n_r];
		    if (a < b) {
			a = b; m = c;
		    }
		}
	    else if(*ties_meth == 3) /* return the *last* max ... */
		for (c = 1; c < *nc; c++) {
		    b = matrix[r + c * n_r];
		    if (a <= b) {
			a = b; m = c;
		    }
		}
	    else error("invalid 'ties_meth' {should not happen}");
	}
	maxes[r] = m + 1;
    }
    if(used_random) PutRNGstate();
}