Rutils/maybe-not-useful/closest.r

In manfredo89/ED2io: Manages Input/Output for Ecosystem Demography 2 Model

#==========================================================================================#
#==========================================================================================#
#        Pick the element in array A that has the closest value to x. x can be either a    #
# scalar or a vector with the same length as a.                                            #
#------------------------------------------------------------------------------------------#
which.closest <<- function(x,A,mask=rep(TRUE,length(A)) ){

   #----- Create indices before applying the mask, so we retrieve the actual index. -------#
   if (length(x) == 1){
      x = x + 0. * A
   }else if(length(x) != length(A)){
      cat(" Length(x) = ",length(x),"\n",sep="")
      cat(" Length(A) = ",length(A),"\n",sep="")
      stop ("length(x) must be either 1 or the same as length(A)")
   }#end if
   #---------------------------------------------------------------------------------------#



   #----- Create indices before applying the mask, and throw away masked data. ------------#
   A.idx = sequence(length(A))
   A     = A    [mask]
   A.idx = A.idx[mask]
   x     = x    [mask]
   #---------------------------------------------------------------------------------------#




   #---------------------------------------------------------------------------------------#
   #     Check whether there is any data that 
   #---------------------------------------------------------------------------------------#
   if (! any(is.finite(x)) || ! any(mask,na.rm=TRUE)){
      #----- x is invalid, return NA. -----------------------------------------------------#
      idx = NA
   }else if(sum(x %==% A,na.rm=TRUE) > 1){
      #------------------------------------------------------------------------------------#
      #      If there are multiple values of x that are the same as x, we randomly sample  #
      # one value.                                                                         #
      #------------------------------------------------------------------------------------#
      idx = sample(A.idx[x %==% A],size=1)
      #------------------------------------------------------------------------------------#
   }else{
      #------------------------------------------------------------------------------------#
      #      Either there is a single value that matches, or none of them match.  Either   #
      # way, we select the closest match.                                                  #
      #------------------------------------------------------------------------------------#
      idx = A.idx[which.min((A-x)^2)]
      #------------------------------------------------------------------------------------#
   }#end if
   #---------------------------------------------------------------------------------------#

   return(idx)
}#end which.closest
#==========================================================================================#
#==========================================================================================#






#==========================================================================================#
#==========================================================================================#
#        Pick the element in array A that has the closest value to x, and return the bias. #
# The result is the bias of the closest value, (x-A).                                      #
#------------------------------------------------------------------------------------------#
closest.bias <<- function(x,A,mask=rep(TRUE,length(A)) ){
   mycall = match.call()


   #---------------------------------------------------------------------------------------#
   #     Use which.closest to pick the closest point.                                      #
   #---------------------------------------------------------------------------------------#
   idx = which.closest(x=x,A=A,mask=mask)
   if (is.na(idx)){
      ans = NA
   }else{
      ans = (x - A)[idx]
   }#end if
   #---------------------------------------------------------------------------------------#

   return(ans)
}#end closest.bias
#==========================================================================================#
#==========================================================================================#






#==========================================================================================#
#==========================================================================================#
#        Pick the element in array A that has the closest value to x.  In case y is not    #
# NULL, then the answer is the element of y that corresponds to the closest point between  #
# x and A (thus y must be of the same length as A).                                        #
#------------------------------------------------------------------------------------------#
closest <<- function(x,y=NULL,A,mask=rep(TRUE,length(A)) ){
   mycall = match.call()

   #----- Make sure that y is a valid option. ---------------------------------------------#
   if (! is.null(y)){
      if (length(y) != length(A)){
         cat(" - Call:      ",mycall,"\n",sep="")
         cat(" - Length(y): ",length(y),"\n",sep="")
         cat(" - Length(A): ",length(A),"\n",sep="")
         stop(" y and A must have the same length if y is not NULL")
      }#end if
      #------------------------------------------------------------------------------------#
   }#end if
   #---------------------------------------------------------------------------------------#


   #---------------------------------------------------------------------------------------#
   #     Use which.closest to pick the closest point.                                      #
   #---------------------------------------------------------------------------------------#
   idx = which.closest(x=x,A=A,mask=mask)
   if (is.na(idx)){
      ans = NA
   }else if (is.null(y)){
      ans = A[idx]
   }else{
      ans = y[idx]
   }#end if
   #---------------------------------------------------------------------------------------#

   return(ans)
}#end closest
#==========================================================================================#
#==========================================================================================#