.packageName <- "ref"
#-- ref.r ------------------------------------
# Jens Oehlschlaegel
# created:            14.08.97
# simplified:         30.08.03
# performance tested: 30.08.03
# documented:         30.08.03
# (gpl) 2003
#---------------------------------------------


if (!exists("is.R")){
  is.R <- function()exists("version") && !is.null(vl <- version$language) && vl == "R"
}

#! \name{ref}
#! \alias{ref}
#! \alias{print.ref}
#! \title{ creating references }
#! \description{
#!   Package \code{ref} implements references for S (R/S+).
#!   Function \code{ref} creates references.
#!   For a memory efficient wrapper to matrixes and data.frames which allows nested subsetting see \code{\link{refdata}}
#! }
#! \usage{
#! ref(name, loc = parent.frame())
#! }
#! \arguments{
#!   \item{name}{ name of an (existing) object to be referenced }
#!   \item{loc}{ location of the referenced object, i.e. an environment in R or a frame in S+ }
#! }
#! \details{
#!   In S (R/S+) paramters are passed by value and not by reference.
#!   When passing big objects, e.g. in recursive algorithms, this can quickly eat up memory.
#!   The functions of package \code{ref} allow to pass references in function calls.
#!   The implementation is purely S and should work in R and S+.
#!   Existence of the referenced object is not checked by function \code{ref}.
#!   Usually \code{\link{as.ref}} is more convenient and secure to use.
#!   There is also a print method for references.
#! }
#! \value{
#!   a list with
#!   \item{ name }{  name of the referenced object }
#!   \item{ loc }{ location of the referenced object, i.e. an environment in R or a frame in S+ }
#!   and class "ref"
#! }
#! \note{
#!  Using this type of references is fine for prototyping in a non-objectoriented programming style.
#!  For bigger projects and safer programming you should consider the approach suggested by Henrik Bengtsson
#!  at \url{http://www.maths.lth.se/help/R/ImplementingReferences} (announced to be released as package "oo" or "classes")
#! }
#! \section{WARNING}{
#!  Usually functions in S have no side-effects except for the main effect of returning something.
#!  Working with references circumvents this programming style and can have considerable side-effects.
#!  You are using it at your own risk.
#! }
#! \section{R 1.8 WARNING}{
#!  Changing parts of referenced objects has been slowed down by order of magnitudes since R version 1.8 (see performance test examples on the help page for \{code\link{deref}}). Hopefully the old performance can be restored in future versions.
#! }
#! \section{S+ WARNING}{
#!  Package ref should generally work under R and S+. However, when changing very small parts of referenced objects, using references under S+ might be inefficient (very slow with high temporary memory requirements).
#! }
#! \section{Historical remarks}{
#!   This package goes back to an idea submitted April 9th 1997 and code offered on August 17th 1997 on s-news.
#!   The idea of implementing references in S triggered an intense discussion on s-news. The status reached in 1997 can be summarized as follows:\cr
#!   \enumerate{
#!     \item{\bold{advantage}}{passing by reference can save memory compared to passing by value}
#!     \item{\bold{disadvantage}}{passing by reference is more dangerous than passing by value}
#!     \item{\bold{however}}{the implementation is purely in S, thus rather channels existing danger than adding new danger}
#!     \item{\bold{restriction}}{assigning to a subsetted part of a referenced object was inefficient in S+ (was S+ version 3)}
#!   }
#!   Due to the last restriction the code was never submitted as a mature library.
#!   Now in 2003 we have a stable version of R and astonishingly assigning to a subsetted part of a referenced object \emph{can} be implemented efficient.
#!   This shows what a great job the R core developers have done. In the current version the set of functions for references was dramatically simplified, the main differences to 1997 beeing the following:
#!   \enumerate{
#!     \item{\bold{no idempotence}}{ \code{\link{deref}} and  \code{\link{deref<-}} now are a simple function and no longer are methods. This decision was made due top performance reasons. As a consequence, \code{deref()} no longer is idempotent: one has to know whether an object is a reference. Function \code{\link{is.ref}} provides a test. }
#!     \item{\bold{no write protection}}{ The 1997 suggestion included a write protection attribute of references, allowing for read only references and allowing for references that could only be changed by functions that knwe the access code. Reasons for this: there is no need for readonly references (due to copy on modify) and oop provides better mechanisms for security. }
#!     \item{\bold{no static variables}}{ The suggestion made in 1997 did include an implementation of static variables realized as special cases of references with a naming convention which reduced the risc of name collisions in the 1997 practice of assigning to frame 0. Now R has namespaces and the oop approach of Henrik Bengtsson using environments is to be prefered over relatively global static objects. }
#!   }
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{
#!  \code{\link{as.ref}}, \code{\link{deref}}, \code{\link{deref<-}}, \code{\link{exists.ref}}, \code{\link{is.ref}}, \code{\link{print.ref}}, \code{\link{HanoiTower}}
#! }
#! \examples{
#!   v <- 1
#!   r <- ref("v")
#!   r
#!   deref(r)
#!   cat("For more examples see ?deref\n")
#! }
#! \keyword{ programming }

ref <-
if(is.R()){
  function(name, loc=parent.frame())
    # creator for ref objects
  {
    temp <- list(
      name  = name
    , loc = loc
    )
    class(temp) <- "ref"
    temp
  }
}else{
  function(name, loc=sys.parent())
    # creator for ref objects
  {
    temp <- list(
      name  = name
    , loc = loc
    )
    class(temp) <- "ref"
    temp
  }
}


print.ref <-
if(is.R()){
  function(x, ...)
    # prints reference, optionally referenced object
  {
    cat("reference to", x$name, "in ")
    print(x$loc)
    if (exists.ref(x)){
      cat("(object exists)\n")
    }else{
      cat("(no object)\n")
    }
    invisible()
  }
}else{
  function(x, ...)
    # prints reference, optionally referenced object
  {
    if (x$loc==1)
      cat("reference to", x$name, "in where=", x$loc)
    else
      cat("reference to", x$name, "in frame=", x$loc)
    if (exists.ref(x)){
      cat(" (object exists)\n")
    }else{
      cat(" (no object)\n")
    }
    invisible()
  }
}



#! \name{as.ref}
#! \alias{as.ref}
#! \title{ coercing to reference }
#! \description{
#!   This function RETURNs a reference to its argument.
#! }
#! \usage{
#! as.ref(obj)
#! }
#! \arguments{
#!   \item{obj}{ an object existing in the current environment/frame }
#! }
#! \value{
#!   an object of class "ref"
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link{ref}}, \code{\link{deref}} }
#! \examples{
#!   v <- 1
#!   r <- as.ref(v)
#!   r
#!   deref(r)
#! }
#! \keyword{ programming }

as.ref <-
if(is.R()){
  function(obj)
    # return reference to obj
    # if obj is already a reference return the reference directly
  {
    obj.name <- substitute(obj)
    obj.loc <- parent.frame()
    if (!is.name(obj.name))
      stop("obj must be a named object")
    obj.name <- deparse(obj.name)
    if (is.ref(obj)){
      obj
    }else{
      ref(obj.name, obj.loc)
    }
  }
}else{
  function(obj)
    # return reference to obj
    # if obj is already a reference return the reference directly
  {
    obj.name <- substitute(obj)
    obj.loc <- sys.parent()
    if (!is.name(obj.name))
      stop("obj must be a named object")
    obj.name <- deparse(obj.name)
    if (is.ref(obj)){
      obj
    }else{
      ref(obj.name, obj.loc)
    }
  }
}


