Rutils/maybe-not-useful/wapply.r

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

#==========================================================================================#
#==========================================================================================#
#     wapply: This function applies a function to a vector with a window.                  #
#------------------------------------------------------------------------------------------#
wapply <<- function(X,W,FUN,cyclic=FALSE,...){
   #----- Stop if required variables are missing. -----------------------------------------#
   if (missing(X  )) stop("X is missing, with no default!")
   if (missing(W  )) stop("W is missing, with no default!")
   if (missing(FUN)) stop("FUN is missing, with no default!")
   #---------------------------------------------------------------------------------------#


   #----- Additional sanity checks. -------------------------------------------------------#
   if (! is.vector(X)) stop ("X must be a vector!")
   if (W %>=% length(X)) stop ("W must be less than the length of X")
   #---------------------------------------------------------------------------------------#



   #---------------------------------------------------------------------------------------#
   #     Decide the number of columns to retain depend on whether the input data are       #
   # cyclic or not.                                                                        #
   #---------------------------------------------------------------------------------------#
   nx = length(X)
   if (cyclic){
      cc = sequence(nx)
   }else{
      cc = sequence(nx-W+1)
   }#end if
   #---------------------------------------------------------------------------------------#


   #---------------------------------------------------------------------------------------#
   #     Expand X to a matrix, and retain only the components that matter.                 #
   #---------------------------------------------------------------------------------------#
   warn = getOption("warn")
   options(warn=-1)
   XM = matrix(X,ncol=nx+1,nrow=W,byrow=TRUE)[,cc]
   options(warn=warn)
   #---------------------------------------------------------------------------------------#



   #---------------------------------------------------------------------------------------#
   #     Apply the function to each column, the result will be the vector with the         #
   # function.                                                                             #
   #---------------------------------------------------------------------------------------#
   ans = apply(X=XM,MARGIN=2,FUN=FUN,...)
   #---------------------------------------------------------------------------------------#

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