
dtk.null <- function(...) {}

#
# Fix loss of dimnames when subcripting with "[":
#
# According to Gary Sabot <gary@sabot.com>, S-Plus originally had the
# correct name-preserving behavior we want.  Then in 1996 Insightful
# broke that in Splus 3.4, which Gary fixed for his own use.  In 2001,
# Splus 6.0 broke something in Gary's fix, he posted questions to the
# s-news list, generating discussion, including some shock that anyone
# could think that arbitrarily losing dimnames made sense:
# 
#   http://www.biostat.wustl.edu/archives/html/s-news/2001-09/msg00020.html
#
# Unfortunately R seems to mimic much of the more recent buggy S-Plus
# behavior!  Thus our patches to both S-Plus and R below.  To test
# that they do the right thing, run dtk.test.brace.names().
#
# Note that currently these patches wrap the stock subscripting
# functions, they do NOT replace them.  TODO: Investigate fixing the
# stock implementation instead, especially for R.
#
# --atp@piskorski.com, 2005/09/27 17:03 EDT
#

if (!.R.) { # For S-Plus:

   # First make sure that if you run this twice, you still get the
   # real original function:
   data.frame.original.fcn <- get("[.data.frame", where="splus")

   # For S-Plus (at least version 6.2.1) we do not need to override
   # the "[" function, it already does the right thing.
   # --atp@piskorski.com, 2005/07/01 10:11 EDT

   "[.data.frame" <- function(x ,... ,drop=T) {

      # TODO: Problem: New lm() is dying with my patch, because it indexes something
      # and produces something that looks like it has 2 cols, but ncol returns 1.
      # I can detect/avoid this case since it has class = c("model.frame", "data.frame")
      # see test case below where I figured out this issue in case it needs further work.

      class.x <- class(x)
      caller <- sys.call(sys.parent())[[2]]
      if (length(class.x)==1 && class.x=="data.frame" &&
          (mode(caller) != "name" || (caller != "value"))) {
         # If caller is a name and it is "value", then it is the
         # lhs case that we just want the original fcn to handle:

         result <- data.frame.original.fcn(x, ..., drop=F)

         if (drop && length(ncol(result) > 0) && ncol(result)==1) {
            save.names <- dimnames(result)[[1]]
            #this approach works for factors too
            result <- result[[1]]
            names(result) <- save.names

            # TODO: Unfortunately still broken for objects with new
            # style classes, since it does not distinguish among
            # methods that have or do not have a getnames method.
            # library(missing) is an example: The multiple imputations
            # on an object get lost if subscripted with this function.
         } else {
            if (!missing(drop) && drop && length(nrow(result)) > 0 && nrow(result)==1) {
               #replicate documented behavior of [.data.frame: drop=T acts
               #differently then missing drop arg for this case!
               result <- as.list(result)
            } 
         }
      } else {
         result <- data.frame.original.fcn(x, ..., drop=F)     
      }
      result
   }

} else { # For R:
   # First make sure that if you run this twice, you still get the
   # real original function:

   # Also remove the obnoxious "drop argument will be ignored" warning
   # entirely from the function.  I would like to regsub out the whole
   # warning() call, but I can't seem to get that to work.  So, just
   # replace the first warning() call with a call to our dtk.null()
   # function which does nothing.  Fortunately, the warning() call we
   # want to get rid of is indeed the first (actually the only) one:
   # --atp@piskorski.com, 2005/07/01 17:53 EDT

   brace.original.fcn <- get("[",pos="package:base")
   data.frame.original.fcn.0 <- get("[.data.frame",pos="package:base")
   data.frame.original.fcn <- data.frame.original.fcn.0
   body(data.frame.original.fcn) <-
      parse(text=sub('warning(..?drop argument will be ignored..?)'  ,'dtk.null()'
              ,deparse(body(data.frame.original.fcn.0)) ,ignore.case=T))

   # For R (at least version 2.1.0) we need to override BOTH the
   # "[.data.frame" and "[" functions.
   # --atp@piskorski.com, 2005/07/01 10:11 EDT

   "[.data.frame" <- function(x ,i ,j ,... ,drop=T) {

      # The stock R default value for the drop arg is:
      #   drop=(if(missing(i)) TRUE else length(names(x)) == 1)
      # However, that DOES cause certain differences from S-Plus, so
      # we do NOT use it.  --atp@piskorski.com, 2005/07/01 13:18 EDT

      # TODO: Does above S-Plus problem with lm() also apply here?
      # --atp@piskorski.com, 2005/07/01 10:51 EDT

      class.x <- class(x)
      caller <- sys.call(sys.parent())[[2]]
      if (length(class.x)==1 && class.x=="data.frame" &&
          (mode(caller) != "name" || (caller != "value"))) {
         # If caller is a name and it is "value", then it is the
         # lhs case that we just want the original fcn to handle:

         code <- 'data.frame.original.fcn(x,'
         if (!missing(i))    code <- paste(code ,'i' ,sep="")
         if (length(dim(x)) > 1 && (missing(i) || length(dim(i)) <= 1))
            code <- paste(code ,',' ,sep="")
         if (!missing(j))    code <- paste(code ,'j' ,sep="")
         if (!missing(...))  code <- paste(code ,',...' ,sep="")
         code <- paste(code ,',drop=F' ,sep="")
         code <- paste(code ,')' ,sep="")
         #cat("Debug: code to eval:  ") ; print(code)
         result <- eval(parse(text=code))

         if (drop && length(ncol(result) > 0) && ncol(result)==1) {
            save.names <- dimnames(result)[[1]]
            #this approach works for factors too
            result <- result[[1]]
            names(result) <- save.names

            # TODO: Unfortunately still broken for objects with new
            # style classes, since it does not distinguish among
            # methods that have or do not have a getnames method.
            # library(missing) is an example: The multiple imputations
            # on an object get lost if subscripted with this function.
         } else {
            if (!missing(drop) && drop && length(nrow(result)) > 0 && nrow(result)==1) {
               #replicate documented behavior of [.data.frame: drop=T acts
               #differently then missing drop arg for this case!
               result <- as.list(result)
            } 
         }
      } else {
         if (missing(i))
            result <- data.frame.original.fcn(x ,... ,drop=F)
         else if (missing(j))
            result <- data.frame.original.fcn(x ,i ,... ,drop=F)
         else
            result <- data.frame.original.fcn(x ,i ,j ,... ,drop=F)
      }
      result
   }

   # R has this problem with NA names:
   # 
   #   # S-Plus 6.2.1:
   #   > foo <- c("a"=1,"b"=2,"c"=3)
   #   > foo[c("a","c","atp")]
   #    a c atp 
   #    1 3  NA
   # 
   #   # R 2.0.0, or 2.1.0:
   #   > foo <- c("a"=1,"b"=2,"c"=3)
   #   > foo[c("a","c","atp")]
   #      a    c <NA> 
   #      1    3   NA 
   #
   # This is very very bad, it causes soft "you just get different
   # results" bugs when running our nag.optimize() from R, and
   # probably in many other places in our code as well.
   # --atp@piskorski.com, 2005/06/30 17:40 EDT

   "[" <- function(x ,i ,j ,... ,drop=TRUE) {

      # We MUST be able to blank positional arguments, and it seems
      # that do.call() gives us no way to do that, so use eval():
      # --atp@piskorski.com, 2005/07/01 16:00 EDT

      code <- 'brace.original.fcn(x,'
      if (!missing(i))    code <- paste(code ,'i' ,sep="")
      if (length(dim(x)) > 1 && (missing(i) || length(dim(i)) <= 1))
         code <- paste(code ,',' ,sep="")
      if (!missing(j))    code <- paste(code ,'j' ,sep="")
      if (!missing(...))  code <- paste(code ,',...' ,sep="")
      if (!missing(drop)) code <- paste(code ,',drop=drop' ,sep="")
      code <- paste(code ,')' ,sep="")
      #cat("Debug: code to eval:  ") ; print(code)
      result <- eval(parse(text=code))

      # This fix is being really specific, it handles this:
      #      x[i]
      # But does not try to handle this:
      #      x[i, j, ... , drop = TRUE]
      # --atp@piskorski.com, 2005/06/30 17:40 EDT

      if (is.null(attributes(x)$class) && length(list(...)) == 0) {
         # Just a simple index operation on a vector or list:
         new.names <- names(result)
         if (length(new.names) > 0) {
            # Names are present:
            bad.names <- is.na(new.names)
            if (any(bad.names)) {
               # Some names are NA, so fix them:
               names(result)[bad.names] <- brace.original.fcn(i ,bad.names)
            }
         }
      }
      result
   }
}