#! \name{deref}
#! \alias{deref}
#! \alias{deref<-}
#! \title{ dereferencing references }
#! \description{
#!   This functions allow to access a referenced object. \code{deref(ref)} returns the object, and \code{deref(ref) <- value} assigns to the referenced object.
#! }
#! \usage{
#! deref(ref)
#! deref<-(ref, value)
#! #the following does not pass R CMD CHECK
#! #deref(ref) <- value
#! #deref(ref)[1] <- value  # subsetted assignment appears to be inefficent in S+.
#! }
#! \arguments{
#!   \item{ref}{ a reference as returned by \code{\link{ref}} or \code{\link{as.ref}} }
#! }
#! \details{
#!   \code{deref} and \code{deref<-} provide convenient access to objects in other environments/frames.
#!   In fact they are wrappers to \code{\link{get}} and \code{\link{assign}}.
#!   However, convenient does not neccessarily means efficient.
#!   If performance is an issue, the direct use of \code{\link{new.env}}, \code{\link{substitute}} and \code{\link{eval}} may give better results.
#!   See the examples below.
#! }
#! \value{
#!   \code{deref} returns the referenced object.
#!   \cr \code{"deref<-"} returns a reference to the modified object, see \code{\link{ref}}.
#! }
#! \references{ Writing R Extensions }
#! \author{ Jens Oehlschlgel }
#! \note{ Subsetted assignment appears to be inefficent in S+. Note the use of \code{\link{substitute}} in the examples. }
#! \seealso{ \code{\link{ref}}, \code{\link{as.ref}},  \code{\link[base]{get}},  \code{\link[base]{assign}},  \code{\link[base]{substitute}},  \code{\link[base]{eval}} }
#! \examples{
#!   # Simple usage example
#!   x <- cbind(1:5, 1:5)          # take some object
#!   rx <- as.ref(x)               # wrap it into a reference
#!   deref(rx)                     # read it through the reference
#!   deref(rx) <- rbind(1:5, 1:5)  # replace the object in the reference by another one
#!   deref(rx)[1, ]                # read part of the object
#!   deref(rx)[1, ] <- 5:1         # replace part of the object
#!   deref(rx)                     # see the change
#!   cat("For examples how to pass by references see the Performance test examples at the help pages\n")
#!
#!  \dontrun{
#!   ## Performance test examples showing actually passing by reference
#!   # define test size
#!   nmatrix <- 1000   # matrix size of nmatrix by nmatrix
#!   nloop   <- 10     # you might want to use less loops in S+, you might want more in R versions before 1.8
#!
#!   # Performance test using ref
#!   t1 <- function(){ # outer function
#!     m <- matrix(nrow=nmatrix, ncol=nmatrix)
#!     a <- as.ref(m)
#!       t2(a)
#!     m[1,1]
#!   }
#!   # subsetting deref is slower (by factor 75 slower since R 1.8 compared to previous versions, and much, much slower in S+) ...
#!   t2 <- function(ref){ # inner function
#!     cat("timing", timing.wrapper(
#!       for(i in 1:nloop)
#!         deref(ref)[1,1] <- i
#!     ), "\n")
#!   }
#!   if (is.R())gc()
#!   t1()
#!   # ... than using substitute
#!   t2 <- function(ref){
#!     obj <- as.name(ref$name)
#!     loc <- ref$loc
#!     cat("timing", timing.wrapper(
#!       for(i in 1:nloop)
#!         eval(substitute(x[1,1] <- i, list(x=obj, i=i)), loc)
#!     ), "\n")
#!   }
#!   if (is.R())gc()
#!   t1()
#!
#!
#!   # Performance test using Object (R only)
#!   # see Henrik Bengtsson package(oo)
#!   Object <- function(){
#!     this <- list(env.=new.env());
#!     class(this) <- "Object";
#!     this;
#!   }
#!   "$.Object" <- function(this, name){
#!     get(name, envir=unclass(this)$env.);
#!   }
#!   "$<-.Object" <- function(this, name, value){
#!     assign(name, value, envir=unclass(this)$env.);
#!     this;
#!   }
#!   # outer function
#!   t1 <- function(){
#!     o <- Object()
#!     o$m <- matrix(nrow=nmatrix, ncol=nmatrix)
#!       t2(o)
#!     o$m[1,1]
#!   }
#!   # subsetting o$m is slower ...
#!   t2 <- function(o){
#!     cat("timing", timing.wrapper(
#!       for(i in 1:nloop)
#!         o$m[1,1] <- i
#!     ), "\n")
#!   }
#!   if (is.R())gc()
#!   t1()
#!   # ... than using substitute
#!   t2 <- function(o){
#!     env <- unclass(o)$env.
#!     cat("timing", timing.wrapper(
#!       for(i in 1:nloop)
#!         eval(substitute(m[1,1] <- i, list(i=i)), env)
#!     ), "\n")
#!   }
#!   if (is.R())gc()
#!   t1()
#!
#!   }
#! }
#! \keyword{ programming }


deref <-
if(is.R()){
  function(ref)
    # returns referenced object
  {
    get(ref$name, envir=ref$loc)
  }
}else{
  function(ref)
    # returns referenced object
  {
    if (ref$loc==1)
      get(ref$name, where=ref$loc)
    else
      get(ref$name, frame=ref$loc)
  }
}

"deref<-" <-
if(is.R()){
  function(ref, value)
    # assigns value to referenced object
  {
    assign(ref$name, value, envir=ref$loc)
    ref
  }
}else{
  function(ref, value)
    # assigns value to referenced object
  {
    if (ref$loc==1)
      assign(ref$name, value, where=ref$loc)
    else
      assign(ref$name, value, frame=ref$loc)
    ref
  }
}


#! \name{is.ref}
#! \alias{is.ref}
#! \alias{exists.ref}
#! \title{ checking (for) references }
#! \description{
#!   \code{is.ref} checks whether an object inherits from class "ref". \cr
#!   \code{exists.ref} checks whether an referenced object exists.
#! }
#! \usage{
#!   is.ref(x)
#!   exists.ref(ref)
#! }
#! \arguments{
#!   \item{x}{ an object that might be a reference }
#!   \item{ref}{ a reference as returned from \code{\link{ref}} or \code{\link{as.ref}} }
#! }
#! \value{
#!   logical scalar
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link{ref}}, \code{\link[base]{exists}}, \code{\link[base]{inherits}}, \code{\link[base]{class}} }
#! \examples{
#!   v <- 1
#!   good.r <- as.ref(v)
#!   bad.r <- ref("NonExistingObject")
#!   is.ref(v)
#!   is.ref(good.r)
#!   is.ref(bad.r)
#!   exists.ref(good.r)
#!   exists.ref(bad.r)
#! }
#! \keyword{ programming }

exists.ref <-
if(is.R()){
  function(ref)
  {
    exists(ref$name, envir=ref$loc)
  }
}else{
  function(ref)
  {
    if (ref$loc==1)
      exists(ref$name, where=ref$loc)
    else
      exists(ref$name, frame=ref$loc)
  }
}


is.ref <- function(x)
{
  inherits(x, "ref")
}


