R/f.preCKrige.check.and.test.R

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

# # # Function to check and test whether the input variable fulfil
# # # the minimum requirements
# # # Christoph Hofer, 1-04-2010

# 2023-11-22 A. Papritz minor changes and code re-formatting
# 2023-12-15 A. Papritz checking ncores and fork

f.preCKrige.check.and.test <- function(
  newdata, neighbours, model, pwidth, pheight, napp,
  ncores, fork
){
    
  
  if( 
    inherits( newdata, what = c("SpatialPolygons", "SpatialPolygonsDataFrame") )
  ){
    
    # define default neighbours if missing
    if( missing(neighbours) ){
      neighbours <- lapply( 
        1L:length(newdata@polygons), 
        function( x ){ return( integer(0) ) } 
      )
    }
    
    # check structure of neighbours
    stopifnot( is.list(neighbours) )
    # check newdata and neighbour list have the same number of elements
    stopifnot( length( neighbours ) == length( newdata@polygons ) )
    # check whether all elements in neighbours are numeric
    lapply(neighbours, function(x){ stopifnot( is.numeric( x ) ) } )
    # check whether all numbers in the neighbours list are smaller or equal
    # to the number of elements in the newdata list
    stopifnot( max( c(0, unlist( neighbours )) ) <= length( newdata@polygons ) )
    
    # check whether pwidth and pheight are positive real numbers
    stopifnot( is.numeric( pwidth ) && is.numeric( pheight ) )
    stopifnot( length( pwidth )  == 1 && length( pheight ) == 1 )
    stopifnot( pwidth > 0 && pheight > 0  )
    
    # check whether napp is a positive integer
    stopifnot( 
      is.numeric( napp ) && length( napp) == 1 && napp %% 1 == 0 && napp > 0
    )
    
    # check whether ncores is a positive integer
    stopifnot( 
      is.numeric( ncores ) && length( ncores) == 1 && ncores %% 1 == 0 && ncores > 0
    )
    
    # check whether fork is a logical scaler
    stopifnot(is.logical(fork) && length( fork == 1 ) )
    
    
  } else if( 
    inherits( newdata, what = c("SpatialPoints", "SpatialPointsDataFrame") )
  ){
    
    # define default neighbours if missing
    if( missing(neighbours) ){
      neighbours <- lapply( 
        as.list( 1:nrow(newdata@coords) ), 
        function( x ){ return( integer(0) ) } 
      )
    }
    
    # check structure of neighbours
    stopifnot( is.list(neighbours) )
    # check newdata and neighbour list have the same number of elements
    stopifnot( length( neighbours ) == dim( newdata@coords )[1] )
    # check whether all elements in neighbours are numeric
    lapply( neighbours, function(x){stopifnot( is.numeric( x ) )} )
    # check whether all numbers in the neighbours list are smaller or equal
    # to the number of elements in the newdata
    stopifnot( max( c(0, unlist( neighbours )) ) <= dim( newdata@coords )[1] )
        
  } else stop(
    "'newdata' must be of class 'SpatialPoints', 'SpatialPointsDataFrame', ",
    "'SpatialPolygons' or 'SpatialPolygonsDataFrame'"    
  )
  
  # check whether there is a valid covariance model
  t.models <- c(
    "bessel", "cauchy", "cauchytbm", "circular", "constant", 
    "cubic", "dampedcosine", "exponential", "gauss", 
    "gencauchy", "gengneiting", "gneiting", "hyperbolic", "lgd1", 
    "matern", "nugget", "penta", "power", "qexponential", 
    "spherical", "stable", "wave", "whittle", 
    "mev"
  )
  
  stopifnot( class(model)[1] == "covmodel" && length( model ) > 0 )
  # check whether model$model are names of covariance functions implemented
  # in constrainedKriging
  
  t.mod <- sum(unlist( lapply(model, function(x){ return(sum( x$model == t.models))}) ))
  if( !length( model ) == t.mod ){covmodel(); stop("unknown covariance model name")}
  
}# end functions