Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Set aspect in image.plot function #8

Open
rodrigolustosa opened this issue Jul 6, 2022 · 2 comments
Open

Set aspect in image.plot function #8

rodrigolustosa opened this issue Jul 6, 2022 · 2 comments

Comments

@rodrigolustosa
Copy link

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
Copy link
Contributor

dnychka commented Jul 6, 2022 via email

@rodrigolustosa
Copy link
Author

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()
  }
}

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

2 participants