#! \name{sleep.wrapper}
#! \alias{sleep.wrapper}
#! \alias{memsize.wrapper}
#! \alias{timing.wrapper}
#! \title{ wrapper to get some measures for all platforms }
#! \description{
#!   interrupts execution for specified no. of seconds
#! }
#! \usage{
#! sleep.wrapper(time)
#! }
#! \arguments{
#!   \item{time}{ no. of seconds }
#! }
#! \value{
#!   NULL
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link[base]{Sys.sleep}} }
#! \keyword{ internal }

sleep.wrapper <- if(is.R()){
  Sys.sleep
}else{
  sleep
}

memsize.wrapper <- if(is.R()){
  function()sum(gc()[,2])
}else{
  function()memory.size()/ 1048576
}

timing.wrapper <- if(is.R()){
  function(expr)system.time(expr)[1]
}else{
  function(expr)sys.time(expr)[1]
}


#! \name{HanoiTower}
#! \alias{HanoiTower}
#! \alias{move.HanoiTower}
#! \alias{print.HanoiTower}
#! \alias{plot.HanoiTower}
#! \title{ application example for references }
#! \description{
#!   This is an example for using references in S (R/S+) with package \code{ref}.
#!   \code{HanoiTower} implements a recursive algorithm solving the Hanoi tower problem.
#!   It is implemented such that the recursion can be done either by passing the HanoiTower \emph{by reference} or \emph{by value} to the workhorse function \code{move.HanoiTower}.
#!   Furthermore you can choose whether recursion should use \code{\link{Recall}} or should directly call \code{move.HanoiTower}.
#!   As the HanoiTower object is not too big, it can be extended by some garbage MBytes, that will demonstrate the advantage of passing references instead of values.
#!   The deeper we recurse, the more memory we waist by passing values (and the more memory we save by passing references).
#!   Functions \code{move.HanoiTower} and \code{print.HanoiTower} are internal (not intended to be called by the user directly).
#! }
#! \usage{
#!   HanoiTower(n = 5
#!   , parameter.mode = c("reference", "value")[1]
#!   , recursion.mode = c("recall", "direct")[1]
#!   , garbage = 0
#!   , print = FALSE
#!   , plot = TRUE
#!   , sleep = 0
#!   )
#! }
#! \arguments{
#!   \item{n}{ number of slices }
#!   \item{parameter.mode}{ one of "reference" or "value" deciding how to pass the HanoiTower object }
#!   \item{recursion.mode}{ one of "recall" or "direct" deciding how to call recursively }
#!   \item{garbage}{ no. of bytes to add to the HanoiTower size }
#!   \item{print}{ TRUE print the HanoiTower changes }
#!   \item{plot}{ FALSE not to plot the HanoiTower changes }
#!   \item{sleep}{ no. of seconds to wait between HanoiTower changes for better monitoring of progress }
#! }
#! \details{
#!   The Hanoi Tower problem can be described as follows: you have n slices of increasing size placed on one of three locations a,b,c such that the biggest slice is at the bottom, the next biggest slice on top of it and so forth with the smallest slice as the top of the tower.
#!   Your task is to move all slices from one stick to the other, but you are only allowed to move one slice at a time and you may never put a bigger slice on top of a smaller one.
#!   The recursive solution is: to move n slices from a to c you just need to do three steps: move n-1 slices to b, move the biggest slice to c and move n-1 slices from b to c. If n equals 1, just move from a to c.
#! }
#! \value{
#!   invisible()
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link{ref}}, \code{\link[base]{Recall}} }
#!
#! \examples{
#!     HanoiTower(n=2)
#!
#!  \dontrun{
#!     # small memory examples
#!     HanoiTowerDemoBytes <- 0
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "reference"
#!     , recursion.mode  = "direct"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "reference"
#!     , recursion.mode  = "recall"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "value"
#!     , recursion.mode  = "direct"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "value"
#!     , recursion.mode  = "recall"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     rm(HanoiTowerDemoBytes)
#!
#!     # big memory examples
#!     HanoiTowerDemoBytes <- 100000
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "reference"
#!     , recursion.mode  = "direct"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "reference"
#!     , recursion.mode  = "recall"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "value"
#!     , recursion.mode  = "direct"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     if (is.R())
#!       gc()
#!     HanoiTower(
#!       parameter.mode  = "value"
#!     , recursion.mode  = "recall"
#!     , garbage = HanoiTowerDemoBytes
#!     )
#!     rm(HanoiTowerDemoBytes)
#!   }
#! }
#! \keyword{ programming }


HanoiTower <- function(
  n = 5
, parameter.mode  = c("reference", "value")[1]
, recursion.mode  = c("recall", "direct")[1]
, garbage = 0     # bytes added to emulate bigger object size
, print   = FALSE
, plot    = TRUE
, sleep   = 0
)
  ## outer function
{
  cat("\nHanoiTower() start\n")

  parameter.mode <- match.arg(parameter.mode, c("reference", "value"))
  recursion.mode <- match.arg(recursion.mode, c("recall", "direct"))

  # create a local object which shall be modified by a recursive function, either by ref or by val
  Tower <- list(
    Tower = list(
      a=n:1
    , b=numeric()
    , c=numeric()
    )
  , garbage = 1:(garbage %/% 4)
  )
  class(Tower) <- "HanoiTower"

  # create a local object that shall always be manipulated by ref
  Info <- list(
    print = print
  , plot  = plot
  , sleep = sleep
  , frames = 0
  , MBytes = 0
  )
  Info.ref <- as.ref(Info)

  # show initial object size
  cat("object.size(HanoiTower)=", object.size(Tower), "\n")

  # display first Tower
  if (print)
    print.HanoiTower(Tower)
  if (plot)
    plot.HanoiTower(Tower)

  # inform user about recursion mode
  cat(ifelse(recursion.mode=="direct","recursion.mode='direct'  [uses move.HanoiTower()]","recursion.mode='recall'  [uses Recall()]"),"\n")

  # do the work according to parameter mode
  if(parameter.mode=="value") {
    cat("parameter.mode='value'     [each recursive call copies Tower]\n")
    # Tower is a local object
    seconds <- timing.wrapper(move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, n, 1, 3))
  }else{
    cat("parameter.mode='reference' [reference to TowerObject in local frame of HanoiTower()]\n")
    # Tower parameter to move.HanoiTower is a reference into this frame
    seconds <- timing.wrapper(move.HanoiTower(as.ref(Tower), Info.ref, parameter.mode, recursion.mode, n, 1, 3))
  }
  # here's the work done
  # get Info
  cat("\nHanoiTower() done\n")
  cat("seconds     ", round(seconds, 2), "\n")
  cat("max(frames) ", Info$frames, "\n")
  cat("max(MBytes) ", round(Info$MBytes, 2), "\n")
  invisible()
}


