#  File src/library/graphics/R/abline.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

abline <- function(a = NULL, b = NULL, h = NULL, v = NULL, reg = NULL,
                   coef = NULL, untf = FALSE, ...)
{
    int_abline <- function(a, b, h, v, untf, col = par("col"),
                           lty = par("lty"), lwd = par("lwd"), ...)
        .External.graphics(C_abline, a, b, h, v, untf, col, lty, lwd, ...)

    if(!is.null(reg)) {
        if(!is.null(a)) warning("'a' is overridden by 'reg'")
        a <- reg
    }
    if(is.object(a) || is.list(a)) {
	## was	(!is.null(a) && is.list(a))
	p <- length(coefa <- as.vector(coef(a)))
	if (p > 2)
            warning(gettextf("only using the first two of %d regression coefficients", p), domain = NA)
	islm <- inherits(a, "lm")
	noInt <- if(islm) !as.logical(attr(stats::terms(a), "intercept")) else p == 1
	if (noInt) {
	    a <- 0
	    b <- coefa[1L]
	} else {
	    a <- coefa[1L]
	    b <- if (p >= 2) coefa[2L] else 0
	}
    }
    if(!is.null(coef)) {
	if(!is.null(a)) warning("'a' and 'b' are overridden by 'coef'")
	a <- coef[1L]
	b <- coef[2L]
    }
    int_abline(a=a, b=b, h=h, v=v, untf=untf, ...)
    invisible()
}
#  File src/library/graphics/R/arrows.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2014 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/

arrows <-
    function(x0, y0, x1 = x0, y1 = y0, length = 0.25, angle = 30, code = 2,
             col = par("fg"), lty = par("lty"), lwd = par("lwd"), ...)
{
    if (missing(x1) && missing(y1))
        stop("one of 'x1' and 'y1' must be given")
    if (length(length) > 1 || length(angle) > 1 || length(code) > 1)
        warning("'length', 'angle', or 'code' greater than length 1; values after the first are ignored")
    .External.graphics(C_arrows, x0, y0, x1, y1, length = length,
                       angle = angle, code = code, col = col,
                       lty = lty, lwd = lwd, ...)
    invisible()
}
#  File src/library/graphics/R/assocplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2014 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/

assocplot <- function(x, col = c("black", "red"), space = 0.3,
                      main = NULL, xlab = NULL, ylab = NULL)
{
    if(length(dim(x)) != 2L)
        stop("'x' must be a 2-d contingency table")
    if(any(x < 0) || anyNA(x))
        stop("all entries of 'x' must be nonnegative and finite")
    if((n <- sum(x)) == 0L)
        stop("at least one entry of 'x' must be positive")
    if(length(col) != 2L)
        stop("incorrect 'col': must be length 2")

    f <- x[ , rev(1L:NCOL(x))]           # rename for convenience;
                                        # f is observed freqs
                                        # reverse to be consistent with
                                        # mosaicplot().
    e <- outer(rowSums(f), colSums(f)) / n
                                        # e is expected freqs
    d <- (f - e) / sqrt(e)              # Pearson residuals
    e <- sqrt(e)
    x.w <- apply(e, 1L, max)             # the widths of the x columns
    y.h <- apply(d, 2L, max) - apply(d, 2L, min)
                                        # the heights of the y rows
    x.delta <- mean(x.w) * space
    y.delta <- mean(y.h) * space
    xlim <- c(0, sum(x.w) + NROW(f) * x.delta)
    ylim <- c(0, sum(y.h) + NCOL(f) * y.delta)
    dev.hold(); on.exit(dev.flush())
    plot.new()
    plot.window(xlim, ylim, log = "")
    x.r <- cumsum(x.w + x.delta)
    x.m <- (c(0, x.r[-NROW(f)]) + x.r) / 2
    y.u <- cumsum(y.h + y.delta)
    y.m <- y.u - apply(pmax(d, 0), 2L, max) - y.delta / 2
    z <- expand.grid(x.m, y.m)
    rect(z[, 1] - e / 2, z[, 2],
         z[, 1] + e / 2, z[, 2] + d,
         col = col[1 + (d < 0)])
    axis(1, at = x.m, labels = rownames(f), tick = FALSE)
    axis(2, at = y.m, labels = colnames(f), tick = FALSE)
    abline(h = y.m, lty = 2)
    ndn <- names(dimnames(f))
    if(length(ndn) == 2L) {
        if(is.null(xlab))
            xlab <- ndn[1L]
        if(is.null(ylab))
            ylab <- ndn[2L]
    }
    title(main = main, xlab = xlab, ylab = ylab)
}
#  File src/library/graphics/R/axis.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2021 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/

axis <- function(side, at = NULL, labels = TRUE, tick = TRUE, line = NA,
                 pos = NA, outer = FALSE, font = NA,
                 lty = "solid", lwd = 1, lwd.ticks = lwd,
                 col = NULL, col.ticks = NULL,
                 hadj = NA, padj = NA, gap.axis = NA, ...)
{
    ## we need to do this as the C code processes 'col' before '...'
    if(is.null(col) && !missing(...) && !is.null(fg <- list(...)$fg))
        ## help(par) 'fg' says this should work
        col <- fg
    ## watch out: some people do things like
    ## axis(1, at = my.at <- 10^(1L:5), labels = formatC(my.at, format="fg"))
    ## which depends on the order of evaluation of the args.
    invisible(.External.graphics(C_axis, side, at, as.graphicsAnnot(labels),
          tick, line, pos, outer, font, lty, lwd, lwd.ticks,
          col, col.ticks, hadj, padj, gap.axis, ...))
}


Axis <- function(x = NULL, at = NULL, ..., side, labels = NULL)
{
    if (!is.null(x)) UseMethod("Axis", x)
    else if (!is.null(at)) UseMethod("Axis", at)
    else axis(side = side, at = at, labels = labels, ...)
}

Axis.default <- function(x = NULL, at = NULL, ..., side, labels = NULL)
    axis(side = side, at = at, labels = labels, ...)

Axis.table <- function(x, at, ..., side = 1, labels)
{
     if (length(dim(x)) == 1) {
         nx <- dimnames(x)[[1]]
         ow <- options(warn = -1)
         is.num <- !any(is.na(xx <- as.numeric(nx)))
         options(ow)
         x0 <- if (is.num) xx else seq.int(x)
         if(missing(at)) at <- x0
         if(missing(labels)) labels <- nx
         axis(side, at = at, labels = labels, ...)
     }
     else stop("only for 1-D table")
}



## Note that axTicks() can be used without any graphics device
## when (axp, usr, log, nintLog) are specified..
axTicks <- function(side, axp = NULL, usr = NULL, log = NULL, nintLog = NULL)
{
    ## Compute tickmark "at" values which axis(side) would use by default;
    ## using par("Xaxp") , par("usr") & par("Xlog") where X = x|y
    ## an R version of internal CreateAtVector()
    if(!(side <- as.integer(side)) %in% 1L:4L)
        stop("'side' must be in {1:4}")
    is.x <- side %% 2 == 1
    XY <- function(ch) paste0(if(is.x) "x" else "y", ch)
    if(is.null(axp)) axp <- par(XY("axp"))
    else if(!is.numeric(axp) || length(axp) != 3) stop("invalid 'axp'")
    if(is.null(log)) log <- par(XY("log"))
    else if(!is.logical(log) || anyNA(log)) stop("invalid 'log'")
    if(log && axp[3L] > 0) { ## special log-scale axp[]
        if(!any((iC <- as.integer(axp[3L])) == 1L:3L))
            stop("invalid positive 'axp[3]'")
        if(is.null(usr)) usr <- par("usr")[if(is.x) 1:2 else 3:4]
        else if(!is.numeric(usr) || length(usr) != 2) stop("invalid 'usr'")
        if(is.null(nintLog)) nintLog <- par("lab")[2L - is.x]
        if(is.finite(nintLog)) { # based on internal CreateAtVector() in ../../../main/plot.c
            axisTicks(usr, log=log, axp=axp, nint=nintLog)
        } else { ## nintLog = Inf <--> "cheap" back compatible
	    if(needSort <- is.unsorted(usr)) { ## need sorting for reverse axes
		usr <- usr[2:1]; axp <- axp[2:1]
	    } else axp <- axp[1:2]
	    ii <- round(log10(axp))
	    x10 <- 10^((ii[1L] - (iC >= 2L)):ii[2L])
	    r <- switch(iC, ## axp[3]
			x10,			     ## 1
			c(outer(c(1,  5), x10))[-1L],## 2
			c(outer(c(1,2,5), x10))[-1L])## 3
	    if(needSort) # revert
		r <- rev(r)
            r[usr[1L] <= log10(r) & log10(r) <= usr[2L]]
        }
    } else { # linear
	n <- as.integer(abs(axp[3L]) + 0.25)
	r <- seq.int(axp[1L], axp[2L], length.out = n + 1L)
	## zapsmall(r), but using same computations as C-based axisTicks()
	n. <- max(1L, n)
	N <- 100*n.
	r[abs(r) < abs(axp[2L]/N - axp[1L]/N)] <- 0
	r
    }
}
#  File src/library/graphics/R/barplot.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/

barplot <- function(height, ...) UseMethod("barplot")

barplot.default <-
function(height, width = 1, space = NULL, names.arg = NULL,
	 legend.text = NULL, beside = FALSE, horiz = FALSE,
	 density = NULL, angle = 45,
	 col = NULL, border = par("fg"),
	 main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
	 xlim = NULL, ylim = NULL, xpd = TRUE, log = "",
	 axes = TRUE, axisnames = TRUE,
	 cex.axis = par("cex.axis"), cex.names = par("cex.axis"),
         inside = TRUE, plot = TRUE, axis.lty = 0, offset = 0, add = FALSE,
	 ann = !add && par("ann"),
         args.legend = NULL, ...)
 {
    if (!missing(inside)) .NotYetUsed("inside", error = FALSE)# -> help(.)

    if (is.null(space))
	space <- if (is.matrix(height) && beside) c(0, 1) else 0.2
    space <- space * mean(width)

    if (plot && axisnames && is.null(names.arg))
	names.arg <-
	    if(is.matrix(height)) colnames(height) else names(height)

    vectorInput <- (is.vector(height)
	|| (is.array(height) && (length(dim(height)) == 1)))
	## Treat vectors and 1-d arrays the same.
    if (vectorInput) {
	height <- cbind(height)
	beside <- TRUE
	## The above may look strange, but in particular makes color
	## specs work as most likely expected by the users.
	if(is.null(col)) col <- "grey"
    } else if (is.matrix(height)) {
	## In the matrix case, we use "colors" by default.
	if(is.null(col))
	    col <- gray.colors(nrow(height))
    }
    else
	stop("'height' must be a vector or a matrix")

    if(is.logical(legend.text))
      legend.text <-
	if(isTRUE(legend.text) && is.matrix(height)) rownames(height) else NULL

    stopifnot(is.character(log))
    logx <- logy <- FALSE
    if (log != "") {
	logx <- length(grep("x", log)) > 0L
	logy <- length(grep("y", log)) > 0L
    }
    ## Cannot use rect(*, density=.) when log scales used
    if ((logx || logy) && !is.null(density))
      stop("Cannot use shading lines in bars when log scale is used")

    NR <- nrow(height)
    NC <- ncol(height)

    if (beside) {
	if (length(space) == 2 && !vectorInput)
	    space <- rep.int(c(space[2L], rep.int(space[1L], NR - 1)), NC)
	width <- rep_len(width, NR)
    } else {
	width <- rep_len(width, NC)
    }

    offset <- rep_len(as.vector(offset), length(width))

    delta <- width / 2
    w.r <- cumsum(space + width)
    w.m <- w.r - delta
    w.l <- w.m - delta

    log.dat <- (logx && horiz) || (logy && !horiz)# log scale in data direction
    ## check height + offset if using log scale to prevent log(<=0) error
    if (log.dat) {
	if (min(height + offset, na.rm = TRUE) <= 0)
	    stop("log scale error: at least one 'height + offset' value <= 0")
	if (logx && !is.null(xlim) && min(xlim) <= 0)
	    stop("log scale error: 'xlim' <= 0")
	if (logy && !is.null(ylim) && min(ylim) <= 0)
	    stop("log scale error: 'ylim' <= 0")

	## if axis limit is set to < above, adjust bar base value
	## to draw a full bar
	rectbase <-
	    if	    (logy && !horiz && !is.null(ylim))	ylim[1L]
	    else if (logx && horiz  && !is.null(xlim))	xlim[1L]
	    else 0.9 * min(height, na.rm = TRUE)
    } else rectbase <- 0

    ## if stacked bar, set up base/cumsum levels, adjusting for log scale
    if (!beside)
	height <- rbind(rectbase, apply(height, 2L, cumsum))

    rAdj <- offset + (if (log.dat) 0.9 * height else -0.01 * height)

    delta <- width / 2
    w.r <- cumsum(space + width)
    w.m <- w.r - delta
    w.l <- w.m - delta
    if (horiz) {
	if (is.null(xlim)) xlim <- range(rAdj, height + offset, na.rm = TRUE)
	if (is.null(ylim)) ylim <- c(min(w.l), max(w.r))
    } else {
	if (is.null(xlim)) xlim <- c(min(w.l), max(w.r))
	if (is.null(ylim)) ylim <- range(rAdj, height + offset, na.rm = TRUE)
    }
    if (beside)
	w.m <- matrix(w.m, ncol = NC)
    if(plot) { ##-------- Plotting :
        dev.hold()
	opar <-
	    if (horiz)	par(xaxs = "i", xpd = xpd)
	    else	par(yaxs = "i", xpd = xpd)
	on.exit({dev.flush();par(opar)})

	if (!add) {
	    plot.new()
	    plot.window(xlim, ylim, log = log, ...)
	}

	xyrect <- function(x1,y1, x2,y2, horizontal = TRUE, ...) {
	    if(horizontal)
		rect(x1,y1, x2,y2, ...)
	    else
		rect(y1,x1, y2,x2, ...)
	}
	if (beside)
	    xyrect(rectbase + offset, w.l, c(height) + offset, w.r,
		   horizontal = horiz,
		   angle = angle, density = density,
                   col = col, border = border)
	else {
	    ## noInside <- NC > 1 && !inside # outside border, but not inside
	    ## bordr <- if(noInside) 0 else border
	    for (i in 1L:NC) {
		xyrect(height[1L:NR, i] + offset[i], w.l[i],
		       height[ -1,  i] + offset[i], w.r[i],
		       horizontal = horiz, angle = angle, density = density,
		       col = col, border = border)# = bordr
		## if(noInside)
		##  xyrect(min(height[, i]), w.l[i], max(height[, i]), w.r[i],
		##	   horizontal = horiz, border= border)
	    }
	}
	if (axisnames && !is.null(names.arg)) { # specified or from {col}names
	    at.l <- if (length(names.arg) != length(w.m)) {
		if (length(names.arg) == NC) # i.e. beside (!)
		    colMeans(w.m)
		else
		    stop("incorrect number of names")
	    } else w.m
	    axis(if(horiz) 2 else 1, at = at.l, labels = names.arg,
		 lty = axis.lty, cex.axis = cex.names, ...)
	}
	if(!is.null(legend.text)) {
	    legend.col <- rep_len(col, length(legend.text))
	    if((horiz & beside) || (!horiz & !beside)){
		legend.text <- rev(legend.text)
		legend.col <- rev(legend.col)
		density <- rev(density)
		angle <- rev(angle)
	    }
	    xy <- par("usr")
            if(is.null(args.legend)) {
                legend(xy[2L] - xinch(0.1), xy[4L] - yinch(0.1),
                       legend = legend.text, angle = angle, density = density,
                       fill = legend.col, xjust = 1, yjust = 1)
            } else {
                args.legend1 <- list(x = xy[2L] - xinch(0.1),
                                     y = xy[4L] - yinch(0.1),
                                     legend = legend.text,
                                     angle = angle, density = density,
                                     fill = legend.col, xjust = 1, yjust = 1)
                args.legend1[names(args.legend)] <- args.legend
                do.call("legend", args.legend1)
            }
	}
	if(ann) title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if(axes) axis(if(horiz) 1 else 2, cex.axis = cex.axis, ...)
	invisible(w.m)
    } else w.m
}

barplot.formula <- function(formula, data, subset, na.action,
                            horiz = FALSE, xlab = NULL, ylab = NULL, ...)
{
    if (missing(formula) || length(formula) != 3L)
        stop("'formula' missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if (is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- m$horiz <- m$xlab <- m$ylab <- NULL
    m[[1L]] <- quote(stats::model.frame)

    mf <- eval(m, parent.frame())
    if (ncol(mf[-1L]) == 0L || ncol(mf[-1L]) >= 3L)
        stop("formula must specify 1 or 2 categorical variables")
    if (anyDuplicated(mf[-1L]))
        stop("duplicated categorical values - try another formula or subset")
    if (horiz) {
        if(is.null(ylab)) ylab <- names(mf)[ncol(mf)]
    } else
        if(is.null(xlab)) xlab <- names(mf)[ncol(mf)]
    if (is.matrix(mf[[1L]])) { ## LHS is cbind()
        if (ncol(mf[-1L]) != 1L)
            stop("formula with cbind() must specify 1 categorical variable")
        lhs <- t(mf[[1L]])
        colnames(lhs) <- mf[[ncol(mf)]]
        barplot.default(lhs, horiz = horiz, xlab = xlab, ylab = ylab, ...)
    } else {
	if (horiz) {
	    if(is.null(xlab)) xlab <- names(mf)[1L]
	} else
	    if(is.null(ylab)) ylab <- names(mf)[1L]
	barplot.default(stats::xtabs(mf, addNA = TRUE),
			horiz = horiz, xlab = xlab, ylab = ylab, ...)
  }
}
#  File src/library/graphics/R/box.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

box <- function(which="plot", lty="solid", ...)
{
    which <- pmatch(which[1L], c("plot", "figure", "inner", "outer"))
    .External.graphics(C_box, which=which, lty=lty, ...)
    invisible()
}
#  File src/library/graphics/R/boxplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2021 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/

boxplot <- function(x, ...) UseMethod("boxplot")

boxplot.default <-
function(x, ..., range = 1.5, width = NULL, varwidth = FALSE,
	 notch = FALSE, outline = TRUE, names, plot = TRUE,
	 border = par("fg"), col = "lightgray", log = "",
	 pars = list(boxwex = 0.8, staplewex = 0.5, outwex = 0.5),
	 ann = !add,
	 horizontal = FALSE, add = FALSE, at = NULL)
{
    args <- list(x, ...)
    namedargs <-
	if(!is.null(attributes(args)$names)) attributes(args)$names != ""
	else rep_len(FALSE, length(args))
    ## pars <- c(args[namedargs], pars)
    groups <- if(is.list(x)) x else args[!namedargs]
    if(0L == (n <- length(groups)))
	stop("invalid first argument")
    if(length(class(groups)))
	groups <- unclass(groups)
    if(!missing(names))
	attr(groups, "names") <- names
    else {
	if(is.null(attr(groups, "names")))
	    attr(groups, "names") <- 1L:n
	names <- attr(groups, "names")
    }
    cls <- lapply(groups, class)
    cl <- NULL
    ## Check for simple numeric structures with only a common class attribute
    if(all(vapply(groups,
                  function(e) {
                      is.numeric(unclass(e)) &&
                          identical(names(attributes(e)), "class")
                  },
                  NA)) &&
       (length(unique(cls)) == 1L))
        cl <- cls[[1L]]
    for(i in 1L:n)
	groups[i] <- list(boxplot.stats(unclass(groups[[i]]), range)) # do.conf=notch)
    stats <- matrix(0, nrow = 5L, ncol = n)
    conf  <- matrix(0, nrow = 2L, ncol = n)
    ng <- out <- group <- numeric(0L)
    ct <- 1
    for(i in groups) {
	stats[,ct] <- i$stats
	conf [,ct] <- i$conf
	ng <- c(ng, i$n)
	if((lo <- length(i$out))) {
	    out	  <- c(out,i$out)
	    group <- c(group, rep.int(ct, lo))
	}
	ct <- ct+1
    }
    if(length(cl) == 1L && cl != "numeric") # was length(cl)
        oldClass(stats) <- oldClass(conf) <- oldClass(out) <- cl
    z <- list(stats = stats, n = ng, conf = conf, out = out, group = group,
	      names = names)
    if(plot) {
        if(is.null(pars$boxfill) && is.null(args$boxfill)) pars$boxfill <- col
        do.call(bxp,
                c(list(z, notch = notch, width = width, varwidth = varwidth,
                       log = log, border = border, pars = pars,
                       outline = outline, horizontal = horizontal, add = add,
                       ann = ann,
                       at = at), args[namedargs]),
                quote = TRUE)# *not* to eval() calls in labels etc
	invisible(z)
    }
    else z
}

boxplot.matrix <- function(x, use.cols = TRUE, ...)
{
    ## Purpose: Boxplot for each column or row [use.cols= TRUE / FALSE] of a matrix
    ## -------------------------------------------------------------------------
    ## Arguments: x: a numeric matrix; use.cols: logical, columns (T) or rows (F)
    ## <FIXME split.matrix>
    groups <- if(use.cols) {
        split(c(x), rep.int(1L:ncol(x), rep.int(nrow(x), ncol(x))))
    } else split(c(x), seq(nrow(x)))
    ## Make use of col/row names if present
    if (length(nam <- dimnames(x)[[1+use.cols]])) names(groups) <- nam
    invisible(boxplot(groups, ...))
}

boxplot.formula <-
    function(formula, data = NULL, ..., subset, na.action = NULL,
             xlab = mklab(y_var = horizontal),
             ylab = mklab(y_var =!horizontal),
             add = FALSE, ann = !add, horizontal = FALSE,
	     drop = FALSE, sep = ".", lex.order = FALSE)
{
    if(missing(formula) || (length(formula) != 3L))
	stop("'formula' missing or incorrect")
    if(missing(xlab) || missing(ylab))
        mklab <- function(y_var)
            if(y_var)  names(mf)[ response]
            else paste(names(mf)[-response], collapse = " : ")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    m$... <- m$drop <- m$sep <- m$lex.order <- NULL
    m$xlab <- m$ylab  <- m$add <- m$ann <- m$horizontal <- NULL
    m$na.action <- na.action # force use of default for this method
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame.default)
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")
    boxplot(split(mf[[response]], mf[-response],
		  drop = drop, sep = sep, lex.order = lex.order),
	    xlab = xlab, ylab = ylab, add = add, ann = ann, horizontal = horizontal,
	    ...)
}

bxp <- function(z, notch = FALSE, width = NULL, varwidth = FALSE,
                outline = TRUE, notch.frac = 0.5, log = "", border = par("fg"),
		pars = NULL, frame.plot = axes, horizontal = FALSE,
                ann = TRUE,
		add = FALSE, at = NULL, show.names = NULL, ...)
{
    pars <- as.list(pars)
    if(...length()) { ## ensure '...' takes precedence over 'pars' and does not have duplicates
	nmsA <- names(args <- list(...))
	if(anyDuplicated(nmsA)) {
	    iD <- duplicated(nmsA)
	    warning(sprintf(ngettext(sum(iD),
				     "Duplicated argument %s is disregarded",
				     "Duplicated arguments %s are disregarded"),
			    sub("^list\\((.*)\\)", "\\1", deparse(args[iD]))),
		    domain = NA)
	    nmsA <- names(args <- args[!iD])
	}
	pars[nmsA] <- args
    }
    bplt <- function(x, wid, stats, out, conf, notch, xlog, i)
    {
	## Draw single box plot
        ok <- TRUE
	if(!anyNA(stats)) {
	    ## stats = +/- Inf:	polygon & segments should handle

	    ## Compute 'x + w' -- "correctly" in log-coord. case:
	    xP <-
		if(xlog) function(x,w) x * exp(w)
		else function(x,w) x + w
	    wid <- wid/2
	    if (notch) {
                ## check for overlap of notches and hinges
                ok <- stats[2L] <= conf[1L] && conf[2L] <= stats[4L]

		xx <- xP(x, wid * c(-1, 1, 1, notch.frac, 1,
				    1, -1,-1,-notch.frac,-1))
		yy <- c(stats[c(2, 2)], conf[1L], stats[3L], conf[2L],
			stats[c(4, 4)], conf[2L], stats[3L], conf[1L])
	    }
	    else {
		xx <- xP(x, wid * c(-1, 1, 1, -1))
		yy <- stats[c(2, 2, 4, 4)]
	    }
	    if(!notch) notch.frac <- 1
	    wntch <- notch.frac*wid

	    ## the box filling over which to draw the rest:
	    xypolygon(xx, yy, lty = "blank", col = boxfill[i])
	    ## Median
	    xysegments(xP(x, -wntch), stats[3L],
		       xP(x, +wntch), stats[3L],
		       lty = medlty[i], lwd = medlwd[i], col = medcol[i],
                       lend = 1) ## avoid oerlap by butt line endings.
	    xypoints(x, stats[3L],
		     pch = medpch[i], cex = medcex[i], col = medcol[i], bg = medbg[i])
	    ## Whiskers
	    xysegments(rep.int(x, 2), stats[c(1,5)],
		       rep.int(x, 2), stats[c(2,4)],
		       lty = whisklty[i], lwd = whisklwd[i], col = whiskcol[i])
	    xysegments(rep.int(xP(x, -wid * staplewex[i]), 2), stats[c(1,5)],
		       rep.int(xP(x, +wid * staplewex[i]), 2), stats[c(1,5)],
		       lty = staplelty[i], lwd = staplelwd[i], col = staplecol[i])
	    ## finally the box borders
	    xypolygon(xx, yy, lty = boxlty[i], lwd = boxlwd[i], border = boxcol[i])

	    if ((nout <- length(out))) { ## Outliers
		xysegments(rep(x - wid * outwex, nout), out,
			   rep(x + wid * outwex, nout), out,
			   lty = outlty[i], lwd = outlwd[i], col = outcol[i])
		xypoints(rep.int(x, nout), out, pch = outpch[i],
                         lwd = outlwd[i],
			 cex = outcex[i], col = outcol[i], bg = outbg[i])
	    }

	    if(any(inf <- !is.finite(out))) {
		## FIXME: should MARK on plot !! (S-plus doesn't either)
		warning(sprintf(ngettext(length(unique(out[inf])),
				 "Outlier (%s) in boxplot %d is not drawn",
				 "Outliers (%s) in boxplot %d are not drawn"),
				paste(unique(out[inf]), collapse=", "), i),
			domain = NA)
	    }
	}
        return(ok)
    } ## bplt

    if(!is.list(z) || 0L == (n <- length(z$n)))
	stop("invalid first argument")
    if(is.null(at))
	at <- 1L:n
    else if(length(at) != n)
        stop(gettextf("'at' must have same length as 'z$n', i.e. %d", n),
             domain = NA)
    ## just for compatibility with S
    if(is.null(z$out))
	z$out <- numeric()
    if(is.null(z$group) || !outline)
	z$group <- integer()
    if(is.null(pars$ylim))
	ylim <- range(z$stats[is.finite(z$stats)],
		      if(outline) z$out[is.finite(z$out)],
		      if(notch)  z$conf[is.finite(z$conf)])
    else {
	ylim <- pars$ylim
	pars$ylim <- NULL
    }

    if(length(border) == 0L) border <- par("fg")

    dev.hold(); on.exit(dev.flush())
    if (!add) {
	if(is.null(pars$xlim))
	    xlim <- range(at, finite=TRUE) + c(-0.5, 0.5)
	else {
	    xlim <- pars$xlim
	    pars$xlim <- NULL
	}
	plot.new()
	## shall we switch log for horizontal with
	## switch(log, x="y", y="x", log) ??
	if (horizontal)
	    plot.window(ylim = xlim, xlim = ylim, log = log, xaxs = pars$yaxs)
	else
	    plot.window(xlim = xlim, ylim = ylim, log = log, yaxs = pars$yaxs)
    }
    xlog <- (par("ylog") && horizontal) || (par("xlog") && !horizontal)

    pcycle <- function(p, def1, def2 = NULL)# or rather NA {to be rep()ed}?
	rep(if(length(p)) p else if(length(def1)) def1 else def2,
	    length.out = n)
    ## we have to be careful to avoid partial matching here
    p <- function(sym) pars[[sym, exact = TRUE]]

    boxlty    <- pcycle(pars$boxlty,	p("lty"), par("lty"))
    boxlwd    <- pcycle(pars$boxlwd,	p("lwd"), par("lwd"))
    boxcol    <- pcycle(pars$boxcol,	border)
    boxfill   <- pcycle(pars$boxfill,	par("bg"))
    boxwex    <- pcycle(pars$boxwex,	0.8 * {
	if(n <= 1) 1 else
	stats::quantile(diff(sort(if(xlog) log(at) else at)), 0.10) })
    medlty    <- pcycle(pars$medlty,	p("lty"), par("lty"))
    medlwd    <- pcycle(pars$medlwd,	3*p("lwd"), 3*par("lwd"))
    medpch    <- pcycle(pars$medpch,	NA_integer_)# NA when that works
    medcex    <- pcycle(pars$medcex,	p("cex"), par("cex"))
    medcol    <- pcycle(pars$medcol,	border)
    medbg     <- pcycle(pars$medbg,	p("bg"),  par("bg"))
    whisklty  <- pcycle(pars$whisklty,	p("lty"), "dashed")
    whisklwd  <- pcycle(pars$whisklwd,	p("lwd"), par("lwd"))
    whiskcol  <- pcycle(pars$whiskcol,	border)
    staplelty <- pcycle(pars$staplelty, p("lty"), par("lty"))
    staplelwd <- pcycle(pars$staplelwd, p("lwd"), par("lwd"))
    staplecol <- pcycle(pars$staplecol, border)
    staplewex <- pcycle(pars$staplewex,	0.5)
    outlty    <- pcycle(pars$outlty,	"blank")
    outlwd    <- pcycle(pars$outlwd,	p("lwd"), par("lwd"))
    outpch    <- pcycle(pars$outpch,	p("pch"), par("pch"))
    outcex    <- pcycle(pars$outcex,	p("cex"), par("cex"))
    outcol    <- pcycle(pars$outcol,	border)
    outbg     <- pcycle(pars$outbg,	p("bg"),  par("bg"))
    outwex    <- pcycle(pars$outwex,	0.5)

    width <-
	if(!is.null(width)) {
	    if(length(width) != n || anyNA(width) || any(width <= 0))
		stop("invalid boxplot widths")
	    boxwex * width/max(width)
	}
	else if(varwidth) boxwex * sqrt(z$n/max(z$n))
	else if(n == 1) 0.5 * boxwex
	else rep.int(boxwex, n)

    if(horizontal) {
	xypoints <- function(x, y, ...) points(y, x, ...)
	xypolygon <- function(x, y, ...) polygon(y, x, ...)
	xysegments <- function(x0, y0, x1, y1, ...) segments(y0, x0, y1, x1, ...)
    }
    else {
	xypoints <- points
	xypolygon <- polygon
	xysegments <- segments
    }

    ok <- TRUE
    for(i in 1L:n)
	ok <- ok & bplt(at[i], wid = width[i], stats = z$stats[,i],
                        out = z$out[z$group == i], conf = z$conf[,i],
			notch = notch, xlog = xlog, i = i)
    if(!ok)
	warning("some notches went outside hinges ('box'): maybe set notch=FALSE")

    axes <- is.null(pars$axes)
    if(!axes) { axes <- pars$axes; pars$axes <- NULL }
    if(axes) {
	ax.pars <- pars[names(pars) %in% c("xaxt", "yaxt", "xaxp", "yaxp",
					   "gap.axis",
                                           "las",
					   "cex.axis", "col.axis", "format")]
	if (is.null(show.names)) show.names <- n > 1
	if (show.names)
	    do.call("axis", c(list(side = 1 + horizontal,
				   at = at, labels = z$names), ax.pars),
		    quote = TRUE)
	do.call("Axis", c(list(x = z$stats, side = 2 - horizontal), ax.pars),
		quote = TRUE)
    }
    if(ann) do.call(title,
	    pars[names(pars) %in% c("main", "cex.main", "col.main",
				    "sub", "cex.sub", "col.sub",
				    "xlab", "ylab", "cex.lab", "col.lab")],
	    quote = TRUE)
    if(frame.plot)
	box()
    invisible(at)
}
#  File src/library/graphics/R/cdplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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/

