[R-gregmisc-users] SF.net SVN: r-gregmisc: [1120] trunk/gtools

[<wa...@us...>]

Revision: 1120
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1120&view=rev
Author:   warnes
Date:     2007-08-08 06:48:43 -0700 (Wed, 08 Aug 2007)

Log Message:
-----------
Add the binsearch(), previously in the genetics package.

Modified Paths:
--------------
    trunk/gtools/DESCRIPTION
    trunk/gtools/NAMESPACE
    trunk/gtools/NEWS

Added Paths:
-----------
    trunk/gtools/R/binsearch.R
    trunk/gtools/man/binsearch.Rd

Modified: trunk/gtools/DESCRIPTION
===================================================================
--- trunk/gtools/DESCRIPTION	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/DESCRIPTION	2007-08-08 13:48:43 UTC (rev 1120)
@@ -2,7 +2,7 @@
 Title: Various R programming tools
 Description: Various R programming tools
 Depends: R
-Version: 2.3.1
+Version: 2.4.0
 Author: Gregory R. Warnes. Includes R source code and/or documentation
         contributed by Ben Bolker and Thomas Lumley
 Maintainer: Gregory R. Warnes <wa...@bs...>

Modified: trunk/gtools/NAMESPACE
===================================================================
--- trunk/gtools/NAMESPACE	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/NAMESPACE	2007-08-08 13:48:43 UTC (rev 1120)
@@ -4,6 +4,7 @@
        addLast,
        ask,
        assert,
+       binsearch,
        capture,
        combinations,
        ddirichlet,

Modified: trunk/gtools/NEWS
===================================================================
--- trunk/gtools/NEWS	2007-08-03 04:44:05 UTC (rev 1119)
+++ trunk/gtools/NEWS	2007-08-08 13:48:43 UTC (rev 1120)
@@ -1,6 +1,12 @@
-SVN
-----
+gtools 2.4.0
+------------
 
+- Add binsearch() function, previously in the genetics() package.  
+
+
+gtoosl 2.3.1
+------------
+
 - Add ask() function to prompt the user and collect a single response.
 
 

Added: trunk/gtools/R/binsearch.R
===================================================================
--- trunk/gtools/R/binsearch.R	                        (rev 0)
+++ trunk/gtools/R/binsearch.R	2007-08-08 13:48:43 UTC (rev 1120)
@@ -0,0 +1,134 @@
+# $Id: binsearch.R 1295 2007-08-08 13:38:18Z warnes $
+
+binsearch <- function(fun, range, ..., target=0,
+                      lower=ceiling(min(range)),upper=floor(max(range)),
+                      maxiter=100, showiter=FALSE)
+    {
+
+      # initialize
+      lo <- lower
+      hi <- upper
+      counter <- 0
+      val.lo <- fun(lo,...)
+      val.hi <- fun(hi,...)
+
+      # check whether function is increasing or decreasing, & set sign
+      # appropriately.
+      if( val.lo > val.hi )
+        sign <- -1
+      else
+        sign <- 1
+
+      # check if value is outside specified range
+      if(target * sign < val.lo * sign)
+          outside.range <- TRUE
+      else if(target * sign >  val.hi * sign)
+          outside.range <- TRUE
+      else
+        outside.range <- FALSE
+
+      # iteratively move lo & high closer together until we run out of
+      # iterations, or they are adjacent, or they are identical
+      while(counter < maxiter && !outside.range )
+        {
+
+          counter <- counter+1
+
+          if(hi-lo<=1 || lo<lower || hi>upper) break;
+
+          center <- round((hi - lo)/2 + lo ,0  )
+          val <- fun(center, ...)
+
+          if(showiter)
+            {
+              cat("--------------\n")
+              cat("Iteration #", counter, "\n")
+              cat("lo=",lo,"\n")
+              cat("hi=",hi,"\n")
+              cat("center=",center,"\n")
+              cat("fun(lo)=",val.lo,"\n")
+              cat("fun(hi)=",val.hi,"\n")
+              cat("fun(center)=",val,"\n")
+            }
+
+          
+          if( val==target )
+            {
+              val.lo <- val.hi <- val
+              lo <- hi <- center
+              break;
+            }
+          else if( sign*val < sign*target )
+            {
+              lo <- center
+              val.lo <- val
+            }
+          else #( val > target )
+            {
+              hi <- center
+              val.hi <- val
+            }
+
+        if(showiter)
+          {
+            cat("new lo=",lo,"\n")
+            cat("new hi=",hi,"\n")
+            cat("--------------\n")
+          }
+          
+        }
+      
+      # Create return value
+      retval <- list()
+      retval$call <- match.call()
+      retval$numiter <- counter
+
+      if( outside.range )
+        {
+          if(target * sign < val.lo * sign)
+            {
+              warning("Reached lower boundary")
+              retval$flag="Lower Boundary"
+              retval$where=lo
+              retval$value=val.lo
+            }
+          else #(target * sign >  val.hi * sign)
+          {
+            warning("Reached upper boundary")
+            retval$flag="Upper Boundary"
+            retval$where=hi
+            retval$value=val.hi
+          }
+        }
+      else if( counter >= maxiter )
+        {
+          warning("Maximum number of iterations reached")
+          retval$flag="Maximum number of iterations reached"
+          retval$where=c(lo,hi)
+          retval$value=c(fun.lo,fun.hi)
+        }
+      else if( val.lo==target )
+        {
+          retval$flag="Found"
+          retval$where=lo
+          retval$value=val.lo
+        }
+      else if( val.hi==target )
+        {
+          retval$flag="Found"
+          retval$where=lo
+          retval$value=val.lo
+        }
+      else
+        {
+          retval$flag="Between Elements"
+          retval$where=c(lo, hi)
+          retval$value=c(val.lo, val.hi)
+        }
+      
+      return(retval)
+
+    }
+                 
+                                             
+