dtk.test.brace.names <- function
(return.results.p=F  ,only="all") {
   # Some simple test cases for our patched "[.data.frame" and "[" functions:

   # Note that return.results.p=T will always work correctly, but
   # automatically deciding if those results are CORRECT will ONLY
   # work if using our patched all.equal() from PR#8191, which is
   # available here:
   #   http://r-bugs.biostat.ku.dk/cgi-bin/R/incoming?id=8191
   # --atp@piskorski.com, 2005/10/09 13:23 EDT

   ### Examples of correct output for the cases below:
   # > (c("a"=1,"b"=2,"c"=3)[c("a","c","no")])
   #  a c no 
   #  1 3 NA
   # > (cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6))[c(1,2),2])
   #  a b 
   #  4 5
   # > (cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6))[c(3,2,1),2])
   #  c b a 
   #  6 5 4
   # > (cbind(col1=c(a=1,b=2) ,col2=c(3:4))[,2])
   #  a b 
   #  3 4
   # > (cbind(col1=c(a=1,b=2) ,col2=c(3:4))[2,])
   #  col1 col2 
   #     2    4
   # > (cbind(col1=c(a=1,b=2) ,col2=c(3:4))[2,,drop=T])
   #  col1 col2 
   #     2    4
   # > (cbind(col1=c(a=1,b=2) ,col2=c(3:4))[2,,drop=F])
   #   col1 col2 
   # b    2    4

   mm <- matrix(1:25 ,nrow=5 ,ncol=5 ,dimnames=list(letters[1:5],letters[6:10]))
   idx <- 1:(dim(mm)[1])
   mm.df <- as.data.frame(mm)

   results <-
      list( "vec.1"=list((c("a"=1,"b"=2,"c"=3)[c("a","c","no")])  ,c(a=1 ,c=3 ,no=NA) )
           ,"diag.1"=list(   mm[cbind(idx,idx)]  ,c(1,7,13,19,25) )
           ,"diag.2"=list(mm.df[cbind(idx,idx)]  ,c(1,7,13,19,25) )
           ,"df.a.1"=list((           cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6)) [c(1,2),2])    ,c(a=4,b=5)                    ) 
           ,"df.b.1"=list((data.frame(cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6)))[c(1,2),2])    ,c(a=4,b=5)                    ) 
           ,"df.a.2"=list((           cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6)) [c(3,2,1),2])  ,c(c=6,b=5,a=4)                )
           ,"df.b.2"=list((data.frame(cbind(col1=c(a=1,b=2,c=3) ,col2=c(4:6)))[c(3,2,1),2])  ,c(c=6,b=5,a=4)                )
           ,"df.a.3"=list((           cbind(col1=c(a=1,b=2) ,col2=c(3:4)) [,2])              ,c(a=3,b=4)                    )
           ,"df.b.3"=list((data.frame(cbind(col1=c(a=1,b=2) ,col2=c(3:4)))[,2])              ,c(a=3,b=4)                    )
           ,"df.a.4"=list((           cbind(col1=c(a=1,b=2) ,col2=c(3:4)) [2,])              ,c(col1=2,col2=4)                     )
           ,"df.b.4"=list((data.frame(cbind(col1=c(a=1,b=2) ,col2=c(3:4)))[2,])              ,data.frame(col1=c(b=2) ,col2=c(b=4)) )
           ,"df.a.5"=list((           cbind(col1=c(a=1,b=2) ,col2=c(3:4)) [2,,drop=T])       ,c(   col1=2,col2=4)           )
           ,"df.b.5"=list((data.frame(cbind(col1=c(a=1,b=2) ,col2=c(3:4)))[2,,drop=T])       ,list(col1=2,col2=4)           )
           ,"df.a.6"=list((           cbind(col1=c(a=1,b=2) ,col2=c(3:4)) [2,,drop=F])       ,cbind(col1=c(b=2) ,col2=c(4)) )
           ,"df.b.6"=list((data.frame(cbind(col1=c(a=1,b=2) ,col2=c(3:4)))[2,,drop=F])       ,data.frame(cbind(col1=c(b=2) ,col2=c(4))) )
           )

   # TODO: I don't know how to check these cases:
   # --atp@piskorski.com, 2005/07/01 10:34 EDT

   # > (data.frame(a=letters[1:3] ,b=2:4)[,1])
   # [1] a b c
   # > structure(.Data = c(1, 2, 3)  ,levels = c("a", "b", "c")  ,class = "factor"  ,names = c("1", "2", "3"))
   # [1] a b c
   # > dput(data.frame(a=letters[1:3], b=2:4)[,1])
   # structure(.Data = c(1, 2, 3)
   # , levels = c("a", "b", "c")
   # , class = "factor"
   # , names = c("1", "2", "3")
   # )

   # > library("missing")
   # > data.frame.original.fcn(cholesterolImpExample,,3)
   #  [1]  NA  NA  NA  NA  NA  NA  NA  NA  NA 156 242 256 142 216 248 168 236 200 264 264
   # [21] 188 182 294 214 198 256 280 204
   # 
   # miVariable object with 5 sets of multiple imputations 
   #                  1        2        3        4        5 
   #  2.chol14 190.7459 209.3937 220.1499 213.2871 218.0670
   #  4.chol14 156.6425 101.6117 173.6432 129.3747 140.9941
   #  5.chol14 176.8996 257.0628 157.2997 227.3769 173.9429
   # 10.chol14 255.8360 275.2017 284.1347 257.6721 289.8643
   # 13.chol14 252.9045 209.9261 257.6222 228.4710 270.7223
   # 16.chol14 298.6389 252.4810 259.4355 332.3279 287.4087
   # 18.chol14 180.9732 204.0033 194.7192 199.9087 200.9603
   # 23.chol14 219.6375 216.8488 125.2673 213.3161 263.5186
   # 25.chol14 268.8816 289.2164 229.5734 273.3548 240.9536
   # > 
   # > cholesterolImpExample[,3]
   #   2  4  5 10 13 16 18 23 25   1   3   6   7   8   9  11  12  14  15  17  19  20  21 
   #  NA NA NA NA NA NA NA NA NA 156 242 256 142 216 248 168 236 200 264 264 188 182 294
   # 
   #   22  24  26  27  28 
   #  214 198 256 280 204
   # 
   # miVariable object with 5 sets of multiple imputations 
   #                  1        2        3        4        5 
   #  2.chol14 190.7459 209.3937 220.1499 213.2871 218.0670
   #  4.chol14 156.6425 101.6117 173.6432 129.3747 140.9941
   #  5.chol14 176.8996 257.0628 157.2997 227.3769 173.9429
   # 10.chol14 255.8360 275.2017 284.1347 257.6721 289.8643
   # 13.chol14 252.9045 209.9261 257.6222 228.4710 270.7223
   # 16.chol14 298.6389 252.4810 259.4355 332.3279 287.4087
   # 18.chol14 180.9732 204.0033 194.7192 199.9087 200.9603
   # 23.chol14 219.6375 216.8488 125.2673 213.3161 263.5186
   # 25.chol14 268.8816 289.2164 229.5734 273.3548 240.9536
   # > 

   tt <- rep(F ,times=length(results)) ; names(tt) <- names(results)
   for (jj in 1:length(results)) {
      tmp <- all.equal(results[[jj]][[1]] ,results[[jj]][[2]])
      tt[jj] <- (length(tmp) == 1 && tmp == T)
      results[[jj]][3] <- list("pass"=as.vector(tt[jj]))
   }

   if (return.results.p) {
      if (only == "bad")
         results[!tt]
      else if (only == "good")
         results[tt]
      else results
   } else if (all(tt)) T else F
}