## CD plots contributed by Achim Zeileis

cdplot <- function(x, ...) {
  UseMethod("cdplot")
}

cdplot.formula <-
function(formula, data = list(),
         plot = TRUE, tol.ylab = 0.05, ylevels = NULL,
         bw = "nrd0", n = 512, from = NULL, to = NULL,
         col = NULL, border = 1, main = "", xlab = NULL, ylab = NULL,
         yaxlabels = NULL, xlim = NULL, ylim = c(0, 1), ...,
         subset = NULL, weights = NULL)
{
    ## extract x, y from formula
    m <- match.call(expand.dots = FALSE)
    m <- m[c(1L, match(c("formula", "data", "subset", "weights"), names(m), 0L))]
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame)
    mf <- eval.parent(m)
    if(length(setdiff(names(mf), "(weights)")) != 2L)
        stop("'formula' should specify exactly two variables")
    y <- mf[,1L]
    if(!is.factor(y))
        stop("dependent variable should be a factor")
    if(!is.null(ylevels))
      y <- factor(y, levels = if(is.numeric(ylevels)) levels(y)[ylevels] else ylevels)
    x <- mf[,2L]
    w <- if("(weights)" %in% names(mf)) mf[,"(weights)"] else NULL

    ## graphical parameters
    if(is.null(xlab)) xlab <- names(mf)[2L]
    if(is.null(ylab)) ylab <- names(mf)[1L]
    if(is.null(yaxlabels)) yaxlabels <- levels(y)

    ## call default interface
    cdplot(x, y, plot = plot, tol.ylab = tol.ylab, bw = bw, n = n,
           from = from, to = to, col = col, border = border, main = main,
           xlab = xlab, ylab = ylab, yaxlabels = yaxlabels, xlim = xlim,
           ylim = ylim, weights = w, ...)
}

cdplot.default <-
function(x, y,
         plot = TRUE, tol.ylab = 0.05, ylevels = NULL,
         bw = "nrd0", n = 512, from = NULL, to = NULL,
         col = NULL, border = 1, main = "", xlab = NULL, ylab = NULL,
         yaxlabels = NULL, xlim = NULL, ylim = c(0, 1), weights = NULL, ...)
{
    ## graphical parameters
    if(is.null(xlab)) xlab <- deparse1(substitute(x))
    if(is.null(ylab)) ylab <- deparse1(substitute(y))
    if(is.null(col)) col <- gray.colors(length(levels(y)))
    col <- rep_len(col, length.out = length(levels(y)))
    if(is.null(yaxlabels)) yaxlabels <- levels(y)

    ## coerce x and check y
    xorig <- x
    x <- as.numeric(x)
    if(!is.factor(y)) stop("dependent variable should be a factor")

    ## normalize weights (if any)
    w <- if (is.null(weights)) NULL else weights/sum(weights)

    ## reverse ordering on y-axis compared to R < 4.0.0
    ylevels <- if(is.null(ylevels)) nlevels(y):1L else rev(ylevels)
    y <- factor(y, levels = if(is.numeric(ylevels)) levels(y)[ylevels] else ylevels)
    yaxlabels <- yaxlabels[ylevels]

    ## unconditional density of x
    dx <- if(is.null(from) && is.null(to))
        stats::density(x, bw = bw, n = n, weights = w, ...)
    else
        stats::density(x, bw = bw, from = from, to = to, n = n, weights = w, ...)
    x1 <- dx$x

    ## setup conditional values
    ny <- length(levels(y))
    if(is.null(weights)) {
      yprop <- cumsum(proportions(table(y)))
    } else {
      yprop <- cumsum(proportions(tapply(weights, y, FUN = sum, na.rm = TRUE)))
      yprop[is.na(yprop)] <- 0
    }
    y1 <- matrix(rep(0, n * (ny - 1L)), nrow = (ny - 1L))

    ## setup return value
    rval <- list()

    for(i in seq_len(ny-1L)) {
        yi <- y %in% levels(y)[seq_len(i)]
        wi <- if (is.null(weights)) NULL else weights[yi] / sum(weights[yi])
        dxi <- stats::density(x[yi], bw = dx$bw, n = n,
                              from = min(dx$x), to = max(dx$x), weights = wi, ...)
        y1[i,] <- dxi$y/dx$y * yprop[i]
        rval[[i]] <- stats::approxfun(x1, y1[i,], rule = 2)
    }
    names(rval) <- levels(y)[seq_len(ny-1L)]

    ## use known ranges
    y1 <- rbind(0, y1, 1)
    y1 <- y1[,which(x1 >= min(x) & x1 <= max(x))]
    x1 <- x1[x1 >= min(x) & x1 <= max(x)]

    if(is.null(xlim)) xlim <- range(x1)
    if(any(ylim < 0) || any(ylim > 1)) {
        warning("y axis is on a cumulative probability scale, 'ylim' must be in [0,1]")
        if(min(ylim) > 1 || max(ylim) < 0) ylim <- c(0, 1)
        else ylim <- c(max(min(ylim), 0), min(max(ylim), 1))
    }

    ## plot polygons
    if(plot) {
        dev.hold(); on.exit(dev.flush())
        plot(0, 0, xlim = xlim, ylim = ylim, type = "n", axes = FALSE,
             xaxs = "i", yaxs = "i", xlab = xlab, ylab = ylab, main = main)
        for(i in seq_len(NROW(y1) - 1L))
            polygon(c(x1, rev(x1)), c(y1[i+1,], rev(y1[i,])), col = col[i],
                    border = border)
        Axis(xorig, side = 1)

        equidist <- any(diff(y1[,1L]) < tol.ylab)
        if(equidist)
            axis(2, at = seq.int(1/(2*ny), 1-1/(2*ny), by = 1/ny), labels = yaxlabels, tick = FALSE)
        else
            axis(2, at = (y1[-1L,1L] + y1[-NROW(y1), 1L])/2, labels = yaxlabels, tick = FALSE)
        axis(4)
        box()
    }

    ## return conditional density functions
    invisible(rval)
}

#  File src/library/graphics/R/contour.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/

contour <- function(x, ...) UseMethod("contour")

contour.default <-
function (x = seq(0, 1, length.out = nrow(z)),
          y = seq(0, 1, length.out = ncol(z)),
	  z,
	  nlevels = 10, levels = pretty(zlim, nlevels), labels = NULL,
	  xlim = range(x, finite = TRUE), ylim = range(y, finite = TRUE),
	  zlim = range(z, finite = TRUE),
	  labcex = 0.6, drawlabels = TRUE, method = "flattest",
          vfont, axes = TRUE, frame.plot = axes,
	  col = par("fg"), lty = par("lty"), lwd = par("lwd"),
	  add = FALSE, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		z <- x
		x <- seq.int(0, 1, length.out = nrow(z))
	    }
	} else stop("no 'z' matrix specified")
    } else if (is.list(x)) {
	y <- x$y
	x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing 'x' and 'y' values expected")
    if (!is.matrix(z) || nrow(z) <= 1L || ncol(z) <= 1L)
	stop("no proper 'z' matrix specified")
    if (!add) {
        localPlotWindow <-
            function(xlim, ylim, ..., main, sub, xlab, ylab, outer, line)
                plot.window(xlim, ylim, ...)
        localTitle <- function(..., log) title(...)
	plot.new()
	localPlotWindow(xlim, ylim, ...)
	localTitle(...)
    }
    ##- don't lose  dim(.)
    method <- pmatch(method[1L], c("simple", "edge", "flattest"))
    if (missing(vfont))
       vfont <- if(.Call(C_contourDef)) NULL else c("sans serif", "plain")
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1L], Hershey$typeface),
                   fontindex = pmatch(vfont[2L], Hershey$fontindex))
    if (!is.null(labels)) {
        labels <- as.character(labels)
	if (isTRUE(drawlabels) && !length(labels))
	    stop("'labels' is length zero.  Use 'drawlabels = FALSE' to suppress labels.")
    }
    .External.graphics(C_contour, x, y, z, levels, labels, labcex, drawlabels,
                       method, vfont, col, lty, lwd)
    if(!add) {
        ## at least col, lty, lwd are not needed,
        ## but easiest to be consistent with plot.default
        localAxis <- function(..., col, bg, pch, cex, lty, lwd) Axis(...)
        localBox <- function(..., col, bg, pch, cex, lty, lwd) box(...)
        if(axes) {
            localAxis(x, side = 1, ...)
            localAxis(y, side = 2, ...)
        }
        if(frame.plot) localBox(...)
    }
    invisible()
}
#  File src/library/graphics/R/coplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2013 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/

co.intervals <- function (x, number = 6, overlap = 0.5)
{
    x <- sort(x[!is.na(x)])
    n <- length(x)
    ## "from the record"
    r <- n/(number * (1 - overlap) + overlap)
    ii <- 0:(number - 1) * (1 - overlap) * r
    x1 <- x[round(1 + ii)]
    xr <- x[round(r + ii)]
    ## Omit any range of values identical with the previous range;
    ## happens e.g. when `number' is less than the number of distinct x values.
    keep <- c(TRUE, diff(x1) > 0 | diff(xr) > 0)
    ## Set eps > 0 to ensure that the endpoints of a range are never
    ## identical, allowing display of a given.values bar
    j.gt.0 <- 0 < (jump <- diff(x))
    eps <- 0.5 * if(any(j.gt.0)) min(jump[j.gt.0]) else 0
    cbind(x1[keep] - eps, xr[keep] + eps)
}

panel.smooth <- function(x, y, col = par("col"), bg = NA, pch = par("pch"),
			 cex = 1, col.smooth = 2, span = 2/3, iter = 3, ...)
{
    points(x, y, pch=pch, col=col, bg=bg, cex=cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok))
	lines(stats::lowess(x[ok], y[ok], f=span, iter=iter),
              col = col.smooth, ...)
}

coplot <-
    function(formula, data, given.values, panel=points, rows, columns,
	     show.given = TRUE, col = par("fg"), pch=par("pch"),
	     bar.bg = c(num = gray(0.8), fac = gray(0.95)),
	     xlab = c(x.name, paste("Given :", a.name)),
	     ylab = c(y.name, paste("Given :", b.name)),
	     subscripts = FALSE, axlabels = function(f) abbreviate(levels(f)),
	     number = 6, overlap = 0.5, xlim, ylim, ...)
{
    deparen <- function(expr) {
	while (is.language(expr) && !is.name(expr) &&
               deparse(expr[[1L]])[1L] == "(")
	    expr <- expr[[2L]]
	expr
    }
    bad.formula <- function() stop("invalid conditioning formula")
    bad.lengths <- function() stop("incompatible variable lengths")
    getOp <- function(call) deparse(call[[1L]], backtick=FALSE)[[1L]]

    ## parse and check the formula

    formula <- deparen(formula)
    if (!inherits(formula, "formula"))
	bad.formula()
    y <- deparen(formula[[2L]])
    rhs <- deparen(formula[[3L]])
    if (getOp(rhs) != "|") bad.formula()
    x <- deparen(rhs[[2L]])
    rhs <- deparen(rhs[[3L]])
    if (is.language(rhs) && !is.name(rhs) && getOp(rhs) %in%  c("*", "+")) {
	have.b <- TRUE
	a <- deparen(rhs[[2L]])
	b <- deparen(rhs[[3L]])
    } else {
	have.b <- FALSE
	a <- rhs
    }

    ## evaluate the formulae components to get the data values

    if (missing(data))
	data <- parent.frame()
    x.name <- deparse(x)
    x <- eval(x, data, parent.frame())
    nobs <- length(x)
    y.name <- deparse(y)
    y <- eval(y, data, parent.frame())
    if(length(y) != nobs) bad.lengths()
    a.name <- deparse(a)
    a <- eval(a, data, parent.frame())
    if(length(a) != nobs) bad.lengths()
    if(is.character(a)) a <- as.factor(a)
    a.is.fac <- is.factor(a)
    if (have.b) {
	b.name <- deparse(b)
	b <- eval(b, data, parent.frame())
	if(length(b) != nobs) bad.lengths()
	if(is.character(b)) b <- as.factor(b)
        b.is.fac <- is.factor(b)
	missingrows <- which(is.na(x) | is.na(y) | is.na(a) | is.na(b))
    }
    else {
	missingrows <- which(is.na(x) | is.na(y) | is.na(a))
	b <- NULL
	b.name <- "" # for default ylab
    }

    ## generate the given value intervals

    number <- as.integer(number)
    if(length(number) == 0L || any(number < 1))
        stop("'number' must be integer >= 1")
    if(any(overlap >= 1)) stop("'overlap' must be < 1 (and typically >= 0).")

    bad.givens <- function() stop("invalid 'given.values'")
    if(missing(given.values)) {
	a.intervals <-
	    if(a.is.fac) {
		i <- seq_along(a.levels <- levels(a))
		a <- as.numeric(a)
		cbind(i - 0.5, i + 0.5)
	    } else co.intervals(unclass(a), number=number[1L], overlap=overlap[1L])
	b.intervals <-
	    if (have.b) {
		if(b.is.fac) {
                    i <- seq_along(b.levels <- levels(b))
		    b <- as.numeric(b)
		    cbind(i - 0.5, i + 0.5)
		}
		else {
		    if(length(number) == 1L) number  <- rep.int(number,2)
		    if(length(overlap) == 1L) overlap <- rep.int(overlap,2)
		    co.intervals(unclass(b), number=number[2L], overlap=overlap[2L])
		}
	    }
    } else {
	if(!is.list(given.values))
	    given.values <- list(given.values)
	if(length(given.values) != (if(have.b) 2L else 1L))
	    bad.givens()
	a.intervals <- given.values[[1L]]
	if(a.is.fac) {
	    a.levels <- levels(a)
	    if (is.character(a.intervals))
		a.intervals <- match(a.intervals, a.levels)
	    a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
	    a <- as.numeric(a)
	}
	else if(is.numeric(a)) {
	    if(!is.numeric(a.intervals)) bad.givens()
	    if(!is.matrix(a.intervals) || ncol(a.intervals) != 2)
		a.intervals <- cbind(a.intervals - 0.5, a.intervals + 0.5)
	}
	if(have.b) {
	    b.intervals <- given.values[[2L]]
	    if(b.is.fac) {
		b.levels <- levels(b)
		if (is.character(b.intervals))
		    b.intervals <- match(b.intervals, b.levels)
		b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
		b <- as.numeric(b)
	    }
	    else if(is.numeric(b)) {
		if(!is.numeric(b.intervals)) bad.givens()
		if(!is.matrix(b.intervals) || ncol(b.intervals) != 2)
		    b.intervals <- cbind(b.intervals - 0.5, b.intervals + 0.5)
	    }
	}
    }
    if(anyNA(a.intervals) || (have.b && anyNA(b.intervals)))
	bad.givens()

    ## compute the page layout

    if (have.b) {
	rows	<- nrow(b.intervals)
	columns <- nrow(a.intervals)
	nplots <- rows * columns
	if(length(show.given) < 2L) show.given <- rep.int(show.given, 2L)
    }
    else {
	nplots <- nrow(a.intervals)
	if (missing(rows)) {
	    if (missing(columns)) { ## default
		rows <- ceiling(round(sqrt(nplots)))
		columns <- ceiling(nplots/rows)
	    }
	    else rows <- ceiling(nplots/columns)
	}
	else if (missing(columns))
	    columns <- ceiling(nplots/rows)
	if (rows * columns < nplots)
	    stop("rows * columns too small")
    }
    total.columns <- columns
    total.rows <- rows
    f.col <- f.row <- 1
    if(show.given[1L]) {
	total.rows <- rows + 1
	f.row <- rows/total.rows
    }
    if(have.b && show.given[2L]) {
	total.columns <- columns + 1
	f.col <- columns/total.columns
    }

    mar <- if(have.b) rep.int(0, 4) else c(0.5, 0, 0.5, 0)
    oma <- c(5, 6, 5, 4)
    if(have.b) { oma[2L] <- 5 ; if(!b.is.fac) oma[4L] <- 5 }
    if(a.is.fac && show.given[1L]) oma[3L] <- oma[3L] - 1

    ## Start Plotting only now
    opar <- par(mfrow = c(total.rows, total.columns),
		oma = oma, mar = mar, xaxs = "r", yaxs = "r")
    on.exit(par(opar))
    dev.hold(); on.exit(dev.flush(), add = TRUE)
    plot.new()
    ## as.numeric() allowing factors for x & y:
    if(missing(xlim))
	xlim <- range(as.numeric(x), finite = TRUE)
    if(missing(ylim))
	ylim <- range(as.numeric(y), finite = TRUE)
    pch <- rep_len(pch, nobs)
    col <- rep_len(col, nobs)
    do.panel <- function(index, subscripts = FALSE, id) {
	## Use `global' variables
	##	rows, columns,	total.rows, total.columns, nplots, xlim, ylim
        Paxis <- function(side, x) {
            if(nlevels(x)) {
                lab <- axlabels(x)
                axis(side, labels = lab, at = seq(lab), xpd = NA)
            } else
                Axis(x, side=side, xpd = NA)
        }
	istart <- (total.rows - rows) + 1
	i <- total.rows - ((index - 1)%/%columns)
	j <- (index - 1)%%columns + 1
	par(mfg = c(i, j, total.rows, total.columns))
	plot.new()
	plot.window(xlim, ylim)
	if(anyNA(id)) id[is.na(id)] <- FALSE
	if(any(id)) {
	    grid(lty="solid")
	    if(subscripts)
		panel(x[id], y[id], subscripts = id,
		      col = col[id], pch=pch[id], ...)
	    else
		panel(x[id], y[id], col = col[id], pch=pch[id], ...)
	}
	if((i == total.rows) && (j%%2 == 0))
	    Paxis(1, x)
	else if((i == istart || index + columns > nplots) && (j%%2 == 1))
	    Paxis(3, x)

	if((j == 1) && ((total.rows - i)%%2 == 0))
	    Paxis(2, y)
	else if((j == columns || index == nplots) && ((total.rows - i)%%2 == 1))
	    Paxis(4, y)
	box()
    }## END function do.panel()

    if(have.b) {
	count <- 1
	for(i in 1L:rows) {
	    for(j in 1L:columns) {
		id <- ((a.intervals[j,1] <= a) & (a <= a.intervals[j,2]) &
		       (b.intervals[i,1] <= b) & (b <= b.intervals[i,2]))
		do.panel(count, subscripts, id)
		count <- count + 1
	    }
	}
    } else {
	for (i in 1L:nplots) {
	    id <- ((a.intervals[i,1] <= a) & (a <= a.intervals[i,2]))
	    do.panel(i, subscripts, id)
	}
    }
    mtext(xlab[1L], side = 1, at = 0.5*f.col, outer = TRUE, line = 3.5,
          xpd = NA, font = par("font.lab"), cex = par("cex.lab"))
    mtext(ylab[1L], side = 2, at = 0.5*f.row, outer = TRUE, line = 3.5,
          xpd = NA, font = par("font.lab"), cex = par("cex.lab"))

    if(length(xlab) == 1L)
        xlab <- c(xlab, paste("Given :", a.name))
    ##mar <- par("mar")
    if(show.given[1L]) {
	par(fig = c(0, f.col, f.row, 1),
            mar = mar + c(3+ !a.is.fac, 0, 0, 0), new=TRUE)
	plot.new()
	nint <- nrow(a.intervals)
        a.range <- range(a.intervals, finite=TRUE)
        ## 3% correction because axs = "r" extends by 4% :
	plot.window(a.range + c(.03,-.03)*diff(a.range), 0.5 + c(0, nint))
	rect(a.intervals[, 1], 1L:nint - 0.3,
	     a.intervals[, 2], 1L:nint + 0.3,
	     col = bar.bg[if(a.is.fac) "fac" else "num"])
	if(a.is.fac) {
	    text(apply(a.intervals, 1L, mean), 1L:nint, a.levels)
        }
        else {
            Axis(a, side = 3, xpd=NA)
            axis(1, labels=FALSE)
        }
	box()
	mtext(xlab[2L], 3, line = 3 - a.is.fac, at=mean(par("usr")[1L:2]),
              xpd=NA, font = par("font.lab"), cex = par("cex.lab"))
    }
    else { ## i. e. !show.given
	mtext(xlab[2L], 3, line = 3.25, outer = TRUE, at = 0.5*f.col,
              xpd = NA, font = par("font.lab"), cex = par("cex.lab"))
    }
    if(have.b) {
	if(length(ylab) == 1L)
            ylab <- c(ylab, paste("Given :", b.name))
	if(show.given[2L]) {
	    par(fig = c(f.col, 1, 0, f.row),
                mar = mar + c(0, 3+ !b.is.fac, 0, 0), new=TRUE)
	    plot.new()
	    nint <- nrow(b.intervals)
            b.range <- range(b.intervals, finite=TRUE)
            ## 3% correction (see above)
            plot.window(0.5 + c(0, nint), b.range+ c(.03,-.03)*diff(b.range))
	    rect(1L:nint - 0.3, b.intervals[, 1],
                 1L:nint + 0.3, b.intervals[, 2],
                 col = bar.bg[if(b.is.fac)"fac" else "num"])
	    if(b.is.fac) {
                text(1L:nint, apply(b.intervals, 1L, mean), b.levels, srt = 90)
            }
            else {
                Axis(b, side=4, xpd=NA)
                axis(2, labels=FALSE)
            }
	    box()
	    mtext(ylab[2L], 4, line = 3 - b.is.fac,
                  at = mean(par("usr")[3:4]), xpd = NA,
                  font = par("font.lab"), cex = par("cex.lab"))
	}
	else {
	    mtext(ylab[2L], 4, line = 3.25, at=0.5*f.row, outer = TRUE,
                  xpd = NA, font = par("font.lab"), cex = par("cex.lab"))
	}
    }
    if (length(missingrows)) {
	cat("\n", gettextf("Missing rows: %s",
                           paste0(missingrows, collapse = ", ")), "\n")
	invisible(missingrows)
    } else invisible()
}
#  File src/library/graphics/R/curve.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

curve <- function(expr, from = NULL, to = NULL, n = 101, add = FALSE,
                  type = "l", xname = "x", xlab = xname,
                  ylab = NULL, log = NULL, xlim = NULL, ...)
{
    sexpr <- substitute(expr)
    if (is.name(sexpr)) {
        ## beter than parse() !
        expr <- call(as.character(sexpr), as.name(xname))
    } else {
	if ( !( (is.call(sexpr) || is.expression(sexpr)) &&
              xname %in% all.vars(sexpr) ))
	    stop(gettextf("'expr' must be a function, or a call or an expression containing '%s'", xname), domain = NA)
	expr <- sexpr
    }
    if (dev.cur() == 1L && !isFALSE(add)) {
        warning("'add' will be ignored as there is no existing plot")
        add <- FALSE
    }
    addF <- isFALSE(add)
    if (is.null(ylab)) ylab <- deparse(expr)
    if (is.null(from) || is.null(to)) {
        xl <- xlim %||%
          if (!addF) {
            ## determine xlim of current plot.
            pu <- par("usr")[1L:2L]
            if (par("xaxs") == "r") pu <- extendrange(pu, f = -1/27)
            if (par("xlog")) 10^pu else pu
          } else c(0, 1) # was c(1/27, 26/27) in R < 2.14.0
        if (is.null(from)) from <- xl[1L]
        if (is.null(to))     to <- xl[2L]
    }
    lg <- if (length(log)) log else if (!addF && par("xlog")) "x" else ""
    if (length(lg) == 0) lg <- ""
    if (grepl("x", lg, fixed = TRUE)) {
        if (from <= 0 || to <= 0)
            stop("'from' and 'to' must be > 0 with log=\"x\"")
        x <- exp(seq.int(log(from), log(to), length.out = n))
    } else x <- seq.int(from, to, length.out = n)
    ll <- list(x = x); names(ll) <- xname
    y <- eval(expr, envir = ll, enclos = parent.frame())
    if (length(y) != length(x))
        stop("'expr' did not evaluate to an object of length 'n'")
    if (isTRUE(add))
	lines(x = x, y = y, type = type, ...)
    else
        plot(x = x, y = y, type = type, xlab = xlab, ylab = ylab,
             xlim = xlim, log = lg, ...)
    invisible(list(x = x, y = y))
}
#  File src/library/graphics/R/datetime.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2023 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/


### internal function used by axis.Date() and axis.POSIXct(). Extends the current format 
### if not sufficiently precise for value in argument at.
extendDateTimeFormat <- function(x, z){
    ## vectorize when needed:
    if(length(z) > 1L){
        formats <- vapply(z, function(zz) extendDateTimeFormat(x, zz), "")
        return(formats[which.max(nchar(formats))])
    }

    # used format:
    format <- attr(grDevices:::prettyDate(x), "format")
    formatparts <- gsub("%", "", strsplit(format, " |:|-")[[1]])

    # appropriate format for z
    chz <- format(z, "%Y-%m-%d %H:%M:%OS6")  # max. detailed format
    chz <- as.numeric(strsplit(chz, "-| |:|\\.")[[1]])
    default <- c(1, 1, 1, 0, 0, 0, 0)
    names(chz) <- names(default) <-  c("Y", if("m" %in% formatparts) "m" else "b",
                                       "d", "H", "M", "S", "OS6")
    if(any(w <- names(chz) %in% formatparts)){
        if((L <- max(which(w))+1) <= length(chz)){
            add <- chz[L:length(chz)]
            # add month
            if(chz[2] > default[2]){
                if("b" %in% names(add)) format <- paste(format, "%b")
                if("m" %in% names(add)) format <- paste(format, "-%m")
            }
            # add day
            if(chz[3] > default[3] && "d" %in% names(add)){
                if("Y" %in% formatparts & "b" %in% formatparts) format <- paste("%d", format)
                if("Y" %in% formatparts & "m" %in% formatparts) format <- paste0(format, "-%d")
                if(!"Y" %in% formatparts) format <- paste0(format, if("m" %in% formatparts) "-%d" else " %d")
            }
            add <- add[add > 0L]
            if(length(add) && any(c("H", "M", "S", "OS6") %in% names(add))){
                if(!all(c("H", "M") %in% formatparts)) format <- paste(format, "%H:%M")
                if("S" %in% names(add) & !"OS6" %in% names(add)) format <- paste0(format, ":%S")
                if("OS6" %in% names(add)) format <- gsub(":%S", "", paste0(format, ":%OS6"))
            }
        }
    }
    format
}


