R-alpha: Re: NextMethod replacement

Gregory R. Warnes (warnes@biostat.washington.edu)
Fri, 18 Oct 1996 15:25:32 -0700 (PDT)


Date: Fri, 18 Oct 1996 15:25:32 -0700 (PDT)
From: "Gregory R. Warnes" <warnes@biostat.washington.edu>
To: Ross Ihaka <ihaka@stat.auckland.ac.nz>,
Subject: R-alpha: Re: NextMethod replacement
In-Reply-To: <Pine.SUN.3.91.960921112852.12029A-100000@chekov>


Whoops.  Wrong version of the file.  Try this one instead...


On Fri, 18 Oct 1996, Gregory R. Warnes wrote:

> 
> I've written a replacement for NextMethod that allows you to call it with
> no parameters--like the SPlus version.  It also seems to fix a couple of
> other subtle incompatabilities in behavour between S and R when used. 
> Thomas and I have tested it and it seems to work for us.  It is attached
> below, please give it a try.
> 
> -------------------------------------------------------------------------------
>     Gregory R. Warnes          | It is high time that the ideal of success
> warnes@biostat.washington.edu  |  be replaced by the ideal of service.
>                                |                       Albert Einstein
> -------------------------------------------------------------------------------
> 

NextMethod <- function (cname, object, ...) 
{
	call <- sys.call(sys.parent())
	# store call
	env <- sys.frame(-2)
	# store parent's environment
	if (missing(object)) 
		object <- eval(call[[2]], sys.parent())
	# get object from previous call #
	objclass <- class(object)
	# store objects class
	#########################################
	# find out appropriate base method name #
	#########################################
	#browser()
	name <- call[1]
	if (missing(cname)) {
	  sname <- strsplit(name, ".")[[1]]
	  cname <- as.character(sname[[1]])
	  counter <- 2

	  # loop through looking for the base method #
	  while (!(flag <- exists(cname, env, inherits = T)) && 
		 counter <= length(sname
		   )) {
	    cname <- paste(cname, sname[[counter]], sep = ".")
	    counter <- counter + 1
	  }
	  if (!flag) 
	    stop("cannot find method called _from_!")
	}
	else
	  {
	    counter <- 2
	    sname <- strsplit(name, ".")[[1]]
	  }

	#############################################
	# find out what class to use in method call #
	#############################################
	if (counter <= length(sname)) {
		oldclass <- NULL
		# some of methodname was class, use this to know what class is next #
		# construct class name for last call from method name #
		while (counter <= length(sname)) {
			oldclass <- paste(oldclass, sname[[counter]], sep = "")
			counter <- counter + 1
		}
		# the class we want to use is the one AFTER the last one
		which <- match(oldclass, objclass, nomatch = NA) + 1
		# should never happen ... #
		if (is.na(which)) 
			stop("cannot find called class in class list")
	}
	else {
		which <- length(objclass)
		# use last element of objclass #
	}
	# only call methods which exist! #
	if (is.na(which) || which > length(objclass) || which<1 ) {
		newclass <- "default"
		newmethod <- paste(cname, newclass, sep = ".")
	}
	else {
		newclass <- objclass[[which]]
		newmethod <- paste(cname, newclass, sep = ".")
		while (!(flag <- exists(newmethod, env, inherits = T)) && which > 1) {
			which <- which - 1
			newclass <- objclass[[which]]
			newmethod <- paste(cname, newclass, sep = ".")
		}
		if (which <= 0 || !flag) 
			newmethod <- paste(cname, "default", sep = ".")
	}
	call[[1]] <- as.name(newmethod)
	newcall <- as.call(as.list(call))
	return(eval(newcall, env))
}


=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-testers mailing list -- To (un)subscribe, send
subscribe	or	unsubscribe
(in the "body", not the subject !)  To: r-testers-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-