Added: trunk/gtools/man/binsearch.Rd
===================================================================
--- trunk/gtools/man/binsearch.Rd	                        (rev 0)
+++ trunk/gtools/man/binsearch.Rd	2007-08-08 13:48:43 UTC (rev 1120)
@@ -0,0 +1,103 @@
+% $Id: binsearch.Rd 1087 2006-11-11 04:09:59Z warnes $
+
+\name{binsearch}
+\alias{binsearch}
+\title{Binary Search}
+\description{
+  Search within a specified range to locate an integer parameter which
+  results in the the specified monotonic function obtaining a given value.
+}
+\usage{
+binsearch(fun, range, ..., target = 0, lower = ceiling(min(range)),
+          upper = floor(max(range)), maxiter = 100, showiter = FALSE)
+}
+\arguments{
+  \item{fun}{Monotonic function over which the search will be performed.}
+  \item{range}{2-element vector giving the range for the search.}
+  \item{\dots}{Additional parameters to the function \code{fun}.}
+  \item{target}{Target value for \code{fun}.  Defaults to 0.}
+  \item{lower}{Lower limit of search range. Defaults to \code{min(range)}.}
+  \item{upper}{Upper limit of search range. Defaults to \code{max(range)}.}
+  \item{maxiter}{ Maximum number of search iterations. Defaults to 100.}
+  \item{showiter}{ Boolean flag indicating whether the algorithm state
+    should be printed at each iteration. Defaults to FALSE.}
+}
+\details{
+  This function implements an extension to the standard binary search
+  algorithm for searching a sorted list.  The algorithm has been
+  extended to cope with cases where an exact match is not possible, to
+  detect whether that the function may be monotonic increasing or
+  decreasing and act appropriately, and to detect when the target value
+  is outside the specified range.
+
+  The algorithm initializes two variable \code{lo} and
+  \code{high} to the extremes values of \code{range}.  It then generates
+  a new value \code{center} halfway between \code{lo} and \code{hi}.  If
+  the value of \code{fun} at \code{center} exceeds \code{target}, it
+  becomes the new value for \code{lo}, otherwise it becomes the new
+  value for \code{hi}.  This process is iterated until \code{lo} and
+  \code{hi} are adjacent.  If the function at one or the other equals
+  the target, this value is returned, otherwise \code{lo}, \code{hi},
+  and the function value at both are returned.
+
+  Note that when the specified target value falls between integers, the
+  \em{two} closest values are returned.  If the specified target falls
+  outside of the specified \code{range}, the closest endpoint of the
+  range will be returned, and an warning message will be generated.  If
+  the maximum number if iterations was reached, the endpoints of the
+  current subset of the range under consideration will be returned.
+}
+\value{
+  A list containing:
+  \item{call}{How the function was called.}
+  \item{numiter}{The number of iterations performed}
+  \item{flag }{One of the strings,  "Found", "Between Elements",
+    "Maximum number of iterations reached", "Reached lower boundary", or
+    "Reached upper boundary."}
+  \item{where}{One or two values indicating where the search
+    terminated.}
+  \item{value}{Value of the function \code{fun} at the values of
+    \code{where}.}
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Gregory R. Warnes \email{wa...@bs...} }
+\note{This function often returns two values for \code{where} and
+  \code{value}.  Be sure to check the \code{flag} parameter to see what
+  these values mean.}
+\seealso{ \code{\link[base]{optim}}, \code{\link[base]{optimize}},
+  \code{\link[base]{uniroot}} }
+\examples{
+
+### Toy examples
+
+# search for x=10
+binsearch( function(x) x-10, range=c(0,20) )
+
+# search for x=10.1
+binsearch( function(x) x-10.1, range=c(0,20) )
+
+### Classical toy example
+
+# binary search for the index of 'M' among the sorted letters
+fun <- function(X) ifelse(LETTERS[X] > 'M', 1,
+                          ifelse(LETTERS[X] < 'M', -1, 0 ) )
+
+binsearch( fun, range=1:26 ) 
+# returns $where=13
+LETTERS[13]
+
+### Substantive example, from genetics
+\dontrun{
+library(genetics)
+# Determine the necessary sample size to detect all alleles with
+# frequency 0.07 or greater with probability 0.95.
+power.fun <- function(N) 1 - gregorius(N=N, freq=0.07)$missprob
+
+binsearch( power.fun, range=c(0,100), target=0.95 )
+
+# equivalent to
+gregorius( freq=0.07, missprob=0.05)
+}
+}
+\keyword{optimize}
+\keyword{programming}


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.