move.HanoiTower <- function(Tower, Info.ref, parameter.mode, recursion.mode, n=1, from=1, to=1)
  ## (inner) recalling function
{

  # emulate a manipulation to the big object
  # (mainly because otherwise S+ is so clever to recognize that the big object is nver changed)
  if (is.ref(Tower)){
    if (length(deref(Tower)$garbage))
      deref(Tower)$garbage[1] <- 1
  }else{
    if (length(Tower$garbage))
      Tower$garbage[1] <- 1
  }

  if (n==1){

    # parameter Tower is either value or reference
    if (is.ref(Tower)){

      # write actions in the final recursion branches
      nfrom <- length(deref(Tower)$Tower[[from]])
      deref(Tower)$Tower[[to]][length(deref(Tower)$Tower[[to]])+1] <- deref(Tower)$Tower[[from]][nfrom]
      length(deref(Tower)$Tower[[from]]) <- nfrom-1

    }else{

      # write actions in the final recursion branches
      nfrom <- length(Tower$Tower[[from]])
      Tower$Tower[[to]][length(Tower$Tower[[to]])+1] <- Tower$Tower[[from]][nfrom]
      length(Tower$Tower[[from]]) <- nfrom-1

    }

    # show progress
    sleep.wrapper(deref(Info.ref)$sleep)
    if (deref(Info.ref)$print)
      print.HanoiTower(Tower)
    if (deref(Info.ref)$plot)
      plot.HanoiTower(Tower)

    # update performance Info
    deref(Info.ref)$frames <- max( deref(Info.ref)$frames, sys.nframe() )
    deref(Info.ref)$MBytes <- max( deref(Info.ref)$MBytes, memsize.wrapper() )

  }else{

  # recall actions
    free <- (1:3)[-c(from, to)]

    if (parameter.mode=="reference"){
      if (recursion.mode=="direct"){
        move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, n-1, from, free)
        move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, 1  , from, to  )
        move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, n-1, free, to  )
      }else{
        Recall(Tower, Info.ref, parameter.mode, recursion.mode, n-1, from, free)
        Recall(Tower, Info.ref, parameter.mode, recursion.mode, 1  , from, to  )
        Recall(Tower, Info.ref, parameter.mode, recursion.mode, n-1, free, to  )
      }
    }else{
      if (recursion.mode=="direct"){
        Tower <- move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, n-1, from, free)
        Tower <- move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, 1  , from, to  )
        Tower <- move.HanoiTower(Tower, Info.ref, parameter.mode, recursion.mode, n-1, free, to  )
      }else{
        Tower <- Recall(Tower, Info.ref, parameter.mode, recursion.mode, n-1, from, free)
        Tower <- Recall(Tower, Info.ref, parameter.mode, recursion.mode, 1  , from, to  )
        Tower <- Recall(Tower, Info.ref, parameter.mode, recursion.mode, n-1, free, to  )
      }
    }
  }
  Tower
}


print.HanoiTower<- function(x, ...){
  # parameter x is either deref or reference
  if (is.ref(x))
    Tower <- deref(x)$Tower
  else
    Tower <- x$Tower
  nmax <- max(unlist(lapply(Tower, length)))
  outp <- matrix("", nrow=nmax, ncol=3)

  if (length(Tower[[1]]))
    outp[1:length(Tower[[1]]), 1] <- as.character(Tower[[1]])
  if (length(Tower[[2]]))
    outp[1:length(Tower[[2]]), 2] <- as.character(Tower[[2]])
  if (length(Tower[[3]]))
    outp[1:length(Tower[[3]]), 3] <- as.character(Tower[[3]])

  outp <- outp[nmax:1,]
  outp <- rbind(outp,rep("-",3),c("A","B","C"))
  outp <- data.frame(outp)
  names(outp) <- c("         .","    .","    .")
  print(outp)
  invisible()
}

plot.HanoiTower <- function(x, ...){
  # parameter x is either deref or reference
  if (is.ref(x))
    Tower <- deref(x)$Tower
  else
    Tower <- x$Tower
  n <- sum(unlist(lapply(Tower,length)))
  plot(1, 1, xlim=c(0,3*n), ylim=c(0,n), type="n")
  for (i in 1:3) if (length(Tower[[i]])>0)
    for (j in 1:length(Tower[[i]])){
      x <- (i-0.5)*n
      y <- j-0.5
      polygon(x+Tower[[i]][j]*c(0.5,-0.5,-0.5,0.5),y+c(0.5,0.5,-0.5,-0.5), density=0)
      text(x,y,Tower[[i]][j], adj=0.5)
    }
  invisible()
}

#-- refdata.r ------------------------------------
# Jens Oehlschlaegel
# created:            28.09.03
# performance tested: 28.09.03
# documented:         28.09.03
# changes 06.03.2004: optimal.index(oi) now is idempotent, also for oi=NULL which is interpreted as 'no indexing required'
# changes 06.03.2004: new function need.index(oi) returning TRUE if indexing is required (returning FALSE for NULL)
# changes 06.03.2004: new function posi.index(oi) converting optimal index into positive integers (does not make sense for NULL and non-optimal indices)
# (gpl) 2003
#---------------------------------------------


#! \name{optimal.index}
#! \alias{optimal.index}
#! \alias{need.index}
#! \alias{posi.index}
#! \title{ creating standardized, memory optimized index for subsetting }
#! \description{
#!   Function \code{optimal.index} converts an index specification of type {logical, integer, -integer, character} into one of {integer, -integer} whatever is smaller.
#!   Function \code{need.index} returns TRUE if the index does represent a subset (and thus indexing is needed).
#!   Function \code{posi.index} returns positive integers representing the (sub)set.
#! }
#! \usage{
#! optimal.index(i, n=length(i.names), i.names = names(i), i.previous = NULL, strict = TRUE)
#! need.index(oi)
#! posi.index(oi)
#! }
#! \arguments{
#!   \item{i}{ the original one-dimensional index }
#!   \item{n}{ length of the indexed dimension  (potential iMax if i where integer), not necessary if names= is given }
#!   \item{i.names}{ if i is character then names= represents the names of the indexed dimension }
#!   \item{i.previous}{ if i.previous= is given, the returned index represents \code{x[i.previous][i] == x[optimal.index]} rather than \code{x[i] == x[optimal.index]} }
#!   \item{strict}{ set to FALSE to allow for NAs and duplicated index values, but see details }
#!   \item{oi}{ a return value of \code{optimal.index} }
#! }
#! \details{
#!   When strict=TRUE it is expected that i does not contain NAs and no duplicated index values. Then \code{ identical(x[i], x[optimal.index(i, n=length(x), i.names=names(x))$i]) == TRUE } . \cr
#!   When strict=FALSE i may contain NAs and/or duplicated index values. In this case length optimisation is not performed and optimal.index always returns positive integers.
#! }
#! \note{
#!   \code{need.index(NULL)} is defined and returns FALSE. This allows a function to have an optional parameter oi=NULL and to determine the need of subsetting in one reqest.
#! }
#! \value{
#!   \code{optimal.index} returns the index oi with attributes n=n and ni=length(x[optimal.index]) (which is n-length(i) when i is negative).
#!   \code{need.index} returns a logical scalar
#!   \code{posi.index}  returns a vector of positive integers (or integer(0))
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link{refdata}}
#!           \cr please ignore the following unpublished links: ids2index, shift.index, startstop2index
#! }
#! \examples{
#!   l <- letters
#!   names(l) <- letters
#!   stopifnot({i <- 1:3 ; identical(l[i], l[optimal.index(i, n=length(l))])})
#!   stopifnot({i <- -(4:26) ; identical(l[i], l[optimal.index(i, n=length(l))])})
#!   stopifnot({i <- c(rep(TRUE, 3), rep(FALSE, 23)) ; identical(l[i], l[optimal.index(i, n=length(l))])})
#!   stopifnot({i <- c("a", "b", "c"); identical(l[i], l[optimal.index(i, i.names=names(l))])})
#!   old.options <- options(show.error.messages=FALSE); stopifnot(inherits(try(optimal.index(c(1:3, 3), n=length(l))), "try-error")); options(old.options)
#!   stopifnot({i <- c(1:3, 3, NA);identical(l[i], l[optimal.index(i, n=length(l), strict=FALSE)])})
#!   stopifnot({i <- c(-(4:26), -26);identical(l[i], l[optimal.index(i, n=length(l), strict=FALSE)])})
#!   stopifnot({i <- c(rep(TRUE, 3), rep(FALSE, 23), TRUE, FALSE, NA);identical(l[i], l[optimal.index(i, n=length(l), strict=FALSE)])})
#!   stopifnot({i <- c("a", "b", "c", "a", NA);identical(l[i], l[optimal.index(i, i.names=names(l), strict=FALSE)])})
#!   rm(l)
#! }
#! \keyword{ utilities }
#! \keyword{ manip }


