Example R Function, AnalyticalWay

You can extend R/S-Plus usability by writing functions. This is similar to macros in the SAS Language. These functions can be anything from a new statistical algorithm to file operation to data manipulation. Below I give an example of a custom R macro. This function takes output from an rpart tree and converts it to SAS code suitable to use in a data a step. This is useful when coding nodes into a model. This dirty little secret: I developed the code by looking at the default print method for the rpart package and adapting it to generate SAS code. This code can also be modified to generate SQL code as well. When attempting to write new code I suggest first looking at published package that do something similar then try to adapt them to your own use.

The S language (which both R and SPlus use) is similar to C. There are many good editor for S. this code was written using TinnR.

printSAS.rpart <- function(x, minlength=0, spaces=2, cp,
digits=getOption( digits ), …) {

tree.depth <- getFromNamespace( tree.depth , rpart )

if(!inherits(x, rpart )) stop( Not legitimate rpart object )
if (!is.null(x$frame$splits)) x <- rpconvert(x) #help for old objects
if (!missing(cp)) x <- prune.rpart(x, cp=cp)
frame <- x$frame

ylevel <- attr(x, ylevels )
node <- as.numeric(row.names(frame))
depth <- tree.depth(node)
indent <- paste(rep( , spaces * 32), collapse = )

#32 is the maximal depth
if(length(node) > 1) {
indent <- substring(indent, 1, spaces * seq(depth))
# indent <- TT
indent <- paste(c( , indent[depth]), format(node), ) , sep = )
}
else indent <- paste(format(node), ) , sep = )

tfun <- (x$functions)$print
if (!is.null(tfun)) {
if (is.null(frame$yval2))
yval <- tfun(frame$yval, ylevel, digits)
else yval <- tfun(frame$yval2, ylevel, digits)
}
else yval <- format(signif(frame$yval, digits = digits))

z <- labels(x, digits=digits, minlength=minlength, …)

term <- rep( , length(depth))
final <- rep( , length(depth))
temp1 <- rep( , length(depth))
tempnode <- rep(10000, length(depth))
term[frame$var == <leaf> ] <- Terminal

for(i in 1:length(depth)) #print(1:i)
{
if(term[i] != Terminal )
{
final[i] <-
}

if(term[i] == Terminal )
{
for(j in 1:length(depth))
{
if (node[i – j] == 1) break
if(term[i – j] != Terminal )
{
if (node[i – j] != tempnode[i] -1)
{
if (node[i – j ] < tempnode[i])
{
temp1[i] <- paste ( z[i – j], And , temp1[i] )
tempnode[i] = node[i – j]
}
}
}

} # end for

final[i] <- paste ( If , temp1[i] , z[i], then NodeVal = , yval[i] , ; )
}# end if *
} # end Main loop
cat(final, sep = \n ) ## Print results
}