R/f.polygons.preCKrige.R

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

###############################################################
#                                                             #
#   Berechnungen der Polygonapproximationen durch die Pixel   #
#   ch 22-02-2010                                             #
#                                                             #
###############################################################

# 2023-01-24 A. Papritz class queries by is()
# 2023-11-23 A. Papritz conversion of polygons and pixelgrid to sf objects
# 2023-12-13 A. Papritz new arguments ncores and fork for f.polygons.preCKrige 
# 2023-12-15 A. Papritz deleted set.seed()

f.polygons.preCKrige <- function(
  newdata,
  neighbours,
  model,
  pwidth,
  pheight,
  napp = 1,
  ncores, 
  fork
)
{
  
  # no attributes -> only for ordinary kriging
  # add an empty data.frame to the Polygons
  # and build Class SpatialPolygonsDataFrame
  if( class( newdata )[1] == "SpatialPolygons" ){
    data = as.data.frame( matrix( ncol = 0, nrow = 0 ) )
  }
  # extract data slot
  if( is( newdata, "SpatialPolygonsDataFrame" ) )  {
    data = newdata@data
  }
  
  # covmodel of measurement free error process
  class(model) <- "list"
  model.me.free <- model[unlist(lapply(1:length(model), function(i,m){m[[i]]$model != "mev"},m = model))]
  # Polygons as calss SpatialPolygons
  
  newdata.polygons <- as( newdata, "SpatialPolygons" )
  
  # Ziel polygone haben keien Nachbarn
  if( missing( neighbours ) )
  {
    neighbours <- lapply( as.list( 1:length(newdata@polygons) ), function( x ){ return( integer(0) ) } )
  }
  stopifnot( is.list(neighbours) )
  
  # conversion of SpatialPolygons to simple feature geometry list-column
  # (sfc object)
  
  newdata.polygons.sfc <- st_as_sfc(newdata.polygons)
  
  # generation of grid of pixels from simple feature geometry list-column
  # with function precompute{spatialCovariance} for the largest bounding
  # box
  
  pixgrid.sfc <- f.pixelgrid.sfc(
    polygons = newdata.polygons.sfc,
    neighbours = neighbours,
    pixel.x.width = pwidth,
    pixel.y.width = pheight
  )
  
  # compute covariance matrix of pixels using computeV{spatialCovariance}

  pixcm.sfc <- f.pixelcovmat(
    pixgrid = pixgrid.sfc,
    model = model.me.free
  )
  
  # generate pixel representation of polygons
    
  # using polygons defined by simple feature geometry list-column
    
  for( i in 1:napp ){
    
    pc.tmp <- f.pixconfig.sfc(
      polygons = newdata.polygons.sfc,
      neighbours = neighbours,
      pixgrid = pixgrid.sfc,
      n = napp
    )
    
    if( i == 1 ){
      
      pixconfig.sfc = pc.tmp
      
    } else {
      
      pixconfig.sfc <- lapply( 
        pixconfig.sfc,
        function( pc, pc.tmp )
        {
                    
          pc$pixcenter <- cbind( 
            pc$pixcenter, 
            pc.tmp[[ pc$posindex[1] ]]$pixcenter 
          )
          pc$pix.in.poly <- cbind( 
            pc$pix.in.poly, 
            pc.tmp[[ pc$posindex[1] ]]$pix.in.poly 
          )
          pc$sa.polygons  <- c(
            pc$sa.polygons, pc.tmp[[ pc$posindex[1] ]]$sa.polygons
          )
          return(pc)
        },
        pc.tmp= pc.tmp
      )
    }
    rm( pc.tmp )
  }
  
    
  cm.list.sfc <- f.polygoncovmat(
    pixconfig = pixconfig.sfc,
    pixcm = pixcm.sfc,
    model = model.me.free,
    n = napp,
    ncores = ncores,
    fork = fork
  )
  
  #
  return( new( "preCKrigePolygons",
      covmat = cm.list.sfc$mean.bb.cov.mat, # block block Covariance Matrix
      se.covmat = cm.list.sfc$var.mean.bb.cov.mat, # standard error of block block Covariance
      pixconfig = pixconfig.sfc,
      pixcovmat = pixcm.sfc,
      model = model,
      data = data,
      polygons = newdata@polygons
    )
  )
  rm( pixcm.sfc, pixgrid.sfc, newdata.polygons.sfc, pixconfig.sfc, cm.list.sfc)
}