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
plot.preCKrigePolygons <- function(x, index, ...)
{
t.par.user <- par()
par( mfrow = c(1,2) )
#
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)
#
#
par(mfrow = c(1,1))
#
}