home *** CD-ROM | disk | FTP | other *** search
/ Big Green CD 8 / BGCD_8_Dev.iso / NEXTSTEP / UNIX / Educational / R-0.49-MI / R-0.49-I / library / integrate < prev    next >
Encoding:
Text File  |  1997-09-14  |  2.2 KB  |  65 lines
  1. integrate<-function(functn, lower,upper,minpts=100,maxpts=500,eps=0.01,...){
  2. adapt(1,lower,upper,minpts,maxpts,functn,eps,...)
  3. }
  4.  
  5. adapt <- function(ndim,lower,upper,minpts,maxpts,functn,eps,...)
  6. {
  7. # This function has way too many comments and checks. It is written so
  8. # that someone other than me can use it as a template for future functions.
  9.  
  10. # fudge for 1-d functions 
  11.    if (ndim==1) {
  12.     ff<-function(x) functn(x[1],...)
  13.     lower<-c(lower,0)
  14.     upper<-c(upper,1)
  15.     ndim<-2
  16.     }
  17.    else
  18.     ff<-function(x) functn(x,...)
  19.  
  20. # Check to make sure that upper and lower are reasonable lengths
  21. # Both the upper and lower limits should be at least of length ndim
  22. #
  23.   if( length(lower) < ndim || length(upper) < ndim) {
  24.      cat("The lower and upper vectors need to have at least ndim elements\n")
  25.      cat("Your parameters are,  ndim ",ndim, " length(lower) ",length(lower),
  26.          "length(upper) ",length(upper), "\n")
  27.      return()
  28.      }
  29. # rulcls and lenwrk are mandated in the adapt source
  30. #
  31.   rulcls <-  2**ndim+2*ndim**2+6*ndim+1
  32.   lenwrk <- (2*ndim+3)*(1+maxpts/rulcls)/2
  33.  
  34.   if( minpts > maxpts ){
  35.     cat("maxpts must be > minpts. Maxpts has be increased to\n")
  36.     cat("minpts + 1\n")
  37.     maxpts <- minpts + 1
  38.     }
  39. # maxpts should be large enough.  Prefer 10*rulclc, but use 2*rulclc.
  40. #
  41.   if ( maxpts < 2*rulcls) {
  42.     cat("You have maxpts (= ", maxpts, " too small\n")
  43.     cat("It needs to be at least 2 times 2**ndim+2*ndim**2+6*ndim+1\n")
  44.     cat("It has been reset to ", 2*rulcls,"\n")
  45.     maxpts <- 2*rulcls
  46.     }
  47.   relerr <- finest <- 0.0
  48.   ifail <- 0
  49.   storage.mode(ifail) <- "integer"
  50. #/* TSL changed list(functn) to functn in next line, then to ff */
  51.   answ _ .C("cadapt", as.integer(ndim), lower, upper,
  52.             minpts=as.integer(minpts), as.integer(maxpts),ff,
  53.             eps,relerr = relerr, as.integer(lenwrk),
  54.         finest = finest,ifail=ifail)
  55.               # Finest is the value of the function.
  56.   switch( answ$ifail,
  57.           cat("Ifail is 1, maxpts was too small. Check the returned relerr\n"),
  58.           cat("Ifail is 2, lenwrk was too small. Check the returned relerr\n"),
  59.           cat("Ifail is 3, This should not happen\n")
  60.      )
  61.    result <- list(finest=answ$finest,relerr=answ$relerr,minpts=answ$minpts,
  62.          ifail=answ$ifail)
  63.     result
  64.   }
  65.