#######################################################################
#the regr example
setClass("regr", representation(X = "matrix", y = "numeric",
b = "numeric", intercept = "logical"))

getClass("regr")

isClass("regr")
removeClass("regr")
isClass("regr")

setClass("regr", representation(X = "matrix", y = "numeric",
b = "numeric", intercept = "logical"))

setClass("regr", representation(X = "matrix", y = "numeric",
b = "numeric", intercept = "logical"), prototype(X =
matrix(0, 1, 1), y = 0, b = 0, intercept = TRUE))

#the mtcars data regr object
data(mtcars)
A <- as.matrix(mtcars[, c(1, 3, 6, 7)])
regrCar <- new("regr", X = A[, 2:4], y = A[, 1])
regrCar
XTX <- t(cbind(1, regrCar@X))%*%cbind(1, regrCar@X)
regrCar@b <- solve(XTX, drop(t(cbind(1, regrCar@X))%*%regrCar@y))
regrCar@b
slot(regrCar, "b")[1]

#the regr class constructor
regr <- function(X, y, Intercept = TRUE){
  regrObj <- new("regr", X = as.matrix(X), y = as.numeric(y),
    intercept = Intercept)
  if(Intercept){
     XTX <- t(cbind(1, regrObj@X))%*%cbind(1, regrObj@X)
    regrObj@b <- solve(XTX, drop(t(cbind(1, regrObj@X))%*%regrObj@y))
  }
  else{
    XTX <- t(regrObj@X)%*%regrObj@X
    regrObj@b <- solve(XTX, drop(t(regrObj@X)%*%regrObj@y))
  }
  regrObj
}

#mtcars again
regrCar <- regr(A[,2:4], A[,1])
regrCar@b
regrCar <- regr(A[,2:4], A[,1], FALSE)
regrCar@b

#validity check
setValidity("regr", function(object){
  if(nrow(object@X) != length(object@y))
    return("The number of rows for X and y differ")
  if(object@intercept){
    if(qr(cbind(1, object@X))$rank < (ncol(object@X) + 1))
      return("The matrix of predictors is singular")
  }
  else{
    if(qr(object@X)$rank < ncol(object@X))
      return("The matrix of predictors is singular")
  }
  return(TRUE)
})

regrObj <- regr(matrix(1, 10, 10), rnorm(3))
regrObj <- regr(matrix(1, 10, 10), rnorm(10))
regrObj <- regr(matrix(1, 10, 10), rnorm(10), FALSE)

#the derived regrFit class
setClass("regrFit", contains = "regr", representation(yHat
= "numeric"), prototype(yHat = 0))

regrFit <- function(X, y, intercept = TRUE){
  fitObj <- regr(X, y, intercept)
  fitObj <- as(fitObj, "regrFit")
  if(fitObj@intercept)
    fitObj@yHat <- drop(cbind(1, fitObj@X)%*%fitObj@b)
  else
    fitObj@yHat <- drop(fitObj@X%*%fitObj@b)

  fitObj
}

#mtcars again
regrCarFit <- regrFit(A[,2:4], A[,1])
regrCarFit@y[1:3]
regrCarFit@yHat[1:3]

#creating an S3 method function
methods(coefficients)
coef.regr <- function(object){
  object@b
}
methods(coefficients)
coefficients(regrCar)
coefficients(regrCarFit)

func <- function(x) UseMethod("func")
func.regr <- function(x) print("func for regr")
func(regrCar)    

#the func example
setGeneric("func", function(object1, object2, ...)
standardGeneric("func"))
setMethod("func",  signature("numeric", "numeric"),
 function(object1, object2) object1*object2)
