R-alpha: Logarithmic scales

Arne Kovac Arne Kovac <maak@stats.bris.ac.uk>
Sun, 11 May 1997 20:08:32 +0000 (GMT)


Here are another three problems with logarithmic scales:

1) segments() does not work with logarithmic scales. I suggest to change
lines 962-973 in "plot.c":

    for (i = 0; i < n; i++) {
        if (FINITE(xt(x0[i%nx0])) && FINITE(yt(y0[i%ny0]))
            && FINITE(xt(x1[i%nx1])) && FINITE(yt(y1[i%ny1]))) {
            GP->col = INTEGER(col)[i % ncol];
            if(GP->col == NA_INTEGER) GP->col = colsave;
            GP->lty = INTEGER(lty)[i % nlty];
            GStartPath();
            GMoveTo(XMAP(xt(x0[i % nx0])), YMAP(yt(y0[i % ny0])));
            GLineTo(XMAP(xt(x1[i % nx1])), YMAP(yt(y1[i % ny1])));
            GEndPath();
        }
    }

2) rect() does not work either. Unfortunately, do_rect() in "plot.c" 
overrides the yt() function... What about this (lines 983-1031):

SEXP do_rect(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP sxl, sxr, syb, sys, col, lty, border;
    double *xl, *xr, *yb, *ys;
    int i, n, nxl, nxr, nyb, nys;
    int ncol, nlty, nborder;
    int colsave, ltysave;

    GCheckState();

    if(length(args) < 4) errorcall(call, "too few arguments\n");
    xypoints(call, args, &n);

    sxl = CAR(args); nxl = length(sxl); args = CDR(args);
    syb = CAR(args); nyb = length(syb); args = CDR(args);
    sxr = CAR(args); nxr = length(sxr); args = CDR(args);
    sys = CAR(args); nys = length(sys); args = CDR(args);

    PROTECT(col = FixupCol(GetPar("col", args)));
    ncol = LENGTH(col);

    PROTECT(border =  FixupCol(GetPar("border", args)));
    nborder = LENGTH(border);

    PROTECT(lty = FixupLty(GetPar("lty", args)));
    nlty = length(lty);

    xl = REAL(sxl);
    xr = REAL(sxr);
    yb = REAL(syb);
    ys = REAL(sys);

    ltysave = GP->lty;
    colsave = GP->col;
    GMode(1);
    for (i = 0; i < n; i++) {
        if (FINITE(xt(xl[i%nxl])) && FINITE(yt(yb[i%nyb]))
            && FINITE(xt(xr[i%nxr])) && FINITE(yt(ys[i%nys])))
                GRect(XMAP(xt(xl[i % nxl])), YMAP(yt(yb[i % nyb])),
                      XMAP(xt(xr[i % nxr])), YMAP(yt(ys[i % nys])),
                    INTEGER(col)[i % ncol],
                    INTEGER(border)[i % nborder]);
    }
    GMode(0);
    GP->col = colsave;
    GP->lty = ltysave;
    UNPROTECT(3);
    return R_NilValue;
}

3) The legend() function needs changes as well. I attach my
quick hack below, but I think there are better solutions... :-)

legend <-
function (x, y, legend, fill, col = "black", lty, pch, bty = "o", 
        bg = par("bg"), xjust = 0, yjust = 1, ...) 
{
        xlog <- par("xlog")
        ylog <- par("ylog")
        if (xlog) 
                x <- log10(x)
        if (ylog) 
                y <- log10(y)
        xchar <- xinch(par("cin")[1])
        ychar <- yinch(par("cin")[2]) * 1.2
        xbox <- xinch(par("cin")[2] * 0.8)
        ybox <- yinch(par("cin")[2] * 0.8)
        yline <- 2 * xchar
        w <- 2 * xchar + max(strwidth(legend))
        h <- (length(legend) + 1) * ychar
        if (missing(y)) {
                if (is.list(x)) {
                        y <- x$y
                        x <- x$x
                }
        }
        if (!is.numeric(x) || !is.numeric(y)) 
                stop("non-numeric coordinates")
        if (length(x) <= 0 || length(x) != length(y)) 
                stop("differing coordinate lengths")
        if (length(x) != 1) {
                x <- mean(x)
                y <- mean(y)
                xjust <- 0.5
                yjust <- 0.5
        }
        if (!missing(fill)) {
                w <- w + xchar + xbox
        }
        if (!missing(pch)) {
                if (is.character(pch) && nchar(pch) > 1) {
                        np <- nchar(pch)
                        pch <- substr(rep(pch[1], np), 1:np, 
                                1:np)
                }
                w <- w + 1.5 * xchar
        }
        if (!missing(lty)) 
                w <- w + 3 * xchar
        x <- x - xjust * w
        y <- y + (1 - yjust) * h
        xt <- rep(x, length(legend)) + xchar
        yt <- y - (1:length(legend)) * ychar
        if (bty != "n") {
                if (xlog) {
                        x1 <- 10^x
                        x2 <- 10^(x + w)
                }
                else {
                        x1 <- x
                        x2 <- x + w
                }
                if (ylog) {
                        y1 <- 10^y
                        y2 <- 10^(y - h)
                }
                else {
                        y1 <- y
                        y2 <- y - h
                }
                rect(x1, y1, x2, y2, col = bg)
        }
        x <- x + xchar
        if (!missing(fill)) {
                if (xlog) {
                        x1 <- 10^xt
                        x2 <- 10^(xt + xbox)
                }
                else {
                        x1 <- xt
                        x2 <- xt + xbox
                }
                if (ylog) {
                        y1 <- 10^(yt - 0.5 * ybox)
                        y2 <- 10^(yt + 0.5 * ybox)
                }
                else {
                        y1 <- yt - 0.5 * ybox
                        y2 <- yt + 0.5 * ybox
                }
                rect(xt, yt - 0.5 * ybox, xt + xbox, yt + 0.5 * 
                        ybox, col = fill)
                xt <- xt + xbox + xchar
        }
        if (!missing(pch)) {
                if (xlog) 
                        x1 <- 10^(xt + 0.25 * xchar)
                else x1 <- xt + 0.25 * xchar
                if (ylog) 
                        y1 <- 10^yt
                else y1 <- yt
                points(x1, y1, pch, col = col)
                xt <- xt + 1.5 * xchar
        }
        if (!missing(lty)) {
                if (xlog) {
                        x1 <- 10^xt
                        x2 <- 10^(xt + 2 * xchar)
                }
                else {
                        x1 <- xt
                        x2 <- xt + 2 * xchar
                }
                if (ylog) 
                        y1 <- 10^yt
                else y1 <- yt
                segments(x1, y1, x2, y1, lty = lty, col = col)
                xt <- xt + 3 * xchar
        }
        if (xlog) 
                x1 <- 10^xt
        else x1 <- xt
        if (ylog) 
                y1 <- 10^yt
        else y1 <- yt
        text(x1, y1, text = legend, adj = c(0, 0.35))
}

Arne

-- 
Arne Kovac
School of Mathematics                    Phone: +44 (0117) 942 7551
University of Bristol                    A.Kovac@bristol.ac.uk    
University Walk, Bristol, BS8 1TW, U.K.  http://www.stats.bris.ac.uk/~maak


=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-