Question

我想使用coplot{graphic}创建一个很好的条件图。感谢这个回答Add a line to coplot {graphics}, classic approaches don't work我可以简单地在我的情节中添加几个数据（线）。但是，请问，我怎样才能很好地添加辅助轴及其名称 - 理想情况下是不同的颜色？我发现我可以在axis(4, col = "red", lwd = 2)中将辅助轴添加为panel，在mtext(2,...)中添加其名称。这有效，但我的所有情节都有xlab和ylab，而不仅仅是条件图的边界。请问，如何添加辅助轴名称并使其可读？谢谢！

我的代码：

# exemple data
set.seed(15)
dd <- do.call("rbind", 
    do.call("Map", c(list(function(a,b) {
        cbind.data.frame(a,b, x=1:5, 
        y1=cumsum(rpois(5,7)),
        y2=cumsum(rpois(5,9)+100))   # make y axis ad different scale
    }), 
    expand.grid(a=letters[1:5], b=letters[20:22])))
 )


# create coplot

coplot(y~x|a+b, 
   # make a fake y col to cover range of all y1 and y2 values
   cbind(dd, y=seq(min(dd$y1, dd$y2), max(dd$y1, dd$y2), length.out=nrow(dd))), xlab="", ylab = "", main = "", 
    #request subscripts to be sent to panel function
    subscripts=TRUE, 
    panel=function(x,y,subscripts, ...) {
           # add first plot for y1
           par(new=T)
           plot(x, dd$y1[subscripts], axes = F)
        # draw group 1
        lines(x, dd$y1[subscripts])
        # axis(2, col = "black", lwd = 2)  - how to write this??
        # mtext(2, text = "name y1 axe", col = "black")

        # add data on secondary y2 axis
        par(new=T)
        plot(x, dd$y2[subscripts], axes = F)
        lines(x, dd$y2[subscripts], col="red")
        # axis(4, col = "red", lwd = 2)  - and this?
        # mtext(4, text = "name y2 axe", col = "red")      
})

它应该如何：

Answer 1

这里开始回答你的两个问题：1-在顶行和底行添加辅助y轴，在辅助轴上添加y-label。诀窍是仅为特定下标绘制辅助y轴（和标签）。你可能想玩下标数字来了解它们在情节中的位置。例如，下标[[75]]是右上角的面板。

if(subscripts[[25]]|subscripts[[75]]) axis(4, col = "red", lwd = 2)#  - and this?
if(subscripts[[50]]) mtext(4, text = "name y2 axe", col = "red",line=2)

这里是完整的代码：

coplot(y~x|a+b,
   # make a fake y col to cover range of all y1 and y2 values
   cbind(dd, y=seq(min(dd$y1, dd$y2), max(dd$y1, dd$y2), length.out=nrow(dd))), xlab="", ylab = "", main = "", xaxs=FALSE,
    #request subscripts to be sent to panel function
    subscripts=TRUE,
    panel=function(x,y,subscripts, ...) {
           # add first plot for y1
           par(new=T)
           plot(x, dd$y1[subscripts], axes = F)
        # draw group 1
        lines(x, dd$y1[subscripts])
        # axis(2, col = "black", lwd = 2)  - how to write this??
        # mtext(2, text = "name y1 axe", col = "black")

        # add data on secondary y2 axis
        par(new=T)
        plot(x, dd$y2[subscripts], axes = F)
        lines(x, dd$y2[subscripts], col="red")
        if(subscripts[[25]]|subscripts[[75]]) axis(4, col = "red", lwd = 2)#  - and this?
        if(subscripts[[50]]) mtext(4, text = "name y2 axe", col = "red",line=2)
})

这是你得到的：

现在，我怀疑你也想摆脱coplot生成的原始轴。没有直接的方法可以做到这一点。我建议您根据原始函数创建自己的coplot2函数。

你想要的是摆脱coplot函数的这一部分（这会在面板上添加左右轴）：

if ((j == 1) && ((total.rows - i)%%2 == 0))
    Paxis(2, y)
else if ((j == columns || index == nplots) && ((total.rows -
    i)%%2 == 0))
    Paxis(4, y)

<强>更新以下是如何修改coplot功能以满足您的要求。

这是一个新的coplot2功能，它不会绘制面板＆＃39;左右轴。代码与coplot相同，但上面的行已被注释掉。

coplot2 <- 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]]
    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
    }
    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 <- ""
    }
    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 (any(is.na(a.intervals)) || (have.b && any(is.na(b.intervals))))
        bad.givens()
    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)) {
                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
    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()
    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) {
        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 (any(is.na(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 == 0))
#            Paxis(4, y)
        box()
    }
    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))
    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)
        plot.window(a.range + c(0.03, -0.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 {
        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)
            plot.window(0.5 + c(0, nint), b.range + c(0.03, -0.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()
}

使用这个新的coplot2函数，您现在可以使用此代码生成图表。我还修正了y轴的范围，使它们在各行之间保持不变。

coplot2(y~x|a+b,
   # make a fake y col to cover range of all y1 and y2 values
   cbind(dd, y=seq(min(dd$y1, dd$y2), max(dd$y1, dd$y2), length.out=nrow(dd))), xlab="", ylab = "", main = "", xaxs=FALSE,
    #request subscripts to be sent to panel function
    subscripts=TRUE,
    panel=function(x,y,subscripts, ...) {
           # add first plot for y1
           par(new=T)
           plot(x, dd$y1[subscripts], axes = F, ylim=(range(dd$y1)))
        # draw group 1
        lines(x, dd$y1[subscripts])
        if(subscripts[[5]]|subscripts[[30]]|subscripts[[55]]) axis(2, col = "black", lwd = 2, cex.axis=0.9)#  - and this?
        if(subscripts[[30]]) mtext(2, text = "name y1 axe", col = "black",line=2)

        # add data on secondary y2 axis
        par(new=T)
        plot(x, dd$y2[subscripts], axes = F, ylim=(range(dd$y2)))
        lines(x, dd$y2[subscripts], col="red")
        if(subscripts[[25]]|subscripts[[50]]|subscripts[[75]]) axis(4, col = "red", col.axis="red", lwd = 2, cex.axis=0.9)#  - and this?
        if(subscripts[[50]]) mtext(4, text = "name y2 axe", col = "red",line=2)
})

R：将辅助轴的名称添加到coplot {graphic}

1 个答案: