.packageName <- "pad"
"clt" <- function(x, n, nsim, plot = TRUE, ncols = 2) {
  par.now <- par(no.readonly = TRUE)
  on.exit(par(par.now))
  ##
  if(missing(x))
    x <- eval(parse(prompt="enter a vector with data values \n(an object, an expression or use the format c() to enter a numeric vector),\n  x = "))
  if(any(is.na(x)) | !is.numeric(x))
    stop("a numerical vector \"x\" must be provided")
  if(missing(n)){
    cat("\nenter sample sizes, <return> will assume defaults values c(2,4,8,16,32)\n")
    n <- as.numeric(readline("n = "))
  }
  if(any(is.na(n)) | n == "") n <- c(2,4,8,16,32)
  if(any(is.na(n)) | (!is.numeric(n) && !is.integer(n)))
    stop("a numerical integer value for \"n\" must be provided")
  if(missing(nsim)){
    cat("\nenter the number of simultions sim, \n <return> will assume the default value 1000\n")
    nsim <- as.numeric(readline(prompt="nsim = "))
  }
  if(any(is.na(nsim)) | nsim == "") nsim <- 1000
  if(any(is.na(nsim)) |  (!is.numeric(nsim) && !is.integer(n)))
    stop("a numerical integer value for \"nsim\" must be provided")
  ##
  cat("\nsampling  ...  ")
  res <- list(data = x)
  for(nsz in n){
    sims <- matrix(0,nsim,nsz)
    for (i in 1:nsim)
      sims[i,] <- sample(x, nsz, replace = TRUE)
    xbar <- apply(sims, 1, mean)
    sd <- sqrt(apply(sims, 1, var))
    res[[paste("size", nsz, sep="")]] <- list(xbar = xbar, sd = sd)
  }
  class(res) <- "clt"
  cat("done.\n\n")
  if(plot){
    par(mfrow=c(ceiling((length(n)+1)/ncols),2),
        mar=c(3,2.5,2,.5), mgp=c(1.7,.7,0))
    plot.clt(res)
  }
  return(invisible(res))
}

"plot.clt" <- function(x, ...){
  hist(x$data, main = "", probability=TRUE)
  mtext("original population")
  nx <- length(x)
  lims <- function(y){
    ind.hist <- hist(y$xbar, probability=TRUE, plot=FALSE)
    return(c(range(ind.hist$breaks), range(ind.hist$dens)))
  }
  h.lims <- sapply(x[-1], lims)
  xymin <- apply(h.lims[c(1,3),,drop=FALSE], 1, min)
  xymax <- apply(h.lims[c(2,4),,drop=FALSE], 1, max)
  for(i in 2:nx){
    hist(x[[i]]$xbar, prob = TRUE, xlab=expression(bar(x)),
         ylab="density", main = "",
         xlim = c(xymin[1], xymax[1]), ylim = c(0, xymax[2]))
    mtext(paste("sample ",names(x)[i]))
  }
  return(invisible())
}

"clt.plot1" <- function(x, nsim) {
  data <- NULL
  for (i in 1:nsim) {
    data <- c(data, sample(x,1, replace=TRUE))
  }
  xl <- c(floor(min(data)-5),floor(max(data)+5))
  hist(data,xlim=xl,xlab="data",ylab="frequency")
  for (i in 1:nsim) {
    data <- c(data, mean(sample(x,2, replace=TRUE)))
  }
  hist(data,xlab="means of 2",ylab="frequency",xlim=xl)
  for (i in 1:nsim) {
    data <- c(data, mean(sample(x,4, replace=TRUE)))
  }
  hist(data,xlab="means of 4",ylab="frequency",xlim=xl)
  
  for (i in 1:nsim) {
    data <- c(data, mean(sample(x,8, replace=TRUE)))
  }
  hist(data,xlab="means of 8",ylab="frequency",xlim=xl)
}