optimal.index <- function(i, n=length(i.names), i.names=names(i), i.previous=NULL, strict=TRUE){
  # idempotence
  if (is.null(i) || (!is.null(attr(i, "ni")) && !is.null(attr(i, "n"))))
    return(i)
  index <- seq(length=n)
  if (!is.null(i.names) && (is.character(i) || is.character(i.previous))){
    names(index) <- i.names
  }
  if (is.null(i.previous)){
    i <- as.vector(index[i])
  }else{
    i <- as.vector(index[i.previous][i])
  }
  ni <- length(i)
  if (strict){
    if (any(is.na(i)))
      stop("not all index values matched")
    if (any(duplicated(i)))
      stop("index not unique, you can only select subsets, not supersets")
    if ( ni > (n/2) ){
      # return either positive or negative indices, whatever is smaller
      i <- -((seq(length=n))[is.na(match(seq(length=n), i))])
    }
  }
  attributes(i) <- list(n=n, ni=ni)
  i
}

posi.index <- function(oi){
  if (attr(oi, "ni")){
    if (length(oi)){
      if (oi[1]>0)
        oi
      else
        (1:attr(oi, "n"))[oi]
    }else{
      1:attr(oi, "n")
    }
  }else{
    integer(0)
  }
}

need.index <- function(oi)
{
  if (length(oi))
    return(TRUE)
  ni <- attr(oi, "ni")
  !is.null(ni) && ni==0
}




#! \name{refdata}
#! \alias{refdata}
#! \alias{[.refdata}
#! \alias{[<-.refdata}
#! \alias{[[.refdata}
#! \alias{[[<-.refdata}
#! \alias{$.refdata}
#! \alias{$<-.refdata}
#! \alias{dim.refdata}
#! \alias{dim<-.refdata}
#! \alias{dimnames.refdata}
#! \alias{dimnames<-.refdata}
#! \alias{print.refdata}
#! \title{ subsettable reference to matrix or data.frame }
#! \description{
#!   Function \code{refdata} creates objects of class refdata which behave not totally unlike matrices or data.frames but allow for much more memory efficient handling.
#! }
#! \usage{
#! # -- usage for R CMD CHECK, see below for human readable version -----------
#! refdata(x)
#! [.refdata(x, i = NULL, j = NULL, drop = FALSE, ref = FALSE)
#! [<-.refdata(x, i = NULL, j = NULL, ref = FALSE, value)
#!  \method{dim}{refdata}(x, ref = FALSE)
#!  \method{dim}{refdata}(x) <- value
#!  \method{dimnames}{refdata}(x, ref = FALSE)
#!  \method{dimnames}{refdata}(x, ref = FALSE) <- value
#!
#! # -- most important usage for human beings (does not pass R CMD CHECK) -----
#! # rd <- refdata(x)                   # create reference
#! # rd[]                               # get all data
#! # rd[i, j]                           # get part of data
#! # rd[i, j, ref=TRUE]                 # get new reference on part of data
#! # rd[i, j] <- value                  # modify part of data (now rd is reference on local copy of the data)
#! # rd[i, j, ref=TRUE] <- value        # modify part of original data (respecting subsetting history)
#! # dim(rd)                            # dim of (subsetted) data
#! # dim(rd, ref=TRUE)                  # dim of original data
#! # dimnames(rd)                       # dimnames of (subsetted) data
#! # dimnames(rd, ref=TRUE)             # dimnames of original data
#! # dimnames(rd) <- value              # modify dimnames (now rd is reference on local copy of the data)
#! # dimnames(rd, ref=TRUE) <- value    # modify complete dimnames of original object (NOT respecting subsetting history)
#! }
#! \arguments{
#!   \item{x}{ a matrix or data.frame or any other 2-dimensional object that has operators "[" and "[<-" defined }
#!   \item{i}{ row index }
#!   \item{j}{ col index }
#!   \item{ref}{ FALSE by default. In subsetting: FALSE returns data, TRUE returns new refdata object. In assignments: FALSE modifies a local copy and returns a refdata object embedding it, TRUE modifies the original. }
#!   \item{drop}{ FALSE by default, i.e. returned data have always a dimension attribute. TRUE drops dimension in some cases, the exact result depends on whether a \code{\link{matrix}} or \code{\link{data.frame}} is embedded }
#!   \item{value}{ some value to be assigned }
#! }
#! \details{
#!   Refdata objects store 2D-data in one environment and index information in another environment. Derived refdata objects usually share the data environment but not the index environment. \cr
#!   The index information is stored in a standardized and memory efficient form generated by \code{\link{optimal.index}}. \cr
#!   Thus refdata objects can be copied and subsetted and even modified without duplicating the data in memory. \cr
#!   Empty square bracket subsetting (\code{rd[]}) returns the data, square bracket subsetting (\code{rd[i, j]}) returns subsets of the data as expected. \cr
#!   An additional argument (\code{rd[i, j, ref=TRUE]}) allows to get a reference that stores the subsetting indices. Such a reference behaves transparently as if a smaller matrix/data.frame would be stored and can be subsetted again recursively.
#!   With ref=TRUE indices are always interpreted as row/col indices, i.e. \code{x[i]} and \code{x[cbind(i, j)]} are undefined (and raise stop errors) \cr
#!   Standard square bracket assignment (\code{rd[i, j] <- value}) creates a reference to a locally modified copy of the (potentially subsetted) data. \cr
#!   An additional argument (\code{rd[i, j, ref=TRUE] <- value}) allows to modify the original data, properly recognizing the subsetting history. \cr
#!   A method \code{\link{dim}(refdata)} returns the dim of the (indexed) data, the dim of the original (non-indexed) data can be accessed using parameter \code{ref=TRUE}. Assignment to dim(refdata)<- is not possible.  but \code{dim(refdata)<-} cannot be assigned. \cr
#!   A \code{\link{dimnames}(refdata)} returns the dimnames of the (indexed) data resp. the original data using parameter \code{ref=TRUE}. Assignment is possible but not recommended, parameter \code{ref} decides whether the original data is modified or a copy is created. \cr
#! }
#! \note{
#!   The refdata code is currently R only (not implemented for S+). \cr
#!   Please note the following differences to matrices and dataframes: \cr
#!   \describe{
#!      \item{\code{x[]}}{you need to write \code{x[]} in order to get the data}
#!      \item{\code{drop=FALSE}}{by default drop=FALSE which gives consistent behaviour for matrices and data.frames. You can use the $- or [[-operator to extract single column vectors which are granted to be of a consistent data type. However, currently $ and [[ are only wrappers to [. They might be performance tuned in later versions.}
#!      \item{\code{x[i]}}{single index subsetting is not defined, use \code{x[][i]} instead, but beware of differences between matrices and dataframes}
#!      \item{\code{x[cbind()]}}{matrix index subsetting is not defined, use \code{x[][cbind(i, j)]} instead}
#!      \item{\code{ref=TRUE}}{parameter \code{ref} needs to be used sensibly to exploit the advantages of refdata objects}
#!   }
#! }
#! \value{
#!   an object of class refdata (appended to class attributes of data), which is an empty list with two attributes
#!   \item{dat}{the environment where the data x and its dimension dim is stored}
#!   \item{ind}{the environment where the indexes i, j and the effective subset size ni, nj is stored}
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link[base]{Extract}},  \code{\link[base]{matrix}},  \code{\link[base]{data.frame}}, \code{\link{optimal.index}}, \code{\link{ref}} }
#!
#! \examples{
#!
#!   ## Simple usage Example
#!   x <- cbind(1:5, 5:1)            # take a matrix or data frame
#!   rx <- refdata(x)                # wrap it into an refdata object
#!   rx                              # see the autoprinting
#!   rm(x)                           # delete original to save memory
#!   rx[]                            # extract all data
#!   rx[-1, ]                        # extract part of data
#!   rx2 <- rx[-1, , ref=TRUE]       # create refdata object referencing part of data (only index, no data is duplicated)
#!   rx2                             # compare autoprinting
#!   rx2[]                           # extract 'all' data
#!   rx2[-1, ]                       # extract part of (part of) data
#!   cat("for more examples look the help pages\n")
#!
#!  \dontrun{
#!   # Memory saving demos
#!   square.matrix.size <- 1000
#!   recursion.depth.limit <- 10
#!   non.referenced.matrix <- matrix(1:(square.matrix.size*square.matrix.size), nrow=square.matrix.size, ncol=square.matrix.size)
#!   rownames(non.referenced.matrix) <- paste("a", seq(length=square.matrix.size), sep="")
#!   colnames(non.referenced.matrix) <- paste("b", seq(length=square.matrix.size), sep="")
#!   referenced.matrix <- refdata(non.referenced.matrix)
#!   recurse.nonref <- function(m, depth.limit=10){
#!     x <- m[1,1]   # need read access here to create local copy
#!     gc()
#!     cat("depth.limit=", depth.limit, "  memory.size=", memsize.wrapper(), "\n", sep="")
#!     if (depth.limit)
#!       Recall(m[-1, -1, drop=FALSE], depth.limit=depth.limit-1)
#!     invisible()
#!   }
#!   recurse.ref <- function(m, depth.limit=10){
#!     x <- m[1,1]   # read access, otherwise nothing happens
#!     gc()
#!     cat("depth.limit=", depth.limit, "  memory.size=",  memsize.wrapper(), "\n", sep="")
#!     if (depth.limit)
#!       Recall(m[-1, -1, ref=TRUE], depth.limit=depth.limit-1)
#!     invisible()
#!   }
#!   gc()
#!   memsize.wrapper()
#!   recurse.ref(referenced.matrix, recursion.depth.limit)
#!   gc()
#!    memsize.wrapper()
#!   recurse.nonref(non.referenced.matrix, recursion.depth.limit)
#!   gc()
#!    memsize.wrapper()
#!   rm(recurse.nonref, recurse.ref, non.referenced.matrix, referenced.matrix, square.matrix.size, recursion.depth.limit)
#!   }
#!   cat("for even more examples look at regression.test.refdata()\n")
#!   regression.test.refdata()  # testing correctness of refdata functionality
#! }
#! \keyword{ programming }
#! \keyword{ manip }