axis.POSIXct <- function(side, x, at, format, labels = TRUE, ...)
{
    has.at <- !missing(at) && !is.null(at)
    range <- sort(par("usr")[if(side %% 2) 1L:2L else 3L:4L])
    tz <- if(!missing(x) && ("tzone" %in% names(attributes(x)))) attr(x, "tzone") else ""
    rangeTime <- .POSIXct(range, tz = tz)
    
    if(has.at){
        # convert at to POSIXct:
        if(is.numeric(at))
            z <- .POSIXct(at, tz = tz)
        else{
            if(inherits(at, "POSIXt")){
                z <- if(inherits(at, "POSIXlt")) .POSIXct(as.numeric(at), tz = tz) else at
                attr(z, "tzone") <- tz
            }else{
                z <- sapply(at, function(a) as.POSIXct(as.character(a), tz = tz))
                if(is.numeric(z)) z <- .POSIXct(z, tz = tz)
            }
        }    
        z <- z[is.finite(z)] 
        
        # find format if missing:
        if(missing(format)){
#            format <- if(!missing(x)) attr(grDevices:::prettyDate(x), "format") else attr(grDevices:::prettyDate(rangeTime), "format")
#        }else if(is.null(format)){ # exdend format if needed for proper representation of at
            format <- extendDateTimeFormat(if(!missing(x)) x else rangeTime, z)
        }
    } else {
        z <- grDevices:::prettyDate(rangeTime, n = par("lab")[2 - side %% 2])
        if(missing(format)) format <- attr(z, "format")
    }

    keep <- z >= range[1L] & z <= range[2L]
    z <- z[keep]
    if (!is.logical(labels)) 
        labels <- labels[keep]
    else if (isTRUE(labels))
        labels <- format(z, format = format)
    else if (isFALSE(labels))
        labels <- rep("", length(z)) # suppress labelling of ticks
        
    axis(side, at = z, labels = labels, ...)
}


hist.POSIXt <- function(x, breaks, ..., xlab = deparse1(substitute(x)),
                        plot = TRUE, freq = FALSE,
                        start.on.monday = TRUE, format, right = TRUE)
{
    if(!inherits(x, "POSIXt")) stop("wrong method")
    force(xlab)
    x <- as.POSIXct(x)
    incr <- 1
    ## handle breaks ourselves
    if(missing(breaks))
	stop("Must specify 'breaks' in hist(<POSIXt>)")
    if (inherits(breaks, "POSIXt")) {
        breaks <- as.POSIXct(breaks)
        d <- min(abs(diff(unclass(breaks))))
        if(d > 60) incr <- 60
        if(d > 3600) incr <- 3600
        if(d > 86400) incr <- 86400
        if(d > 86400*7) incr <- 86400*7
        if(d > 86400*28) incr <- 86400*28
        if(d > 86400*366) incr <- 86400*366
        num.br <- FALSE
    } else {
        num.br <- is.numeric(breaks) && length(breaks) == 1L
        if(num.br) {
            ## specified number of breaks
        } else if(is.character(breaks) && length(breaks) == 1L) {
            valid <-
                pmatch(breaks,
                       c("secs", "mins", "hours", "days", "weeks",
                         "months", "years", "quarters"))
            if(is.na(valid)) stop("invalid specification of 'breaks'")
            start <- as.POSIXlt(min(x, na.rm = TRUE))
            ## may alter later
            ## we need to invalidate isdst whenever we play with components
            incr <- 1
            if(valid > 1L) { start$sec <- 0; incr <- 59.99 }
            if(valid > 2L) { start$min <- 0L; incr <- 3600 - 1 }
            if(valid > 3L) { start$hour <- 0L; incr <- 86400 - 1 }
            if(valid > 4L) { start$isdst <- -1L}
            if(valid == 5L) { # "weeks"
                start$mday <- start$mday - start$wday
                if(start.on.monday)
                    start$mday <- start$mday + if(start$wday > 0L) 1L else -6L
                incr <- 7*86400
            }
            if(valid == 6L) { # "months"
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (31 * 86400))
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- seq(start, end, "months")
                ind <- seq_along(breaks[-1L])
                if (right)
                    breaks[ind] <- breaks[ind] - 86400
		if (missing(format)) format <- "%Y-%m-%d"
            } else if(valid == 7L) { # "years"
                start$mon <- 0L
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (366 * 86400))
                end$mon <- 0L
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- seq(start, end, "years")
                ind <- seq_along(breaks[-1L])
                if (right)
                    breaks[ind] <- breaks[ind] - 86400
		if (missing(format)) format <- "%Y-%m-%d"
            } else if(valid == 8L) { # "quarters"
                qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
                start$mon <- qtr[start$mon + 1L]
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (93 * 86400))
                end$mon <- qtr[end$mon + 1L]
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- seq(start, end, "3 months")
                ind <- seq_along(breaks[-1L])
                if (right)
                    breaks[ind] <- breaks[ind] - 86400
		if (missing(format)) format <- "%Y-%m-%d"
           } else { # anything from "secs" to "weeks"
                maxx <- max(x, na.rm = TRUE)
                breaks <- seq(start, maxx + incr, breaks)
                if (length(breaks) > 2L)
                breaks <- breaks[seq_len(1L + max(which(breaks < maxx)))]
            }
        }
        else stop("invalid specification of 'breaks'")
    }
    res <- hist.default(unclass(x), unclass(breaks), plot = FALSE,
                        warn.unused = FALSE, right = right, ...)
    res$equidist <- TRUE # years are of uneven lengths
    res$xname <- xlab
    if(plot) {
        ## swallow '...' args only for hist.default() above & separate out 'axes':
        myplot <- function(res, xlab, freq, format, breaks,
                           include.lowest, fuzz, # <<- swallowed here
                           density = NULL, angle = 45, col = "lightgray",
                           border = NULL, lty = NULL,
                           labels = FALSE,
                           axes = TRUE, xaxt = par("xaxt"), ...)
        {
	    plot(res, xlab = xlab, axes = FALSE, freq = freq,
                 density = density, angle = angle, col = col,
                 border = border, lty = lty,
		 labels = labels, ...)
	    if(axes) {
		axis(2, ...)
		if(xaxt != "n") {
		    if(num.br)
                        breaks <- as.POSIXct(res$breaks,
                                             origin = "1970-01-01")
		    axis.POSIXct(1, at = breaks,  format = format, ...)
					# '...' : e.g. cex.axis
		}
	    }
        }
        myplot(res, xlab, freq, format, breaks, ...)
     }
    invisible(res)
}


## methods for class "Date"

axis.Date <- function(side, x, at, format, labels = TRUE, ...)
{
    has.at <- !missing(at) && !is.null(at)
    
    range <- sort(par("usr")[if(side %% 2) 1L:2L else 3:4L])
    range[1L] <- ceiling(range[1L])
    range[2L] <- floor(range[2L])
    rangeDate <- range
    class(rangeDate) <- "Date"

    if(has.at){
        # convert at to Date:
        if(is.numeric(at))
            class(at) <- "Date"
        else 
            at <- as.Date(at)
        z <- at[is.finite(at)]

        # find format if missing:
        if(missing(format)){
#            format <- if(!missing(x)) attr(grDevices:::prettyDate(x), "format") else attr(grDevices:::prettyDate(rangeDate), "format")
#        }else if(is.null(format)){ # exdend format if needed for proper representation of at
            format <- if(!missing(x)) extendDateTimeFormat(x, z) else extendDateTimeFormat(rangeDate, z)
            }
    } else {
        z <- grDevices:::prettyDate(rangeDate, n = par("lab")[2 - side %% 2])
        if(missing(format)) format <- attr(z, "format")
    }

    keep <- z >= range[1L] & z <= range[2L]
    z <- z[keep]
    if (!is.logical(labels)) 
        labels <- labels[keep]
    else if (isTRUE(labels))
        labels <- format(z, format = format)
    else if (isFALSE(labels))
        labels <- rep("", length(z)) # suppress labelling of ticks

    axis(side, at = z, labels = labels, ...)
}


hist.Date <- function(x, breaks, ..., xlab = deparse1(substitute(x)),
                      plot = TRUE, freq = FALSE,
                      start.on.monday = TRUE, format, right = TRUE)
{
    if(!inherits(x, "Date")) stop("wrong method")
    force(xlab)
    incr <- 1
    ## handle breaks ourselves
    if(missing(breaks))
        stop("Must specify 'breaks' in hist(<Date>)")
    if (inherits(breaks, "Date")) {
        breaks <- as.Date(breaks)
        d <- min(abs(diff(unclass(breaks))))
        if(d > 1) incr <- 1
        if(d > 7) incr <- 7
        if(d > 28) incr <- 28
        if(d > 366) incr <- 366
        num.br <- FALSE
    } else {
        num.br <- is.numeric(breaks) && length(breaks) == 1L
        if(num.br) {
            ## specified number of breaks
        } else if(is.character(breaks) && length(breaks) == 1L) {
            valid <- pmatch(breaks, c("days", "weeks", "months", "years",
                                      "quarters"))
            if(is.na(valid)) stop("invalid specification of 'breaks'")
            start <- as.POSIXlt(min(x, na.rm = TRUE))
            incr <- 1
            if(valid > 1L) { start$isdst <- -1L}
            if(valid == 2L) { ## "weeks"
                start$mday <- start$mday - start$wday
                if(start.on.monday)
                    start$mday <- start$mday + if(start$wday > 0L) 1L else -6L
                incr <- 7
                ## drops through to "days".
            }
            if(valid == 3L) { ## "months"
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (31 * 86400))
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- as.Date(seq(start, end, "months"))
                if (right)
                    breaks <- breaks - 1
		if (missing(format)) format <- "%Y-%m-%d"
            } else if(valid == 4L) { ## "years"
                start$mon <- 0L
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (366 * 86400))
                end$mon <- 0L
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- as.Date(seq(start, end, "years"))
                if (right)
                    breaks <- breaks - 1
		if (missing(format)) format <- "%Y-%m-%d"
            } else if(valid == 5L) { ## "quarters"
                qtr <- rep(c(0L, 3L, 6L, 9L), each = 3L)
                start$mon <- qtr[start$mon + 1L]
                start$mday <- 1L
                end <- as.POSIXlt(max(x, na.rm = TRUE))
                end <- as.POSIXlt(end + (93 * 86400))
                end$mon <- qtr[end$mon + 1L]
                end$mday <- 1L
                end$isdst <- -1L
                breaks <- as.Date(seq(start, end, "3 months"))
                if (right)
                    breaks <- breaks - 1
		if (missing(format)) format <- "%Y-%m-%d"
            } else { ## "days" (or "weeks")
                start <- as.Date(start)
                maxx <- max(x, na.rm = TRUE)
                breaks <- seq(start, maxx + incr, breaks)
                if (length(breaks) > 2L)
                breaks <- breaks[seq_len(1L + max(which(breaks < maxx)))]
            }
        } else stop("invalid specification of 'breaks'")
    }
    res <- hist.default(unclass(x), unclass(breaks), plot = FALSE,
                        warn.unused = FALSE, right = right, ...)
    res$equidist <- TRUE # years are of uneven lengths
    res$xname <- xlab
    if(plot) {
        ## swallow '...' args only for hist.default() above & separate out 'axes':
        myplot <- function(res, xlab, freq, format, breaks,
                           include.lowest, fuzz, # <<- swallowed here
                           density = NULL, angle = 45, col = "lightgray",
                           border = NULL, lty = NULL,
                           labels = FALSE,
                           axes = TRUE, xaxt = par("xaxt"), ...)
        {
            plot(res, xlab = xlab, axes = FALSE, freq = freq,
                 density = density, angle = angle, col = col,
                 border = border, lty = lty,
                 labels = labels, ...)
	    if(axes) {
                axis(2, ...)
              if(xaxt != "n") {
                if(num.br)
                    breaks <- as.Date(res$breaks,
                                      origin = "1970-01-01")
                axis.Date(1, at = breaks,  format = format, ...)
              }
            }
        }
        myplot(res, xlab, freq, format, breaks, ...)
     }
    invisible(res)
}

Axis.Date <- function(x=NULL, at=NULL, ..., side, labels=TRUE)
    axis.Date(side=side, x=x, at=at, labels=labels, ...)

Axis.POSIXt <- function(x=NULL, at=NULL, ..., side, labels=TRUE)
    axis.POSIXct(side=side, x=x, at=at, labels=labels, ...)

#  File src/library/graphics/R/dotchart.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2020 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/

dotchart <-
function(x, labels = NULL, groups = NULL, gdata = NULL, offset = 1/8,
         ann = par("ann"), xaxt = par("xaxt"), frame.plot = TRUE, log = "",
         cex = par("cex"), pt.cex = cex,
	 pch = 21, gpch = 21, bg = par("bg"),
	 color = par("fg"), gcolor = par("fg"), lcolor = "gray",
	 xlim = range(x[is.finite(x)]),
	 main = NULL, xlab = NULL, ylab = NULL, ...)
{
    ## old-style "graphics" design-bug: ("mar"), ("mai"), ("mar", "mai")
    ##			    all fail, just the following, ("mai", "mar") is ok:
    opar <- par("mai", "mar", "mgp", "cex", "yaxs")
    on.exit(par(opar))
    par(cex = cex, yaxs = "i")

    if(!is.numeric(x))
        stop("'x' must be a numeric vector or matrix")
    n <- length(x)
    if (is.matrix(x)) {
	if (is.null(labels))
	    labels <- rownames(x)
	if (is.null(labels))
	    labels <- as.character(seq_len(nrow(x)))
	labels <- rep_len(labels, n)
	if (is.null(groups))
	    groups <- col(x, as.factor = TRUE)
	glabels <- levels(groups)
    } else {
	if (is.null(labels)) labels <- names(x)
	glabels <- if(!is.null(groups)) levels(groups)
        if (!is.vector(x)) { # e.g. a table
            warning("'x' is neither a vector nor a matrix: using as.numeric(x)")
            x <- as.numeric(x)
        }
    }

    plot.new() # for strwidth()

    linch <-
	if(!is.null(labels)) max(strwidth(labels, "inch"), na.rm = TRUE) else 0
    if (is.null(glabels)) {
	ginch <- 0
	goffset <- 0
    }
    else {
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- offset
    }
    nmai <- opar[["mai"]]
    if(ann)
        nm.2 <- nmai[2L]
    if (!(is.null(labels) && is.null(glabels))) {
        ## The intention seems to be to balance the whitespace
        ## on each side (2 & 4) of the labels+plot.
	yi <- if(is.null(ylab) || !ann) 0 else offset
	nm.2 <- nmai[4L] + max(yi + linch + goffset, ginch) + 1/16
	if (nmai[2L] <	nm.2) { ## add space for ylab + glabels on left margin
	    nmai[2L] <- nm.2
	    par(mai = nmai)
	}
    }

    if (is.null(groups)) {
	o <- seq_len(n)
	y <- o
	ylim <- c(0, n + 1)
    }
    else {
	o <- sort.list(as.numeric(groups), decreasing = TRUE)
	x      <- x     [o]
	groups <- groups[o]
	color  <- rep_len(color,  length(groups))[o]
	lcolor <- rep_len(lcolor, length(groups))[o]
	pch    <- rep_len(pch,    length(groups))[o]
	of.1 <- cumsum(c(0, diff(as.numeric(groups)) != 0))
	y <- seq_len(n) + 2 * of.1
	ylim <- range(0, y + 2)
    }

    plot.window(xlim = xlim, ylim = ylim, log = log)
#    xmin <- par("usr")[1L]
    lheight <- par("csi")
    if (!is.null(labels)) {
	loffset <- (linch + 0.1)/lheight
        mtext(labels[o], side = 2, line = loffset, at = y, adj = 0,
              col = color, las = 2, cex = cex, ...)
    }
    abline(h = y, lty = "dotted", col = lcolor)
    points(x, y, pch = pch, col = color, bg = bg, cex = pt.cex/cex)
    if (!is.null(groups)) {
	gpos <- rev(cumsum(rev(tapply(groups, groups, length)) + 2) - 1)
	ginch <- max(strwidth(glabels, "inch"), na.rm = TRUE)
	goffset <- (max(linch+offset, ginch, na.rm = TRUE) + 1/16)/lheight
        mtext(glabels, side = 2, line = goffset, at = gpos,
              adj = 0, col = gcolor, las = 2, cex = cex, ...)
	if (!is.null(gdata)) {
	    abline(h = gpos, lty = "dotted")
	    points(gdata, gpos, pch = gpch, col = gcolor, bg = bg,
                   cex = pt.cex/cex, ...)
	}
    }
    axis(1, xaxt=xaxt) # FIXME? add '...' or use localAxis() as plot.default()
    if(frame.plot)
	box()
    if(ann) {
	title(main=main, xlab=xlab, ...) # with default "mgp"
	## y-axis label must be left of the (regular + group) labels:
	mgp <- par("mgp")
	par(mgp = c(max(mgp[1], nm.2 / lheight - 1.5), mgp[-1]))
	title(ylab=ylab, ...)
    }
    invisible()
}
#  File src/library/graphics/R/filled.contour.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2023 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/