"clt.plot2" <- function(nsim) {
  data(class98)
  xbar <- matrix(0,3,4)
  xvar <- xbar
  
  x <- class98[,1]
  x <- x[!is.na(x)]
  junk <- clt(x,1,nsim)
  xbar[1,1] <- mean(junk$xbar); xvar[1,1] <- var(junk$xbar)
  
  junk <- clt(x,2,nsim)
  xbar[1,2] <- mean(junk$xbar); xvar[1,2] <- var(junk$xbar)
  
  junk <- clt(x,4,nsim)
  xbar[1,3] <- mean(junk$xbar); xvar[1,3] <- var(junk$xbar)
  
  junk <- clt(x,8,nsim)
  xbar[1,4] <- mean(junk$xbar); xvar[1,4] <- var(junk$xbar)
  
  x <- class98[,2]
  x <- x[!is.na(x)]
  junk <- clt(x,1,nsim)
  xbar[2,1] <- mean(junk$xbar); xvar[2,1] <- var(junk$xbar)
  
  junk <- clt(x,2,nsim)
  xbar[2,2] <- mean(junk$xbar); xvar[2,2] <- var(junk$xbar)
  
  junk <- clt(x,4,nsim)
  xbar[2,3] <- mean(junk$xbar); xvar[2,3] <- var(junk$xbar)
  
  junk <- clt(x,8,nsim)
  xbar[2,4] <- mean(junk$xbar); xvar[2,4] <- var(junk$xbar)
  
  x <- -50*log(runif(50))
  x <- x[!is.na(x)]
  junk <- clt(x,1,nsim)
  xbar[3,1] <- mean(junk$xbar); xvar[3,1] <- var(junk$xbar)
  
  junk <- clt(x,2,nsim)
  xbar[3,2] <- mean(junk$xbar); xvar[3,2] <- var(junk$xbar)
  
  junk <- clt(x,4,nsim)
  xbar[3,3] <- mean(junk$xbar); xvar[3,3] <- var(junk$xbar)
  
  junk <- clt(x,8,nsim)
  xbar[3,4] <- mean(junk$xbar); xvar[3,4] <- var(junk$xbar)
  list(xbar=xbar, xvar=xvar)
}

#"matern" <- function(u, kappa){
#  out <- .C("cormatern", as.integer(length(u)), as.double(u),
#            as.double(kappa), res = as.double(rep(0,length(u))), PACKAGE="pad")$res
#  return(out)
#}
"mctest" <- function(x, y, paired = TRUE, nsim = 1000, plot = TRUE) {
  if(missing(x))
    x <- eval(parse(prompt="enter a vector with data values \n(an object, an expression or use the format c() to enter a numerical vector),\n  x = "))
  if(missing(y))
    y <- eval(parse(prompt="enter a vector with data values \n(an object name, an expression or use the format c() to enter a numerical vector),\n  y = "))
  nx <- length(x)
  ny <- length(y)
  if(paired){
    if(nx != ny)
      stop("this function requires x and y with same length")
    df <- nx - 1
    dxy <- x-y
    d <- mean(dxy)/sqrt(var(dxy)/nx)
    for (i in 1:nsim) {
      r <- runif(nx)
      xx <- x*(r<0.5)+y*(r>=0.5)
      yy <- x*(r>=0.5)+y*(r<0.5)
      dxy <- xx - yy
      d <- c(d, mean(dxy)/sqrt(var(dxy)/nx))
    }
  }
  else{
    xy <- c(x, y)
    df <- nx + ny - 2
    s2 <- ((nx-1) * var(x) + (ny-1) * var(y))/df
    d <- (mean(x)-mean(y))/sqrt(s2)
    for (i in 1:nsim) {
      ind <- sample(1:(nx+ny))
      xx <- xy[ind <= nx]
      yy <- xy[ind > nx]
      s2 <- ((nx-1) * var(xx) + (ny-1) * var(yy))/df
      d <- c(d, (mean(xx)-mean(yy))/sqrt(s2*((1/nx)+(1/ny))))
    }
  }
  Pmc <- sum(d>=d[1])/(nsim+1)
  ##  p2 <- sum(d<=d[1])/(nsim+1)
  Pt <- pt(d[1], df = df, lower=FALSE)
  res <- list(p=c(upper.tail = Pmc, lower.tail = 1-Pmc),
              pt = c(upper.tail = Pt, lower.tail = 1-Pt),
              data.statistic = d[1], sim.statistic = d[-1])
  attr(res, "paired") <- paired
  attr(res, "df") <- df
  class(res) <- "mctest"
  if(plot) plot.mctest(res)
  return(res)
}

