R Code

Comments: This code can generally be copied from this page and pasted directly into R. In some cases extra (or not enough) line breaks may cause R to report a syntax error. As such, it may be better to paste these functions into a text editor, and then paste from the text editor into R. The functions are arranged in order of their appearance in the book, but are also indexed below in alphabetical order. I have not attempted to use any of these functions in S+, and therefore cannot guarantee compatibility with that package. If you have tested these functions in S+ you can report their compatibility to me via email. Also, if you wish to submit S+ compatible functions I can post them here as well (will full credit given to the author of course).

As I have not yet finished this page - if there are functions that you need please feel free to email me at polansky@math.niu.edu

Enjoy!

Jump to Chapter: 2 3 4 5 6

Function Index:

bioaccel

biobootbc

bioboothyb

biobootperc

biobootse

biobootstud

cpk.perc

hyb.fun.all

perc.fun

perc.fun.all

stud.fun.all

R Functions Used in Chapter 2

bioboothyb <- function(data,i,tval) {
    d <- data[i,]
    that <- sum(data[,3]-data[,2])/sum(data[,2]-data[,1])
    thats <- sum(d[,3]-d[,2])/sum(d[,2]-d[,1])
    if(thats<=(2.0*that-tval)) delta <- 1 else delta <- 0 delta }

biobootperc <- function(data,i,tval) {
    d <- data[i,] that <- sum(data[,3]-data[,2])/sum(data[,2]-data[,1])
    thats <- sum(d[,3]-d[,2])/sum(d[,2]-d[,1])
    if(thats<=tval) delta <- 1 else delta <- 0 delta }

biobootse <- function(data,i) {
    d <- data[,i]
    thats <- sum(d[,3]-d[,2])/sum(d[,2]-d[,1])
    thats }

biobootstud <- function(data,i,tval,sehat) {
    d <- data[i,]
    that <- sum(data[,3]-data[,2])/sum(data[,2]-data[,1])
    thats <- sum(d[,3]-d[,2])/sum(d[,2]-d[,1])
    sehats <- sd(boot(data=d,statistic=biobootse,R=100)$t)
    if(tval <= sehat*(that-thats)/sehats + that) delta <- 1 else delta <- 0
    delta }

biobootbc <- function(data,i) {
    d <- data[i,]
    that <- sum(data[,3]-data[,2])/ sum(data[,2]-data[,1])
    thats <- sum(d[,3]-d[,2])/sum(d[,2]-d[,1])
    if(that >= thats) delta <- 1 else delta <- 0
    delta }

bioaccel <- function(data) {
    n <- nrow(data) thetai <- matrix(0,n,1)
    for(i in 1:n) { thetai[i] <- sum(data[-i,3]-data[-i,2])/ sum(data[-i,2]-data[-i,1]) }
    thetadot <- mean(thetai)
    accel <- sum((thetadot - thetai)^3)/6*sum((thetadot-thetai)^2)^(1.5)
    accel }

Functions used in Chapter 3

perc.fun <- function(data,i) {
    m <- apply(data[i,],2,mean)
    if((m[1]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[4])) return(1)
    else return(0) }

perc.fun.all <- function(data,i) {
    m <- apply(data[i,],2,mean)
    if((m[1]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[4])) return(1)
    if((m[1]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[3])) return(2)
    if((m[1]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[4])) return(3)
    if((m[1]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[2])) return(4)
    if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(5)
    if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(6)
    if((m[2]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[4])) return(7)
    if((m[2]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[3])) return(8)
    if((m[2]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[4])) return(9)
    if((m[2]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[1])) return(10)
    if((m[2]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[3])) return(11)
    if((m[2]<=m[4])&&(m[4]<=m[3])&&(m[3]<=m[1])) return(12)
    if((m[3]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[4])) return(13)
    if((m[3]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[2])) return(14)
    if((m[3]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[4])) return(15)
    if((m[3]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[1])) return(16)
    if((m[3]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[2])) return(17)
    if((m[3]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[1])) return(18)
    if((m[4]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[3])) return(19)
    if((m[4]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[2])) return(20)
    if((m[4]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[3])) return(21)
    if((m[4]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[1])) return(22)
    if((m[4]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[2])) return(23)
    if((m[4]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[1])) return(24) }