filled.contour <-
function (x = seq(0, 1, length.out = nrow(z)),
          y = seq(0, 1, length.out = ncol(z)),
          z,
          xlim = range(x, finite=TRUE),
          ylim = range(y, finite=TRUE),
          zlim = range(z, finite=TRUE),
          levels = pretty(zlim, nlevels), nlevels = 20,
          color.palette = function(n) hcl.colors(n, "YlOrRd", rev = TRUE),
          col = color.palette(length(levels) - 1),
          plot.title, plot.axes, key.title, key.axes, key.border = NULL,
          asp = NA, xaxs = "i", yaxs = "i", las = 1, axes = TRUE,
          frame.plot = axes, ...)
{
    if (missing(z)) {
        if (!missing(x)) {
            if (is.list(x)) {
                z <- x$z
                y <- x$y
                x <- x$x
            }
            else {
                z <- x
                x <- seq.int(0, 1, length.out = nrow(z))
            }
        }
        else stop("no 'z' matrix specified")
    }
    else if (is.list(x)) {
        y <- x$y
        x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
        stop("increasing 'x' and 'y' values expected")

    mar.orig <- (par.orig <- par(c("mar","las","mfrow")))$mar
    on.exit(par(par.orig))

    w <- (3 + mar.orig[2L]) * par("csi") * 2.54
    layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
    par(las = las)

    ## Plot the 'plot key' (scale):
    mar <- mar.orig
    mar[4L] <- mar[2L]
    mar[2L] <- 1
    par(mar = mar)
    plot.new()
    plot.window(xlim = c(0,1), ylim = range(levels), xaxs = "i", yaxs = "i")
    rect(0, levels[-length(levels)], 1, levels[-1L], col = col, border = key.border)
    if (missing(key.axes)) {
        if (axes)
            axis(4)
    }
    else key.axes
    box()
    if (!missing(key.title))
	key.title

    ## Plot contour-image::
    mar <- mar.orig
    mar[4L] <- 1
    par(mar = mar)
    plot.new()
    plot.window(xlim, ylim, "", xaxs = xaxs, yaxs = yaxs, asp = asp)

    .filled.contour(x, y, z, levels, col)
    if (missing(plot.axes)) {
        if (axes) {
            title(main = "", xlab = "", ylab = "")
            Axis(x, side = 1)
            Axis(y, side = 2)
        }
    }
    else plot.axes
    if (frame.plot) box()
    if (missing(plot.title))
        title(...)
    else
	plot.title
    invisible()
}

.filled.contour <- function(x, y, z , levels, col)
{
    if (!is.matrix(z) || nrow(z) <= 1L || ncol(z) <= 1L)
        stop("no proper 'z' matrix specified")
    .External.graphics(C_filledcontour, x, y, z, levels, col)
    invisible()
}
#  File src/library/graphics/R/fourfoldplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 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/

fourfoldplot <-
function(x, color = c("#99CCFF", "#6699CC"), conf.level = 0.95,
         std = c("margins", "ind.max", "all.max"), margin = c(1, 2),
         space = 0.2, main = NULL, mfrow = NULL, mfcol = NULL)
{
    ## Code for producing fourfold displays.
    ## Reference:
    ##   Friendly, M. (1994).
    ##   A fourfold display for 2 by 2 by \eqn{k} tables.
    ##   Technical Report 217, York University, Psychology Department.
    ##   http://www.math.yorku.ca/SCS/Papers/4fold/4fold.ps.gz
    ##
    ## Implementation notes:
    ##
    ##   We need plots with aspect ratio FIXED to 1 and glued together.
    ##   Hence, even if k > 1 we prefer keeping everything in one plot
    ##   region rather than using a multiple figure layout.
    ##   Each 2 by 2 pie is is drawn into a square with x/y coordinates
    ##   between -1 and 1, with row and column labels in [-1-space, -1]
    ##   and [1, 1+space], respectively.  If k > 1, strata labels are in
    ##   an area with y coordinates in [1+space, 1+(1+gamma)*space],
    ##   where currently gamma=1.25.  The pies are arranged in an nr by
    ##   nc layout, with horizontal and vertical distances between them
    ##   set to space.
    ##
    ##   The drawing code first computes the complete are of the form
    ##     [0, totalWidth] x [0, totalHeight]
    ##   needed and sets the world coordinates using plot.window().
    ##   Then, the strata are looped over, and the corresponding pies
    ##   added by filling rows or columns of the layout as specified by
    ##   the mfrow or mfcol arguments.  The world coordinates are reset
    ##   in each step by shifting the origin so that we can always plot
    ##   as detailed above.

    if(!is.array(x))
        stop("'x' must be an array")
    if(length(dim(x)) == 2L) {
        x <- if(is.null(dimnames(x)))
            array(x, c(dim(x), 1L))
        else
            array(x, c(dim(x), 1L), c(dimnames(x), list(NULL)))
    }
    if(length(dim(x)) != 3L)
        stop("'x' must be 2- or 3-dimensional")
    if(any(dim(x)[1L:2L] != 2L))
        stop("table for each stratum must be 2 by 2")
    dnx <- dimnames(x)
    if(is.null(dnx))
        dnx <- vector("list", 3L)
    for(i in which(sapply(dnx, is.null)))
        dnx[[i]] <- LETTERS[seq_len(dim(x)[i])]
    if(is.null(names(dnx)))
        i <- 1L : 3L
    else
        i <- which(is.null(names(dnx)))
    if(any(i))
        names(dnx)[i] <- c("Row", "Col", "Strata")[i]
    dimnames(x) <- dnx
    k <- dim(x)[3L]

    if(!((length(conf.level) == 1) && is.finite(conf.level) &&
         (conf.level >= 0) && (conf.level < 1)))
        stop("'conf.level' must be a single number between 0 and 1")
    if(conf.level == 0)
        conf.level <- FALSE

    std <- match.arg(std)

    findTableWithOAM <- function(or, tab) {
        ## Find a 2x2 table with given odds ratio 'or' and the margins
        ## of a given 2x2 table 'tab'.
        m <- rowSums(tab)[1L]
        n <- rowSums(tab)[2L]
        t <- colSums(tab)[1L]
        if(or == 1)
            x <- t * n / (m + n)
        else if(or == Inf)
            x <- max(0, t - m)
        else {
            A <- or - 1
            B <- or * (m - t) + (n + t)
            C <- - t * n
            x <- (- B + sqrt(B ^ 2 - 4 * A * C)) / (2 * A)
        }
        matrix(c(t - x, x, m - t + x, n - x), nrow = 2)
    }

    drawPie <- function(r, from, to, n = 500, col = NA) {
        p <- 2 * pi * seq.int(from, to, length.out = n) / 360
        x <- c(cos(p), 0) * r
        y <- c(sin(p), 0) * r
        polygon(x, y, col = col)
        invisible(NULL)
    }

    stdize <- function(tab, std, x) {
        ## Standardize the 2 x 2 table 'tab'.
        if(std == "margins") {
            if(all(sort(margin) == c(1L, 2L))) {
                ## standardize to equal row and col margins
                u <- sqrt(odds(tab)$or)
                u <- u / (1 + u)
                y <- matrix(c(u, 1 - u, 1 - u, u), nrow = 2L)
            }
            else if(margin %in% c(1, 2))
                y <- proportions(tab, margin)
            else
                stop("incorrect 'margin' specification")
        }
        else if(std == "ind.max")
            y <- tab / max(tab)
        else if(std == "all.max")
            y <- tab / max(x)
        y
    }

    odds <- function(x) {
        ## Given a 2 x 2 or 2 x 2 x k table 'x', return a list with
        ## components 'or' and 'se' giving the odds ratios and standard
        ## deviations of the log odds ratios.
        if(length(dim(x)) == 2L) {
            dim(x) <- c(dim(x), 1L)
            k <- 1
        }
        else
            k <- dim(x)[3L]
        or <- double(k)
        se <- double(k)
        for(i in 1 : k) {
            f <- x[ , , i]
            storage.mode(f) <- "double" # protect against integer overflow
            if(any(f == 0))
                f <- f + 0.5
            or[i] <- (f[1L, 1L] * f[2L, 2L]) / (f[1L, 2L] * f[2L, 1L])
            se[i] <- sqrt(sum(1 / f))
        }
        list(or = or, se = se)
    }

    gamma <- 1.25                       # Scale factor for strata labels
    debug <- FALSE                      # Visualize the geometry.
                                        # Not settable by user!
    angle.f <- c( 90, 180,  0, 270)     # 'f' for 'from'
    angle.t <- c(180, 270, 90, 360)     # 't' for 'to'

    opar <- par(mar = c(0, 0, if(is.null(main)) 0 else 2.5, 0))
    on.exit(par(opar))

    byrow <- FALSE
    if(!is.null(mfrow)) {
        nr <- mfrow[1L]
        nc <- mfrow[2L]
    }
    else if(!is.null(mfcol)) {
        nr <- mfcol[1L]
        nc <- mfcol[2L]
        byrow <- TRUE
    }
    else {
        nr <- ceiling(sqrt(k))
        nc <- ceiling(k / nr)
    }
    if(nr * nc < k)
        stop("incorrect geometry specification")
    if(byrow)
        indexMatrix <- expand.grid(1 : nc, 1 : nr)[, c(2, 1)]
    else
        indexMatrix <- expand.grid(1 : nr, 1 : nc)

    totalWidth <- nc * 2 * (1 + space) + (nc - 1L) * space
    totalHeight <- if(k == 1)
        2 * (1 + space)
    else
        nr * (2 + (2 + gamma) * space) + (nr - 1L) * space
    xlim <- c(0, totalWidth)
    ylim <- c(0, totalHeight)

    dev.hold(); on.exit(dev.flush(), add = TRUE)
    plot.new()
    plot.window(xlim = xlim, ylim = ylim, asp = 1)

    o <- odds(x)

    scale <- space / (2 * strheight("Ag"))
    v <- 0.95 - max(strwidth(as.character(c(x)), cex = scale)) / 2

    for(i in 1 : k) {

        tab <- x[ , , i]

        fit <- stdize(tab, std, x)

        xInd <- indexMatrix[i, 2L]
        xOrig <- 2 * xInd - 1 + (3 * xInd - 2) * space
        yInd <- indexMatrix[i, 1L]
        yOrig <- if(k == 1)
            (1 + space)
        else
            (totalHeight
             - (2 * yInd - 1 + ((3 + gamma) * yInd - 2) * space))
        plot.window(xlim - xOrig, ylim - yOrig, asp = 1)

        if(debug) {
            abline(h = -1 - space)
            abline(h =  1 + space)
            abline(h =  1 + (1 + gamma) * space)
            abline(v = -1 - space)
            abline(v =  1 + space)
        }

        ## drawLabels()
        u <- 1 + space / 2
        adjCorr <- 0.2
        text(0, u,
             paste(names(dimnames(x))[1L],
                   dimnames(x)[[1L]][1L],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale)
        text(-u, 0,
             paste(names(dimnames(x))[2L],
                   dimnames(x)[[2L]][1L],
                   sep = ": "),
             adj = c(0.5, 0.5 - adjCorr),
             cex = scale,
             srt = 90)
        text(0, -u,
             paste(names(dimnames(x))[1L],
                   dimnames(x)[[1L]][2L],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale)
        text(u, 0,
             paste(names(dimnames(x))[2L],
                   dimnames(x)[[2L]][2L],
                   sep = ": "),
             adj = c(0.5, 0.5 + adjCorr),
             cex = scale,
             srt = 90)
        if(k > 1) {
            text(0, 1 + (1 + gamma / 2) * space,
                 paste(names(dimnames(x))[3L],
                       dimnames(x)[[3L]][i],
                       sep = ": "),
                 cex = gamma * scale)
        }

        ## drawFrequencies()
        d <- odds(tab)$or
        drawPie(sqrt(fit[1,1]),  90, 180, col = color[1 + (d > 1)])
        drawPie(sqrt(fit[2,1]), 180, 270, col = color[2 - (d > 1)])
        drawPie(sqrt(fit[1,2]),   0,  90, col = color[2 - (d > 1)])
        drawPie(sqrt(fit[2,2]), 270, 360, col = color[1 + (d > 1)])
        u <- 1 - space / 2
        text(c(-v, -v,  v,  v),
             c( u, -u,  u, -u),
             as.character(c(tab)),
             cex = scale)

        ## drawConfBands()
        if(is.numeric(conf.level)) {
            or <- o$or[i]
            se <- o$se[i]
            ## lower
            theta <- or * exp(stats::qnorm((1 - conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
            ## upper
            theta <- or * exp(stats::qnorm((1 + conf.level) / 2) * se)
            tau <- findTableWithOAM(theta, tab)
            r <- sqrt(c(stdize(tau, std, x)))
            for(j in 1 : 4)
                drawPie(r[j], angle.f[j], angle.t[j])
        }

        ## drawBoxes()
        polygon(c(-1,  1, 1, -1),
                c(-1, -1, 1,  1))
        lines(c(-1, 1), c(0, 0))
        for(j in seq.int(from = -0.8, to = 0.8, by = 0.2))
            lines(c(j, j), c(-0.02, 0.02))
        for(j in seq.int(from = -0.9, to = 0.9, by = 0.2))
            lines(c(j, j), c(-0.01, 0.01))
        lines(c(0, 0), c(-1, 1))
        for(j in seq.int(from = -0.8, to = 0.8, by = 0.2))
            lines(c(-0.02, 0.02), c(j, j))
        for(j in seq.int(from = -0.9, to = 0.9, by = 0.2))
            lines(c(-0.01, 0.01), c(j, j))

    }

    if(!is.null(main))
        mtext(main, cex = 1.5, adj = 0.5)

    return(invisible())
}
#  File src/library/graphics/R/grid.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2024 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/

.grid.at <- function(side, n, log, equilogs, axp, usr2, nintLog = NULL) {
    ## return 'at'
    if(is.null(n)) { ## align to tickmarks
        stopifnot(is.numeric(ax <- axp), length(ax) == 3L)
        if(log && equilogs && ax[3L] > 0) ax[3L] <- 1
        axTicks(side, axp = ax, usr=usr2, log=log, nintLog = nintLog)
    } else if(!is.na(n) && (n <- as.integer(n)) >= 1L) { # equidistant, also from box borders
        at <- seq.int(usr2[1L], usr2[2L], length.out = n+1L)
        (if(log) 10^at else at)[-c(1L,n+1L)]
    } # else NULL
}

grid <- function (nx = NULL, ny = nx, col="lightgray", lty="dotted",
                  lwd = par("lwd"), equilogs = TRUE, nintLog = NULL)
{
    atx <- if(is.null(nx) || (!is.na(nx) && nx >= 1))
	       .grid.at(1L, nx, log = par("xlog"), equilogs, axp = par("xaxp"), usr2 = par("usr")[1:2],
                        nintLog = nintLog[1])
    ## else NULL
    aty <- if(is.null(ny) || (!is.na(ny) && ny >= 1))
	       .grid.at(2L, ny, log = par("ylog"), equilogs, axp = par("yaxp"), usr2 = par("usr")[3:4],
                        nintLog = nintLog[min(2L, length(nintLog))])
    abline(v = atx, h = aty, col = col, lty = lty, lwd = lwd)
    invisible(list(atx = atx, aty = aty))
}
#  File src/library/graphics/R/hist.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2025 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/

hist <- function(x, ...) UseMethod("hist")

hist.default <-
    function (x, breaks = "Sturges", freq = NULL,
	      probability = !freq, include.lowest= TRUE,
	      right = TRUE, fuzz = 1e-7,
              density = NULL, angle = 45,
	      col = "lightgray", border = NULL,
	      main = paste("Histogram of", xname),
	      xlim = range(breaks), ylim = NULL,
	      xlab = xname, ylab,
	      axes = TRUE, plot = TRUE, labels = FALSE, nclass = NULL,
	      warn.unused = TRUE, ...)
{
    if (!is.numeric(x))
	stop("'x' must be numeric")
    xname <- deparse1(substitute(x), collapse="\n")
    n <- length(x <- x[is.finite(x)])
    n <- as.integer(n)
    if(is.na(n)) stop("invalid length(x)")
    use.br <- !missing(breaks)
    if(use.br) {
	if(!missing(nclass))
	    warning("'nclass' not used when 'breaks' is specified")
    }
    else if(!is.null(nclass) && length(nclass) == 1L)
	breaks <- nclass
    use.br <- use.br && (nB <- length(breaks)) > 1L
    if(use.br)
	breaks <- sort(breaks)
    else {				# construct vector of breaks
	if(!include.lowest) {
	    include.lowest <- TRUE
	    warning("'include.lowest' ignored as 'breaks' is not a vector")
	}
	if(is.character(breaks)) {
	    breaks <- match.arg(tolower(breaks),
				c("sturges", "fd",
				  "freedman-diaconis", "scott"))
	    breaks <- switch(breaks,
			     sturges = nclass.Sturges(x),
			     "freedman-diaconis" =,
			     fd = nclass.FD(x),
			     scott = nclass.scott(x),
			     stop("unknown 'breaks' algorithm"))
	} else if(is.function(breaks)) {
	    breaks <- breaks(x)
	}
        ## if(!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L)
        ##     stop("invalid number of 'breaks'")
        ## breaks <- pretty (range(x), n = breaks, min.n = 1)
        ## nB <- length(breaks)
        ## if(nB <= 1) ##-- Impossible !
        ##     stop(gettextf("hist.default: pretty() error, breaks=%s",
        ##                   format(breaks)), domain = NA)
        if (length(breaks) == 1) {
            if(!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L)
                stop("invalid number of 'breaks'")
	    if(breaks > 1e6) { # pretty() must have n <= maximal integer
		warning(gettextf("'breaks = %g' is too large and set to 1e6",
				 breaks), domain = NA)
		breaks <- 1e6L
	    }
            breaks <- pretty (range(x), n = breaks, min.n = 1)
            nB <- length(breaks)
            if(nB <= 1) ##-- Impossible !
                stop(gettextf("hist.default: pretty() error, breaks=%s",
                              format(breaks)), domain = NA)
        }
        else {
            if(!is.numeric(breaks) || length(breaks) <= 1)
                stop(gettextf("Invalid breakpoints produced by 'breaks(x)': %s",
                              format(breaks)), domain = NA)
            breaks <- sort(breaks)
            nB <- length(breaks)
            use.br <- TRUE # To allow equidist=FALSE below (FIXME: Find better way?)
        }
    }
    nB <- as.integer(nB)
    if(is.na(nB)) stop("invalid length(breaks)")

    ## Do this *before* adding fuzz or logic breaks down ..

    h <- as.double(diff(breaks))
    equidist <- !use.br || diff(range(h)) < 1e-7 * mean(h)
    if (!use.br && any(h <= 0))
	stop("'breaks' are not strictly increasing")
    freq1 <- freq # we want to do missing(freq) later
    if (is.null(freq)) {
	freq1 <- if(!missing(probability)) !as.logical(probability) else equidist
    } else if(!missing(probability) && any(probability == freq))
	stop("'probability' is an alias for '!freq', however they differ.")

    ## Fuzz to handle cases where points are "effectively on"
    ## the boundaries
    ## As one break point could be very much larger than the others,
    ## as from 1.9.1 we no longer use the range. (PR#6931)
    ## diddle <- 1e-7 * max(abs(range(breaks)))  ## NB: h == diff(breaks)
    stopifnot("fuzz must be non-negative" = fuzz >= 0)
    diddle <- fuzz * if(nB > 5) stats::median(h)
    ## for few breaks, protect against very large bins:
		     else if(nB <= 3) diff(range(x)) else min(h[h > 0])
    fuzz <- if(right)
	c(if(include.lowest) -diddle else diddle, rep.int(diddle, nB - 1L))
    else
	c(rep.int(-diddle, nB - 1L), if(include.lowest) diddle else -diddle)
    fuzzybreaks <- breaks + fuzz
    ## With the fuzz adjustment above, the "right" and "include"
    ## arguments are often irrelevant (but not with integer data!)
    counts <- .Call(C_BinCount, x, fuzzybreaks, right, include.lowest)
    if (any(counts < 0L))
	stop("negative 'counts'. Internal Error.", domain = NA)
    if (sum(counts) < n)
	stop("some 'x' not counted; maybe 'breaks' do not span range of 'x'")
    dens <- counts/(n*h) # use un-fuzzed intervals
    mids <- 0.5 * (breaks[-1L] + breaks[-nB])
    r <- structure(list(breaks = breaks, counts = counts,
			density = dens, mids = mids,
			xname = xname, equidist = equidist),
		   class = "histogram")
    if (plot) {
	plot(r, freq = freq1, col = col, border = border,
	     angle = angle, density = density,
	     main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab,
	     axes = axes, labels = labels, ...)
	invisible(r)
    }
    else { ## plot is FALSE
    	if (warn.unused) {
	    ## make an effort to warn about "nonsensical" arguments, notably those only in plot(.) above
	    nf <- names(formals()) ## all formals but those:
	    nf <- nf[is.na(match(nf, c("x", "breaks", "nclass", "plot",
				       "include.lowest", "right", "fuzz")))]
	    missE <- lapply(nf, function(n)
			    substitute(missing(.), list(. = as.name(n))))
	    not.miss <- ! vapply(missE, eval, NA, envir = environment())
	    nf <- nf[not.miss]
	    nnmiss <- sum(not.miss)
	    if(any(iM <- nf == "...")) { # replace "..." with arg names in `...`
		dnms <- ...names()
		nf     <- c(nf[!iM], dnms)
		nnmiss <- nnmiss -1L + length(dnms)
	    }
	    if(any(not.miss))
		warning(sprintf(ngettext(nnmiss,
					 "argument %s is not made use of",
					 "arguments %s are not made use of"),
				paste(sQuote(nf), collapse=", ")),
			domain = NA)
	}
        r
    }
}

plot.histogram <-
    function (x, freq = equidist, density = NULL, angle = 45,
	      col = "lightgray", border = NULL, lty = NULL,
	      main = paste("Histogram of", paste(x$xname, collapse="\n")),
              sub = NULL,
	      xlab = x$xname, ylab,
	      xlim = range(x$breaks), ylim = NULL, log = "",
	      axes = TRUE, labels = FALSE, add = FALSE, ann = TRUE, ...)
{
    equidist <-
	if(is.logical(x$equidist)) x$equidist
	else { h <- diff(x$breaks) ; diff(range(h)) < 1e-7 * mean(h) }
    if(freq && !equidist)
	warning("the AREAS in the plot are wrong -- rather use 'freq = FALSE'")

    y <- if (freq) x$counts else x$density
    nB <- length(x$breaks)
    if(is.null(y) || 0L == nB) stop("'x' is wrongly structured")

    dev.hold(); on.exit(dev.flush())
    if(!add) {
	if(is.null(ylim))
	    ylim <- range(y, 0)
	if (missing(ylab))
	    ylab <- if (!freq) "Density" else "Frequency"
	plot.new()
	plot.window(xlim, ylim, log, ...)	#-> ylim's default from 'y'
	if(ann) title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
	if(axes) {
	    axis(1, ...)
            yt <- axTicks(2)
            if(freq && any(ni <- (yt %% 1) != 0)) # remove non-integers:
                yt <- yt[!ni]
	    axis(2, at=yt, ...)
	}
    }
    rect(x$breaks[-nB], 0, x$breaks[-1L], y,
	 col = col, border = border,
	 angle = angle, density = density, lty = lty)
    if((logl <- is.logical(labels) && labels) || is.character(labels))
	text(x$mids, y,
	     labels = if(logl) {
		 if(freq) x$counts else round(x$density,3)
	     } else labels,
	     adj = c(0.5, -0.5))
    invisible()
}

lines.histogram <- function(x, ...) plot.histogram(x, ..., add = TRUE)

#  File src/library/graphics/R/identify.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 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/

identify <- function(x, ...) UseMethod("identify")

identify.default <-
    function(x, y = NULL, labels = seq_along(x), pos = FALSE,
             n = length(x), plot = TRUE, atpen = FALSE,
             offset = 0.5, tolerance = 0.25, order = FALSE, ...)
{
    if(length(extras <- list(...))) {
        opar <- par(extras)
        on.exit(par(opar))
    }
    xy <- xy.coords(x, y, setLab = FALSE)
    x <- xy$x
    y <- xy$y
    if (length(x) == 0) {
        if (!pos && !order)
            return(numeric())
        else {
            result <- list(ind = numeric())
            if (pos)
                result$pos <- numeric()
            if (order)
                result$order <- numeric()
            return(result)
        }
    }
    z <- .External2(C_identify, x, y, as.character(labels), n, plot,
                    offset, tolerance, atpen)
    i <- seq.int(z[[1L]])[z[[1L]]]
    if (!pos && !order) 
        i
    else {
        result <- list(ind = i)
        if (pos)
            result$pos <- z[[2L]][z[[1L]]]
        if (order)
            result$order <- z[[3L]][z[[1L]]]
        result
    }
}
#  File src/library/graphics/R/image.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2014 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/

image <- function(x, ...) UseMethod("image")

image.default <- function (x = seq(0, 1, length.out = nrow(z)),
		   y = seq(0, 1, length.out = ncol(z)),
		   z,
		   zlim = range(z[is.finite(z)]),
		   xlim = range(x),
		   ylim = range(y),
		   col = hcl.colors(12, "YlOrRd", rev = TRUE),
                   add = FALSE,
		   xaxs = "i", yaxs = "i", xlab, ylab,
                   breaks, oldstyle = FALSE,
                   useRaster, ...)
{
    if (missing(z)) {
	if (!missing(x)) {
	    if (is.list(x)) {
		z <- x$z; y <- x$y; x <- x$x
	    } else {
		if(is.null(dim(x)))
		   stop("argument must be matrix-like")
		z <- x
		x <- seq.int(0, 1, length.out = nrow(z))
	    }
	    if (missing(xlab)) xlab <- ""
	    if (missing(ylab)) ylab <- ""
	} else stop("no 'z' matrix specified")
    } else if (is.list(x)) {
	xn <- deparse1(substitute(x))
	if (missing(xlab)) xlab <- paste0(xn, "$x")
	if (missing(ylab)) ylab <- paste0(xn, "$y")
	y <- x$y
	x <- x$x
    } else {
	if (missing(xlab))
	    xlab <- if (missing(x)) "" else deparse1(substitute(x))
	if (missing(ylab))
	    ylab <- if (missing(y)) "" else deparse1(substitute(y))
    }
    if (any(!is.finite(x)) || any(!is.finite(y)))
        stop("'x' and 'y' values must be finite and non-missing")
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
	stop("increasing 'x' and 'y' values expected")
    if (!is.matrix(z))
        stop("'z' must be a matrix")
    if (!typeof(z) %in% c("logical", "integer", "double"))
        stop("'z' must be numeric or logical")
    if (length(x) > 1 && length(x) == nrow(z)) { # midpoints
        dx <- 0.5*diff(x)
        x <- c(x[1L] - dx[1L], x[-length(x)] + dx,
               x[length(x)] + dx[length(x)-1])
    }
    if (length(y) > 1 && length(y) == ncol(z)) { # midpoints
        dy <- 0.5*diff(y)
        y <- c(y[1L] - dy[1L], y[-length(y)] + dy,
               y[length(y)] + dy[length(y)-1L])
    }

    if (missing(breaks)) {
        nc <- length(col)
        if (!missing(zlim) && (any(!is.finite(zlim)) || diff(zlim) < 0))
            stop("invalid z limits")
        if (diff(zlim) == 0)
            zlim <- if (zlim[1L] == 0) c(-1, 1)
                    else zlim[1L] + c(-.4, .4)*abs(zlim[1L])
        z <- (z - zlim[1L])/diff(zlim)
        zi <- if (oldstyle) floor((nc - 1) * z + 0.5)
              else floor((nc - 1e-5) * z + 1e-7)
        zi[zi < 0 | zi >= nc] <- NA
    } else {
	if (length(breaks) != length(col) + 1)
	    stop("must have one more break than colour")
	if (any(!is.finite(breaks)))
	    stop("'breaks' must all be finite")
        if (is.unsorted(breaks)) {
            warning("unsorted 'breaks' will be sorted before use")
            breaks <- sort(breaks)
        }
        ## spatstat passes a factor matrix here, but .bincode converts to double
        zi <- .bincode(z, breaks, TRUE, TRUE) - 1L
    }
    if (!add) # use xlim, ylim here to get dispatch on Axis.
	plot(xlim, ylim, xlim = xlim, ylim = ylim, type = "n", xaxs = xaxs,
	     yaxs = yaxs, xlab = xlab, ylab = ylab, ...)
    ## need plot set up before we do this
    if (length(x) <= 1) x <- par("usr")[1L:2]
    if (length(y) <= 1) y <- par("usr")[3:4]
    if (length(x) != nrow(z)+1 || length(y) != ncol(z)+1)
        stop("dimensions of z are not length(x)(-1) times length(y)(-1)")

    check_irregular <- function(x, y)
    {
        # check that the grid is regular
        dx <- diff(x)
        dy <- diff(y)
        (length(dx) && !isTRUE(all.equal(dx, rep(dx[1], length(dx))))) ||
        (length(dy) && !isTRUE(all.equal(dy, rep(dy[1], length(dy)))))
    }
    if (missing(useRaster)) {
       useRaster <- getOption("preferRaster", FALSE)
       if (useRaster && check_irregular(x, y)) useRaster <- FALSE
       if (useRaster) {
           useRaster <- FALSE
           ras <- dev.capabilities("rasterImage")$rasterImage
           if(identical(ras, "yes")) useRaster <- TRUE
           if(identical(ras, "non-missing")) useRaster <- all(!is.na(zi))
       }
    }
    if (useRaster) {
         if(check_irregular(x,y))
            stop(gettextf("%s can only be used with a regular grid",
                          sQuote("useRaster = TRUE")),
                 domain = NA)
        # this should be mostly equivalent to RGBpar3 with bg = R_TRANWHITE
        if (!is.character(col)) {
            col <- as.integer(col)
            if (any(!is.na(col) & col < 0L))
                stop("integer colors must be non-negative")
            col[col < 1L] <- NA_integer_
            p <- palette()
            col <- p[((col - 1L) %% length(p)) + 1L]
        }
        zc <- col[zi + 1L]
        dim(zc) <- dim(z)
        zc <- t(zc)[ncol(zc):1L,, drop = FALSE]
        rasterImage(as.raster(zc),
                    min(x), min(y), max(x), max(y),
                    interpolate = FALSE)
     } else .External.graphics(C_image, x, y, zi, col)
    invisible()
}
#  File src/library/graphics/R/layout.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

## FIXME: Deprecate! - users *can* use  paste(.., "cm") themselves!
lcm <- function(x) paste(x, "cm")#-> 3 characters (used in layout!)

layout <-
    function(mat, widths = rep.int(1, ncol(mat)),
	     heights = rep.int(1, nrow(mat)), respect = FALSE)
{
    storage.mode(mat) <- "integer"
    mat <- as.matrix(mat) # or barf
    if(!is.logical(respect)) {
	respect <- as.matrix(respect)#or barf
	if(!is.matrix(respect) || any(dim(respect) != dim(mat)))
	    stop("'respect' must be logical or matrix with same dimension as 'mat'")
    }
    num.figures <- as.integer(max(mat))
    ## check that each value in 1..n is mentioned
    for (i in 1L:num.figures)
	if (match(i, mat, nomatch=0L) == 0L)
            stop(gettextf("layout matrix must contain at least one reference\nto each of the values {1 ... %d}\n",
                          num.figures), domain = NA)

    dm <- dim(mat)
    num.rows <- dm[1L]
    num.cols <- dm[2L]

    cm.widths  <- if (is.character(widths)) grep("cm", widths, fixed = TRUE)
    cm.heights <- if (is.character(heights)) grep("cm", heights, fixed = TRUE)

    ## pad widths/heights with 1's	and remove "cm" tags
    pad1.rm.cm <- function(v, cm.v, len) {
	if ((ll <- length(v)) < len)
	    v <- c(v, rep.int(1, len-ll))
	if (is.character(v)) {
	    wcm <- v[cm.v]
	    v[cm.v] <- substring(wcm, 1L, nchar(wcm, type="c") - 3)
            v <- chartr(getOption("OutDec"), ".", v)
	}
	as.numeric(v)
    }
    widths  <- pad1.rm.cm(widths, cm.widths,  len = num.cols)
    heights <- pad1.rm.cm(heights,cm.heights, len = num.rows)

    if (is.matrix(respect)) {
	respect.mat <- as.integer(respect)
	respect <- 2
    } else {# respect: logical	|--> 0 or 1
	respect.mat <- matrix(0L, num.rows, num.cols)
    }
    .External.graphics(C_layout,
                       num.rows, num.cols,
                       mat,# integer
                       as.integer(num.figures),
                       col.widths = widths,
                       row.heights = heights,
                       cm.widths,
                       cm.heights,
                       respect = as.integer(respect),
                       respect.mat)
    invisible(num.figures)
}

layout.show <- function(n=1)
{
    ## cheat to make sure that current plot is figure 1
    oma.saved <- par("oma")
    par(oma=rep.int(0,4))
    par(oma=oma.saved)

    o.par <- par(mar=rep.int(0,4))
    on.exit(par(o.par))
    for (i in seq_len(n)) {
	plot.new()
	box()
	text(0.5, 0.5, i)
    }
    invisible()
}
#  File src/library/graphics/R/legend.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/

legend <-
function(x, y = NULL, legend, fill = NULL, col = par("col"), border="black",
         lty, lwd, pch, angle = 45, density = NULL, bty = "o", bg = par("bg"),
         box.lwd = par("lwd"), box.lty = par("lty"), box.col = par("fg"),
	 pt.bg = NA, cex = 1, pt.cex = cex, pt.lwd = lwd,
	 xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = c(0, 0.5),
	 text.width = NULL, text.col = par("col"), text.font = NULL,
	 merge = do.lines && has.pch, trace = FALSE,
	 plot = TRUE, ncol = 1, horiz = FALSE, title = NULL,
	 inset = 0, xpd, title.col = text.col[1], title.adj = 0.5, 
	 title.cex = cex[1], title.font = text.font[1],
         seg.len = 2)
{
    ## the 2nd arg may really be `legend'
    if(missing(legend) && !missing(y) && (is.character(y) || is.expression(y))) {
	legend <- y
	y <- NULL
    }
    mfill <- !missing(fill) || !missing(density)

    if(!missing(xpd)) {
        op <- par("xpd")
        on.exit(par(xpd=op))
        par(xpd=xpd)
    }
    if(is.null(text.font)) text.font <- par("font")
    title <- as.graphicsAnnot(title)
    if(length(title) > 1) stop("invalid 'title'")
    legend <- as.graphicsAnnot(legend)
	## if legend is a length one call or a list containing at least one call, 
	## we want to convert to an expression:
	if(any(vapply(legend, is.language, NA))) legend <- as.expression(legend)
    n.leg <- length(legend)
    if(n.leg == 0) stop("'legend' is of length 0")
    auto <-
	if (is.character(x))
	    match.arg(x, c("bottomright", "bottom", "bottomleft", "left",
			   "topleft", "top", "topright", "right", "center"))
	else NA

    if (is.na(auto)) {
	xy <- xy.coords(x, y, setLab = FALSE); x <- xy$x; y <- xy$y
	nx <- length(x)
	if (nx < 1 || nx > 2) stop("invalid coordinate lengths")
    } else nx <- 0

    reverse.xaxis <- par("xaxp")[1] > par("xaxp")[2]
    reverse.yaxis <- par("yaxp")[1] > par("yaxp")[2]    
    xlog <- par("xlog")
    ylog <- par("ylog")

    ## recycle
    cex <- rep(cex, length.out=n.leg)
    x.intersp <- rep(x.intersp, length.out=n.leg)
    seg.len <- rep(seg.len, length.out=n.leg)

    rect2 <- function(left, top, dx, dy, density = NULL, angle, ...) {
	r <- left + dx; if(xlog) { left <- 10^left; r <- 10^r }
	b <- top  - dy; if(ylog) {  top <- 10^top;  b <- 10^b }
	rect(left, top, r, b, angle = angle, density = density, ...)
    }
    segments2 <- function(x1, y1, dx, dy, ...) {
	x2 <- x1 + dx; if(xlog) { x1 <- 10^x1; x2 <- 10^x2 }
	y2 <- y1 + dy; if(ylog) { y1 <- 10^y1; y2 <- 10^y2 }
	segments(x1, y1, x2, y2, ...)
    }
    points2 <- function(x, y, ...) {
	if(xlog) x <- 10^x
	if(ylog) y <- 10^y
	points(x, y, ...)
    }
    text2 <- function(x, y, ...) {
	##--- need to adjust  adj == c(xadj, yadj) ?? --
	if(xlog) x <- 10^x
	if(ylog) y <- 10^y
	text(x, y, ...)
    }
    colwise <- function(x, n, ncol, n.legpercol, fun, reverse=FALSE){
	## needed for legend with >1 columns
	xmat <- matrix(c(rep(x, length.out=n), rep(0L, n.legpercol * ncol - n)), ncol=ncol)
	res <- apply(xmat, 2, fun)
	res[res == 0L] <- max(res) # space for empty columns
	if(reverse) -res else res
    }
    rowwise <- function(x, n, ncol, n.legpercol, fun, reverse=FALSE){
	## needed for legend with >1 rows
	xmat <- matrix(c(rep(x, length.out=n), rep(0L, n.legpercol * ncol - n)), ncol=ncol)
	res <- apply(xmat, 1, fun)
	if(reverse) -res else res
    }
    if(trace) {
	catn <- function(...)
	    do.call(cat, c(lapply(list(...),formatC), "\n"))
        fv <- function(...)
            paste(vapply(lapply(list(...), formatC),
                         paste, collapse=",", ""),
                  collapse=", ")
    }

    ## number of ("rbinded") legends _per_ column:
    n.legpercol <-
	if(horiz) {
	    if(ncol != 1)
                warning(gettextf("horizontal specification overrides: Number of columns := %d",
                                 n.leg), domain = NA)
	    ncol <- n.leg
	    1
	} else ceiling(n.leg / ncol)

    Cex <- cex * par("cex") # = the `effective' cex for text

    ## at this point we want positive width even for reversed x axis.
    if(is.null(text.width))
	text.width <- max(abs(mapply(strwidth, legend, cex = cex,
				     font = text.font, MoreArgs = list(units = "user"))))
    else if((length(text.width) > 1L && any(is.na(text.width)))  ||
            (all(!is.na(text.width)) && (!is.numeric(text.width) || any(text.width < 0))))
	stop("'text.width' must be numeric, >= 0, or a scalar NA")

    if(auto.text.width <- all(is.na(text.width))) {
	## textwidth for each legend element
	text.width <- abs(mapply(strwidth, legend, cex = cex, 
				 font = text.font, MoreArgs = list(units = "user")))
	ncol <- ceiling(n.leg / n.legpercol) # adjust ncol to the really needed number
    }

    xyc <- xyinch(par("cin"), warn.log=FALSE) # [uses par("usr") and "pin"]
    xc <- Cex * xyc[1L]
    yc <- Cex * xyc[2L]
    if(any(xc < 0)) text.width <- -text.width

    xchar  <- xc
    xextra <- 0

    y.intersp <- rep(y.intersp, length.out=n.legpercol)
    yextra <- rowwise(yc, n=n.leg, ncol=ncol, n.legpercol=n.legpercol, 
                      fun=function(x) max(abs(x)), reverse = reverse.yaxis) * (y.intersp - 1)
    ## watch out for reversed axis here: heights can be negative
    ymax <- sign(yc[1]) * max(abs(yc)) *
		max(1, mapply(strheight, legend, cex = cex, font = text.font,
			      MoreArgs = list(units = "user"))/yc)
    ychar <- yextra + ymax
    ymaxtitle <- title.cex * par("cex") * xyc[2L] * 
    	max(1, strheight(title, cex = title.cex, font = title.font, units = "user") / 
		(title.cex * par("cex") * xyc[2L]))
    ychartitle <- yextra[1] + ymaxtitle
    if(trace) catn("  xchar=", fv(xchar), "; (yextra, ychar)=", fv(yextra,ychar))

    if(mfill) {
	##= sizes of filled boxes.
	xbox <- xc * 0.8
	ybox <- yc * 0.5
	dx.fill <- max(xbox) ## + x.intersp*xchar
    }
    do.lines <- (!missing(lty) && (is.character(lty) || any(lty > 0))
		 ) || !missing(lwd)

    has.pch <- !missing(pch) && length(pch) > 0 # -> default 'merge' is available
    if(do.lines) {
	x.off <- if(merge) -0.7 else 0
    } else if(merge)
	warning("'merge = TRUE' has no effect when no line segments are drawn")

    if(has.pch) {
	if(is.character(pch) && !is.na(pch[1L]) &&
           nchar(pch[1L], type = "c") > 1) {
	    if(length(pch) > 1)
		warning("not using pch[2..] since pch[1L] has multiple chars")
	    np <- nchar(pch[1L], type = "c")
	    pch <- substr(rep.int(pch[1L], np), 1L:np, 1L:np)
	}
        ## this coercion was documented but not done in R < 3.0.0
        if(!is.character(pch)) pch <- as.integer(pch)
    }

    if (is.na(auto)) {
	##- Adjust (x,y) :
	if (xlog) x <- log10(x)
	if (ylog) y <- log10(y)
    }
    if(nx == 2) {
	## (x,y) are specifiying OPPOSITE corners of the box
	x <- sort(x)
	y <- sort(y)
	left <- x[1L]
	top  <- y[2L]
	w <- diff(x)# width
	h <- diff(y)# height
	w0 <- w/ncol # column width

	x <- mean(x)
	y <- mean(y)
	if(missing(xjust)) xjust <- 0.5
	if(missing(yjust)) yjust <- 0.5
    }
    else {## nx == 1  or  auto
	## -- (w,h) := (width,height) of the box to draw -- computed in steps
	yc <- rowwise(yc, n.leg, ncol, n.legpercol,
		      fun = function(x) max(abs(x)), reverse = reverse.yaxis)
	h <- sum(ychar) + yc[length(yc)] + (!is.null(title)) * ychartitle

	## calculate optimal width per column, and other widths
	xch1 <- colwise(xchar, n.leg, ncol, n.legpercol,
			fun = function(x) max(abs(x)), reverse=reverse.xaxis)
	x.interspCol <- colwise(x.intersp, n.leg, ncol, n.legpercol, fun = max)
	seg.lenCol <- colwise(seg.len, n.leg, ncol, n.legpercol, fun = max)
	text.width <- colwise(text.width, n = if(auto.text.width) n.leg else ncol, ncol,
			      n.legpercol = if(auto.text.width) n.legpercol else 1,
			      fun = function(x) max(abs(x)), reverse=reverse.xaxis)

	w0 <- text.width + (x.interspCol + 1) * xch1
	if(mfill)	w0 <- w0 + dx.fill
	if(do.lines)	w0 <- w0 + (seg.lenCol + x.off)*xch1

	w <- sum(w0) + 0.5 * xch1[ncol]   # width of box

	if (!is.null(title)
	    && (abs(tw <- strwidth(title, units="user", 
                               cex = title.cex, font = title.font) + 
			0.5 * title.cex * par("cex") * xyc[1L])) > abs(w)) {
	    xextra <- (tw - w)/2
	    w <- tw
	}

	##-- (w,h) are now the final box width/height.

	if (is.na(auto)) {
	    left <- x - xjust * w
	    top	 <- y + (1 - yjust) * h
	} else {
	    usr <- par("usr")
	    inset <- rep_len(inset, 2)
	    insetx <- inset[1L]*(usr[2L] - usr[1L])
	    left <- switch(auto, "bottomright" =,
			   "topright" =, "right" = usr[2L] - w - insetx,
			   "bottomleft" =, "left" =, "topleft" = usr[1L] + insetx,
			   "bottom" =, "top" =, "center" = (usr[1L] + usr[2L] - w)/2)
	    insety <- inset[2L]*(usr[4L] - usr[3L])
	    top <- switch(auto, "bottomright" =,
			  "bottom" =, "bottomleft" = usr[3L] + h + insety,
			  "topleft" =, "top" =, "topright" = usr[4L] - insety,
			  "left" =, "right" =, "center" = (usr[3L] + usr[4L] + h)/2)
	}
    }

    if (plot && bty != "n") { ## The legend box :
	if(trace)
	    catn("  rect2(", left, ",", top,", w=", w, ", h=", h, ", ...)",
                 sep = "")
	rect2(left, top, dx = w, dy = h, col = bg, density = NULL,
              lwd = box.lwd, lty = box.lty, border = box.col)
    }

    ## (xt[],yt[]) := `current' vectors of (x/y) legend text
    xt <- left + xc + xextra +  
	rep(c(0, cumsum(w0))[1L:ncol], each=n.legpercol, length.out=n.leg)
    topspace <- 0.5 * ymax + (!is.null(title)) * ychartitle
    yt <- top -	topspace - cumsum((c(0, ychar)/2 + c(ychar, 0)/2)[1L:n.legpercol])
    yt <- rep(yt, length.out=n.leg)

    if (mfill) {			#- draw filled boxes -------------
	if(plot) {
	    if(!is.null(fill)) fill <- rep_len(fill, n.leg)
	    rect2(left = xt, top=yt+ybox/2, dx = xbox, dy = ybox,
		  col = fill,
		  density = density, angle = angle, border = border)
	}
	xt <- xt + dx.fill
    }
    if(plot && (has.pch || do.lines))
	col <- rep_len(col, n.leg)

    ## NULL is not documented but people use it.
    if(missing(lwd) || is.null(lwd))
	lwd <- par("lwd") # = default for pt.lwd
    if (do.lines) {			#- draw lines ---------------------
        ## NULL is not documented
	if(missing(lty) || is.null(lty)) lty <- 1
	lty <- rep_len(lty, n.leg)
	lwd <- rep_len(lwd, n.leg)
	ok.l <- !is.na(lty) & (is.character(lty) | lty > 0) & !is.na(lwd)
	if(trace)
	    catn("  segments2(",xt[ok.l] + x.off*xchar[ok.l], ",", yt[ok.l],
		 ", dx=", (seg.len*xchar)[ok.l], ", dy=0, ...)")
	if(plot)
	    segments2(xt[ok.l] + x.off*xchar[ok.l], yt[ok.l],
                      dx = (seg.len*xchar)[ok.l], dy = 0,
		      lty = lty[ok.l], lwd = lwd[ok.l], col = col[ok.l])
	# if (!merge)
	xt <- xt + (seg.len+x.off) * xchar
    }
    if (has.pch) {			#- draw points -------------------
	pch <- rep_len(pch, n.leg)
	pt.bg <- rep_len(pt.bg, n.leg)
	pt.cex <- rep_len(pt.cex, n.leg)
	pt.lwd <- rep_len(pt.lwd, n.leg)
        ok <- !is.na(pch)
        if (!is.character(pch)) {
            ## R 2.x.y omitted pch < 0
            ok <- ok & (pch >= 0 | pch <= -32)
        } else {
            ## like points
            ok <- ok & nzchar(pch)
        }
	x1 <- (if(merge && do.lines) xt-(seg.len/2)*xchar else xt)[ok]
	y1 <- yt[ok]
	if(trace)
	    catn("  points2(", x1,",", y1,", pch=", pch[ok],", ...)")
	if(plot)
	    points2(x1, y1, pch = pch[ok], col = col[ok],
		    cex = pt.cex[ok], bg = pt.bg[ok], lwd = pt.lwd[ok])
    }

    xt <- xt + x.intersp * xc
    if(plot) {
	if (!is.null(title))
            text2(left + w*title.adj, top - ymaxtitle, labels = title,
                  adj = c(title.adj, 0), cex = title.cex, 
                  col = title.col, font = title.font)

	text2(xt, yt, labels = legend, adj = adj, cex = cex,
	      col = text.col, font = text.font)
    }
    invisible(list(rect = list(w = w, h = h, left = left, top = top),
		   text = list(x = xt, y = yt)))
}
#  File src/library/graphics/R/lines.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

lines <- function(x, ...) UseMethod("lines")

lines.default <- function(x, y=NULL, type="l", ...)
    plot.xy(xy.coords(x, y), type=type, ...)

lines.table <- function (x, y = NULL, type = "h", lwd = 2,  ...)
{
     if (is.null(y) && length(dim(x)) == 1L) {
         nx <- dimnames(x)[[1L]]
         is.num <- suppressWarnings(!any(is.na(xx <- as.numeric(nx))))
         x0 <- if (is.num) xx else seq_along(x)
         lines(x0, unclass(x), type = type, lwd = lwd, ...)
     }
     else stop("only for 1-D table")
}

## lines.formula  --> ./plot.R
#  File src/library/graphics/R/locator.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

locator <- function(n = 512, type="n", ...)
{
    if(length(extras <- list(...))) {
        opar <- par(extras)
        on.exit(par(opar))
    }
    z <- .External2(C_locator, n, type = type) # n <= 0 gives error
    x <- z[[1L]]
    y <- z[[2L]]
    if((n <- z[[3L]]) > 0) list(x=x[1L:n], y=y[1L:n])
}
#  File src/library/graphics/R/matplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2020 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/

## Author: Martin Maechler, Date: 27 Jun 97

matpoints <-
    function(x, y,  type = "p", lty = 1:5, lwd = 1, pch = NULL, col = 1:6, ...)
    matplot(x = x, y = y, type  =  type, lty = lty, lwd = lwd, pch = pch,
            col = col, add = TRUE, ...)

matlines  <-
    function(x, y, type = "l", lty = 1:5, lwd = 1, pch = NULL, col = 1:6, ...)
    matplot(x = x, y = y, type = type, lty = lty, lwd = lwd, pch = pch,
            col = col, add = TRUE, ...)

matplot <- function(x, y, type = "p",
		    lty = 1:5, lwd = 1, lend = par("lend"),
                    pch = NULL, col = 1:6, cex = NULL, bg = NA,
		    xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
		    log = "",
		    ..., add = FALSE, verbose = getOption("verbose"))
{
    paste.ch <- function(chv) paste0('"',chv,'"', collapse=" ")
    str2vec <- function(string) {
	if(nchar(string, type="c")[1L] > 1L) strsplit(string[1L], NULL)[[1L]]
	else string
    }
    ## These from plot.default :
    xlabel <- if (!missing(x)) deparse1(substitute(x))# else NULL
    ylabel <- if (!missing(y)) deparse1(substitute(y))
    ##
    if(missing(x)) {
	if(missing(y)) stop("must specify at least one of 'x' and 'y'")
	else x <- seq_len(NROW(y))
    } else if(missing(y)) {
	y <- x;	 ylabel <- xlabel
	x <- seq_len(NROW(y)); xlabel <- ""
    }
    ## To preserve class, typically don't use as.matrix() or matrix() but only `dim<-`:
    if(is.matrix(x)) {
        n <- nrow(x)
    } else if(!is.null(dim(x))) { # matrix-like: data.frame, sparseMatrix, ..
        n <- nrow(x <- as.matrix(x))
    } else {
        n <- length(x)
        dim(x) <- c(n, 1L)
    }
    if(is.matrix(y)) {
        ## nothing
    } else if(!is.null(dim(y))) { # matrix-like
        y <- as.matrix(y)
    } else {
        dim(y) <- c(length(y), 1L)
    }
    if(n != nrow(y)) stop("'x' and 'y' must have same number of rows")
    kx <- ncol(x)
    ky <- ncol(y)
    if(!kx || !ky) return(invisible())
    ## otherwise kx, ky >= 1
    if(FALSE) ## No longer needed:
    if(kx > 1L && ky > 1L && kx != ky)
	stop("'x' and 'y' must have only 1 or the same number of columns")
    k <- max(kx, ky)

    type <- str2vec(type)
    if(is.null(pch)) {
	pch <- c(1L:9L, 0L, letters, LETTERS)
	if(k > length(pch) && any(type %in% c("p","o","b")))
	    warning("default 'pch' is smaller than number of columns and hence recycled")
    } else if(is.character(pch)) pch <- str2vec(pch)
    ## else pch is numeric supposedly
    if(verbose)
	message("matplot: doing ", k, " plots with ",
		paste0(" col= (", paste.ch(col), ")"),
		paste0(" pch= (", paste.ch(pch), ")"),
		" ...\n", domain=NA)
    xy <- xy.coords(x, y, xlabel, ylabel, log = log, recycle=TRUE) # recycle if kx or ky is 1
    if(is.null(xlab)) xlab <- xy$xlab
    if(is.null(ylab)) ylab <- xy$ylab
    if(is.null(xlim)) xlim <- range(xy$x[is.finite(xy$x)])
    if(is.null(ylim)) ylim <- range(xy$y[is.finite(xy$y)])
    if(length(type)< k) type <- rep_len(type,k)
    if(length(lty) < k) lty  <- rep_len(lty, k)
    if(length(lend)< k) lend <- rep_len(lend,k)
    ## sciplot passes NULL
    if(length(lwd) < k && !is.null(lwd)) lwd <- rep_len(lwd, k)
    if(length(pch) < k) pch <- rep_len(pch, k)
    if(length(col) < k) col <- rep_len(col, k)
    if(length(bg)  < k)	bg  <- rep_len(bg,  k)
    ## should not be able to call rep() on NULL
    if(is.null(cex)) cex <- 1
    if(length(cex) < k) cex <- rep_len(cex, k)
    ii <- seq_len(k)
    dev.hold(); on.exit(dev.flush())
    if(!add) {
	ii <- ii[-1L]
	plot(x[, 1L],y[, 1L], type = type[1L], xlab = xlab, ylab = ylab,
	     xlim  =  xlim, ylim  =  ylim, lty = lty[1L], lwd = lwd[1L],
             lend = lend[1L], pch = pch[1L], col = col[1L], cex = cex[1L],
             bg = bg[1L], log = log, ...)
    }
    for (i in ii)
	lines(x[, 1L + (i-1L) %% kx], y[, 1L + (i-1L) %% ky],
              type = type[i], lty = lty[i], lwd = lwd[i],
              lend = lend[i], pch = pch[i], col = col[i], cex = cex[i],
              bg = bg[i])
    invisible()
}
#  File src/library/graphics/R/mosaicplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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/

## Original code copyright (C) 1998 John W. Emerson
## This version distributed under GPL (version 2 or later)

mosaicplot <- function(x, ...) UseMethod("mosaicplot")

### Changes by MM:
## - NULL instead of NA for default arguments, etc  [R / S convention]
## - plotting at end; cosmetic; warn about unused ... since we really don't..
## - mosaic.cell():  ...(?)
### Changes by KH:
##   Shading of boxes to visualize deviations from independence by
##   displaying sign and magnitude of the standardized residuals.
### Changes by W. Fischer and U. Ligges:
## - Deparsing x in for main title. New arguments: sub, las, cex.axis
## - made to work by BDR
### Changes by John W. Emerson (JWE):
## - Fixed xlab and ylab to reflect changes in variables and/or
##   orientation (e.g. use of sort and dir options).

mosaicplot.default <-
function(x, main = deparse1(substitute(x)), sub = NULL, xlab = NULL,
         ylab = NULL, sort = NULL, off = NULL, dir = NULL,
         color = NULL, shade = FALSE, margin = NULL,
         cex.axis = 0.66, las = par("las"), border = NULL,
         type = c("pearson", "deviance", "FT"), ...)
{
    mosaic.cell <- function(X, x1, y1, x2, y2, srt.x, srt.y,
            adj.x, adj.y, off, dir, color, lablevx, lablevy,
            maxdim, currlev, label)
    {
        ## Recursive function doing "the job"
        ##
        ## explicitly relying on (1,1000)^2 user coordinates.
        p <- ncol(X) - 2
        if (dir[1L] == "v") {            # split here on the X-axis.
            xdim <- maxdim[1L]
            XP <- rep.int(0, xdim)
            for (i in seq_len(xdim))
                XP[i] <- sum(X[X[, 1L] == i,p]) / sum(X[,p])
            if(anyNA(XP)) stop("missing values in contingency table")
            white <- off[1L] * (x2 - x1) / max(1, xdim-1)
            x.l <- x1
            x.r <- x1 + (1 - off[1L]) * XP[1L] * (x2 - x1)
            if (xdim > 1L)
                for (i in 2:xdim) {
                    x.l <- c(x.l, x.r[i-1L] + white)
                    x.r <- c(x.r, x.r[i-1L] + white +
                             (1 - off[1L]) * XP[i] * (x2 - x1))
                }
            if (lablevx > 0L) {
                this.lab <-
                    if (is.null(label[[1L]][1L])) {
                        paste(rep.int(as.character(currlev),
                                      length(currlev)),
                              as.character(seq_len(xdim)), sep = ".")
                    } else label[[1L]]
                text(x = x.l + (x.r - x.l) / 2,
                     y = 1000 - 35*cex.axis/0.66 +
                         22*cex.axis/0.65 * (lablevx - 1),
                     srt = srt.x, adj = adj.x, cex = cex.axis, this.lab,
                     xpd = NA)
            }
            if (p > 2L) {                # recursive call.
                for (i in seq_len(xdim)) {
                    if (XP[i] > 0) {
                        Recall(X[X[, 1L] == i, 2L:(p+2L) , drop = FALSE],
                               x.l[i], y1, x.r[i], y2,
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1L], dir[-1L], color,
                               lablevx-1, (i == 1L)*lablevy,
                               maxdim[-1L], currlev+1, label[2:p])
                    } else {
                        segments(rep.int(x.l[i], 3L), y1+(y2-y1)*c(0,2,4)/5,
                                 rep.int(x.l[i], 3L), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            } else { # ncol(X) <= 1 : final split polygon and segments.
                for (i in seq_len(xdim)) {
                    if (XP[i] > 0) {
                        ## FIXME: why not call rect()
                        polygon(c(x.l[i], x.r[i], x.r[i], x.l[i]),
                                c(y1, y1, y2, y2),
                                lty = if(extended) X[i, p+1L] else 1L,
                                col = color[if(extended) X[i, p+2L] else i],
                                border = border)
                    } else {
                        segments(rep.int(x.l[i], 3L), y1+(y2-y1)*c(0,2,4)/5,
                                 rep.int(x.l[i], 3L), y1+(y2-y1)*c(1,3,5)/5)
                    }
                }
            }
        } else {                        # split here on the Y-axis.
            ydim <- maxdim[1L]
            YP <- rep.int(0, ydim)
            for (j in seq_len(ydim)) {
                YP[j] <- sum(X[X[, 1L] == j,p]) / sum(X[,p])
            }
            white <- off[1L] * (y2 - y1) / (max(1, ydim - 1))
            y.b <- y2 - (1 - off[1L]) * YP[1L] * (y2 - y1)
            y.t <- y2
            if (ydim > 1L) {
                for (j in 2:ydim) {
                    y.b <- c(y.b, y.b[j-1] - white -
                             (1 - off[1L]) * YP[j] * (y2 - y1))
                    y.t <- c(y.t, y.b[j-1] - white)
                }
            }
            if (lablevy > 0L) {
                this.lab <-
                    if (is.null(label[[1L]][1L])) {
                        paste(rep.int(as.character(currlev),
                                      length(currlev)),
                              as.character(seq_len(ydim)), sep=".")
                    } else label[[1L]]
                text(x = 35*cex.axis/0.66 - 20*cex.axis/0.66 * (lablevy - 1),
                     y = y.b + (y.t - y.b) / 2,
                     srt = srt.y, adj = adj.y, cex = cex.axis, this.lab,
                     xpd = NA)
            }
            if (p > 2L) {                # recursive call.
                for (j in seq_len(ydim)) {
                    if (YP[j] > 0) {
                        Recall(X[X[, 1L] == j, 2:(p+2) , drop=FALSE],
                               x1, y.b[j], x2, y.t[j],
                               srt.x, srt.y, adj.x, adj.y,
                               off[-1L], dir[-1L], color,
                               (j == 1L)*lablevx, lablevy-1,
                               maxdim[-1L], currlev+1, label[2:p])
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep.int(y.b[j], 3L),
                                 x1+(x2-x1)*c(1,3,5)/5, rep.int(y.b[j], 3L))
                    }
                }
            } else { # ncol(X) <= 1L: final split polygon and segments.
                for (j in seq_len(ydim)) {
                    if (YP[j] > 0) {
                        polygon(c(x1,x2,x2,x1),
                                c(y.b[j],y.b[j],y.t[j],y.t[j]),
                                lty = if(extended) X[j, p+1] else 1,
                                col = color[if(extended) X[j, p+2] else j],
                                border = border)
                    } else {
                        segments(x1+(x2-x1)*c(0,2,4)/5, rep.int(y.b[j], 3L),
                                 x1+(x2-x1)*c(1,3,5)/5, rep.int(y.b[j], 3L))
                    }
                }
            }
        }
        invisible()
    }

    ##-- Begin main function

    ## Calculate string rotation for different settings of las:
    srt.x <- if(las > 1) 90 else 0
    srt.y <- if(las == 0 || las == 3) 90 else 0

    if(is.null(dim(x)))
        x <- as.array(x)
    else if(is.data.frame(x))
        x <- data.matrix(x)
    dimd <- length(dx <- dim(x))
    if(dimd == 0L || any(dx == 0L))
        stop("'x' must not have 0 dimensionality")
    chkDots(...)
    ##-- Set up 'Ind' matrix : to contain indices and data
    Ind <- 1L:dx[1L]
    if(dimd > 1L) {
        Ind <- rep.int(Ind, prod(dx[2:dimd]))
        for (i in 2:dimd) {
            Ind <- cbind(Ind,
                         c(matrix(1L:dx[i], byrow = TRUE,
                                  nrow = prod(dx[1L:(i-1)]),
                                  ncol = prod(dx[i:dimd]))))
        }
    }
    Ind <- cbind(Ind, c(x))
    ## Ok, now the columns of 'Ind' are the cell indices (which could
    ## also have been created by 'expand.grid()' and the corresponding
    ## cell counts.  We add two more columns for dealing with *EXTENDED*
    ## mosaic plots which are produced unless 'shade' is FALSE, which
    ## currently is the default.  These columns have NAs for the simple
    ## case.  Otherwise, they specify the line type (1 for positive and
    ## 2 for negative residuals) and color (by giving the index in the
    ## color vector which ranges from the "most negative" to the "most
    ## positive" residuals.
    if(is.logical(shade) && !shade) {
        extended <- FALSE
        Ind <- cbind(Ind, NA, NA)
    }
    else {
        if(is.logical(shade))
            shade <- c(2, 4)
        else if(any(shade <= 0) || length(shade) > 5)
            stop("invalid 'shade' specification")
        extended <- TRUE
        shade <- sort(shade)
        breaks <- c(-Inf, - rev(shade), 0, shade, Inf)
        color <- c(hsv(0,               # red
                       s = seq.int(1, to = 0, length.out = length(shade) + 1)),
                   hsv(4/6,             # blue
                       s = seq.int(0, to = 1, length.out = length(shade) + 1)))
        if(is.null(margin))
            margin <- as.list(1L:dimd)
        ## Fit the loglinear model.
        E <- stats::loglin(x, margin, fit = TRUE, print = FALSE)$fit
        ## Compute the residuals.
        type <- match.arg(type)
        residuals <-
            switch(type,
                   pearson = (x - E) / sqrt(E),
                   deviance = {
                       tmp <- 2 * (x * log(ifelse(x == 0, 1, x/E)) - (x-E))
                       tmp <- sqrt(pmax(tmp, 0))
                       ifelse(x > E, tmp, -tmp)
                   },
                   FT = sqrt(x) + sqrt(x + 1) - sqrt(4 * E + 1))
        ## And add the information to the data matrix.
        Ind <- cbind(Ind,
                     c(1 + (residuals < 0)),
                     as.numeric(cut(residuals, breaks)))
    }

    label <- dimnames(x) # this is needed here.
    ##############################################################
    ### MOVED by JWE to below.
    ## nam.dn <- names(label)
    ## if(is.null(xlab)) xlab <- nam.dn[1L]
    ## if(is.null(ylab)) ylab <- nam.dn[2L]
    ##############################################################

    ## Initialize spacing.
    if(is.null(off))
        off <- if(dimd == 2) 2 * (dx - 1) else rep.int(10, dimd)
    if(length(off) != dimd)
        off <- rep_len(off, dimd)
    if(any(off > 50))
        off <- off * 50/max(off)
    ## Initialize directions.
    if (is.null(dir) || length(dir) != dimd) {
        dir <- rep_len(c("v","h"), dimd)
    }
    if (!is.null(sort)) {
        if(length(sort) != dimd)
            stop("length of 'sort' does not conform to 'dim(x)'")
        ## Sort columns.
        Ind[, seq_len(dimd)] <- Ind[, sort]
        off <- off[sort]
        dir <- dir[sort]
        label <- label[sort]
    }

    ## #################################################################
    ## MOVED and modified by JWE, from above, 10/16/2006 to fix dir= and
    ## sort= bug with respect to xlab= and ylab= options.

    ## Here, we need to identify the first "h" and first "v" splits, and
    ## use their names for xlab= and ylab=, if they are NULL.

    nam.dn <- names(label)
    if(is.null(xlab) && any(dir == "v"))
        xlab <- nam.dn[min(which(dir == "v"))]
    if(is.null(ylab) && any(dir == "h"))
        ylab <- nam.dn[min(which(dir == "h"))]

    ## END MODIFICATIONS by JWE
    ## #################################################################

    ncolors <- length(tabulate(Ind[,dimd]))
    if(!extended && ((is.null(color) || length(color) != ncolors))) {
        color <-
            if(is.logical(color))
                if(color[1L])
                    gray.colors(ncolors)
                else
                    rep.int(0, ncolors)
            else if(is.null(color))
                rep.int("grey", ncolors)
            else                        # recycle
                rep_len(color, ncolors)
    }

    ##-- Plotting
    dev.hold(); on.exit(dev.flush())
    plot.new()
    if(!extended) {
        opar <- par(usr = c(1, 1000, 1, 1000), mgp = c(1, 1, 0))
        on.exit(par(opar), add = TRUE)
    } else {
        ## This code is extremely ugly, and certainly can be improved.
        ## In the case of extended displays, we also need to provide a
        ## legend for the shading and outline patterns.  The code works
        ## o.k. with integer breaks in 'shade'; rounding to two 2 digits
        ## will not be good enough if 'shade' has length 5.
        pin <- par("pin")
        rtxt <- "Standardized\nResiduals:"
        ## Compute cex so that the rotated legend text does not take up
        ## more than 1/12 of the of the plot region horizontally and not
        ## more than 1/4 vertically.
        rtxtCex <- min(1,
                       pin[1L] / (strheight(rtxt, units = "inches") * 12),
                       pin[2L] / (strwidth (rtxt, units = "inches") / 4))
        rtxtWidth <- 0.1                # unconditionally ..
        ## We put the legend to the right of the third axis.
        opar <- par(usr = c(1, 1000 * (1.1 + rtxtWidth), 1, 1000),
                    mgp = c(1, 1, 0))
        on.exit(par(opar), add = TRUE)
        rtxtHeight <-
            strwidth(rtxt, units = "i", cex = rtxtCex) / pin[2L]
        text(1000 * (1.05 + 0.5 * rtxtWidth), 0, labels = rtxt,
             adj = c(0, 0.25), srt = 90, cex = rtxtCex)
        ## 'len' is the number of positive or negative intervals of
        ## residuals (so overall, there are '2 * len')
        len <- length(shade) + 1
        ## 'bh' is the height of each box in the legend (including the
        ## separating whitespace
        bh <- 0.95 * (0.95 - rtxtHeight) / (2 * len)
        x.l <- 1000 * 1.05
        x.r <- 1000 * (1.05 + 0.7 * rtxtWidth)
        y.t <- 1000 * rev(seq.int(from = 0.95, by = - bh, length.out = 2 * len))
        y.b <- y.t - 1000 * 0.8 * bh
        ltype <- c(rep.int(2, len), rep.int(1, len))
        for(i in 1 : (2 * len)) {
            polygon(c(x.l, x.r, x.r, x.l),
                    c(y.b[i], y.b[i], y.t[i], y.t[i]),
                    col = color[i], lty = ltype[i], border = border)
        }
        brks <- round(breaks, 2)
        y.m <- y.b + 1000 * 0.4 * bh
        text(1000 * (1.05 + rtxtWidth), y.m,
             c(paste0("<", brks[2L]),
               paste(brks[2 : (2 * len - 1)],
                     brks[3 : (2 * len)],
                     sep = ":"),
               paste0(">", brks[2 * len])),
             srt = 90, cex = cex.axis, xpd = NA)
    }

    if (!is.null(main) || !is.null(xlab) || !is.null(ylab) || !is.null(sub))
        title(main, sub = sub, xlab = xlab, ylab = ylab)
    adj.x <- adj.y <- 0.5
    x1 <- 30 + 20*cex.axis/0.66; y1 <- 5; x2 <- 950; y2 <- 1000-x1
    maxlen.xlabel <- maxlen.ylabel <- 35*cex.axis/0.66
    ## Calculations required for 'las' related string rotation
    ## and adjustment
    if(srt.x == 90) {
        maxlen.xlabel <-
            max(strwidth(label[[dimd + 1L - match("v", rev(dir))]],
                cex = cex.axis))
        adj.x <- 1
        y2 <- y2 - maxlen.xlabel
    }
    if(srt.y == 0) {
        maxlen.ylabel <-
            max(strwidth(label[[match("h", dir)]],
                cex = cex.axis))
        adj.y <- 0
        x1 <- x1 + maxlen.ylabel
    }

    mosaic.cell(Ind, x1 = x1, y1 = y1, x2 = x2, y2 = y2,
                srt.x = srt.x, srt.y = srt.y, adj.x = adj.x,
                adj.y = adj.y, off = off / 100, dir = dir,
                color = color, lablevx = 2, lablevy = 2,
                maxdim = apply(as.matrix(Ind[,1L:dimd]), 2L, max),
                currlev = 1, label = label)
}

mosaicplot.formula <-
function(formula, data = NULL, ...,
         main = deparse1(substitute(data)), subset, na.action = stats::na.omit)
{
    main # force evaluation here
    m <- match.call(expand.dots = FALSE)
    edata <- eval(m$data, parent.frame())
    if(inherits(edata, "ftable")
       || inherits(edata, "table")
       || length(dim(edata)) > 2) {
        data <- as.table(data)
        varnames <- attr(stats::terms.formula(formula), "term.labels")
        if(all(varnames != "."))
            data <- marginSums(data, varnames)
                                 # was match(varnames, names(dimnames(data))))
        mosaicplot(data, main = main, ...)
    } else {
        if(is.matrix(edata))
            m$data <- as.data.frame(data)
        m$main <- m$... <- NULL
        m$na.action <- na.action
        ## need stats:: for non-standard evaluation
        m[[1L]] <- quote(stats::model.frame)
        mf <- eval(m, parent.frame())
        mosaicplot(table(mf), main = main, ...)
    }
}
#  File src/library/graphics/R/mtext.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

mtext <-
function (text, side = 3, line = 0, outer = FALSE, at = NA,
	  adj = NA, padj = NA, cex = NA, col = NA, font = NA, ...)
    invisible(.External.graphics(C_mtext, as.graphicsAnnot(text), side, line, outer,
                       at, adj, padj, cex, col, font, ...))

#  File src/library/graphics/R/pairs.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 The R Core Team
#  Some parts  Copyright (C) 1999 Dr. Jens Oehlschlaegel-Akiyoshi
#
#  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/

pairs <- function(x, ...) UseMethod("pairs")

pairs.formula <-
function(formula, data = NULL, ..., subset, na.action = stats::na.pass)
{
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
        m$data <- as.data.frame(data)
    m$... <- NULL
    m$na.action <- na.action # force in even if  default
    m[[1L]] <- quote(stats::model.frame)
    mf <- eval(m, parent.frame())
    pairs(mf, ...)
}

#################################################
## some of the changes are from code
## Copyright (C) 1999 Dr. Jens Oehlschlaegel-Akiyoshi
## Others are by BDR and MM
## This version distributed under GPL (version 2 or later)
#################################################

pairs.default <-
function (x, labels, panel = points, ...,
          horInd = 1:nc, verInd = 1:nc,
          lower.panel = panel, upper.panel = panel,
          diag.panel = NULL, text.panel = textPanel,
          label.pos = 0.5 + has.diag/3, line.main = 3,
          cex.labels = NULL, font.labels = 1,
          row1attop = TRUE, gap = 1, log = "",
          horOdd = !row1attop, verOdd = !row1attop)
{
    if(doText <- missing(text.panel) || is.function(text.panel))
	textPanel <-
	    function(x = 0.5, y = 0.5, txt, cex, font)
		text(x, y, txt, cex = cex, font = font)

    localAxis <- function(side, x, y, xpd, bg, col=NULL, main, oma, ...) {
      ## Explicitly ignore any color argument passed in as
      ## it was most likely meant for the data points and
      ## not for the axis.
        xpd <- NA
        if(side %% 2L == 1L && xl[j]) xpd <- FALSE
        if(side %% 2L == 0L && yl[i]) xpd <- FALSE
        if(side %% 2L == 1L) Axis(x, side = side, xpd = xpd, ...)
        else Axis(y, side = side, xpd = xpd, ...)
    }

    localPlot <- function(..., main, oma, font.main, cex.main) plot(...)
    localLowerPanel <- function(..., main, oma, font.main, cex.main)
        lower.panel(...)
    localUpperPanel <- function(..., main, oma, font.main, cex.main)
        upper.panel(...)

    localDiagPanel <- function(..., main, oma, font.main, cex.main)
        diag.panel(...)

    dots <- list(...); nmdots <- names(dots)
    if (!is.matrix(x)) {
        x <- as.data.frame(x)
        for(i in seq_along(names(x))) {
            if(is.factor(x[[i]]) || is.logical(x[[i]]))
               x[[i]] <- as.numeric(x[[i]])
            if(!is.numeric(unclass(x[[i]])))
                stop("non-numeric argument to 'pairs'")
        }
    } else if (!is.numeric(x)) stop("non-numeric argument to 'pairs'")
    panel <- match.fun(panel)
    if((has.lower <- !is.null(lower.panel)) && !missing(lower.panel))
        lower.panel <- match.fun(lower.panel)
    if((has.upper <- !is.null(upper.panel)) && !missing(upper.panel))
        upper.panel <- match.fun(upper.panel)
    if((has.diag  <- !is.null( diag.panel)) && !missing( diag.panel))
        diag.panel <- match.fun( diag.panel)

    if(row1attop) {
        tmp <- lower.panel; lower.panel <- upper.panel; upper.panel <- tmp
        tmp <- has.lower; has.lower <- has.upper; has.upper <- tmp
    }

    nc <- ncol(x)
    if (nc < 2L) stop("only one column in the argument to 'pairs'")
    if(!all(1L <= horInd & horInd <= nc))
        stop("invalid argument 'horInd'")
    if(!all(1L <= verInd & verInd <= nc))
        stop("invalid argument 'verInd'")
    if(doText) {
	if (missing(labels)) {
	    labels <- colnames(x)
	    if (is.null(labels)) labels <- paste("var", 1L:nc)
	}
	else if(is.null(labels)) doText <- FALSE
    }
    oma  <- if("oma"  %in% nmdots) dots$oma
    main <- if("main" %in% nmdots) dots$main
    if (is.null(oma))
	oma <- c(4, 4, if(!is.null(main)) 6 else 4, 4)
    opar <- par(mfcol = c(length(horInd), length(verInd)),
                mar = rep.int(gap/2, 4), oma = oma)
    on.exit(par(opar))
    dev.hold(); on.exit(dev.flush(), add = TRUE)

    xl <- yl <- logical(nc)
    if (is.numeric(log)) xl[log] <- yl[log] <- TRUE
    else {xl[] <- grepl("x", log); yl[] <- grepl("y", log)}
    ni <- length(iSet <- if(row1attop) horInd else rev(horInd))
    nj <- length(jSet <- verInd)
    for(j in jSet)
        for(i in iSet) {
            l <- paste0(if(xl[j]) "x" else "",
                        if(yl[i]) "y" else "")
            localPlot(x[, j], x[, i], xlab = "", ylab = "",
                      axes = FALSE, type = "n", ..., log = l)
            if(i == j || (i < j && has.lower) || (i > j && has.upper) ) {
                box()
                j.odd <- (match(j, jSet) + horOdd) %% 2L
                i.odd <- (match(i, iSet) + verOdd) %% 2L
                if(i == iSet[1L] && (!j.odd || !has.upper || !has.lower))
                    localAxis(3L, x[, j], x[, i], ...)
                if(i == iSet[ni] && ( j.odd || !has.upper || !has.lower))
                    localAxis(1L, x[, j], x[, i], ...)
                if(j == jSet[1L] && (!i.odd || !has.upper || !has.lower))
                    localAxis(2L, x[, j], x[, i], ...)
                if(j == jSet[nj] && ( i.odd || !has.upper || !has.lower))
                    localAxis(4L, x[, j], x[, i], ...)
                mfg <- par("mfg")
                if(i == j) {
                    if (has.diag) localDiagPanel(as.vector(x[, i]), ...)
		    if (doText) {
                        par(usr = c(0, 1, 0, 1))
                        if(is.null(cex.labels)) {
                            l.wid <- strwidth(labels, "user")
                            cex.labels <- max(0.8, min(2, .9 / max(l.wid)))
                        }
                        xlp <- if(xl[i]) 10^0.5 else 0.5
                        ylp <- if(yl[j]) 10^label.pos else label.pos
                        text.panel(xlp, ylp, labels[i],
                                   cex = cex.labels, font = font.labels)
                    }
                } else if(i < j)
                    localLowerPanel(as.vector(x[, j]), as.vector(x[, i]), ...)
                else
                    localUpperPanel(as.vector(x[, j]), as.vector(x[, i]), ...)
                if (any(par("mfg") != mfg))
                    stop("the 'panel' function made a new plot")
            }
            else par(new = FALSE)
        }
    if (!is.null(main)) {
        font.main <- if("font.main" %in% nmdots) dots$font.main else par("font.main")
        cex.main  <- if("cex.main"  %in% nmdots) dots$cex.main  else par("cex.main")
        mtext(main, 3, line.main, outer=TRUE, at = 0.5, cex = cex.main, font = font.main)
    }
    invisible(NULL)
}
#  File src/library/graphics/R/par.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2014 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/

##-- These are the ones used in ../../../main/par.c  Query(..) :
##-- Documentation in		../../../include/Graphics.h
.Pars <- c(
           "xlog", "ylog", ## must be before xaxp, yaxp
	   "adj", "ann", "ask", "bg", "bty",
	   "cex", "cex.axis", "cex.lab", "cex.main", "cex.sub", "cin",
	   "col", "col.axis", "col.lab", "col.main", "col.sub",
           "cra", "crt", "csi","cxy",	"din", "err", "family",
           "fg", "fig", "fin",
	   "font", "font.axis", "font.lab", "font.main", "font.sub",
           "lab", "las", "lend", "lheight", "ljoin", "lmitre", "lty", "lwd",
           "mai", "mar", "mex", "mfcol", "mfg", "mfrow", "mgp", "mkh",
	   "new", "oma", "omd", "omi", "page", "pch", "pin", "plt", "ps", "pty",
	   "smo", "srt", "tck", "tcl", "usr",
	   "xaxp", "xaxs", "xaxt",  "xpd",
	   "yaxp", "yaxs", "yaxt", "ylbias"
	   )
# Replaced with function to evaluate readonly pars because "gamma"
# was at one time readonly on a per-device basis
# .Pars.readonly <- c("cin","cra","csi","cxy","din")

par <- function (..., no.readonly = FALSE)
{
    .Pars.readonly <- c("cin","cra","csi","cxy","din","page")
    single <- FALSE
    args <- list(...)
    if (!length(args))
	args <- as.list(if (no.readonly) .Pars[-match(.Pars.readonly, .Pars)]
                        else .Pars)
    else {
	if (all(unlist(lapply(args, is.character))))
	    args <- as.list(unlist(args))
	if (length(args) == 1) {
	    if (is.list(args[[1L]]) || is.null(args[[1L]]))
		args <- args[[1L]]
	    else
		if(is.null(names(args)))
		    single <- TRUE
	}
    }
    value <- .External2(C_par, args)
    if(single) value <- value[[1L]]
    if(!is.null(names(args))) invisible(value) else value
}

clip <- function(x1, x2, y1, y2)
    invisible(.External.graphics(C_clip, x1, x2, y1, y2))

#  File src/library/graphics/R/persp.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 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/

persp <- function(x, ...) UseMethod("persp")

persp.default <-
function (x = seq(0, 1, length.out = nrow(z)),
          y = seq(0, 1, length.out = ncol(z)),
          z, xlim = range(x), ylim = range(y), zlim = range(z, na.rm = TRUE),
          xlab = NULL, ylab = NULL, zlab = NULL, main = NULL, sub = NULL,
          theta = 0, phi = 15, r = sqrt(3), d = 1, scale = TRUE, expand = 1,
          col = "white", border = NULL, ltheta = -135, lphi = 0, shade = NA,
          box = TRUE, axes = TRUE, nticks = 5, ticktype = "simple", ...)
{
    if (is.null(xlab))
        xlab <- if (!missing(x)) deparse1(substitute(x)) else "X"
    if (is.null(ylab))
        ylab <- if (!missing(y)) deparse1(substitute(y)) else "Y"
    if (is.null(zlab))
        zlab <- if (!missing(z)) deparse1(substitute(z)) else "Z"
    ## labcex is disregarded since we do NOT yet put  ANY labels...
    if (missing(z)) {
        if (!missing(x)) {
            if (is.list(x)) {
                z <- x$z
                y <- x$y
                x <- x$x
            }
            else {
                z <- x
                x <- seq.int(0, 1, length.out = nrow(z))
            }
        }
        else stop("no 'z' matrix specified")
    }
    else if (is.list(x)) {
        y <- x$y
        x <- x$x
    }
    if (any(diff(x) <= 0) || any(diff(y) <= 0))
        stop("increasing 'x' and 'y' values expected")
    if (box) {
        zz <- z[!is.na(z)]
        if(any(x < xlim[1]) || any(x > xlim[2]) ||
           any(y < ylim[1]) || any(y > ylim[2]) ||
           any(zz < zlim[1]) || any(zz > zlim[2]))
            warning("surface extends beyond the box")
    }
    ticktype <- pmatch(ticktype, c("simple", "detailed"))
    plot.new()
    r <- .External.graphics(C_persp, x, y, z, xlim, ylim, zlim, theta, phi, r, d,
                            scale, expand, col, border, ltheta, lphi, shade,
                            box, axes, nticks, ticktype,
                            as.character(xlab), as.character(ylab),
                            as.character(zlab), ...)
    for(fun in getHook("persp")) {
        if(is.character(fun)) fun <- get(fun)
        try(fun())
    }
    if(!is.null(main) || !is.null(sub))
        title(main = main, sub = sub, ...)
    invisible(r)
}
#  File src/library/graphics/R/pie.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

pie <-
    function (x, labels = names(x), edges = 200, radius = 0.8,
              clockwise = FALSE, init.angle = if(clockwise) 90 else 0,
              density = NULL, angle = 45, col = NULL, border = NULL,
              lty = NULL, main = NULL, ...)
{
    if (!is.numeric(x) || any(is.na(x) | x < 0))
	stop("'x' values must be positive.")
    if (is.null(labels))
	labels <- as.character(seq_along(x))
    else labels <- as.graphicsAnnot(labels)
    x <- c(0, cumsum(x)/sum(x))
    dx <- diff(x)
    nx <- length(dx)
    plot.new()
    # NOTE: this needs to happen AFTER the plot.new so that
    # we enquire about the CURRENT plot region size, not the
    # PREVIOUS plot region size
    pin <- par("pin")
    xlim <- ylim <- c(-1, 1)
    if (pin[1L] > pin[2L]) xlim <- (pin[1L]/pin[2L]) * xlim
    else ylim <- (pin[2L]/pin[1L]) * ylim
    dev.hold(); on.exit(dev.flush())
    plot.window(xlim, ylim, "", asp = 1)
    if (is.null(col))
        col <- if(is.null(density))
            c("white", "lightblue", "mistyrose", "lightcyan",
              "lavender", "cornsilk")
        else par("fg")
    if(!is.null(col))
        col <- rep_len(col, nx)
    if(!is.null(border))
        border <- rep_len(border, nx)
    if(!is.null(lty))
        lty <- rep_len(lty, nx)
    angle <- rep(angle, nx)
    if(!is.null(density))
        density <- rep_len(density, nx)
    twopi <- if(clockwise) -2*pi else 2*pi
    t2xy <- function(t) {
        t2p <- twopi*t + init.angle * pi/180
        list(x = radius * cos(t2p), y = radius * sin(t2p))
    }
    for (i in 1L:nx) {
	n <- max(2, floor(edges * dx[i]))
	P <- t2xy(seq.int(x[i], x[i + 1], length.out = n))
	polygon(c(P$x, 0), c(P$y, 0), density = density[i], angle = angle[i],
                border = border[i], col = col[i], lty = lty[i])
	P <- t2xy(mean(x[i + 0:1]))
        lab <-  as.character(labels[i])
        if(!is.na(lab) && nzchar(lab)) {
            lines(c(1, 1.05)*P$x, c(1, 1.05)*P$y)
            text(1.1*P$x, 1.1*P$y, labels[i], xpd = TRUE,
                 adj = ifelse(P$x < 0, 1, 0), ...)
        }
    }
    title(main = main, ...)
    invisible(NULL)
}
#  File src/library/graphics/R/plot.design.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 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/

plot.design <-
    function(x, y = NULL, fun = mean, data = NULL, ...,
             ylim = NULL, xlab = "Factors", ylab = NULL, main = NULL,
             ask = NULL, xaxt = par("xaxt"), axes = TRUE, xtick = FALSE)
{
    .plot.des <-
        function(x, y, fun, ylab, ylim = NULL, ...) {
	## Arguments: x : data.frame with only factor columns
	##	      y : one numeric vector

	if(!is.numeric(y))
	    stop("'y' must be a numeric vector")
	if(!is.data.frame(x)) # or allow factor (see 2 lines below)?? {FIXME}
	    stop("'x' must be a data frame")
	if(!all(sapply(x, is.factor)) && !is.factor(x)) # incl "ordered"
	    stop("all columns/components of 'x' must be factors")
	k <- ncol(x)
        if(anyNA(y)) {
            FUN <- fun; fun <- function(u) FUN(u [!is.na(u)])
        }
	tot <- fun(y)
	stats <- lapply(x, function(xc) tapply(y, xc, fun))

	if(any(is.na(unlist(stats))))
	    warning("some levels of the factors are empty", call. = FALSE)
        if(is.null(ylim))
            ylim <- range(c(sapply(stats,range,na.rm = TRUE),tot))
	plot(c(0,k+1), ylim, type = "n", axes = axes, xaxt = "n",
             xlab = xlab, ylab = ylab, main = main, adj = 0.5, ...)
	segments(0.5, tot, k+0.5, tot, ...)
	for(i in 1L:k) {
            si <- stats[[i]]
	    segments(i, min(si, na.rm = TRUE),
		     i, max(si, na.rm = TRUE), ...)
	    for(j in 1L:(length(si))) {
                sij <- si[j]
		segments(i-0.05, sij, i+0.05, sij, ...)
		text(i-0.1, sij, labels = names(sij), adj = 1, ...)
	    }
	}
        if(axes && xaxt != "n")
            axis(1, at = 1L:k, names(stats), xaxt = xaxt, tick = xtick,
                 mgp = {p <- par("mgp"); c(p[1L], if(xtick) p[2L] else 0, 0)},
                 ...)
    } ## .plot.des()

    ## 'fun' dealing
    fname <- deparse1(substitute(fun))
    fun <- match.fun(fun)
    if (!(is.data.frame(x) | inherits(x,"formula")))
	stop("'x' must be a dataframe or a formula")

    ## case 'switch' :
    if(is.data.frame(x)) {
	if(is.null(y)) { ## nothing to do
	} else if(inherits(y,"formula")) {
	    x <- stats::model.frame(y , data = x)
	}
	else if(is.numeric(y)) {
	    x <- cbind(y,x[,sapply(x, is.factor)])
	    tmpname <- match.call()
	    names(x) <- as.character(c(tmpname[[3L]],names(x[,-1])))
	}
	else if(is.character(y)) {
	    ynames <- y
	    y <- data.frame(x[,y])
	    if(sum(sapply(y, is.numeric)) != ncol(y)) {
		stop("a variable in 'y' is not numeric")
	    }
	    x <- x[,sapply(x, is.factor)]
	    xnames <- names(x)
	    x <- cbind(x,y)
	    names(x) <- c(xnames,ynames)
	}
    }
    else if (is.data.frame(data)) {
	x <- stats::model.frame(x , data = data)
    }
    else {
	x <- stats::model.frame(x)
    }

    i.fac <- sapply(x, is.factor)
    i.num <- sapply(x, is.numeric)
    nResp <- sum(i.num)
    if (nResp == 0)
	stop("there must be at least one numeric variable!")
    yname <- names(x)[i.num]
    if(is.null(ylab))
	ylab <- paste(fname, "of", yname)
    ydata <- as.matrix(x[,i.num])
    if (!any(i.fac)) {
	x <- data.frame(Intercept = rep.int(" ", nrow(x)))
	i.fac <- 1
    }
    xf <- x[, i.fac, drop = FALSE]
    if (is.null(ask))
	ask <- prod(par("mfcol")) < nResp && dev.interactive(orNone = TRUE)
    if (ask) {
	oask <- devAskNewPage(ask)
	on.exit(devAskNewPage(oask))
    }
    for(j in 1L:nResp)
	.plot.des(xf, ydata[,j], fun = fun, ylab = ylab[j], ylim = ylim, ...)
    invisible()
}
#  File src/library/graphics/R/plot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2020 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/

### xy.coords() is now in the imported 'grDevices' package

## Now in 'base' pkg:
## plot <- function (x, y, ...)  UseMethod("plot")


## xlim = NULL (instead of "missing", since it will be passed to plot.default):
plot.function <-
    function(x, y = 0, to = 1, from = y, xlim = NULL, ylab = NULL, ...)
{
    ## this is to allow things like plot(sin, 0, 2*pi)
    if (!missing(y) && missing(from)) from <- y
    if (is.null(xlim)) {
	if(is.null(from)) from <- 0 # most likely from y = NULL
    } else {
	if(missing(from)) from <- xlim[1L]
	if(missing(to))	to <- xlim[2L]
    }
    if (is.null(ylab)) {
        sx <- substitute(x)
        ylab <- if(mode(x) != "name")
            deparse(sx)[1L]
        else {
            xname <- list(...)[["xname"]]
            if (is.null(xname)) xname <- "x"
            paste0(sx, "(", xname, ")")
        }
    }
    ## name args to avoid partial matches from ...
    curve(expr = x, from = from, to = to, xlim = xlim, ylab = ylab, ...)
}

plot.default <-
    function(x, y = NULL, type = "p", xlim = NULL, ylim = NULL,
             log = "", main = NULL, sub = NULL, xlab = NULL, ylab = NULL,
             ann = par("ann"), axes = TRUE, frame.plot = axes,
             panel.first = NULL, panel.last = NULL, asp = NA,
             xgap.axis = NA, ygap.axis = NA, ...)
{
    ## These col, bg, pch, cex can be vectors, so exclude them
    ## Also, axis and box accept some of these
    localAxis   <- function(..., col, bg, pch, cex, lty, lwd) Axis(...)
    localBox    <- function(..., col, bg, pch, cex, lty, lwd) box(...)
    localWindow <- function(..., col, bg, pch, cex, lty, lwd) plot.window(...)
    localTitle  <- function(..., col, bg, pch, cex, lty, lwd) title(...)
    xlabel <- if (!missing(x)) deparse1(substitute(x))
    ylabel <- if (!missing(y)) deparse1(substitute(y))
    xy <- xy.coords(x, y, xlabel, ylabel, log)
    if (is.null(xlab)) xlab <- xy$xlab
    if (is.null(ylab)) ylab <- xy$ylab
    if (is.null(xlim)) xlim <- range(xy$x[is.finite(xy$x)])
    if (is.null(ylim)) ylim <- range(xy$y[is.finite(xy$y)])
    dev.hold(); on.exit(dev.flush())
    plot.new()
    localWindow(xlim, ylim, log, asp, ...)
    panel.first
    plot.xy(xy, type, ...)
    panel.last
    if (axes) {
	localAxis(if(is.null(y)) xy$x else x, side = 1, gap.axis = xgap.axis, ...)
	localAxis(if(is.null(y))  x   else y, side = 2, gap.axis = ygap.axis, ...)
    }
    if (frame.plot) localBox(...)
    if (ann) localTitle(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
    invisible()
}

plot.factor <- function(x, y, legend.text = NULL, ...)
{
    if (missing(y) || is.factor(y)) {
        dargs <- list(...)
        axisnames <- dargs$axes %||%
            if (!is.null(dargs$xaxt))
                dargs$xaxt != "n"
            else TRUE
    }
    if (missing(y)) {
        barplot(table(x), axisnames = axisnames, ...)
    }
    else if (is.factor(y)) {
        if(is.null(legend.text)) spineplot(x, y, ...) else {
	  args <- c(list(x = x, y = y), list(...))
	  args$yaxlabels <- legend.text
	  do.call("spineplot", args)
	}
    }
    else if (is.numeric(y))
        boxplot(y ~ x, ...)
    else NextMethod("plot")
}

## FIXME (ideas/wishes):
## o for 1-D tables:
##   - alternatively, and/or as default, type = "bar" ??!??
##   - if "h", make the default lwd depend on number of classes instead of lwd=2
plot.table <-
    function(x, type = "h", ylim = c(0, max(x)), lwd = 2,
             xlab = NULL, ylab = NULL, frame.plot = is.num, ...)
{
    xnam <- deparse1(substitute(x))
    rnk <- length(dim(x))
    if(rnk == 0L) stop("invalid table 'x'")
    if(rnk == 1L) {
	dn <- dimnames(x)
	nx <- dn[[1L]]
	if(is.null(xlab)) xlab <- names(dn) %||% ""
	if(is.null(ylab)) ylab <- xnam
        is.num <- suppressWarnings(!any(is.na(xx <- as.numeric(nx))))
	x0 <- if(is.num) xx else seq_along(x)
	plot(x0, unclass(x), type = type,
	     ylim = ylim, xlab = xlab, ylab = ylab, frame.plot = frame.plot,
	     lwd = lwd, ..., xaxt = "n")
        localaxis <- function(..., col, bg, pch, cex, lty, log) axis(...)
	if(!isFALSE(list(...)$axes))
            localaxis(1, at = x0, labels = nx, ...)
    } else {
	if(length(dots <- list(...)) && !is.null(dots$main)) # use 'main'
	    mosaicplot(x, xlab = xlab, ylab = ylab, ...)
	else # default main
	    mosaicplot(x, xlab = xlab, ylab = ylab, main = xnam, ...)
    }
}

plot.formula <-
function(formula, data = parent.frame(), ..., subset,
         ylab = varnames[response], ask = dev.interactive())
{
    m <- match.call(expand.dots = FALSE)
    eframe <- parent.frame()
    md <- eval(m$data, eframe)
    if (is.matrix(md)) m$data <- md <- as.data.frame(data)
    ## NB: this evaluates arguments in ... . (PR#14591)
    dots <- lapply(m$..., eval, md, eframe)
    ## need to avoid evaluation of expressions in do.call later.
    ## see PR#10525
    nmdots <- names(dots)
    for(nm in nmdots[match(c("main", "sub", "xlab"), nmdots, 0L)])
        dots[[nm]] <- enquote(dots[[nm]])
    if(!missing(ylab)) ylab <- enquote(ylab)

    m$ylab <- m$... <- m$ask <- NULL
    subset.expr <- m$subset
    m$subset <- NULL
    m <- as.list(m)
    m[[1L]] <- stats::model.frame.default
    m <- as.call(c(m, list(na.action = NULL)))
    mf <- eval(m, eframe)
    if (!missing(subset)) {
	s <- eval(subset.expr, data, eframe)
	l <- nrow(mf)
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
	mf <- mf[s, , drop=FALSE]
    }
    ## check for horizontal arg
    horizontal <- FALSE
    if ("horizontal" %in% names(dots)) horizontal <- dots[["horizontal"]]
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	funname <- NULL
	xn <- varnames[-response]
        ## Dispatch on class of 'y' (plot() dispatches on class of 'x').
	if( is.object(y) ) {
	    found <- FALSE
	    for(j in class(y)) {
		funname <- paste0("plot.", j)
		if( exists(funname) ) {
		    found <- TRUE
		    break
		}
	    }
	    if( !found ) funname <- NULL
	}
	if( is.null(funname) ) funname <- "plot"
	if (length(varnames) > 2L) {
            oask <- devAskNewPage(ask)
            on.exit(devAskNewPage(oask))
	}
        if(length(xn)) {
            if( !is.null(xlab <- dots[["xlab"]]) )
                dots <- dots[-match("xlab", names(dots))]
            for (i in xn) {
                xl <- xlab %||% i
                yl <- ylab
                if(horizontal && is.factor(mf[[i]])) {yl <- xl; xl <- ylab}
                do.call(funname,
                        c(list(mf[[i]], y, ylab = yl, xlab = xl), dots))
	    }
	} else { # no non-response variable names: only (y, ylab)
	    if(length(varnames) == 1L && length(formula) == 3L &&
	       identical(formula[[2L]], formula[[3L]]))
		warning(gettextf("the formula '%s' is treated as '%s'",
				 format(formula),
				 format(local({ f <- formula; f[[3L]] <- quote(1); f}))),
			domain=NA)
	    do.call(funname, c(list(y, ylab = ylab), dots))
	}
    } else do.call("plot.data.frame", c(list(mf), dots))
    invisible()
}

lines.formula <-
function(formula,  data = parent.frame(), ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    eframe <- parent.frame()
    md <- eval(m$data, eframe)
    if (is.matrix(md)) m$data <- md <- as.data.frame(data)
    dots <- lapply(m$..., eval, md, eframe)
    m$... <- NULL
    m <- as.list(m)
    m[[1L]] <- stats::model.frame.default
    m <- as.call(c(m, list(na.action = NULL)))
    mf <- eval(m, eframe)
    if (!missing(subset)) {
	s <- eval(m$subset, data, eframe)
        ## need the number of points before subsetting
	if(!missing(data)) {
            l <- nrow(data)
        } else {
            mtmp <- m
            mtmp$subset <- NULL
            l <- nrow(eval(mtmp, eframe))
        }
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2L)
	    stop("cannot handle more than one 'x' coordinate")
	xn <- varnames[-response]
	if (length(xn) == 0L)
	    do.call("lines", c(list(y), dots))
	else
	    do.call("lines", c(list(mf[[xn]], y), dots))
    } else
	stop("must have a response variable")
}

points.formula <-
function(formula, data = parent.frame(), ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    eframe <- parent.frame()
    md <- eval(m$data, eframe)
    if (is.matrix(md)) m$data <- md <- as.data.frame(data)
    dots <- lapply(m$..., eval, md, eframe)
    m$... <- NULL
    m <- as.list(m)
    m[[1L]] <- stats::model.frame.default
    m <- as.call(c(m, list(na.action = NULL)))
    mf <- eval(m, eframe)
    if (!missing(subset)) {
	s <- eval(m$subset, data, eframe)
        ## need the number of points before subsetting
	if(!missing(data)) {
            l <- nrow(data)
        } else {
            mtmp <- m
            mtmp$subset <- NULL
            l <- nrow(eval(mtmp, eframe))
        }
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2L)
	    stop("cannot handle more than one 'x' coordinate")
	xn <- varnames[-response]
	if (length(xn) == 0L)
	    do.call("points", c(list(y), dots))
	else
	    do.call("points", c(list(mf[[xn]], y), dots))
    } else
	stop("must have a response variable")
}

text.formula <- function(formula, data = parent.frame(), ..., subset)
{
    m <- match.call(expand.dots = FALSE)
    eframe <- parent.frame()
    md <- eval(m$data, eframe)
    if (is.matrix(md)) m$data <- md <- as.data.frame(data)
    dots <- lapply(m$..., eval, md, eframe)
    m$... <- NULL
    m <- as.list(m)
    m[[1L]] <- stats::model.frame.default
    m <- as.call(c(m, list(na.action = NULL)))
    mf <- eval(m, eframe)
    if (!missing(subset)) {
	s <- eval(m$subset, data, eframe)
        ## need the number of points before subsetting
	if(!missing(data)) {
            l <- nrow(data)
        } else {
            mtmp <- m
            mtmp$subset <- NULL
            l <- nrow(eval(mtmp, eframe))
        }
	dosub <- function(x) if (length(x) == l) x[s] else x
	dots <- lapply(dots, dosub)
    }
    response <- attr(attr(mf, "terms"), "response")
    if (response) {
	varnames <- names(mf)
	y <- mf[[response]]
	if (length(varnames) > 2L)
	    stop("cannot handle more than one 'x' coordinate")
	xn <- varnames[-response]
	if (length(xn) == 0L)
	    do.call("text", c(list(y), dots))
	else
	    do.call("text", c(list(mf[[xn]], y), dots))
    } else
	stop("must have a response variable")
}

## in base "graphics", this is called exactly from   {plot, points, lines}.default():
plot.xy <- function(xy, type, pch = par("pch"), lty = par("lty"),
                    col = par("col"), bg = NA, cex = 1, lwd = par("lwd"),
                    ...)
{
    if (is.null(type)) type <- "p"
    type <- as.character(type)
    if (length(type) != 1L || !nzchar(type) || is.na(type))
        stop(gettextf("invalid plot type"))
    if (nchar(type) > 1L)
        warning(gettextf("plot type '%s' will be truncated to first character",
                         type))
    t <- substr(type, 1L, 1L)
    if (!isTRUE(t %in% c("l", "o", "b", "c", "s", "S", "h", "p", "n")))
        stop(gettextf("invalid plot type '%s'", t))
    invisible(.External.graphics(C_plotXY, xy, t, pch, lty, col, bg, cex, lwd, ...))
}

plot.new <- function()
{
    # TODO: define a general runHook() and use instead
    for (fun in getHook("before.plot.new")) {
        if (is.character(fun)) fun <- get(fun)
        try(fun())
    }
    .External2(C_plot_new)
    grDevices:::recordPalette()
    for(fun in getHook("plot.new")) {
        if(is.character(fun)) fun <- get(fun)
        try(fun())
    }
    invisible()
}

frame <- plot.new

plot.window <- function(xlim, ylim, log = "", asp = NA, ...)
{
    .External.graphics(C_plot_window, xlim, ylim, log, asp, ...)
    invisible()
}

plot.data.frame <- function (x, ...)
{
    plot2 <- function(x, xlab=names(x)[1L], ylab=names(x)[2L], ...)
        plot(x[[1L]], x[[2L]], xlab=xlab, ylab=ylab, ...)

    if(!is.data.frame(x))
	stop("'plot.data.frame' applied to non data frame")
    if(ncol(x) == 1) {
        x1 <- x[[1L]]
        if(class(x1)[1L] %in% c("integer", "numeric"))# is.numeric(.) TRUE for 'ts'
            ## the special case: *not* using plot() method
            stripchart(x1, ...)
        else plot(x1, ...) # factor, ts, complex ...
    } else if(ncol(x) == 2) {
        plot2(x, ...)
    } else {
	pairs(data.matrix(x), ...)
    }
}

## unexported hook for testing
## .newplot.hook <- function()
## {
##     pp <- par(c("mfg","mfcol","oma","mar"))
##     if(all(pp$mfg[1L:2] == c(1, pp$mfcol[2L]))) {
## 	outer <- (oma4 <- pp$oma[4L]) > 0; mar4 <- pp$mar[4L]
## 	mtext(paste("help(", ..nameEx, ")"), side = 4,
##               line = if(outer)max(1, oma4 - 1) else min(1, mar4 - 1),
##               outer = outer, adj = 1, cex = .8, col = "orchid", las=3)
##     }
## }

.units <- c("device", "ndc", "", "", "", "", "nic", "nfc", "", "", "", "",
            "user", "inches", "lines", "chars", "npc")

grconvertX <- function(x, from = "user", to = "user")
{
    from <- pmatch(from, .units)
    to <- pmatch(to, .units)
    .External(C_convertX, as.double(x), from, to)
}

grconvertY <- function(y, from = "user", to = "user")
{
    from <- pmatch(from, .units)
    to <- pmatch(to, .units)
    .External(C_convertY, as.double(y), from, to)
}

## unexported helper for stats::plot.hclust
plotHclust <-
    function (n, merge, height, order, hang, labels, ...)
{
    .External.graphics(C_dendwindow, n, merge, height, hang, labels, ...)
    .External.graphics(C_dend, n, merge, height, order, hang, labels, ...)
}
#  File src/library/graphics/R/points.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

points <- function(x, ...) UseMethod("points")

points.default <- function(x, y=NULL, type="p", ...)
    plot.xy(xy.coords(x,y), type=type, ...)

points.table <- function (x, y = NULL, type = "h", lwd = 2, ...)
{
     if (is.null(y) && length(dim(x)) == 1L) {
         nx <- dimnames(x)[[1L]]
         is.num <- suppressWarnings(!any(is.na(xx <- as.numeric(nx))))
         x0 <- if (is.num) xx else seq.int(x)
         points(x0, unclass(x), type = type, lwd = lwd, ...)
     }
     else stop("only for 1-D table")
}

## points.formula  --> ./plot.R
#  File src/library/graphics/R/polygon.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright 1995-2022 The R Core Team
#  In part (C) 2001 Kevin Buhr
#
#  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/

### polyhatch -  a pure R implementation of polygon hatching
### Copyright (C) 2001 Kevin Buhr
### Provided to the R project for release under GPL.
### Original nice clean structure destroyed by Ross Ihaka

polygon <-
  function(x, y = NULL, density = NULL, angle = 45,
           border = NULL, col = NA, lty = par("lty"), ..., fillOddEven=FALSE)
{
    ## FIXME: remove this eventually
    ..debug.hatch <- FALSE
    ##-- FIXME: what if `log' is active, for x or y?
    xy <- xy.coords(x, y, setLab = FALSE)

    if (is.numeric(density) && all(is.na(density) | density < 0))
        density <- NULL
    if (!is.null(angle) && !is.null(density)) {

        ## hatch helper functions

        polygon.onehatch <-
            function(x, y, x0, y0, xd, yd, ..debug.hatch = FALSE, ...)
        {
            ## draw the intersection of one line with polygon
            ##
            ##  x,y - points of polygon (MUST have first and last points equal)
            ##  x0,y0 - origin of line
            ##  xd,yd - vector giving direction of line
            ##  ... - other parameters to pass to "segments"

            if (..debug.hatch) {
                points(x0, y0)
                arrows(x0, y0, x0 + xd, y0 + yd)
            }

            ## halfplane[i] is 0 or 1 as (x[i], y[i]) lies in left or right
            ##   half-plane of the line

            halfplane <- as.integer(xd * (y - y0) - yd * (x - x0) <= 0)

            ## cross[i] is -1,0, or 1 as segment (x[i], y[i]) -- (x[i+1], y[i+1])
            ##   crosses right-to-left, doesn't cross, or crosses left-to-right

            cross <- halfplane[-1L] - halfplane[-length(halfplane)]
            does.cross <- cross != 0
            if (!any(does.cross)) return() # nothing to draw?

            ## calculate where crossings occur

            x1 <- x[-length(x)][does.cross]; y1 <- y[-length(y)][does.cross]
            x2 <- x[-1L][does.cross]; y2 <- y[-1L][does.cross]

            ## t[i] is "timepoint" on line at which segment (x1, y1)--(x2, y2)
            ##   crosses such that (x0,y0) + t*(xd,yd) is point of intersection

            t <- (((x1 - x0) * (y2 - y1) - (y1 - y0) * (x2 - x1))/
                  (xd * (y2 - y1) - yd * (x2 - x1)))

            ## sort timepoints along line

            o <- order(t)
            tsort <- t[o]

            ## we draw the part of line from t[i] to t[i+1] whenever it lies
            ##   "inside" the polygon --- the definition of this depends on
            ##   fillOddEven:  if FALSE, we crossed
            ##   unequal numbers of left-to-right and right-to-left polygon
            ##   segments to get there.  if TRUE, an odd number of crossings.
            ##

	    crossings <- cumsum(cross[does.cross][o])
	    if (fillOddEven) crossings <- crossings %% 2
            drawline <- crossings != 0

            ## draw those segments

            lx <- x0 + xd * tsort
            ly <- y0 + yd * tsort
            lx1 <- lx[-length(lx)][drawline]; ly1 <- ly[-length(ly)][drawline]
            lx2 <- lx[-1L][drawline]; ly2 <- ly[-1L][drawline]
            segments(lx1, ly1, lx2, ly2, ...)
        }

        polygon.fullhatch <-
            function(x, y, density, angle, ..debug.hatch = FALSE, ...)
        {
            ## draw the hatching for a given polygon
            ##
            ##  x,y - points of polygon (need not have first and last points
            ##        equal, but no NAs are allowed)
            ##  density,angle - of hatching
            ##  ... - other parameters to pass to "segments"

            x <- c(x, x[1L])
            y <- c(y, y[1L])
            angle <- angle %% 180

            if (par("xlog") || par("ylog")) {
                warning("cannot hatch with logarithmic scale active")
                return()
            }
            usr <- par("usr"); pin <- par("pin")

            ## usr coords per inch

            upi <- c(usr[2L] - usr[1L], usr[4L] - usr[3L]) / pin

            ## handle "flipped" usr coords

            if (upi[1L] < 0) angle <- 180 - angle
            if (upi[2L] < 0) angle <- 180 - angle
            upi <- abs(upi)

            ## usr-coords direction vector for hatching

            xd <- cos(angle / 180 * pi) * upi[1L]
            yd <- sin(angle / 180 * pi) * upi[2L]

            ## to generate candidate hatching lines for polygon.onehatch,
            ##   we generate those lines necessary to cover the rectangle
            ##   (min(x),min(y)) to (max(x),max(y)) depending on the
            ##   hatching angle

            ## (Note:  We choose hatch line origins such that the hatching,
            ##   if extended outside polygon, would pass through usr-coordinate
            ##   origin.  This ensures that all hatching with same density,
            ##   angle in figure will be aligned.)

            if (angle < 45 || angle > 135) {

                ## first.x and last.x are x-coords of first and last points
                ##  of rectangle to hit, as y-coord moves from bottom up

                if (angle < 45) {
                    first.x <- max(x)
                    last.x <- min(x)
                }
                else {
                    first.x <- min(x)
                    last.x <- max(x)
                }

                ## y.shift is vertical shift between parallel hatching lines

                y.shift <- upi[2L] / density / abs(cos(angle / 180 * pi))

                ## choose line origin (of first line) to align hatching
                ##   with usr origin

                x0 <- 0
                y0 <- floor((min(y) - first.x * yd / xd) / y.shift) * y.shift

                ## line origins above y.end won't hit figure

                y.end <- max(y) - last.x * yd / xd

                ## hatch against all candidate lines

                while (y0 < y.end) {
                    polygon.onehatch(x, y, x0, y0, xd, yd,
                                     ..debug.hatch=..debug.hatch,...)
                    y0 <- y0 + y.shift
                }
            }
            else {
                ## first.y, last.y are y-coords of first and last points
                ##   of rectangle to hit, as x-coord moves from left to right

                if (angle < 90) {
                    first.y <- max(y)
                    last.y <- min(y)
                }
                else {
                    first.y <- min(y)
                    last.y <- max(y)
                }

                ## x.shift is horizontal shift between parallel hatching lines

                x.shift <- upi[1L] / density / abs(sin(angle / 180 * pi))

                ## choose line origin to align with usr origin

                x0 <- floor((min(x) - first.y * xd / yd) / x.shift) * x.shift
                y0 <- 0

                ## line origins to right of x.end won't hit figure

                x.end <- max(x) - last.y * xd / yd

                ## hatch!

                while (x0 < x.end) {
                    polygon.onehatch(x, y, x0, y0, xd, yd,
                                     ..debug.hatch=..debug.hatch,...)
                    x0 <- x0 + x.shift
                }
            }
        }

        ## end of hatch helper functions


        if (missing(col) || is.null(col)) {
            col <- par("fg")
        } else if (any(is.na(col))) {
            col[is.na(col)] <- par("fg")
        }
        if (is.null(border)) border <- col
        if (is.logical(border)) {
            if (!is.na(border) && border) border <- col
            else border <- NA
        }

        ## process multiple polygons separated by NAs

        start <- 1
        ends <- c(seq_along(xy$x)[is.na(xy$x) | is.na(xy$y)], length(xy$x) + 1)

        num.polygons <- length(ends)
        col <- rep_len(col, num.polygons)
        if(length(border))
            border <- rep_len(border, num.polygons)
        if(length(lty))
            lty <- rep_len(lty, num.polygons)
        if(length(density))
            density <- rep_len(density, num.polygons)
        angle <- rep_len(angle, num.polygons)

        i <- 1L
        for (end in ends) {
            if (end > start) {
                if(is.null(density) || is.na(density[i]) || density[i] < 0)
                    .External.graphics(C_polygon, xy$x[start:(end - 1)],
                                       xy$y[start:(end - 1)],
                                       col[i], NA, lty[i], ...)
                else if (density[i] > 0) {

                        ## note: if col[i]==NA, "segments" will fill with par("fg")

                        polygon.fullhatch(xy$x[start:(end - 1)],
                                          xy$y[start:(end - 1)],
                                          col = col[i], lty = lty[i],
                                          density = density[i],
                                          angle = angle[i],
                                          ..debug.hatch = ..debug.hatch, ...)
                    }

                ## compatible with C_polygon:
                ## only cycle through col, lty, etc. on non-empty polygons
                i <- i + 1
            }
            start <- end + 1
        }
        .External.graphics(C_polygon, xy$x, xy$y, NA, border, lty, ...)
    }
    else {
        if (is.logical(border)) {
            if (isTRUE(border)) border <- par("fg")
            else border <- NA
        }
        .External.graphics(C_polygon, xy$x, xy$y, col, border, lty, ...)
    }
    invisible()
}

xspline <-
  function(x, y = NULL, shape = 0, open = TRUE, repEnds = TRUE,
           draw = TRUE, border = par("fg"), col = NA, ...)
{
    xy <- xy.coords(x, y, setLab = FALSE)
    s <- rep.int(shape, length(xy$x))
    if(open) s[1L] <- s[length(x)] <- 0
    invisible(.External.graphics(C_xspline, xy$x, xy$y, s, open, repEnds,
                                 draw, col, border, ...))
}

polypath <-
  function(x, y = NULL,
           border = NULL, col = NA, lty = par("lty"),
           rule = "winding", ...)
{
    xy <- xy.coords(x, y, setLab = FALSE)
    if (is.logical(border)) {
        if (!is.na(border) && border) border <- par("fg")
        else border <- NA
    }
    rule <- match(rule, c("winding", "evenodd"))
    if (is.na(rule))
        stop("Invalid fill rule for graphics path")
    # Determine path components
    breaks <- which(is.na(xy$x) | is.na(xy$y))
    if (length(breaks) == 0) { # Only one path
        .External.graphics(C_path, xy$x, xy$y,
                           as.integer(length(xy$x)), as.integer(rule),
                           col, border, lty, ...)
    } else {
        nb <- length(breaks)
        lengths <- c(breaks[1] - 1,
                     diff(breaks) - 1,
                     length(xy$x) - breaks[nb])
        .External.graphics(C_path, xy$x[-breaks], xy$y[-breaks],
                           as.integer(lengths), as.integer(rule),
                           col, border, lty, ...)
    }
    invisible()
}

#  File src/library/graphics/R/rect.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

rasterImage <- function (image, xleft, ybottom, xright, ytop,
                         angle = 0, interpolate = TRUE, ...)
{
    .External.graphics(C_raster,
                       if (inherits(image, "nativeRaster")) image else as.raster(image),
                       as.double(xleft), as.double(ybottom),
                       as.double(xright), as.double(ytop),
                       as.double(angle), as.logical(interpolate), ...)
    invisible()
}

plot.raster <- function(x,                  # a "raster" object
                        y,                  # not used
                        xlim=c(0, ncol(x)), # by default based on raster dims
                        ylim=c(0, nrow(x)),
                        xaxs="i",           # by default fill plot region
                        yaxs="i",
                        asp=1,              # by default retain aspect ratio
                        add=FALSE,          # by default new plot
                        ...) {
    if (!add) {
        plot.new()
        plot.window(xlim=xlim, ylim=ylim, asp=asp, xaxs=xaxs, yaxs=yaxs)
    }
    rasterImage(x, 0, 0, ncol(x), nrow(x), ...)
}
#  File src/library/graphics/R/rect.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

rect <-
  function (xleft, ybottom, xright, ytop, density = NULL, angle = 45,
            col = NA, border = NULL, lty = par("lty"), lwd = par("lwd"), ...)
{
    if (is.numeric(density) && all(is.na(density) | density < 0))
        density <- NULL
    if (!is.null(density) && !is.null(angle)) {
        if (is.logical(border) && !is.na(border)) {
            border <- if(border) col else NA
        }
        n <- range(length(xleft), length(xright),
                   length(ybottom), length(ytop))
        if (n[1L] == 0)
            stop("invalid rectangle specification")
        n <- n[2L]
        x <- rbind(rep.int(NA, n), xleft, xright, xright, xleft)[-1L]
        y <- rbind(rep.int(NA, n), ybottom, ybottom, ytop, ytop)[-1L]
        polygon(x, y, col = col, border = border, lty = lty, lwd = lwd,
                density = density, angle = angle, ...)
    }
    else
        .External.graphics(C_rect, as.double(xleft), as.double(ybottom),
                           as.double(xright), as.double(ytop),
                           col = col, border = border,
                           lty = lty, lwd = lwd, ...)
    invisible()
}
#  File src/library/graphics/R/rug.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

rug <- function(x, ticksize = 0.03, side = 1, lwd = 0.5, col = par("fg"),
		quiet = getOption("warn") < 0, ...)
{
    x <- as.vector(x)
    ok <- is.finite(x)
    x <- x[ok]
    if(!quiet) {
	u <- par("usr")
	u <- if (side %% 2 == 1) {
	    if(par("xlog")) 10^u[1L:2] else u[1L:2]
	} else {
	    if(par("ylog")) 10^u[3:4] else u[3:4]
	}
	if(any(x < u[1L] | x > u[2L]))
	    warning("some values will be clipped")
    }
    Axis(side = side, at = x, labels = FALSE,
         lwd = 0, lwd.ticks = lwd, col.ticks = col,
         tck = ticksize, ...)
}
#  File src/library/graphics/R/screen.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2023 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/


## An environment not exported from namespace:graphics used to
## store the split.screen settings
.SSenv <- new.env()

.SSname <- function(x) paste(x, dev.cur(), sep=":")
.SSget    <- function(x)           get(.SSname(x), envir=.SSenv, inherits=FALSE)
.SSexists <- function(x)        exists(.SSname(x), envir=.SSenv, inherits=FALSE)
.SSassign <- function(x, value) assign(.SSname(x), value, envir=.SSenv)
.SSenv$par.list <-
       c("xlog","ylog",
         "adj", "bty", "cex", "col", "crt", "err", "font", "lab",
         "las", "lty", "lwd", "mar", "mex", "mfg", "mgp", "pch",
         "pty", "smo", "srt", "tck", "usr", "xaxp", "xaxs", "xaxt", "xpd",
         "yaxp", "yaxs", "yaxt", "fig")

split.screen <-
    function(figs, screen, erase = TRUE)
{
    first.split <- !.SSexists("sp.screens")
    if(missing(screen))
        screen <- if(!first.split) .SSget("sp.cur.screen") else 0
    if(!first.split) .valid.screens <- .SSget("sp.valid.screens")
    if (missing(figs))
	if (first.split)
	    return(FALSE)
	else
	    return(.valid.screens)
    if ((first.split && screen != 0) ||
	(!first.split && !(screen %in% .valid.screens)))
	stop("invalid screen number")
    ## if figs isn't a matrix, make it one
    if (!is.matrix(figs)) {
	if (!is.vector(figs))
	    stop("'figs' must be a vector or a matrix with 4 columns")
	nr <- figs[1L]
	nc <- figs[2L]
	x <- seq.int(0, 1, length.out=nc+1)
	y <- seq.int(1, 0, length.out=nr+1)
	figs <- matrix(c(rep.int(x[-(nc+1)], nr), rep.int(x[-1L], nr),
			 rep.int(y[-1L], rep.int(nc, nr)),
			 rep.int(y[-(nr+1)], rep.int(nc, nr))),
		       ncol = 4)
    }
    num.screens <- nrow(figs)
    if (num.screens < 1)
	stop("'figs' must specify at least one screen")
    new.screens <- valid.screens <- cur.screen <- 0
    if (first.split) {
        if (erase) plot.new()
	## save the current graphics state
	split.saved.pars <- par(.SSenv$par.list)
	split.saved.pars$fig <- NULL
	## NOTE: remove all margins when split screens
	split.saved.pars$omi <- par(omi=rep.int(0,4))$omi
	.SSassign("sp.saved.pars", split.saved.pars)
	## set up the screen information
	split.screens <- vector(mode="list", length=num.screens)
	new.screens <- 1L:num.screens
	for (i in new.screens) {
	    split.screens[[i]] <- par(.SSenv$par.list)
	    split.screens[[i]]$fig <- figs[i,]
	}
	valid.screens <- new.screens
	cur.screen <- 1
    }
    else {
        if (erase) erase.screen(screen)
	max.screen <- max(.valid.screens)
	new.max.screen <- max.screen + num.screens
	split.screens <- .SSget("sp.screens")
	## convert figs to portions of the specified screen
	total <- c(0,1,0,1)
	if (screen > 0)
	    total <- split.screens[[screen]]$fig
	for (i in 1L:num.screens)
	    figs[i,] <- total[c(1,1,3,3)] +
		figs[i,]*rep.int(c(total[2L]-total[1L],
                                   total[4L]-total[3L]),
                                 c(2,2))
	new.screens <- (max.screen+1):new.max.screen
	for (i in new.screens) {
	    split.screens[[i]] <- par(.SSenv$par.list)
	    split.screens[[i]]$fig <- figs[i-max.screen,]
	}
	valid.screens <- c(.valid.screens, new.screens)
	cur.screen <- max.screen+1
    }
    .SSassign("sp.screens", split.screens)
    .SSassign("sp.cur.screen", cur.screen)
    .SSassign("sp.valid.screens", valid.screens)
    if(first.split) on.exit(close.screen(all.screens=TRUE))
    par(split.screens[[cur.screen]])
    on.exit()
    return(new.screens)
}

screen <- function(n = cur.screen, new = TRUE)
{
    if (!.SSexists("sp.screens"))
	return(FALSE)
    cur.screen <- .SSget("sp.cur.screen")
    if (missing(n) && missing(new))
	return(cur.screen)
    if (!(n %in% .SSget("sp.valid.screens")))
	stop("invalid screen number")
    split.screens <- .SSget("sp.screens")
    split.screens[[cur.screen]] <- par(.SSenv$par.list)
    .SSassign("sp.screens", split.screens)
    .SSassign("sp.cur.screen", n)
    par(split.screens[[n]])
    if (new)
	erase.screen(n)
    invisible(n)
}

erase.screen <- function(n = cur.screen)
{
    if (!.SSexists("sp.screens"))
	return(FALSE)
    cur.screen <- .SSget("sp.cur.screen")
    if (!(n %in% .SSget("sp.valid.screens")) && n != 0)
	stop("invalid screen number")
    old <- par(usr=c(0,1,0,1), mar=c(0,0,0,0),
	       fig = if (n > 0)
	       .SSget("sp.screens")[[n]]$fig
	       else
	       c(0,1,0,1),
	       xaxs="i", yaxs="i")
    on.exit(par(old))
    par(new=TRUE)
    plot.new()
    polygon(c(0,1,1,0), c(0,0,1,1), border=NA, col=0)
    par(new=TRUE)
    invisible()
}

close.screen <- function(n, all.screens=FALSE)
{
    if (!.SSexists("sp.screens"))
	return(FALSE)
    if (missing(n) && missing(all.screens))
	return(.SSget("sp.valid.screens"))
    valid.screens <- .SSget("sp.valid.screens")
    if (all.screens || all(valid.screens %in% n)) {
	par(.SSget("sp.saved.pars") )
	par(mfrow=c(1,1), new=FALSE)
	rm(list=.SSname(c("sp.screens", "sp.cur.screen", "sp.saved.pars", "sp.valid.screens")),
           envir=.SSenv)
	invisible()
    } else {
        valid.screens <- valid.screens[-sort(match(n, valid.screens))]
	.SSassign("sp.valid.screens", valid.screens)
	temp <- .SSget("sp.cur.screen")
	if (temp %in% n) {
            poss <- valid.screens[valid.screens>temp]
	    temp <- if(length(poss)) min(poss) else min(valid.screens)
        }
	screen(temp, new=FALSE)
	valid.screens
    }
}
#  File src/library/graphics/R/segments.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

segments <-
    function(x0, y0, x1 = x0, y1 = y0, col=par("fg"), lty=par("lty"),
             lwd=par("lwd"), ...)
{
    if (missing(x1) && missing(y1))
        stop("one of 'x1' and 'y1' must be given")
    .External.graphics(C_segments, x0, y0, x1, y1, col=col, lty=lty, lwd=lwd, ...)
    invisible()
}
#  File src/library/graphics/R/smoothScatter.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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/


smoothScatter <- function(x, y=NULL, nbin=128, bandwidth,
			  colramp=colorRampPalette(c("white", blues9)),
			  nrpoints=100, ret.selection=FALSE, pch=".", cex=1, col="black",
			  transformation = function(x) x^.25,
                          postPlotHook = box,
			  xlab=NULL, ylab=NULL, xlim, ylim,
			  xaxs=par("xaxs"), yaxs=par("yaxs"), ...)
{
    if (!is.numeric(nrpoints) || nrpoints < 0 || length(nrpoints) != 1)
	stop("'nrpoints' should be numeric scalar with value >= 0.")
    nrpoints <- round(nrpoints)
    ret.selection <- ret.selection && nrpoints > 0

    ## similar as in plot.default
    xlabel <- if (!missing(x)) deparse1(substitute(x))
    ylabel <- if (!missing(y)) deparse1(substitute(y))
    xy <- xy.coords(x, y, xlabel, ylabel)
    if (is.null(xlab)) xlab <- xy$xlab
    if (is.null(ylab)) ylab <- xy$ylab

    ## eliminate non-finite (incl. NA) values
    ## want to keep rownames
    x <- cbind(xy$x, xy$y)[ I <- is.finite(xy$x) & is.finite(xy$y), , drop=FALSE]
    if(ret.selection) iS <- which(I)

    ## xlim and ylim
    if(!missing(xlim)) {
	stopifnot(is.numeric(xlim), length(xlim)==2, is.finite(xlim))
	x <- x[ I <- min(xlim) <= x[,1] & x[,1] <= max(xlim), , drop=FALSE]
        if(ret.selection) iS <- iS[I]
    } else {
	xlim <- range(x[,1])
    }
    if(!missing(ylim)) {
	stopifnot(is.numeric(ylim), length(ylim)==2, is.finite(ylim))
	x <- x[ I <- min(ylim) <= x[,2] & x[,2] <= max(ylim), , drop=FALSE]
        if(ret.selection) iS <- iS[I]
    } else {
	ylim <- range(x[,2])
    }

    ## create density map [ code in --> ../../grDevices/R/smooth2d.R ]:
    map	 <- grDevices:::.smoothScatterCalcDensity(x, nbin, bandwidth)
    xm	 <- map$x1
    ym	 <- map$x2
    dens <- map$fhat
    dens[] <- transformation(dens)

    ## plot color image
    image(xm, ym, z=dens, col=colramp(256),
          xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, xaxs=xaxs, yaxs=yaxs, ...)
    if(!is.null(postPlotHook))
	postPlotHook()

    ## plot selection of dots
    if (nrpoints > 0) {
	nrpoints <- min(nrow(x), ceiling(nrpoints))
	## we assume that map$x1 and map$x2 go linearly from
	## their first to their last value in nbin steps
	stopifnot((nx <- length(xm)) == nrow(dens),
		  (ny <- length(ym)) == ncol(dens))
	ixm <- 1L + as.integer((nx-1)*(x[,1]-xm[1])/(xm[nx]-xm[1]))
	iym <- 1L + as.integer((ny-1)*(x[,2]-ym[1])/(ym[ny]-ym[1]))
	sel <- order(dens[cbind(ixm, iym)])[seq_len(nrpoints)]
	x <- x[sel, , drop=FALSE]
	points(x, pch=pch, cex=cex, col=col)
        if(ret.selection) iS[sel]
    }
}
#  File src/library/graphics/R/spineplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 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/

## Spine plots/Spinograms contributed by Achim Zeileis

spineplot <- function(x, ...) {
    UseMethod("spineplot")
}

spineplot.formula <-
function(formula, data = NULL,
         breaks = NULL, tol.ylab = 0.05, off = NULL, ylevels = NULL,
         col = NULL, main = "", xlab = NULL, ylab = NULL,
         xaxlabels = NULL, yaxlabels = NULL,
         xlim = NULL, ylim = c(0, 1), axes = TRUE, ...,
         subset = NULL, weights = NULL, drop.unused.levels = FALSE)
{
    ## extract x, y from formula
    m <- match.call(expand.dots = FALSE)
    m <- m[c(1L, match(c("formula", "data", "subset", "weights", "drop.unused.levels"), names(m), 0L))]
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame)
    mf <- eval.parent(m)
    if(length(setdiff(names(mf), "(weights)")) != 2L)
        stop("'formula' should specify exactly two variables")
    y <- mf[,1L]
    if(!is.factor(y))
        stop("dependent variable should be a factor")
    if(!is.null(ylevels))
      y <- factor(y, levels = if(is.numeric(ylevels)) levels(y)[ylevels] else ylevels)
    x <- mf[,2L]
    w <- if("(weights)" %in% names(mf)) mf[,"(weights)"] else NULL

    ## graphical parameters
    if(is.null(xlab)) xlab <- names(mf)[2L]
    if(is.null(ylab)) ylab <- names(mf)[1L]

    ## call default interface
    spineplot(x, y, breaks = breaks, tol.ylab = tol.ylab, off = off, ylevels = NULL,
              col = col, main = main, xlab = xlab, ylab = ylab,
              xaxlabels = xaxlabels, yaxlabels = yaxlabels,
              xlim = xlim, ylim = ylim, axes = axes, weights = w, ...)
}

spineplot.default <-
function(x, y = NULL,
         breaks = NULL, tol.ylab = 0.05, off = NULL, ylevels = NULL,
         col = NULL, main = "", xlab = NULL, ylab = NULL,
         xaxlabels = NULL, yaxlabels = NULL,
         xlim = NULL, ylim = c(0, 1), axes = TRUE, weights = NULL, ...)
{
    ## either supply a 2-way table (i.e., both y and x are categorical)
    ## or two variables (y has to be categorical - x can be categorical
    ## or numerical)
    if(missing(y)) {
        if(length(dim(x)) != 2L)
            stop("a 2-way table has to be specified")
        if(!is.null(weights))
            stop("weights are not supported for 2-way table specification")
        tab <- x
        x.categorical <- TRUE
        if(is.null(xlab)) xlab <- names(dimnames(tab))[1L]
        if(is.null(ylab)) ylab <- names(dimnames(tab))[2L]
        xnam <- dimnames(tab)[[1L]]
        ynam <- dimnames(tab)[[2L]]
        ny <- NCOL(tab)
        nx <- NROW(tab)
    } else {
        if(!is.factor(y)) stop("dependent variable should be a factor")
	if(!is.null(ylevels))
          y <- factor(y, levels = if(is.numeric(ylevels)) levels(y)[ylevels] else ylevels)
        x.categorical <- is.factor(x)
        if(is.null(xlab)) xlab <- deparse1(substitute(x))
        if(is.null(ylab)) ylab <- deparse1(substitute(y))
        if(x.categorical) {
            if(is.null(weights)) {
                tab <- table(x, y)
            } else {
                tab <- as.table(tapply(weights, list(x, y), FUN = sum, na.rm = TRUE))
                tab[is.na(tab)] <- 0
            }
            xnam <- levels(x)
            nx <- NROW(tab)
        }
        ynam <- levels(y)
        ny <- length(ynam)
    }

    ## graphical parameters
    if(is.null(col)) col <- gray.colors(ny)
    col <- rep_len(col, ny)
    off <- if(!x.categorical) 0 else if(is.null(off)) 0.02 else off/100
    yaxlabels <- if(is.null(yaxlabels)) ynam else rep_len(yaxlabels, ny)

    if(x.categorical) {
        ## compute rectangle positions on x axis
        xat <- c(0, cumsum(proportions(marginSums(tab, 1)) + off))
        xaxlabels <- if(is.null(xaxlabels)) xnam else rep_len(xaxlabels, nx)
    } else {
        ## handle non-numeric x
	if(!(xnumeric <- is.numeric(x))) {
	    xorig <- x
	    x <- as.numeric(x)
	}
        ## compute breaks for x
        if (is.null(breaks)) {
            breaks <- if(is.null(weights)) nclass.Sturges(x) else ceiling(log2(sum(weights)) + 1)
	}
        breaks <- as.numeric(breaks)
        if (length(breaks) == 1L) {
            if (!is.numeric(breaks) || !is.finite(breaks) || breaks < 1L) {
                stop("invalid number of 'breaks'")
            }
            if (breaks > 1e+06) {
                warning(gettextf("'breaks = %g' is too large and set to 1e6", breaks), domain = NA)
                breaks <- 1000000L
            }
            rg <- if (is.null(weights)) range(x, na.rm = TRUE) else range(x[weights > 0], na.rm = TRUE)
            breaks <- pretty(rg, n = breaks, min.n = 1)        
        }
        ## categorize x
        x1 <- cut(x, breaks = breaks, include.lowest = TRUE)
        ## construct table
        if(is.null(weights)) {
            tab <- table(x1, y)
        } else {
            tab <- as.table(tapply(weights, list(x1, y), FUN = sum, na.rm = TRUE))
            tab[is.na(tab)] <- 0
        }
        ## compute rectangle positions on x axis
        xat <- c(0, cumsum(proportions(marginSums(tab, 1)))) # c(0, cumsum(proportions(table(x1))))
        nx <- NROW(tab)
        xaxlabels <- if(is.null(xaxlabels)) {
	  if(xnumeric) breaks else c(xorig[1L], xorig[c(diff(as.numeric(x1)) > 0, TRUE)])
	} else {
	    rep_len(xaxlabels, nx + 1L)
	}
    }

    ## compute rectangle positions on y axis
    ## (reversing order compared to version R < 4.0.0)
    yaxlabels <- rev(yaxlabels)
    yat <- rbind(0, apply(proportions(tab[, ncol(tab):1L, drop = FALSE], 1), 1L, cumsum))
    yat[is.na(yat)] <- 1

    if(is.null(xlim)) xlim <- c(0, 1 + off * (nx-1L))
    else if(any(xlim < 0) || any(xlim > 1)) {
        warning("x axis is on a cumulative probability scale, 'xlim' must be in [0,1]")
        if(min(xlim) > 1 || max(xlim) < 0) xlim <- c(0, 1)
        else xlim <- c(max(min(xlim), 0), min(max(xlim), 1))
    }
    if(any(ylim < 0) || any(ylim > 1)) {
        warning("y axis is on a cumulative probability scale, 'ylim' must be in [0,1]")
        if(min(ylim) > 1 || max(ylim) < 0) ylim <- c(0, 1)
        else ylim <- c(max(min(ylim), 0), min(max(ylim), 1))
    }

    ## setup plot
    dev.hold(); on.exit(dev.flush())
    plot(0, 0, xlim = xlim, ylim = ylim, type = "n", axes = FALSE,
         xaxs = "i", yaxs = "i", main = main, xlab = xlab, ylab = ylab)

    ## compute coordinates
    ybottom <- as.vector(yat[-(ny + 1L),])
    ytop <- as.vector(yat[-1L,])
    xleft <- rep(xat[1L:nx], rep(ny, nx))
    xright <- rep(xat[2L:(nx+1L)] - off, rep(ny, nx))
    col <- rep(col, nx)

    ## plot rectangles
    rect(xleft, ybottom, xright, ytop, col = col, ...)

    ## axes
    if(axes) {
        ## side --
        ## 1: either numeric or level names
        if(x.categorical)
            axis(1, at = (xat[1L:nx] + xat[2L:(nx+1L)] - off)/2,
                 labels = xaxlabels, tick = FALSE)
        else
            axis(1, at = xat, labels = xaxlabels)

        ## 2: axis with level names of y
        yat <- yat[,1L]
        equidist <- any(diff(yat) < tol.ylab)
        yat <- if(equidist) seq.int(1/(2*ny), 1-1/(2*ny), by = 1/ny)
        else (yat[-1L] + yat[-length(yat)])/2
        axis(2, at = yat, labels = yaxlabels, tick = FALSE)

        ## 3: none
        ## 4: simple numeric
        axis(4)
    }
    if(!x.categorical) box()

    ## return table visualized
    names(dimnames(tab)) <- c(xlab, ylab)
    invisible(tab)
}
#  File src/library/graphics/R/stars.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

### This code started life as spatial star plots by David A. Andrews.
### See http://www.udallas.edu:8080/~andrews/software/software.html
### T. Dye July 1999;  many improvements by MM

stars <-
function(x, full = TRUE, scale = TRUE, radius = TRUE,
	 labels = dimnames(x)[[1L]], locations = NULL,
         nrow = NULL, ncol = NULL, len = 1,
         key.loc = NULL, key.labels = dimnames(x)[[2L]], key.xpd = TRUE,
         xlim = NULL, ylim = NULL, flip.labels = NULL,
         draw.segments = FALSE, col.segments = 1L:n.seg,
         col.stars = NA, col.lines = NA,
         axes = FALSE, frame.plot = axes,
         main = NULL, sub = NULL, xlab = "", ylab = "",
         cex = 0.8, lwd = 0.25, lty = par("lty"), xpd = FALSE,
         mar = pmin(par("mar"),
                    1.1+ c(2*axes+ (xlab != ""), 2*axes+ (ylab != ""), 1,0)),
         add=FALSE, plot=TRUE, ...)
{
    if (is.data.frame(x))
	x <- data.matrix(x)
    else if (!is.matrix(x))
	stop("'x' must be a matrix or a data frame")
    if (!is.numeric(x))
	stop("data in 'x' must be numeric")

    n.loc <- nrow(x)
    n.seg <- ncol(x)

    if (is.null(locations)) { ## Default (x,y) locations matrix
	if(is.null(nrow))
            nrow <- ceiling(if(!is.numeric(ncol)) sqrt(n.loc) else n.loc/ncol)
	if(is.null(ncol))
            ncol <- ceiling(n.loc/nrow)
        if(nrow * ncol < n.loc)
            stop("'nrow * ncol' is less than the number of observations")
        ff <- if(!is.null(labels)) 2.3 else 2.1
        locations <- expand.grid(ff * 1L:ncol, ff * nrow:1)[1L:n.loc, ]
        if(!is.null(labels) && (missing(flip.labels) ||
                                !is.logical(flip.labels)))
            flip.labels <- ncol * mean(nchar(labels, type="c")) > 30
    }
    else {
        if (is.numeric(locations) && length(locations) == 2) {
            ## all stars around the same origin
            locations <- cbind(rep.int(locations[1L],n.loc),
                               rep.int(locations[2L],n.loc))
            if(!missing(labels) && n.loc > 1)
                warning("labels do not make sense for a single location")
            else labels <- NULL
        }
        else {
            if (is.data.frame(locations))
                locations <- data.matrix(locations)
            if (!is.matrix(locations) || ncol(locations) != 2)
                stop("'locations' must be a 2-column matrix.")
            if (n.loc != nrow(locations))
                stop("number of rows of 'locations' and 'x' must be equal.")
        }
        if(missing(flip.labels) || !is.logical(flip.labels))
            flip.labels <- FALSE # have no grid
    }
    xloc <- locations[,1]
    yloc <- locations[,2]
    ## Angles start at zero and pace around the circle counter
    ## clock-wise in equal increments.
    angles <-
	if(full)
	    seq.int(0, 2*pi, length.out=n.seg+1)[-(n.seg+1)]
	else if (draw.segments)
	    seq.int(0, pi, length.out=n.seg+1)[-(n.seg+1)]
	else
	    seq.int(0, pi, length.out=n.seg)

    if (length(angles) != n.seg)
	stop("length of 'angles' must equal 'ncol(x)'")

    ## Missing values are treated as 0
    if (scale) {
        x <- apply(x, 2L, function(x)
                   (x - min(x, na.rm = TRUE))/diff(range(x, na.rm = TRUE)))
    }
    ## Missing values are treated as 0
    x[is.na(x)] <- 0
    mx <- max(x <- x * len)

    if(is.null(xlim)) xlim <- range(xloc) + c(-mx, mx)
    if(is.null(ylim)) ylim <- range(yloc) + c(-mx, mx)

    deg <- pi / 180

    ## The asp argument keeps everything (the symbols!) square
    op <- par(mar = mar, xpd = xpd) ; on.exit(par(op))
    dev.hold(); on.exit(dev.flush(), add = TRUE)
    if(plot && !add)
        plot(0, type="n", ..., xlim=xlim, ylim=ylim,
             main = main, sub = sub, xlab = xlab, ylab=ylab,
             asp = 1, axes = axes)

    if(!plot)
        return(locations)

    s.x <- xloc + x * rep.int(cos(angles), rep.int(n.loc,n.seg))
    s.y <- yloc + x * rep.int(sin(angles), rep.int(n.loc,n.seg))

    if ( draw.segments ) {
        aangl <- c(angles, if(full)2*pi else pi)
	for (i in 1L:n.loc) { ## for each location, draw a segment diagram
	    px <- py <- numeric()
	    for (j in 1L:n.seg) {
		k <- seq.int(from = aangl[j], to = aangl[j+1], by = 1*deg)
		px <- c(px, xloc[i], s.x[i,j], x[i,j]*cos(k) + xloc[i], NA)
		py <- c(py, yloc[i], s.y[i,j], x[i,j]*sin(k) + yloc[i], NA)
	    }
	    polygon(px, py, col = col.segments, lwd=lwd, lty=lty)
	}
    } # Segment diagrams

    else { # Draw stars instead
	for (i in 1L:n.loc) {
	    polygon(s.x[i,], s.y[i,], lwd=lwd, lty=lty, col = col.stars[i])
	    polygon(s.x[i, ], s.y[i, ], lwd = lwd, lty = lty,
			border = col.lines[i], col = col.stars[i])
	    if (radius)
		segments(rep.int(xloc[i],n.seg),
			 rep.int(yloc[i],n.seg),
			 s.x[i,], s.y[i,], lwd=lwd, lty=lty)
	}
    }

    if(!is.null(labels)) {
        ## vertical text offset from center
        y.off <- mx * (if(full) 1 else 0.1)
        if(flip.labels)
            y.off <- y.off + cex*par("cxy")[2L] *
                ((1L:n.loc)%%2 - if(full) .4 else 0)
        ##DBG cat("mx=",format(mx),"y.off:"); str(y.off)
        text(xloc, yloc - y.off, labels, cex=cex, adj=c(0.5, 1))
    }

    if ( !is.null(key.loc) ) { ## Draw unit key

        ## usually allow drawing outside plot region:
        par(xpd = key.xpd) # had `xpd' already above
        key.x <- len * cos(angles) + key.loc[1L]
        key.y <- len * sin(angles) + key.loc[2L]
	if (draw.segments) {
	    px <- py <- numeric()
	    for (j in 1L:n.seg) {
		k <- seq.int(from = aangl[j], to = aangl[j+1], by = 1*deg)
		px <- c(px, key.loc[1L], key.x[j], len * cos(k) + key.loc[1L], NA)
		py <- c(py, key.loc[2L], key.y[j], len * sin(k) + key.loc[2L], NA)
	    }
	    polygon(px, py, col = col.segments, lwd=lwd, lty=lty)
	}
	else { # draw unit star
	    polygon(key.x, key.y, lwd=lwd, lty=lty)
	    if (radius)
		segments(rep.int(key.loc[1L],n.seg), rep.int(key.loc[2L],n.seg),
			 key.x, key.y, lwd=lwd, lty=lty)
	}

        ## Radial Labeling -- should this be a standalone function ?
	lab.angl <- angles +
            if(draw.segments) (angles[2L] - angles[1L]) / 2 else 0
	label.x <- 1.1 * len * cos(lab.angl) + key.loc[1L]
	label.y <- 1.1 * len * sin(lab.angl) + key.loc[2L]
        ## Maybe do the following without loop {need not use adj but ..)!
	for (k in 1L:n.seg) {
	    text.adj <-
                c(## horizontal
                  if      (lab.angl[k] < 90*deg || lab.angl[k] > 270*deg) 0
                  else if (lab.angl[k] > 90*deg && lab.angl[k] < 270*deg) 1
                  else 0.5,
                  ## vertical
                  if (lab.angl[k] <= 90*deg) (1 - lab.angl[k] / (90*deg)) /2
                  else if (lab.angl[k] <= 270*deg)
                  (lab.angl[k] - 90*deg) / (180*deg)
                  else ## lab.angl[k] > 270*deg
                  1 - (lab.angl[k] - 270*deg) / (180*deg)
                  )
	    text(label.x[k], label.y[k],
                 labels = key.labels[k], cex = cex, adj = text.adj)
	}
    } # Unit key is drawn and labelled

    if (frame.plot) box(...)

    invisible(locations)
}
#  File src/library/graphics/R/stem.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2013 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/

stem <- function(x, scale = 1, width = 80, atom = 0.00000001)
{
    if (!is.numeric(x) ) stop("'x' must be numeric")
    x <- x[is.finite(x)]
    n <- as.integer(length(x))
    if (is.na(n)) stop("invalid length(x)")
    if (n == 0) stop("no finite and non-missing values")
    if (scale <= 0) stop("'scale' must be positive") # unlike S
    .Call(C_StemLeaf, as.double(x), scale, width, atom)
    invisible(NULL)
}
#  File src/library/graphics/R/stripchart.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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/

## Dotplots a la Box, Hunter and Hunter

stripchart <- function(x, ...) UseMethod("stripchart")

stripchart.default <-
function(x, method = "overplot", jitter = 0.1, offset = 1/3, vertical = FALSE,
	 group.names, add = FALSE, at = NULL,
	 xlim = NULL, ylim = NULL, ylab = NULL, xlab = NULL,
         dlab = "", glab = "", log = "", pch = 0, col = par("fg"),
         cex = par("cex"), axes = TRUE, frame.plot = axes, ...)
{
    method <- pmatch(method, c("overplot", "jitter", "stack"))[1L]
    if(is.na(method) || method == 0L)
	stop("invalid plotting method")
    groups <-
	if(is.list(x)) x else if(is.numeric(x)) list(x)
    n <- length(groups)
    if(!n) stop("invalid first argument")
    if(!missing(group.names))
	attr(groups, "names") <- group.names
    else if(is.null(attr(groups, "names")))
	attr(groups, "names") <- seq_len(n)
    if(is.null(at)) at <- seq_len(n)
    else if(length(at) != n)
	stop(gettextf("'at' must have length equal to the number %d of groups",
                      n), domain = NA)
    if (is.null(dlab)) dlab <- deparse1(substitute(x))

    dev.hold(); on.exit(dev.flush())
    if(!add) {
        dlim <- range(unlist(groups, use.names = FALSE), na.rm = TRUE)
	glim <- c(1L, n) # in any case, not range(at)
	if(method == 2L) { # jitter
	    glim <- glim + jitter * if(n == 1) c(-5, 5) else c(-2, 2)
	} else if(method == 3) { # stack
	    glim <- glim + if(n == 1L) c(-1,1) else c(0, 0.5)
	}
	if(is.null(xlim))
	    xlim <- if(vertical) glim else dlim
	if(is.null(ylim))
	    ylim <- if(vertical) dlim else glim
        plot.new()
        plot.window(xlim, ylim, log, ...)
        if(frame.plot) box() # maybe (...)
	if(vertical) {
	    if (axes) {
		if(n > 1L) axis(1, at = at, labels = names(groups), ...)
		Axis(x, side = 2, ...)
	    }
	    if (is.null(ylab)) ylab <- dlab
	    if (is.null(xlab)) xlab <- glab
	}
	else {
	    if (axes) {
		Axis(x, side = 1, ...)
		if(n > 1L) axis(2, at = at, labels = names(groups), ...)
	    }
	    if (is.null(xlab)) xlab <- dlab
	    if (is.null(ylab)) ylab <- glab
	}
	title(xlab = xlab, ylab = ylab, ...)
    }
    csize <- cex *
	if(vertical) xinch(par("cin")[1L]) else yinch(par("cin")[2L])
    for(i in seq_len(n)) {
	x <- groups[[i]]
	y <- rep.int(at[i], length(x))
	if(method == 2L) ## jitter
	    y <- y + stats::runif(length(y), -jitter, jitter)
	else if(method == 3L) { ## stack
	    xg <- split(x, factor(x))
	    xo <- lapply(xg, seq_along)
	    x <- unlist(xg, use.names=FALSE)
	    y <- rep.int(at[i], length(x)) +
		(unlist(xo, use.names=FALSE) - 1) * offset * csize
	}
	if(vertical)
            points(y, x, col = col[(i - 1L) %% length(col) + 1L],
                   pch = pch[(i - 1L) %% length(pch) + 1L], cex = cex, ...)
	else
            points(x, y, col = col[(i - 1L) %% length(col) + 1L],
                   pch = pch[(i - 1L) %% length(pch) + 1L], cex = cex, ...)
    }
    invisible()
}

stripchart.formula <-
    function(x, data = NULL, dlab = NULL, ..., subset, na.action = NULL)
{
    if(missing(x) || (length(x) != 3L))
	stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    m$... <- NULL
    m$formula <- m$x
    m$x <- NULL
    m$na.action <- na.action # force use of default for this method
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame)
    mf <- eval(m, parent.frame())
    response <- attr(attr(mf, "terms"), "response")
    if (is.null(dlab)) dlab <- names(mf)[response]
    stripchart(split(mf[[response]], mf[-response]), dlab = dlab, ...)
}
#  File src/library/graphics/R/strwidth.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

strwidth <-
    function(s, units = "user", cex = NULL, font = NULL, vfont = NULL,...)
{
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1L], Hershey$typeface),
                   fontindex = pmatch(vfont[2L], Hershey$fontindex))
    .External.graphics(C_strWidth, as.graphicsAnnot(s),
                       pmatch(units, c("user", "figure", "inches")),
                       cex, font, vfont, ...)
}