"plot.mctest" <- function(x, tcurve = TRUE, ...){
  df <- eval(attr(x, "df"))
  xyhist <- hist(x$sim, prob=TRUE, plot=FALSE)
  ymax <- max(max(xyhist$dens, na.rm=TRUE), dt(0, df = df)) 
  xmax <- max(max(xyhist$breaks, na.rm=TRUE), x$data)
  xmin <- min(min(xyhist$breaks, na.rm=TRUE), x$data)
  ldots <- list(...)
  MCstatistics <- x$sim
  if(is.null(ldots$xlim) & is.null(ldots$ylim))
    hist(MCstatistics, prob=TRUE, xlim = c(xmin, xmax), ylim=c(0, ymax),...)
  else
    hist(x$sim, prob=TRUE, ...)
  arrows(x$data, ymax/5, x$data, 0, lwd=2)
  text(x$data, ymax/5, round(x$data, dig=4), pos=3, col="red")
  st <- round(x$p[1], dig=4)
  text(.75*xmax, .9*ymax,
       substitute(P[upper] == Pval, list(Pval=st)), col="red")
  if(tcurve){
    ap <- function(x) {return(dt(x, df=df))}
    curve(ap(x), from = xmin, to = xmax, add=TRUE)
    prob.t <- pt(x$data.st, df = df, lower=FALSE)
    stt <- round(x$p[1], dig=4)
    text(.75*xmax, .75*ymax,
         substitute(P(t)[upper] == Pval, list(Pval=stt)), col="red")
  }
  return(invisible())
}

"print.mctest" <- function(x, ...){
  paired <- eval(attr(x, "paired"))
  if(paired) cat("Paired data\n")
  else cat("Two-sample data\n")
  cat(paste("data statistics = ", x$data,"\n"))
  cat("\n")
  cat("probabilities based on Monte Carlo simulations:\n")
  print(round(x$p, dig=6))
  cat("\n")
  cat("probabilities based on the \"t\" distribution:\n")
  print(round(x$pt, dig=6))
  return(invisible())
}

"pad.data" <- "gsse401.data" <- function(){
  cat("Data sets included in the package \"gsse401\"\n")
  cat("---------------------------------------------------\n") 
  cat("\n")
  cat("ansc         Anscombe quartet data\n")
  cat("campy        Campylobacter data\n")
  cat("class96      Students weight and height data, 1996\n")
  cat("class97      Students weight and height data, 1997\n")
  cat("class98      Students weight and height data, 1998\n")
  cat("crossover    Asthma data\n")
  cat("glyp         Glyphosate data\n")
  cat("gravity      Gravity data\n")
  cat("lh           Cow luteinising hormone data\n")
  cat("mandible     Golden Jackals Mandible Data\n")
  cat("maxtemp      Daily maximum temperatures in Lancaster\n")
  cat("rubber       Rubber abrasion experiment data\n")
  cat("screen       Screening storm water data\n")
  cat("ugclass      Undergraduate classroom data\n")
  cat("warping      Warping of Cu material data\n")
  cat("---------------------------------------------------\n")
  cat("\n")
  cat("To load one of these data sets type:\n")
  cat("data(THE_NAME_OF_THE_DATA_AS_ABOVE)\n")
  cat("---------------------------------------------------\n")
  return(invisible())
}
  