hyb.fun.all <- function(data,i) {
    m1 <- apply(data[i,],2,mean)
    m0 <- apply(data,2,mean)
    m <- 2*m0-m1
    if((m[1]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[4])) return(1)
    if((m[1]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[3])) return(2)
    if((m[1]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[4])) return(3)
    if((m[1]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[2])) return(4)
    if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(5)
    if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(6)
    if((m[2]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[4])) return(7)
    if((m[2]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[3])) return(8)
    if((m[2]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[4])) return(9)
    if((m[2]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[1])) return(10)
    if((m[2]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[3])) return(11)
    if((m[2]<=m[4])&&(m[4]<=m[3])&&(m[3]<=m[1])) return(12)
    if((m[3]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[4])) return(13)
    if((m[3]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[2])) return(14)
    if((m[3]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[4])) return(15)
    if((m[3]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[1])) return(16)
    if((m[3]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[2])) return(17)
    if((m[3]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[1])) return(18)
    if((m[4]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[3])) return(19)
    if((m[4]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[2])) return(20)
    if((m[4]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[3])) return(21)
    if((m[4]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[1])) return(22)
    if((m[4]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[2])) return(23)
    if((m[4]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[1])) return(24) }

stud.fun.all <- function(data,i) {
    m1 <- apply(data[i,],2,mean)
    m0 <- apply(data,2,mean)
    s1d <- svd(cov(data[i,]))
    s0d <- svd(cov(data))
    s1 <- s1d$u%*%sqrt(diag(s1d$d))%*%s1d$u
    s0 <- s0d$u%*%sqrt(diag(s0d$d))%*%s0d$u
    m <- m0 - s0%*%solve(s1)%*%(m1-m0)             if((m[1]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[4])) return(1)     if((m[1]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[3])) return(2)     if((m[1]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[4])) return(3)     if((m[1]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[2])) return(4)     if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(5)     if((m[1]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[3])) return(6)     if((m[2]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[4])) return(7)      if((m[2]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[3])) return(8)     if((m[2]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[4])) return(9)     if((m[2]<=m[3])&&(m[3]<=m[4])&&(m[4]<=m[1])) return(10)     if((m[2]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[3])) return(11)     if((m[2]<=m[4])&&(m[4]<=m[3])&&(m[3]<=m[1])) return(12)     if((m[3]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[4])) return(13)     if((m[3]<=m[1])&&(m[1]<=m[4])&&(m[4]<=m[2])) return(14)     if((m[3]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[4])) return(15)     if((m[3]<=m[2])&&(m[2]<=m[4])&&(m[4]<=m[1])) return(16)     if((m[3]<=m[4])&&(m[4]<=m[1])&&(m[1]<=m[2])) return(17)     if((m[3]<=m[4])&&(m[4]<=m[2])&&(m[2]<=m[1])) return(18)     if((m[4]<=m[1])&&(m[1]<=m[2])&&(m[2]<=m[3])) return(19)     if((m[4]<=m[1])&&(m[1]<=m[3])&&(m[3]<=m[2])) return(20)     if((m[4]<=m[2])&&(m[2]<=m[1])&&(m[1]<=m[3])) return(21) if((m[4]<=m[2])&&(m[2]<=m[3])&&(m[3]<=m[1])) return(22) if((m[4]<=m[3])&&(m[3]<=m[1])&&(m[1]<=m[2])) return(23) if((m[4]<=m[3])&&(m[3]<=m[2])&&(m[2]<=m[1])) return(24) }

cpk.perc <- function(data,i,UL,LL) {
mu <- mean(data[i])
sg <- sd(data[i])
ret <- min(c((UL-mu)/(3.0*sg),(mu-LL)/(3.0*sg)))
ret }

 

Up Ordering the Book News References R Code Data Corrections About the Author