strheight <-
    function(s, units = "user", cex = NULL, font = NULL, vfont = NULL, ...)
{
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1L], Hershey$typeface),
                   fontindex = pmatch(vfont[2L], Hershey$fontindex))
    .External.graphics(C_strHeight, as.graphicsAnnot(s),
                       pmatch(units, c("user", "figure", "inches")),
                       cex, font, vfont, ...)
}
#  File src/library/graphics/R/sunflowerplot.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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/

sunflowerplot <- function(x, ...) UseMethod("sunflowerplot")

sunflowerplot.default <-
    function(x, y = NULL, number, log = "", digits = 6L,
             xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
             add = FALSE, rotate = FALSE,
             pch = 16, cex = 0.8, cex.fact =  1.5, col = par("col"), bg = NA,
             size = 1/8, seg.col = 2, seg.lwd = 1.5, ...)
{
    ## Argument "checking" as plot.default:

    xlabel <- if (!missing(x)) deparse1(substitute(x))
    ylabel <- if (!missing(y)) deparse1(substitute(y))
    is.xyn <- (is.list(x) && all(c("x","y","number") %in% names(x)))
                                        # as, e.g., from grDevices::xyTable(.)
    xy <-
        if(is.xyn) {
            number <- x$number
            x
        } else xy.coords(x, y, xlabel, ylabel, log)
    if(!add) {
        if (is.null(xlab)) xlab <- xy$xlab
        if (is.null(ylab)) ylab <- xy$ylab
        if (is.null(xlim)) xlim <- range(xy$x[is.finite(xy$x)])
        if (is.null(ylim)) ylim <- range(xy$y[is.finite(xy$y)])
    }
    n <- length(xy$x)
    if(missing(number)) {
	tt <- xyTable(xy, digits = digits)## in ../../grDevices/R/calc.R
	x <- tt$x
	y <- tt$y
	number <- tt$number
    } else {
        if(length(number) != n)
            stop("'number' must have same length as 'x' and 'y'")
        np <- number > 0
        x <- xy$x[np]
        y <- xy$y[np]
        number <- number[np]
    }
    n <- length(x)
    dev.hold(); on.exit(dev.flush())
    if(!add)
        plot(x, y, xlab = xlab, ylab = ylab,
             xlim = xlim, ylim = ylim, log = log, type = "n", ...)

    n.is1 <- number == 1
    if(any(n.is1))
        points(x[ n.is1], y[ n.is1], pch = pch, col = col, bg = bg, cex = cex)
    if(any(!n.is1)) {
        points(x[!n.is1], y[!n.is1], pch = pch, col = col, bg = bg, cex = cex/cex.fact)
        i.multi <- (1L:n)[number > 1]
        ppin <- par("pin")
        pusr <- par("usr")
        xr <- size * abs(pusr[2L] - pusr[1L])/ppin[1L]
        yr <- size * abs(pusr[4L] - pusr[3L])/ppin[2L]

        i.rep <- rep.int(i.multi, number[number > 1])
        z <- numeric()
        for(i in i.multi)
            z <- c(z, 1L:number[i] + if(rotate) stats::runif(1) else 0)
        deg <- (2 * pi * z)/number[i.rep]
        segments(x[i.rep], y[i.rep],
                 x[i.rep] + xr * sin(deg),
                 y[i.rep] + yr * cos(deg),
                 col=seg.col, lwd = seg.lwd)
    }
    invisible(list(x=x, y=y, number=number))
}