"pad.functions" <-  "gsse401.functions" <- function(){
    cat("Data sets included in the package \"gsse401\"\n")
    cat("---------------------------------------------------\n") 
    
  cat("\n")
  cat("clt         Illustrates the Central Limit Theorem\n")
  cat("mctest      Paired and two-sample Monte Carlo tests\n")
  cat("queue       Simulation a Queue\n")
  cat("reg         Illustrates regression models\n")
  cat("---------------------------------------------------\n") 
  cat("\n")
  cat("To see the arguments of a particular function type:\n")
  cat("args(THE_NAME_OF_THE_FUNCTION_AS_ABOVE)\n")
  cat("\n")
  cat("To see the help on a particular function type:\n")
  cat("help(THE_NAME_OF_THE_FUNCTION_AS_ABOVE)\n")
  cat("---------------------------------------------------\n")

  return(invisible())
}
"queue" <- function(lambda, rho, n, plot = TRUE) {
  if(missing(lambda)){
    cat <- cat("enter a value for the arrival parameter\n")
    lambda <- as.numeric(readline(prompt="lambda = "))
  }
  if(is.na(lambda) | !is.numeric(lambda))
    stop("a numerical value for \"lambda\" must be provided")
  ##
  if(missing(rho)){
    cat("enter a value for the services parameter\n")
    rho <- as.numeric(readline(prompt="rho = "))
  }
  if(is.na(rho) | !is.numeric(rho))
    stop("a numerical value for \"rho\" must be provided")
  ##
  if(missing(n)){
    cat("enter the value for number of arrivals \n")
    n <- as.numeric(readline(prompt="n = "))
  }
  if(is.na(n) | (!is.numeric(n) && !is.integer(n)))
    stop("a numerical integer value for \"n\" must be provided")
  ##
  N <- 2*n
  arrivals <- cumsum(rexp(N)/lambda)
  services <- cumsum(rexp(N)/rho)
  labels <- c(rep(1,N),rep(2,N))
  times <- c(arrivals,services)
  lab <- labels[order(times)]
  size <- 0
  queue <- rep(0,1+2*N)
  for (i in 1:(2*N)) {
    if (lab[i]==1) queue[i+1] <- queue[i]+1
    if (lab[i]==2) queue[i+1] <- max(0,queue[i]-1)
  }
  res <- cbind(times = c(0,sort(times)), queue = queue)[1:(1+N),]
  class(res) <- "queue"
  if(plot)
    plot.queue(res)
  return(invisible(res))
#  return(res)
}

"plot.queue" <- function(x, ...) {
  times <- x[,1]; m <- length(times); tt <- matrix(times[2:m],m-1,2)
  tt <- c(times[1],c(t(tt)))
  heights <- x[,2]; hh <- matrix(heights[1:(m-1)],m-1,2)
  hh <- c(c(t(hh)),heights[m])
  plot(tt, hh, type="l", xlab="time", ylab="queue size")
  return(invisible())
}

"reg" <- function(n.expl, ...)
{
  par.now <- par(no.readonly=TRUE)
  on.exit(par(par.now))
  if(missing(n.expl)){
    cat("enter the number of explanatory variables (1 or 2)\n")
    n.expl <- eval(parse(prompt = "number = "))
  }
  if(any(n.expl == c(1,2))){
    par(mfrow=c(2,1), mar=c(2.5,2.5,2,0.5), mgp=c(1.5, .6, 0))
    if (n.expl == 1) reg1(...)
    else reg2(...)
  }
  else stop("number of explanatory variables should be 1 or 2" )
  return(invisible())
}

"reg1" <- function(true.model, n.points, range.x, regular, x, ...){
  if(missing(true.model)){
    cat("enter the true model equation (use a format like: 1 + 2*x):\n ")
    true.model <- parse(prompt = "model : ")
  }
  else true.model <- parse(text=true.model)
  cat("\nInformation on the explanatory variable:\n")
  x <- reg.aux(range.x = range.x, n.points = n.points,
               regular = regular, xvec = x)
  x <- x[order(x)]
  ym <- eval(true.model)
  y <- ym + rnorm(length(ym), mean=0, sd = sqrt(0.20 * var(ym)))
  plot(x, y, main=paste("true model :  Y = ",true.model), ...)
  lines(spline(x, ym), lty=2)
  if(mean(diff(ym)) > 0) xleg <- min(x)
  if(mean(diff(ym)) < 0) xleg <- 0.8 * (diff(range(x)))
  legend(xleg, max(y), c("true", "fitted"), lty=c(2,1))
  regs <- lm(y ~ x)
  abline(regs)
  ##
  nv <- length(y) - 1
  stdres <- regs$resid/sqrt(nv * var(regs$res)/(nv-1))
  emax <- max(abs(stdres))
  plot(regs$fit, stdres, xlab="fitted values",
       ylab = "std residuals", ylim=c(-emax, emax))
  abline(h=0, lty=2)  
  return(invisible())
}