setMethod("func",  signature = c(object1 = "character",
object2 = "numeric"), function(object1, object2)
print(paste(object1, object2)))
setMethod("func",  signature("numeric", "numeric"),
function(object1, object2, object3) object1*object2*object3)
setMethod("func",  signature( "missing", "numeric"),
function(object1 ,object2) print("missing and numeric"))
setMethod("func",  signature("ANY", "numeric"),
function(object1, object2) print("ANY and numeric"))
func("a")
func("a", 2)
func(2)
func(, 2)
func(object2 = 2)
setMethod("func",  signature("ANY", "missing"),
function(object1, object2) print("ANY and missing"))
func("a")
func(2)
setMethod("func",  signature("ANY", "ANY"),
function(object1, object2) print("ANY and ANY"))
func("a")
func(2)
setMethod("func",  signature("ANY"),
function(object1) print("just ANY"))
func("a")
func(2)

#creating a new show method function for the regr class
show.regr <- function(object){
  cat("An object of class regr with", ncol(object@X),
      "predictors\n")
}

setMethod("show", signature("regr"), definition = show.regr)
regrCar
regrCarFit

#defining a new power transform method function
setMethod("^", signature("regr", "numeric"), function(e1, e2)
regr(e1@X, (e1@y)^e2))

setMethod("^", signature("regr", "numeric"), function(e1, e2) {
if(.hasSlot(e1, "yHat")) regrFit(e1@X, (e1@y)^e2)
else regr(e1@X, (e1@y)^e2)
})

#accessor and replacement functions for the coefficient vector
setGeneric("bHat", function(object) standardGeneric("bHat"))
setMethod("bHat", signature = "regr", function(object) object@b)

setGeneric("bHat<-", function(x, value) standardGeneric("bHat<-"))
setReplaceMethod("bHat", "regr", function(x, value)
{x@b <- value; x})
#######################################################################
#the guess5 example

#the g5 class
setClass("g5", representation(drawDate = "Date",
mName = "character", sNo = "integer", Day = "character",
data="matrix"))

validG5 <- function(object){
 if(object@mName != "A" & object@mName != "B")
   return(paste("Incorrect machine name for date", object@drawDate)) 
 if(object@sNo < 1 | object@sNo > 10)
   return(paste("Incorrect set number for date", object@date))
 if(object@Day != "M" & object@Day != "T")
   return(paste("Incorrect day for date", object@date))
 if(any(object@data < 1 | object@data > 40))
    return(paste("Incorrect ball number for date", object@date))      
  return(TRUE)
}

g5 <- function(a){
  drawdate <- as.Date(a[1])
  mname <- a[2]
  sno <- as.integer(a[3])
  day <- a[4]
  A <- matrix(as.integer(a[5:54]), 10, 5, byrow = TRUE)
  g5Obj <- new("g5", drawDate = drawdate, mName = mname, sNo = sno,
               Day = day, data = A)
  g5Obj
}
  
setValidity("g5", validG5)

a <- scan("guess5.txt", what = character(0), n = 108)
g5Obj1 <- g5(a[1:54]); g5Obj2 <- g5(a[55:108])

setGeneric("summary")
setMethod("summary", "g5", function(object){
  cat(paste("Drawings for", object@drawDate, "used Machine",
  object@mName, "and Ball Set", object@sNo, "\n"))
  cat("Drawing results with pre-tests", "\n")
  print(object@data)
  }
)

setMethod("Compare", signature(e1 = "g5", e2 = "g5"),
function(e1, e2) callGeneric(e1@drawDate, e2@drawDate))

#the g5List class
setClass("g5List", representation(objList = "list", nDraws =
"integer", nSet = "integer", nMach = "integer"))

readG5 <- function(fileName){
  out <- tryCatch(suppressWarnings(unlist(strsplit(
  readLines(fileName), split = " "))), error =
  function(e){print(e)
  print("Please enter a file name followed by a return")
  newName <- scan(, what = character(0), quiet = TRUE)
  readG5(newName)})
  out
}