refdata <- function(x){
  d <- dim(x)
  stopifnot(length(d)==2)
  dat <- new.env(parent=NULL)
  ind <- new.env(parent=NULL)
  assign("x", x, dat)
  assign("dim", d, dat)
  assign("ni", d[1], ind)
  assign("nj", d[2], ind)
  assign("i", NULL, ind)
  assign("j", NULL, ind)
  ref <- list()
  attributes(ref) <- list(dat=dat, ind=ind, class=c("refdata", class(x)))
  ref
}


"[.refdata" <- function(x, i=NULL, j=NULL, drop=FALSE, ref=FALSE){
  if (!is.null(dim(i)))
    stop("x[cbind(i, j)] matrix subsetting undefined for refdata objects, you can use x[][cbind(i,j)] instead")
  if ( xor(missing(i), missing(j)) && ( nargs() + missing(x) + missing(drop) + missing(ref)) == 4 )
    stop("x[i] single index subsetting undefined for refdata objects, you can use x[][i] instead")
  dat <- attr(x, "dat")
  xx <- get("x", dat)
  d <- get("dim", dat)
  if (ref){
    new.ind <- new.env(parent=NULL)
    ind <- attr(x, "ind")
    if (is.null(i)){
      assign("i", get("i", ind), new.ind)
      assign("ni", get("ni", ind), new.ind)
    }else{
      i <- optimal.index(i, d[1], rownames(xx), i.previous=get("i", ind))
      assign("i", i, new.ind)
      assign("ni", attr(i, "ni"), new.ind)
    }
    if (is.null(j)){
      assign("j", get("j", ind), new.ind)
      assign("nj", get("nj", ind), new.ind)
    }else{
      j <- optimal.index(j, d[2], colnames(xx), i.previous=get("j", ind))
      assign("j", j, new.ind)
      assign("nj", attr(j, "ni"), new.ind)
    }
    attr(x, "ind") <- new.ind
    x
  }else{
    ind <- attr(x, "ind")
    temp <- get("i", ind)
    if (!is.null(temp)){
      if (is.null(i)){
        i <- temp
      }else{
        i <- optimal.index(i, d[1], rownames(xx), i.previous=temp, strict=FALSE)
      }
    }
    temp <- get("j", ind)
    if (!is.null(temp)){
      if (is.null(j)){
        j <- temp
      }else{
        j <- optimal.index(j, d[2], colnames(xx), i.previous=temp, strict=FALSE)
      }
    }
    if (is.null(i)){
      if (is.null(j)){
        xx
      }else{
        xx[, j, drop=drop]
      }
    }else{
      if (is.null(j)){
        xx[i, , drop=drop]
      }else{
        xx[i, j, drop=drop]
      }
    }
  }
}


