R/test_mat_image.R

In Syksy/TownforgeR: R-package for handling Townforge related data

#' test.mat.image
#'
#' TODO
#'
#' @param x TODO
#'
#' @return TODO
#'
#' @examples
#' c()
#'
#'
#' @export
#' @import Matrix
#' @import lattice
#' @import grid
test.mat.image <- function(x,
  candidates.df,
  xlim = c(1, di[2]),
  ylim = c(di[1], 1), aspect = "iso",
  sub = sprintf("Dimensions: %d x %d", di[1], di[2]),
  xlab = "Column", ylab = "Row", cuts = 15,
  useRaster = FALSE,
  useAbs = NULL, colorkey = !useAbs, col.regions = NULL,
  lwd = NULL, border.col = NULL, ...)
{
  ## 'at' can remain missing and be passed to levelplot
  di <- x@Dim
  xx <- x@x
  if(length(xx) == 0 && length(x) > 0) { # workaround having "empty" matrix
    x@x <- 0
    x@i <- x@j <- 0L
  }
  if(missing(useAbs)) { ## use abs() when all values are non-neg
    useAbs <- if(length(xx)) min(xx, na.rm=TRUE) >= 0 else TRUE
  } else if(useAbs)
    xx <- abs(xx)
  ## rx <- range(xx, finite=TRUE)
  ## FIXME: make use of 'cuts' now
  ##	    and call levelplot() with 'at = ', making sure  0 is included and matching
  ##	    *exactly* - rather than approximately
  if(is.null(col.regions))
    col.regions <-
    if(useAbs) {
      grey(seq(from = 0.7, to = 0, length = 100))
    } else { ## no abs(.), rx[1] < 0
      rx <- range(xx, finite=TRUE)
      nn <- 100
      n0 <- min(nn, max(0, round((0 - rx[1])/(rx[2]-rx[1]) * nn)))
      col.regions <-
        c(colorRampPalette(c("blue3", "gray80"))(n0),
          colorRampPalette(c("gray75","red3"))(nn - n0))
    }
  if(!is.null(lwd) && !(is.numeric(lwd) && all(lwd >= 0))) # allow lwd=0
    stop("'lwd' must be NULL or non-negative numeric")
  stopifnot(length(xlim) == 2, length(ylim) == 2)
  ## ylim: the rows count from top to bottom:
  ylim <- sort(ylim, decreasing=TRUE)
  if(all(xlim == round(xlim))) xlim <- xlim+ c(-.5, +.5)
  if(all(ylim == round(ylim))) ylim <- ylim+ c(+.5, -.5) # decreasing!
  
  levelplot(xx ~ (x@j + 1L) * (x@i + 1L), # no 'data'
    sub = sub, xlab = xlab, ylab = ylab,
    xlim = xlim, ylim = ylim, aspect = aspect,
    colorkey = colorkey, col.regions = col.regions, cuts = cuts,
    par.settings = list(background = list(col = "transparent")),
    ##===
    panel = if(useRaster) panel.levelplot.raster else
      function(x, y, z, subscripts, at, ..., col.regions)
      {   ## a trimmed down version of  lattice::panel.levelplot
        x <- as.numeric(x[subscripts])
        y <- as.numeric(y[subscripts])
        ##
        ## FIXME: use  level.colors() here and 'at' from above --
        ## -----  look at 'zcol' in  panel.levelplot()
        numcol <- length(at) - 1
        num.r <- length(col.regions)
        col.regions <-
          if (num.r <= numcol)
            rep_len(col.regions, numcol)
        else col.regions[1+ ((1:numcol-1)*(num.r-1)) %/% (numcol-1)]
        zcol <- rep.int(NA_integer_, length(z))
        for (i in seq_along(col.regions))
          zcol[!is.na(x) & !is.na(y) & !is.na(z) &
              at[i] <= z & z < at[i+1]] <- i
        zcol <- zcol[subscripts]
        
        if (any(subscripts)) {
          ## the line-width used in grid.rect() inside
          ## levelplot()'s panel for the *border* of the
          ## rectangles: levelplot()panel has lwd= 0.01:
          
          ## Here: use "smart" default !
          if(is.null(lwd)) {
            wh <- grid::current.viewport()[c("width", "height")]
            ## wh : current viewport dimension in pixel
            wh <- c(grid::convertWidth(wh$width, "inches",
              valueOnly=TRUE),
              grid::convertHeight(wh$height, "inches",
                valueOnly=TRUE)) *
              par("cra") / par("cin")
            pSize <- wh/di ## size of one matrix-entry in pixels
            pA <- prod(pSize) # the "area"
            p1 <- min(pSize)
            lwd <- ## crude for now
              if(p1 < 2 || pA < 6) 0.01 # effectively 0
            else if(p1 >= 4) 1
            else if(p1 > 3) 0.5 else 0.2
            ## browser()
            "default"
            #Matrix.msg("rectangle size ",
            #  paste(round(pSize,1), collapse=" x "),
            #  " [pixels];  --> lwd :", formatC(lwd))
          } else stopifnot(is.numeric(lwd), all(lwd >= 0)) # allow 0
          if(is.null(border.col) && lwd < .01) # no border
            border.col <- NA
          grid.rect(x = x, y = y, width = 1, height = 1,
            default.units = "native",
            ## FIXME?: allow 'gp' to be passed via '...' !!
            gp = gpar(fill = col.regions[zcol],
              lwd = lwd, col = border.col))
        }
        
        panel.text(candidates.df$x0, candidates.df$y0, labels = LETTERS[seq_len(nrow(candidates.df))])
        
      }, ...)
  
}