Set aspect in image.plot function

[rodrigolustosa]

The graphics::image function, which image.plot depends on, have an asp argument, as well as other R plot functions. You could allow this argument to be passed to graphics::image inside image.plot, so we can prevent geographical plots from being distorted depending on device dimensions. I made this change in the following code and it seems to be working fine (I made a small plot but didn't search too much for bugs). Only two lines were changed.

image.plot <- function (..., add = FALSE, breaks = NULL, nlevel = 64, col = NULL, 
          horizontal = FALSE, legend.shrink = 0.9, legend.width = 1.2, 
          legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, 
          legend.line = 2, graphics.reset = FALSE, bigplot = NULL, 
          smallplot = NULL, legend.only = FALSE, lab.breaks = NULL, 
          axis.args = NULL, legend.args = NULL, legend.cex = 1, midpoint = FALSE, 
          border = NA, lwd = 1, verbose = FALSE, asp = NA) 
{
  old.par <- par(no.readonly = TRUE)
  if (is.null(col)) {
    col <- tim.colors(nlevel)
  }
  else {
    nlevel <- length(col)
  }
  info <- imagePlotInfo(..., breaks = breaks, nlevel = nlevel)
  breaks <- info$breaks
  if (verbose) {
    print(info)
  }
  if (add) {
    big.plot <- old.par$plt
  }
  if (legend.only) {
    graphics.reset <- TRUE
  }
  if (is.null(legend.mar)) {
    legend.mar <- ifelse(horizontal, 3.1, 5.1)
  }
  temp <- imageplot.setup(add = add, legend.shrink = legend.shrink, 
                          legend.width = legend.width, legend.mar = legend.mar, 
                          horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)
  smallplot <- temp$smallplot
  bigplot <- temp$bigplot
  if (!legend.only) {
    if (!add) {
      par(plt = bigplot)
    }
    if (!info$poly.grid) {
      image(..., breaks = breaks, add = add, col = col, asp = asp)
    }
    else {
      poly.image(..., add = add, breaks = breaks, col = col, 
                 midpoint = midpoint, border = border, lwd.poly = lwd)
    }
    big.par <- par(no.readonly = TRUE)
  }
  if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
    par(old.par)
    stop("plot region too small to add legend\n")
  }
  ix <- 1:2
  iy <- breaks
  nBreaks <- length(breaks)
  midpoints <- (breaks[1:(nBreaks - 1)] + breaks[2:nBreaks])/2
  iz <- matrix(midpoints, nrow = 1, ncol = length(midpoints))
  if (verbose) {
    print(breaks)
    print(midpoints)
    print(ix)
    print(iy)
    print(iz)
    print(col)
  }
  par(new = TRUE, pty = "m", plt = smallplot, err = -1)
  if (!horizontal) {
    image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "", 
          ylab = "", col = col, breaks = breaks)
  }
  else {
    image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", 
          ylab = "", col = col, breaks = breaks)
  }
  if (!is.null(lab.breaks)) {
    axis.args <- c(list(side = ifelse(horizontal, 1, 4), 
                        mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), 
                        at = breaks, labels = lab.breaks), axis.args)
  }
  else {
    axis.args <- c(list(side = ifelse(horizontal, 1, 4), 
                        mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), 
                   axis.args)
  }
  do.call("axis", axis.args)
  if (!is.null(legend.lab)) {
    legend.args <- list(text = legend.lab, side = ifelse(horizontal, 
                                                         1, 4), line = legend.line, cex = legend.cex)
  }
  if (!is.null(legend.args)) {
    do.call(mtext, legend.args)
  }
  mfg.save <- par()$mfg
  if (graphics.reset | add) {
    par(old.par)
    par(mfg = mfg.save, new = FALSE)
    invisible()
  }
  else {
    par(big.par)
    par(plt = big.par$plt, xpd = FALSE)
    par(mfg = mfg.save, new = FALSE)
    invisible()
  }
}

[dnychka]