"[<-.refdata" <- function(x, i=NULL, j=NULL, ref=FALSE, value){
  if (!is.null(dim(i)))
    stop("x[cbind(i, j)] matrix subsetting undefined for refdata objects, you can use x[][cbind(i,j)] instead")
  if ( xor(missing(i), missing(j)) && (nargs() + missing(ref) + missing(value) + missing(x))==4 )
    stop("x[i] single index subsetting undefined for refdata objects, you can use x[][i] instead")
  ind <- attr(x, "ind")
  dat <- attr(x, "dat")
  d <- get("dim", dat)
  if (ref){
    xx <- get("x", dat)
    if (!is.null(i)){
      i <- optimal.index(i, d[1], rownames(xx), i.previous=get("i", ind))
    }else{
      i <- get("i", ind)
    }
    if (!is.null(j)){
      j <- optimal.index(j, d[2], colnames(xx), i.previous=get("j", ind))
    }else{
      j <- get("j", ind)
    }
    if (is.null(i)){
      if (is.null(j)){
        eval(substitute(x[] <- value, list(value=value)), dat)
      }else{
        eval(substitute(x[, j] <- value, list(j=j, value=value)), dat)
      }
    }else{
      if (is.null(j)){
        eval(substitute(x[i, ] <- value, list(i=i, value=value)), dat)
      }else{
        eval(substitute(x[i, j] <- value, list(i=i, j=j, value=value)), dat)
      }
    }
    x
  }else{
    ii <- get("i", ind)
    jj <- get("j", ind)
    if (is.null(ii)){
      if (is.null(jj)){
        x <- get("x", dat)
      }else{
        x <- get("x", dat)[, jj, drop=FALSE]
      }
    }else{
      if (is.null(jj)){
        x <- get("x", dat)[ii, , drop=FALSE]
      }else{
        x <- get("x", dat)[ii, jj, drop=FALSE]
      }
    }
    if (is.null(i)){
      if (is.null(j)){
        x[] <- value
      }else{
        x[, j] <- value
      }
    }else{
      if (is.null(j)){
        x[i, ] <- value
      }else{
        x[i, j] <- value
      }
    }
    refdata(x)
  }
}



"$.refdata" <- function(x, j, drop=TRUE)
  # xx FIXME TODO lazy implementation as special case of [.refdata, can be performance tuned
{
  x[, j, drop=drop, ref=ref]
}

"$<-.refdata" <- function(x, j, ref=FALSE, value)
  # xx FIXME TODO lazy implementation as special case of [<-.refdata, can be performance tuned
{
  x[, j, ref=ref] <- value
}


"[[.refdata" <- function(x, j, drop=TRUE, ref=FALSE)
  # xx FIXME TODO lazy implementation as special case of [.refdata, can be performance tuned
{
  x[, j, drop=drop, ref=ref]
}

"[[<-.refdata" <- function(x, j, ref=FALSE, value)
  # xx FIXME TODO lazy implementation as special case of [<-.refdata, can be performance tuned
{
  x[, j, ref=ref] <- value
}


dim.refdata <- function(x, ref=FALSE){
  if (ref){
    get("dim", attr(x, "dat"))
  }else{
    ind <- attr(x, "ind")
    c(get("ni", ind), get("nj", ind))
  }
}

"dim<-.refdata" <- function(x, value)
  stop("dim assignment of refdata objects not allowed")

dimnames.refdata <- function(x, ref=FALSE){
  if (ref){
    dimnames(get("x", attr(x, "dat")))
  }else{
    dimnames(x[])
  }
}

"dimnames<-.refdata" <- function(x, ref=FALSE, value){
  dat <- attr(x, "dat")
  if (ref){
    #if (is.null(ii)){
    #  if (is.null(jj)){
    #    eval(substitute(dimnames(x) <- value, list(value=value)), dat)
    #  }else{
    #    eval(substitute(dimnames(x)[[1]] <- value, list(value=value[[1]])), dat)
    #    eval(substitute(dimnames(x)[[2]][j] <- value, list(j=jj, value=value[[2]])), dat)
    #  }
    #}else{
    #  if (is.null(jj)){
    #    eval(substitute(dimnames(x)[[1]][i] <- value, list(i=ii, value=value[[1]])), dat)
    #    eval(substitute(dimnames(x)[[2]] <- value, list(value=value[[2]])), dat)
    #  }else{
    #    eval(substitute(dimnames(x)[[1]][i] <- value, list(i=ii, value=value[[1]])), dat)
    #    eval(substitute(dimnames(x)[[2]][j] <- value, list(j=jj, value=value[[2]])), dat)
    #  }
    #}
    eval(substitute(dimnames(x) <- value, list(value=value)), dat)
    x
  }else{
    ind <- attr(x, "ind")
    ii <- get("i", ind)
    jj <- get("j", ind)
    if (is.null(ii)){
      if (is.null(jj)){
        x <- get("x", dat)
      }else{
        x <- get("x", dat)[, jj, drop=FALSE]
      }
    }else{
      if (is.null(jj)){
        x <- get("x", dat)[ii, , drop=FALSE]
      }else{
        x <- get("x", dat)[ii, jj, drop=FALSE]
      }
    }
    dimnames(x) <- value
    refdata(x)
  }
}


print.refdata <- function(x, ...){
  dim.dat <- dim.refdata(x, ref=TRUE)
  dim.ind <- dim.refdata(x)
  cat("refdata (", if (inherits(x, "data.frame")) "data.frame" else if (is.matrix(x[])) "matrix" else "unknown embedded", ") with [", paste(dim.ind, collapse=",") ,"] of [", paste(dim.dat, collapse=","), "]\n", sep="")
  cat("use  x[]  to get the complete actual subset\n")
  cat("use  x[...]  for standard extraction\n")
  cat("use  x[..., ref=TRUE]  to get a newly indexed refdata object\n")
  cat("use  x[...] <- value  to overwrite x with a refdata object containing a new env containing a modified dataset\n")
  cat("use  x[..., ref=TRUE] <- value  to modify the original dataset\n")
}


#! \name{regression.test.refdata}
#! \alias{regression.test.refdata}
#! \title{ regression test for refdata }
#! \description{
#!   This function checks a series of use cases.
#! }
#! \usage{
#! regression.test.refdata()
#! }
#! \details{
#!   raises a stop error if a problem is detected
#! }
#! \value{
#!   TRUE if successful
#! }
#! \author{ Jens Oehlschlgel }
#! \seealso{ \code{\link{refdata}}, \code{\link[base]{example}} }
#!
#! \examples{
#!   regression.test.refdata()
#! }
#! \keyword{ internal }


