https://github.com/cran/CARBayes
Raw File
Tip revision: d6d500cbf5e3654e95ab3ca6f54d5f298cbedc43 authored by Duncan Lee on 27 August 2012, 10:50:23 UTC
version 1.1
Tip revision: d6d500c
W.prior.elicit.R
W.prior.elicit <-
function(phistar, W, ordinate)
{
     ################################################     
     #### Check the elements take on allowable values	
     ################################################
     ## response variable phistar
     if(missing(phistar)) stop("phistar has not been specified.", call.=FALSE)
     if(sum(is.na(phistar))>0) stop("phistar has missing 'NA' values.", call.=FALSE)
     if(!is.numeric(phistar)) stop("phistar has non-numeric values.", call.=FALSE)	
     n <- length(phistar)	
     
     
     #### W matrix
     if(missing(W)) stop("W has not been specified.", call.=FALSE)
     if(!is.matrix(W)) stop("W is not a matrix.", call.=FALSE)
     if(nrow(W)!= n) stop("W has the wrong number of rows.", call.=FALSE)
     if(ncol(W)!= n) stop("W has the wrong number of columns.", call.=FALSE)
     if(sum(is.na(W))>0) stop("W has missing 'NA' values.", call.=FALSE)
     if(!is.numeric(W)) stop("W has non-numeric values.", call.=FALSE)
     if(!sum(names(table(W))==c(0,1))==2) stop("W has non-binary (zero and one) values.", call.=FALSE)
     
     
     ## ordinate	
     if(missing(ordinate)) stop("ordinate has not been specified.", call.=FALSE)
     if(!(ordinate=="geary" | ordinate=="moran")) stop("ordinate must be either 'geary' or 'moran'.", call.=FALSE)
     
     
     
     ####################################
     #### Compute the prior probabilities
     ####################################
     #### Create a lookup table for W
     n.W <- sum(W)/2
     W.lookup <- array(NA, c(n.W, 3))
     colnames(W.lookup) <- c("number", "row", "col")
     W.lookup[ ,1] <- 1:n.W
     current <- 1
     
     for(i in 1:n)
     {		
          neighbours.temp <- which(W[i, ]==1)
          neighbours.final <- neighbours.temp[neighbours.temp>i]	
          num.neighbours <- length(neighbours.final)
          if(num.neighbours==0)
          {
          }else
          {
               W.lookup[current:(current+num.neighbours-1) , 2] <- i
               W.lookup[current:(current+num.neighbours-1) , 3] <- neighbours.final
               current <- current + num.neighbours	
          }
     }
     
     
     #### Compute the prior probabilities
     W.prior <- array(0, c(n,n))
     W.upper <- upper.tri(W, diag=FALSE)
     
     
     if(ordinate=="geary")
     {
          Diff.geary.mat <- as.matrix(dist(cbind(phistar,phistar), method="maximum", diag=TRUE, upper=TRUE))^2
          Diff.geary.all <- Diff.geary.mat[W.upper]
          
          for(i in 1:n.W)
          {
               row <- W.lookup[i, 2]
               col <- W.lookup[i, 3]	
               prob.geary <-  length(which(Diff.geary.mat[row, col] < Diff.geary.all)) / length(Diff.geary.all)	
               W.prior[row, col] <- prob.geary
               W.prior[col, row] <- prob.geary
          }
     }else
     {
          Diff.moran.mat <- (phistar-mean(phistar)) %*% t(phistar-mean(phistar))	
          Diff.moran.all <- Diff.moran.mat[W.upper]
          
          for(i in 1:n.W)
          {
               row <- W.lookup[i, 2]
               col <- W.lookup[i, 3]	
               prob.moran <-  length(which(Diff.moran.mat[row, col] > Diff.moran.all)) / length(Diff.moran.all)		
               W.prior[row, col] <- prob.moran
               W.prior[col, row] <- prob.moran
          }		
     }
     
     
     #######################
     #### Return the results
     #######################
     return(W.prior)	
}
back to top