Rodrigo, Great idea! Some points. A new version of fields (14.0) was just posted yesterday to CRAN. I am bummed I could have added this in. Will do for 14.1. Also the NCAR/fields repository is frozen. I do active development on the https://github.com/dnychka/fieldsRPackage Also the newer version of this function is now called imagePlot and image.plot is frozen. As to your nice idea. We need to make sure that it works with the option where the grid cells are irregular and the call is not to the basic image function. Also I am not sure if the legend will be placed in a rational way with the asp option . Thanks for you comments Best, Doug Douglas Nychka Personal email Cell 3037253199 From: Rodrigo Lustosa ***@***.***> Date: Tuesday, July 5, 2022 at 6:38 PM To: NCAR/fields ***@***.***> Cc: Subscribed ***@***.***> Subject: [NCAR/fields] Set aspect in image.plot function (Issue #8) The graphics::image function, which image.plot depends on, have an asp argument, as well as other R plot functions. You could allow this argument to be passed to graphics::image inside image.plot, so we can prevent geographical plots from being distorted depending on device dimensions. I made this change in the following code and it seems to be working fine (I made a small plot but didn't search too much for bugs). Only two lines were changed. image.plot <- function (..., add = FALSE, breaks = NULL, nlevel = 64, col = NULL, horizontal = FALSE, legend.shrink = 0.9, legend.width = 1.2, legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, legend.line = 2, graphics.reset = FALSE, bigplot = NULL, smallplot = NULL, legend.only = FALSE, lab.breaks = NULL, axis.args = NULL, legend.args = NULL, legend.cex = 1, midpoint = FALSE, border = NA, lwd = 1, verbose = FALSE, asp = NA) { old.par <- par(no.readonly = TRUE) if (is.null(col)) { col <- tim.colors(nlevel) } else { nlevel <- length(col) } info <- imagePlotInfo(..., breaks = breaks, nlevel = nlevel) breaks <- info$breaks if (verbose) { print(info) } if (add) { big.plot <- old.par$plt } if (legend.only) { graphics.reset <- TRUE } if (is.null(legend.mar)) { legend.mar <- ifelse(horizontal, 3.1, 5.1) } temp <- imageplot.setup(add = add, legend.shrink = legend.shrink, legend.width = legend.width, legend.mar = legend.mar, horizontal = horizontal, bigplot = bigplot, smallplot = smallplot) smallplot <- temp$smallplot bigplot <- temp$bigplot if (!legend.only) { if (!add) { par(plt = bigplot) } if (!info$poly.grid) { image(..., breaks = breaks, add = add, col = col, asp = asp) } else { poly.image(..., add = add, breaks = breaks, col = col, midpoint = midpoint, border = border, lwd.poly = lwd) } big.par <- par(no.readonly = TRUE) } if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) { par(old.par) stop("plot region too small to add legend\n") } ix <- 1:2 iy <- breaks nBreaks <- length(breaks) midpoints <- (breaks[1:(nBreaks - 1)] + breaks[2:nBreaks])/2 iz <- matrix(midpoints, nrow = 1, ncol = length(midpoints)) if (verbose) { print(breaks) print(midpoints) print(ix) print(iy) print(iz) print(col) } par(new = TRUE, pty = "m", plt = smallplot, err = -1) if (!horizontal) { image(ix, iy, iz, xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks) } else { image(iy, ix, t(iz), xaxt = "n", yaxt = "n", xlab = "", ylab = "", col = col, breaks = breaks) } if (!is.null(lab.breaks)) { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2), at = breaks, labels = lab.breaks), axis.args) } else { axis.args <- c(list(side = ifelse(horizontal, 1, 4), mgp = c(3, 1, 0), las = ifelse(horizontal, 0, 2)), axis.args) } do.call("axis", axis.args) if (!is.null(legend.lab)) { legend.args <- list(text = legend.lab, side = ifelse(horizontal, 1, 4), line = legend.line, cex = legend.cex) } if (!is.null(legend.args)) { do.call(mtext, legend.args) } mfg.save <- par()$mfg if (graphics.reset | add) { par(old.par) par(mfg = mfg.save, new = FALSE) invisible() } else { par(big.par) par(plt = big.par$plt, xpd = FALSE) par(mfg = mfg.save, new = FALSE) invisible() } } — Reply to this email directly, view it on GitHub<#8>, or unsubscribe<https://github.com/notifications/unsubscribe-auth/ADHJ7U6XWFECU5ZDY6N3MVTVSTIPJANCNFSM52X4YRDA>. You are receiving this because you are subscribed to this thread.Message ID: ***@***.***>

[rodrigolustosa]

Hello Douglas, I'm happy you liked!

Thank you for your points, I'll be using the imagePlot for now on. If any other suggestion occurs to me, I'll open an Issue in the repository you provided, thanks for sharing it!

Indeed the change I made wouldn't work for the irregular grid. I see now that you use poly.image for a irregular grid. Inside it you open the plot with the plot function, so I made some new changes that would pass the asp parameter to poly.image and plot as well and it seems to be working good now. I checked both cases using the following code:

# regular
imagePlot(matrix(1:20,4,5),asp=1)
# irregular
imagePlot(t(matrix(rep(1:4,each=5),5)+(0:4)/10),
                 matrix(rep(1:5,each=4),4)+(0:3)/10,
                 matrix(1:20,4,5),asp=1)

