R/f.points.preCKrige.R

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

###############################################################
#                                                             #
#   Berechnungen der Zielpunkt Kovarianzmatrizen              #
#   ch 22-02-2010                                             #
#                                                             #
###############################################################

# 2023-01-24 A. Papritz class queries by is()
# 2023-12-10 A. Papritz corrected computation of t.dist (lines 50-51)

f.points.preCKrige <- function(newdata, neighbours, model)
{
  
  #
  # no attributes -> only for ordinary kriging
  # build an empty DataFrame
  if( is( newdata, "SpatialPoints" ) )
  {
    data = as.data.frame( matrix( ncol = 0, nrow = 0 ) )
  }
  if( is( newdata, "SpatialPointsDataFrame" ) )
  {
    data = newdata@data
  }
  #
  class( model ) <- "list"
  ### covmodel of measurement free error process
  model.me.free <- model[unlist(lapply(1:length(model), function(i,m){m[[i]]$model != "mev"},m = model))]
  ### coors are coordinates of the target points
  coords <- newdata@coords
  #
  #if no neighbours are defined
  if( missing( neighbours ) )
  
  {
    neighbours <- lapply( as.list( 1:nrow(coords) ), function( x ){ return( integer(0) ) } )
  }
  stopifnot( is.list( neighbours ) )
  #
  t.n <- as.list( 1:length( neighbours ) ) 
  #
  t.covmat.list <- lapply(
    t.n, 
    function(x, model, neighbours, coords)
    {      
      t.point.config  <- c(x, neighbours[[ x ]])
      t.config.coords <- coords[ t.point.config, , drop = FALSE]
      t.dist <- as.matrix( dist( t.config.coords ) )
      t.cov <- f.pp.cov( t.dist, model)
      t.n.point.config <- length( t.point.config)
      
      return(matrix( t.cov, ncol = t.n.point.config, nrow = t.n.point.config ) )
      
    },
    model = model.me.free,
    neighbours = neighbours,
    coords = coords
  )
  #
  posindex <- lapply(t.n,
    function(x, neighbours)
    {
      return( c( x, neighbours[[x]] ) )
    },
    neighbours
  )
  
  return(
    new( "preCKrigePoints",
      covmat = t.covmat.list, # block block Covariance Matrix
      posindex = posindex,
      model = model,
      data = data, 
      coords = coords)
  )
}