"reg2" <- function(true.model, n.points, range.x1, range.x2, regular, x1, x2, ...){
  if(missing(true.model)){
    cat("enter the true model equation (use a format like: 1 + 2*x1 + 3*x2):\n ")
    true.model <- parse(prompt = "model : ")
  }
  else true.model <- parse(text=true.model)
  regular <- FALSE  
  if(missing(x1)){
    cat("\nInformation on the first explanatory variable:\n")
    x1 <- reg.aux(range.x = range.x1, n.points = n.points,
                  regular = regular, xvec = x1)
  }
  else if(!is.numeric(x1)) stop("x1 must be a numeric vector")
  if(missing(x2)){
    cat("\nInformation on the second explanatory variable:\n\n")
    x2 <- reg.aux(range.x=range.x2, n.points=eval(attr(x1,"n")),
                  regular=regular, xvec = x2)
  }
  else if(!is.numeric(x1)) stop("x1 must be a numeric vector")
  if(length(x1) != length(x2))
    stop("x1 and x2 have different lengths")
  ym <- eval(true.model)
  y <- ym + rnorm(length(ym), mean=0, sd = sqrt(0.20 * var(ym)))
  regs <- lm(ym ~ x1 + x2)
  if(require(scatterplot3d)){
    yx1x2 <- scatterplot3d::scatterplot3d(data.frame(x1=x1, x2=x2, y=y),
                           type="h", highlight.3d=FALSE,
                           angle=40, box=FALSE,
                           pch=16, main=paste("true model :  Y = ",true.model))
    yx1x2$plane3d(regs)
  }
  else
    warning("package \"scatterplot3d\" not found. 3D plot not produced") 
  ##
  nv <- length(y) - 1
  stdres <- regs$resid/sqrt(nv * var(regs$res)/(nv-2))
  emax <- max(abs(stdres))
  plot(regs$fit, stdres, xlab="fitted values", ylab = "std residuals",
       ylim=c(-emax, emax))
  abline(h=0, lty=2)  
  return(invisible())
}

"reg.aux" <- function(range.x, n.points, regular, xvec){
  if(missing(xvec)){
    if(missing(n.points)){
      cat("   enter the number of points or press <return> to enter a vector with the values of the explanatory variable\n") 
      n.points <- as.numeric(readline(prompt = "n.points = "))
    }
    if(is.null(n.points) || any(is.na(n.points))){
      cat("   enter a vector with x values\n")
      xvec <- eval(parse(prompt = "xvec = "))
      if(!is.numeric(xvec))
        stop("invalid non-numeric values for xvec")
      n.points <- length(xvec)
    }
    else{
      if(missing(range.x)){
        cat("   enter the range of values for the explanatory variable\n")
        xmin <- as.numeric(readline(prompt = "      minimum = "))
        xmax <- as.numeric(readline(prompt = "      maximum = "))
        if(is.null(xmin)) xmin <- "vec x by user"
        if(is.null(xmax)) xmax <- "vec x by user"
        if(all(is.na(xmin))) xmin <- "vec x by user"
        if(all(is.na(xmax))) xmax <- "vec x by user"
        range.x <- c(xmin, xmax)
        range.x <- range.x[order(range.x)]
      }
      range.x <- range.x[order(range.x)]
      if(is.numeric(range.x)){
        if(missing(regular)){
          cat("   regularly spaced points? (defaults to TRUE)\n")
          regular <- as.logical(readline(prompt = "      (T or F) = "))
        }
        if(is.null(regular) || any(is.na(regular))) regular <- TRUE
        if(regular) xvec <- seq(range.x[1], range.x[2], l=n.points)
        else{
          xvec <- runif(n.points, min=range.x[1], max=range.x[2])
        }
      }
    }
  }
  else n.points <- length(xvec)
  attr(xvec, "n") <- n.points
  return(xvec)
}

".First.lib" <-
  function(lib, pkg)
{
# library.dynam("pad", package = pkg, lib.loc = lib)
 pkg.info <- packageDescription("pad", lib.loc = lib,
                                        fields=c("Title","Version","Date"))
  cat("\n")
  cat("------------------------------------------\n")
    cat(pkg.info$Title)
    cat("\n")
        cat(paste("pacote pad versao", pkg.info$Version,  "carregado\n"))
  cat("------------------------------------------\n")
  cat("\n")
  return(invisible(0))
}