I think the legend position won't be a problem as the plot size inside the device don't change with aspect, just the x or y limits (they're no longer fixed). Bellow I let the final changes I made. Thank you for the support!

poly.image <- function (x, y, z, col = tim.colors(64), breaks, transparent.color = "white", 
          midpoint = FALSE, zlim = range(z, na.rm = TRUE), xlim = range(x), 
          ylim = range(y), add = FALSE, border = NA, lwd.poly = 1, asp = NA,
          ...) 
{
  Dx <- dim(x)
  Dy <- dim(y)
  if (any((Dx - Dy) != 0)) {
    stop(" x and y matrices should have same dimensions")
  }
  Dz <- dim(z)
  if (all((Dx - Dz) == 0) & !midpoint) {
    x <- poly.image.regrid(x)
    y <- poly.image.regrid(y)
  }
  if (missing(breaks)) {
    breaks <- NA
  }
  zcol <- drape.color(z, col = col, midpoint = midpoint, zlim = zlim, 
                      transparent.color = transparent.color, breaks = breaks)$color.index
  if (!add) {
    plot(xlim, ylim, type = "n", asp = asp, ...)
  }
  N <- ncol(x)
  Nm1 <- N - 1
  M <- nrow(x)
  Mm1 <- M - 1
  for (i in (1:Mm1)) {
    xp <- cbind(x[i, 1:Nm1], x[i + 1, 1:Nm1], x[i + 1, 2:N], 
                x[i, 2:N], rep(NA, Nm1))
    yp <- cbind(y[i, 1:Nm1], y[i + 1, 1:Nm1], y[i + 1, 2:N], 
                y[i, 2:N], rep(NA, Nm1))
    xp <- c(t(xp))
    yp <- c(t(yp))
    pcol <- c(zcol[i, 1:Nm1])
    polygon(xp, yp, border = pcol, col = pcol, lwd = lwd.poly)
    if (!is.na(border)) {
      polygon(xp, yp, border = border, col = NA, lwd = lwd.poly)
    }
  }
}


imagePlot <- function (..., add = FALSE, breaks = NULL, nlevel = 64, col = NULL, 
                        horizontal = FALSE, legend.shrink = 0.9, legend.width = 1.2, 
                        legend.mar = ifelse(horizontal, 3.1, 5.1), legend.lab = NULL, 
                        legend.line = 2, graphics.reset = FALSE, bigplot = NULL, 
                        smallplot = NULL, legend.only = FALSE, lab.breaks = NULL, 
                        axis.args = NULL, legend.args = NULL, legend.cex = 1, midpoint = FALSE, 
                        border = NA, lwd = 1, lowerTriangle = FALSE, upperTriangle = FALSE, 
                        verbose = FALSE, asp = NA) 
{
  old.par <- par(no.readonly = TRUE)
  if (is.null(col)) {
    col <- tim.colors(nlevel)
  }
  else {
    nlevel <- length(col)
  }
  info <- imagePlotInfo(..., breaks = breaks, nlevel = nlevel)
  breaks <- info$breaks
  if (verbose) {
    print(info)
  }
  if (add) {
    big.plot <- old.par$plt
  }
  if (legend.only) {
    graphics.reset <- TRUE
  }
  if (is.null(legend.mar)) {
    legend.mar <- ifelse(horizontal, 3.1, 5.1)
  }
  temp <- imageplot.setup(add = add, legend.shrink = legend.shrink, 
                          legend.width = legend.width, legend.mar = legend.mar, 
                          horizontal = horizontal, bigplot = bigplot, smallplot = smallplot)
  smallplot <- temp$smallplot
  bigplot <- temp$bigplot
  if (!legend.only) {
    if (!add) {
      par(plt = bigplot)
    }
    if (!info$poly.grid) {
      image(..., breaks = breaks, add = add, col = col, asp = asp)
    }
    else {
      poly.image2(..., add = add, breaks = breaks, col = col, asp = asp,
                 midpoint = midpoint, border = border, lwd.poly = lwd)
    }
    big.par <- par(no.readonly = TRUE)
  }
  if ((smallplot[2] < smallplot[1]) | (smallplot[4] < smallplot[3])) {
    par(old.par)
    stop("plot region too small to add legend\n")
  }
  colorBar(breaks = breaks, smallplot = smallplot, colorTable = col, 
           horizontal = horizontal, lab.breaks = lab.breaks, axis.args = axis.args, 
           legend.lab = legend.lab, legend.line = legend.line, 
           legend.args = legend.args, legend.cex = legend.cex, 
           lowerTriangle = lowerTriangle, upperTriangle = upperTriangle)
  mfg.save <- par()$mfg
  if (graphics.reset | add) {
    par(old.par)
    par(mfg = mfg.save, new = FALSE)
    invisible()
  }
  else {
    par(big.par)
    par(plt = big.par$plt, xpd = FALSE)
    par(mfg = mfg.save, new = FALSE)
    invisible()
  }
}