R/plot.preCKrigePolygons.R

In constrainedKriging: Constrained, Covariance-Matching Constrained and Universal Point or Block Kriging

### method of plot function to predict block area approximation
### of a prediction target neighbourhood configuration
### ch, 13-01-2010
# 2023-12-15 A. Papritz changes of par() complying with CRAN requirements
plot.preCKrigePolygons <- function(x, index, ...)
{

  oldpar <- par(mfrow = c(1, 2))
  on.exit(par(oldpar))
  #
  t.pntc.index   <- x@pixconfig[[ index ]]$posindex
  t.poly.centers <- x@pixconfig[[ index ]]$polygon.centroids
  
  t.x <- seq(1, ncol( x@pixconfig[[ index ]]$pixcenter ), by = 2)
  t.y <- seq(2, ncol( x@pixconfig[[ index ]]$pixcenter ), by = 2)
  
  t.pix.center <- t(apply(
      x@pixconfig[[ index ]]$pixcenter,
      1,
      function(coords, t.x, t.y)
      {
        return(c( mean( coords[ t.x ] ),
            mean( coords[t.y] ) ) 
        )
      },
      t.x,
      t.y
    )
  )
  
  t.pix.in.poly <- lapply(
    x@polygons[ t.pntc.index ],
    function(poly, pix.center)
    {
      point.in.polygon(
        pix.center[,1],
        pix.center[,2],
        poly@Polygons[[1]]@coords[,1],
        poly@Polygons[[1]]@coords[,2]
      )
    },
    t.pix.center
  )
  # # # t.pix.in.poly  <- matrix( unlist( t.pix.in.poly ), ncol =  length(t.pntc.index))
  t.pix.in.poly <- x@pixconfig[[ index ]]$pix.in.poly
  #
  t.rw <- x@pixconfig[[index]]$rowwidth
  t.cw <- x@pixconfig[[index]]$colwidth
  #
  colors <- ck.colors(length(x@polygons))
  t.col.nr <- sample( 1:(length(x@polygons)), length( t.pntc.index ) )
  #
  t.pntc.polygons <- SpatialPolygons( x@polygons[ t.pntc.index ] ) 
  #
  t.pix.col.nr <- apply(
    t.pix.in.poly,
    1,
    function( pix, col.nr)
    {
      return(t(pix) %*% col.nr)
    },
    t.col.nr
  )
  #
  plot(t.pntc.polygons, lwd = 2.5, col= colors[t.col.nr], border = 
    "grey20")
  title(main = paste("neighbourhood configuration of block ", 
      t.pntc.index[1], sep =""))
  
  
  #
  apply(
    t.pix.center,
    1,
    function(center, t.cw, t.rw)
    {
      t.x0  <- center[1] -  0.5 * t.cw
      t.x1  <- center[1] +  0.5 * t.cw
      t.y0  <- center[2] -  0.5 * t.rw
      t.y1  <- center[2] +  0.5 * t.rw
      rect(t.x0, t.y0, t.x1, t.y1, border = "grey77")
    },
    t.cw,
    t.rw
  )
  
  #
  lapply(
    x@polygons[ t.pntc.index ],
    function(poly)
    {
      polygon(
        poly@Polygons[[1]]@coords[,1],
        poly@Polygons[[1]]@coords[,2],
        lwd = 2,
        border = 1,
        col = 0
      )
    }
  )
  #
  text(t.poly.centers, labels = t.pntc.index)
  points(t.pix.center , pch = 3)
  #
  plot(t.pntc.polygons, lwd = 2,  col= "grey88", border = "grey77")
  title( main = "block area approximation by pixels")
  #
  t.pix.center <- cbind(t.pix.center, t.pix.col.nr)
  #
  apply(
    t.pix.center,
    1,
    function(center, t.cw, t.rw)
    {
      t.x0 <- center[ 1 ] - 0.5 * t.cw
      t.x1 <- center[ 1 ] + 0.5 * t.cw
      t.y0  <- center[ 2 ] - 0.5 * t.rw
      t.y1  <- center[ 2 ] + 0.5 * t.rw
      rect(t.x0, t.y0, t.x1, t.y1, border = 0,
        col = colors[ center[ 3 ] ] )
      if( center[ 3 ] != 0 )
      {
        rect(t.x0, t.y0, t.x1, t.y1, border = 1,
          col = colors[ center[ 3 ] ] )
      }
    },
    t.cw,
    t.rw
  )
  #
  # plot points for those polygons that are not approximated by pixels
  t.poly.app <- !as.logical(apply(t.pix.in.poly,2, mean) )
  points(
    t.poly.centers[t.poly.app, 1], t.poly.centers[t.poly.app, 2],
    pch = 21, bg = colors[t.col.nr[ t.poly.app]],  col = 1, cex = 2)
  #
  #
  #
}