# File src/library/base/R/pmax.R # Part of the R package, https://www.R-project.org # # Copyright (C) 1995-2022 The R Core Team # # 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. # # A copy of the GNU General Public License is available at # https://www.R-project.org/Licenses/ pmin.int <- function(..., na.rm = FALSE) .Internal(pmin(na.rm, ...)) pmax.int <- function(..., na.rm = FALSE) .Internal(pmax(na.rm, ...)) pmax <- function (..., na.rm = FALSE) { elts <- list(...) if(length(elts) == 0L) stop("no arguments") if(all(vapply(elts, function(x) is.null(x) || (is.atomic(x) && !is.object(x)), NA))) { mmm <- .Internal(pmax(na.rm, ...)) mostattributes(mmm) <- attributes(elts[[1L]]) } else { mmm <- elts[[1L]] ## attr(mmm, "dim") <- NULL # dim<- would drop names has.na <- FALSE as <- methods::as asL <- function(x) if(isS4(x)) as(x, "logical") else x for (each in elts[-1L]) { ## attr(each, "dim") <- NULL ## FIXME: deal with d.fr.s ! l1 <- length(each); l2 <- length(mmm) if(l2 && (l2 < l1 || !l1)) { if (l1 %% l2) warning("an argument will be fractionally recycled") mmm <- rep(mmm, length.out = l1) } else if(l1 && (l1 < l2 || !l2)) { if (l2 %% l1) warning("an argument will be fractionally recycled") each <- rep(each, length.out = l2) } na.m <- is.na(mmm) na.e <- is.na(each) if(has.na || (has.na <- any(na.m) || any(na.e))) { if(any(na.m <- asL(na.m))) mmm [na.m] <- each[na.m] if(any(na.e <- asL(na.e))) each[na.e] <- mmm [na.e] } nS4 <- !isS4(mmm) if(isS4(change <- mmm < each) && (nS4 || !isS4(each))) # e.g., keep sparse 'each' change <- as(change, "logical")# not as.vector(): kills the d.fr. case change <- change & !is.na(change) mmm[change] <- each[change] if (has.na && !na.rm) mmm[na.m | na.e] <- NA if(nS4) mostattributes(mmm) <- attributes(elts[[1L]]) } } mmm } pmin <- function (..., na.rm = FALSE) { elts <- list(...) if(length(elts) == 0L) stop("no arguments") if(all(vapply(elts, function(x) is.null(x) || (is.atomic(x) && !is.object(x)), NA))) { mmm <- .Internal(pmin(na.rm, ...)) mostattributes(mmm) <- attributes(elts[[1L]]) } else { mmm <- elts[[1L]] ## attr(mmm, "dim") <- NULL # dim<- would drop names has.na <- FALSE as <- methods::as asL <- function(x) if(isS4(x)) as(x, "logical") else x for (each in elts[-1L]) { ## attr(each, "dim") <- NULL ## FIXME: deal with d.fr.s ! l1 <- length(each); l2 <- length(mmm) if(l2 && (l2 < l1 || !l1)) { if (l1 %% l2) warning("an argument will be fractionally recycled") mmm <- rep(mmm, length.out = l1) } else if(l1 && (l1 < l2 || !l2)) { if (l2 %% l1) warning("an argument will be fractionally recycled") each <- rep(each, length.out = l2) } na.m <- is.na(mmm) na.e <- is.na(each) if(has.na || (has.na <- any(na.m) || any(na.e))) { if(any(na.m <- asL(na.m))) mmm [na.m] <- each[na.m] if(any(na.e <- asL(na.e))) each[na.e] <- mmm [na.e] } nS4 <- !isS4(mmm) if(isS4(change <- mmm > each) && (nS4 || !isS4(each))) # e.g., keep sparse 'each' change <- as(change, "logical")# not as.vector(): kills the d.fr. case change <- change & !is.na(change) mmm[change] <- each[change] if (has.na && !na.rm) mmm[na.m | na.e] <- NA if(nS4) mostattributes(mmm) <- attributes(elts[[1L]]) } } mmm }