sunflowerplot.formula <-
    function(formula, data = NULL, xlab = NULL, ylab = NULL, ...,
             subset, na.action = NULL)
{
    if(missing(formula) || (length(formula) != 3L))
	stop("formula missing or incorrect")
    m <- match.call(expand.dots = FALSE)
    if(is.matrix(eval(m$data, parent.frame())))
	m$data <- as.data.frame(data)
    m$xlab <- m$ylab <- m$... <- NULL
    m$na.action <- na.action # force use of default for this method
    ## need stats:: for non-standard evaluation
    m[[1L]] <- quote(stats::model.frame)
    mf <- eval(m, parent.frame())
    if(NCOL(mf) != 2L)
        stop("'formula' should specify exactly two variables")
    if(is.null(xlab)) xlab <- names(mf)[2L]
    if(is.null(ylab)) ylab <- names(mf)[1L]
    sunflowerplot(mf[[2L]], mf[[1L]], xlab = xlab, ylab = ylab, ...)
}
#  File src/library/graphics/R/symbols.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2019 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/

symbols <-
function (x, y = NULL, circles, squares, rectangles, stars,
	  thermometers, boxplots, inches = TRUE, add = FALSE,
	  fg = par("col"), bg = NA, xlab = NULL, ylab = NULL, main = NULL,
	  xlim=NULL, ylim=NULL, ...)
{
    count <- 0
    if (!missing(circles)) {
	count <- count + 1
	data <- circles
	type <- 1
    }
    if (!missing(squares)) {
	count <- count + 1
	data <- squares
	type <- 2
    }
    if (!missing(rectangles)) {
	count <- count + 1
	data <- rectangles
	type <- 3
    }
    if (!missing(stars)) {
	count <- count + 1
	data <- stars
	type <- 4
    }
    if (!missing(thermometers)) {
	count <- count + 1
	data <- thermometers
	type <- 5
    }
    if (!missing(boxplots)) {
	count <- count + 1
	data <- boxplots
	type <- 6
    }
    if (count != 1)
	stop("exactly one symbol type must be specified")
    xy <- xy.coords(x, y,
                    xlab = deparse1(substitute(x)),
                    ylab = deparse1(substitute(y)))
    x <- xy$x; y <- xy$y
    if (!add) {
	if(is.null(xlab)) xlab <- xy$xlab
	if(is.null(ylab)) ylab <- xy$ylab
	## Expand the range by 2 * 0.10 = 20% : wild guess !
	## FIXME: better guess: use size of largest symbol...
	##	      really would need	 (x, y, type, data, inches) ->
	##	      rather an internal symbols.limits()
	if(is.null(xlim))
	    xlim <- extendrange(x, f = 0.10)
	if(is.null(ylim))
	    ylim <- extendrange(y, f = 0.10)
	plot(NA, NA, type = "n", xlim = xlim, ylim = ylim,
	     xlab = xlab, ylab = ylab, main = main, ...)
    }
    invisible(.External.graphics(C_symbols, x, y, type, data, inches, bg, fg, ...))
}
#  File src/library/graphics/R/text.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 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/