regression.test.refdata <- function(){

  for (i in c("matrix", "data.frame")){

    # example data
    x <- matrix(1:9, ncol=3)
    dimnames(x) <- list(a=paste("a", seq(length=nrow(x)), sep=""), b=paste("b", seq(length=nrow(x)), sep=""))
    if (i=="data.frame"){
      x <- as.data.frame(x)
      cat("testing refdata with data.frame\n")
    }else{
      cat("testing refdata with matrix\n")
    }

    # currently no checks on $.refdata as this is identical to [.refdata

    # check row reduction
    rx3 <- refdata(x)
    stopifnot(identical(rx3[-1, 1:2], x[-1, 1:2]))
    stopifnot(identical(dim(rx3), dim(x)))
    stopifnot(identical(dim(rx3, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx3), dimnames(x)))
    stopifnot(identical(dimnames(rx3, ref=TRUE), dimnames(x)))
    rx2 <- rx3[-1, , ref=TRUE]
    stopifnot(identical(rx2[, 1:2], rx3[-1, 1:2]))
    stopifnot(identical(dim(rx2), dim(x[-1, , drop=FALSE])))
    stopifnot(identical(dim(rx2, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx2), dimnames(x[-1, , drop=FALSE])))
    stopifnot(identical(dimnames(rx2, ref=TRUE), dimnames(x)))
    rx1 <- rx2[-1, , ref=TRUE]
    stopifnot(identical(rx1[, 1:2], rx2[-1, 1:2]))
    stopifnot(identical(dim(rx1), dim(x[-1, , drop=FALSE][-1, , drop=FALSE])))
    stopifnot(identical(dim(rx1, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx1), dimnames(x[-1, , drop=FALSE][-1, , drop=FALSE])))
    stopifnot(identical(dimnames(rx1, ref=TRUE), dimnames(x)))

    # check col reduction
    rx3 <- refdata(x)
    stopifnot(identical(rx3[1:2, -1], x[1:2, -1]))
    rx2 <- rx3[, -1, ref=TRUE]
    stopifnot(identical(rx2[1:2, ], rx3[1:2, -1]))
    stopifnot(identical(dim(rx2), dim(x[, -1, drop=FALSE])))
    stopifnot(identical(dim(rx2, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx2), dimnames(x[, -1, drop=FALSE])))
    stopifnot(identical(dimnames(rx2, ref=TRUE), dimnames(x)))
    rx1 <- rx2[, -1, ref=TRUE]
    stopifnot(identical(rx1[1:2, ], rx2[1:2, -1]))
    stopifnot(identical(dim(rx1), dim(x[, -1, drop=FALSE][, -1, drop=FALSE])))
    stopifnot(identical(dim(rx1, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx1), dimnames(x[, -1, drop=FALSE][, -1, drop=FALSE])))
    stopifnot(identical(dimnames(rx1, ref=TRUE), dimnames(x)))

    # check row+col reduction
    rx3 <- refdata(x)
    stopifnot(identical(rx3[], x))
    rx2 <- rx3[-1, -1, ref=TRUE]
    stopifnot(identical(rx2[], rx3[-1, -1]))
    rx1 <- rx2[-1, -1, ref=TRUE]
    stopifnot(identical(dim(rx2), dim(x[-1, -1, drop=FALSE])))
    stopifnot(identical(dim(rx2, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx2), dimnames(x[-1, -1, drop=FALSE])))
    stopifnot(identical(dimnames(rx2, ref=TRUE), dimnames(x)))
    stopifnot(identical(rx1[], rx2[-1, -1]))
    rx0 <- rx1[-1, -1, ref=TRUE]
    stopifnot(identical(rx0[], rx1[-1, -1]))
    stopifnot(identical(dim(rx1), dim(x[-1, -1, drop=FALSE][-1, -1, drop=FALSE])))
    stopifnot(identical(dim(rx1, ref=TRUE), dim(x)))
    stopifnot(identical(dimnames(rx1), dimnames(x[-1, -1, drop=FALSE][-1, -1, drop=FALSE])))
    stopifnot(identical(dimnames(rx1, ref=TRUE), dimnames(x)))

    # check dim dropping
    rx3 <- refdata(x)
    rx1 <- rx3[1, , ref=TRUE]
    stopifnot(identical(rx1[], rx3[1,]))
    stopifnot(identical(rx1[drop=FALSE], rx3[1, , drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], rx3[1, , drop=TRUE]))
    stopifnot(identical(rx1[drop=FALSE], x[1, , drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], x[1, , drop=TRUE]))
    rx1 <- rx3[, 1, ref=TRUE]
    stopifnot(identical(rx1[], rx3[, 1]))
    stopifnot(identical(rx1[drop=FALSE], rx3[, 1, drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], rx3[, 1, drop=TRUE]))
    stopifnot(identical(rx1[drop=FALSE], x[, 1, drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], x[, 1, drop=TRUE]))
    rx1 <- rx3[1, 1, ref=TRUE]
    stopifnot(identical(rx1[], rx3[1, 1]))
    stopifnot(identical(rx1[drop=FALSE], rx3[1, 1, drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], rx3[1, 1, drop=TRUE]))
    stopifnot(identical(rx1[drop=FALSE], x[1, 1, drop=FALSE]))
    stopifnot(identical(rx1[drop=TRUE], x[1, 1, drop=TRUE]))

    #check assignments
    rx3 <- refdata(x)
    rx2 <- rx3[-1, -1, ref=TRUE]
    rx2b <- rx3[-1, -1, ref=TRUE]
    rx2[] <- x[-1, -1]-1
    stopifnot(identical(rx3[], x))
    stopifnot(identical(rx2[], x[-1, -1] - 1))
    stopifnot(identical(rx2b[], x[-1, -1]))
    rx2 <- rx3[-1, -1, ref=TRUE]
    rx2b <- rx3[-1, -1, ref=TRUE]
    rx2[-1, -1] <- x[-1, -1][-1, -1] - 1
    stopifnot(identical(rx3[], x))
    stopifnot(identical(rx2[-1, -1], x[-1, -1][-1, -1, drop=FALSE] - 1))
    stopifnot(identical(rx2b[-1, -1], x[-1, -1][-1, -1, drop=FALSE]))

    rx2 <- rx3[-1, -1, ref=TRUE]
    rx2b <- rx3[-1, -1, ref=TRUE]
    rx2[, , ref=TRUE] <- x[-1, -1] - 1
    y <- x
    y[-1,-1] <- x[-1, -1] - 1
    stopifnot(identical(rx3[], y))
    stopifnot(identical(rx2[], rx3[-1, -1]))
    stopifnot(identical(rx2b[], rx3[-1, -1]))

    # check dim assignment
    old.options <- options(show.error.messages=FALSE)
    stopifnot(inherits(try( dim(rx3) <- dim(rx3) ), "try-error"))
    options(old.options)

    ##check dimnames assignments
    # creating copies
    rx3 <- refdata(x)
    rx2 <- rx3[-1, -1, ref=TRUE]
    rx2b <- rx3[-1, -1, ref=TRUE]
    if (i=="data.frame"){
      dnam <- list(c("x2","x3"), c("y2","y3"))
    }else{
      dnam <- list(x=c("x2","x3"), y=c("y2","y3"))
    }
    dimnames(rx2) <- dnam
    stopifnot(identical(dimnames(rx3), dimnames(x)))
    stopifnot(identical(dimnames(rx2), dnam))
    y <- x
    rownames(y)[-1] <- c("m2","m3")
    colnames(y)[-1] <- c("n2","n3")
    rownames(rx3)[-1] <- c("m2","m3")
    colnames(rx3)[-1] <- c("n2","n3")
    stopifnot(identical(dimnames(rx3), dimnames(y)))
    stopifnot(identical(dimnames(rx2), dnam))
    stopifnot(identical(dimnames(rx2b), dimnames(x[-1, -1])))
    # changing original
    rx3 <- refdata(x)
    rx2 <- rx3[-1, -1, ref=TRUE]
    rx2b <- rx3[-1, -1, ref=TRUE]
    y <- x
    dimnames(y) <- list(m=c("m1", "m2","m3"), n=c("n1", "n2","n3"))
    dimnames(rx2, ref=TRUE) <- dimnames(y)
    stopifnot(identical(dimnames(rx3), dimnames(y)))
    stopifnot(identical(dimnames(rx2), dimnames(y[-1, -1])))
    stopifnot(identical(dimnames(rx2), dimnames(rx2b)))
    dimnames(rx2, ref=TRUE) <- dimnames(rx2, ref=TRUE)
    stopifnot(identical(dimnames(rx3), dimnames(y)))
    stopifnot(identical(dimnames(rx2), dimnames(y[-1, -1])))
    stopifnot(identical(dimnames(rx2), dimnames(rx2b)))

  }

}