g5List<-function(fileName){
  A <- readG5(fileName)
  ndraws <-length(A)/54
  objlist <- lapply(1:ndraws, FUN =
        function(i) g5(A[(54*i - 53):(54*i)]))
  temp <- sapply(objlist, FUN = function(g5obj) g5obj@mName)
  tempNMach <- sum(temp == "A")
  nmach <- c(tempNMach, ndraws - tempNMach)
  temp <- sapply(objlist, FUN = function(g5obj) g5obj@sNo)
  nset <- integer(10)
  for(i in 1:10) nset[i] <-  sum(temp == i)
  g5ListObj <- new("g5List", objList = objlist, nDraws =
        as.integer(ndraws), nSet = nset,
        nMach = as.integer(nmach))  
}

#accessor functions
setMethod("[[", signature(x = "g5List"), function(x, i, j, ...,
exact = TRUE) x@objList[[i]])

setReplaceMethod("[[", signature(x = "g5List"),
function(x, i, j, ..., exact, value) {x@objList[[i]] <- value; x})

setGeneric("nDraws", function(object) standardGeneric("nDraws"))
setMethod("nDraws", signature = "g5List", function(object)
object@nDraws)

setGeneric("nMach", function(object) standardGeneric("nMach"))
setMethod("nMach", signature = "g5List", function(object)
object@nMach)

setGeneric("nSet", function(object) standardGeneric("nSet"))
setMethod("nSet", signature = "g5List", function(object)
object@nSet)

#chi-square test
setGeneric("chisq.test")
chisq.test

chisq.test.g5List <-function (x, y = list(machRange = c("A", "B"),
  setRange = 1:10), correct, p, rescale.p, simulate.p.value, B){
  objlist <- x@objList
  tempM <- sapply(objlist, FUN = function(g5obj) g5obj@mName)
  tempS <- sapply(objlist, FUN = function(g5obj) g5obj@sNo)
  tempM <- is.element(tempM, y[[1]])
  tempS <- is.element(tempS, y[[2]])
  indices <- as.logical(tempM*tempS)
  newList <- objlist[indices]
  ndraws <- length(newList)
  temp <- as.numeric(sapply(1:ndraws, FUN =
        function(i) newList[[i]]@data))
  chistat = 39*chisq.test(x = table(temp))[[1]]/35
  names(chistat) <- NULL
  list(chistat, 1 - pchisq(chistat, 39))
}

setMethod("chisq.test", signature(x = "g5List", y = "ANY"),
definition = chisq.test.g5List)

g5ListObj <- g5List("guess5.txt")
chisq.test(g5ListObj, list(machRange = "A", setRange = 1:10))
chisq.test(g5ListObj, list(machRange = c("A", "B"), setRange = 10))
chisq.test(g5ListObj)

#sorting
minIndex <- function(x){
  minIndex <- 1
  minObj <- x[[1]]
  for(i in 1:length(x))
    if(x[[i]] < minObj){ 
      minIndex <- i
      minObj <- x[[i]]
    }
  list(minIndex, minObj)
}

sortList <- function(x){
  y = NULL
  if(length(x) > 1){
    temp <- minIndex(x)
    x[temp[[1]]]<- x[[1]]
    x[[1]] <- temp[[2]]    
    y <- sortList(x[2:length(x)])
  }
  y = c(y, x[[1]])
  y
}

setMethod("sort", signature("g5List"), function(x,
decreasing = FALSE, ...) {newObject <- new("g5List",
objList = sortList(x@objList), nDraws = nDraws(x),
nSet = nSet(x), nMach = nMach(x))
newObject
})

as.Date(sapply(g5ListObj@objList, function(e) as.Date(e@drawDate)),
origin = "1970-01-01")[1:5]
as.Date(sapply(sort(g5ListObj)@objList, function(e) 
as.Date(e@drawDate)), origin = "1970-01-01")[1:5]
set.seed(123)
newg5ListObj <- new("g5List", objList = sample(g5ListObj@objList), 
nDraws = nDraws(g5ListObj), nSet = nSet(g5ListObj),
nMach = nMach(g5ListObj))
as.Date(sapply(sort(newg5ListObj)@objList, function(e) 
as.Date(e@drawDate)), origin = "1970-01-01")[1:5]