text <- function(x, ...) UseMethod("text")

text.default <-
function(x, y = NULL, labels = seq_along(x$x),
         adj = NULL, pos = NULL, offset = 0.5,
         vfont = NULL, cex = 1, col = NULL, font = NULL, ...)
{
    if (!missing(y) && (is.character(y) || is.expression(y))) {
	labels <- y; y <- NULL
    }
    x <- xy.coords(x,y, recycle = TRUE, setLab = FALSE)
    labels <- as.graphicsAnnot(labels)
    if (!is.null(vfont))
        vfont <- c(typeface = pmatch(vfont[1L], Hershey$typeface),
                   fontindex = pmatch(vfont[2L], Hershey$fontindex))
    .External.graphics(C_text, x, labels,
                       adj, pos, offset, vfont, cex, col, font, ...)
    invisible()
}
#  File src/library/graphics/R/title.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

title <- function(main=NULL, sub=NULL, xlab=NULL, ylab=NULL,
                  line=NA, outer=FALSE, ...)
{
    main <- as.graphicsAnnot(main)
    sub <- as.graphicsAnnot(sub)
    xlab <- as.graphicsAnnot(xlab)
    ylab <- as.graphicsAnnot(ylab)
    .External.graphics(C_title, main, sub, xlab, ylab, line, outer, ...)
    invisible()
}
#  File src/library/graphics/R/units.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

xinch <- function(x=1, warn.log=TRUE) {
    if(warn.log && par("xlog")) warning("x log scale:  xinch() is nonsense")
    x * diff(par("usr")[1L:2])/par("pin")[1L]
}
yinch <- function(y=1, warn.log=TRUE) {
    if(warn.log && par("ylog")) warning("y log scale:  yinch() is nonsense")
    y * diff(par("usr")[3:4])/par("pin")[2L]
}

xyinch <- function(xy=1, warn.log=TRUE) {
    if(warn.log && (par("xlog") || par("ylog")))
	warning("log scale:  xyinch() is nonsense")
    u <- par("usr"); xy * c(u[2L]-u[1L], u[4L]-u[3L]) / par("pin")
}
#  File src/library/graphics/R/zzz.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2012 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/

## <entry>
## Deprecated in 1.5.0
## Defunct in 1.6.0
piechart <- function(x, labels = names(x), edges = 200, radius = 0.8,
                     density = NULL, angle = 45, col = NULL, main = NULL, ...)
    .Defunct("pie")
## </entry>


.noGenerics <- TRUE

# not yet
# .onUnload <- function(libpath) .Call(RunregisterBase);

