.packageName <- "cwhplot"
lowess.bygroup <- function(x, y, group, lin=FALSE, col = par("col"), bg = NA, pch = par("pch"), cex = 1, ...) {
  for (ii in unique(group)) {
    ind <- complete.cases(x[ii == group],y[ii == group])
    cc  <- cbind(x[ii == group][ind],y[ii == group][ind])
    oi  <- order(cc[,1])
    cat(paste(ii,length(oi),"\n"))
    if (lin) lines(x[oi],y[oi],lty=2)
    if (length(oi)>0) lines(lowess(x[oi],y[oi]))
  }
  invisible()
}

loess.bygroup <- function(x, y, group, lin=FALSE, col = par("col"), bg = NA, pch = par("pch"), cex = 1, ...) {
  for (ii in unique(group)) {
    ind <- complete.cases(x[ii == group],
                          y[ii == group])
    cc  <- cbind(x[ii == group][ind],y[ii == group][ind])
    oi  <- order(cc[,1])
    cat(paste(ii,length(oi),"\n"))
    if (lin) lines(x[oi],y[oi],lty=2)
    if (length(oi)>0) lines(x[oi],predict(loess(y[oi]~x[oi]),x[oi]))
  }
  invisible()
}

lpr <- function (object, file = "Rplotlpr.ps", ...) 
{
    if (missing(object)) {
        current.device <- dev.cur()
        dev.off(dev.copy(device = postscript, file = file, ...))
        dev.set(current.device)
        system(paste("lpr", file))
        print(paste(file, "printed."))
    }
    else {
        if (missing(file)) 
            file <- "Robjlpr.txt"
        sink(file)
        object <- as.character(substitute(object))
        print(get(object))
        sink()
        system(paste("lpr", file))
        print(paste(object, "printed."))
    }
}
mult.fig.p <- function(nr.plots, mfrow, mfcol,
         marP = rep(0,4), mgp = c(1.5,.6,0),
         mar = marP + .1 + c(4,4,2,1),
         main = NULL, sub = NULL, adj.sub = 0.5,
         tit.wid = if (is.null(main)) 0 else 1 + 1.5*cex.main,
         quiet = .Device == "postscript",
         cex.main = par("cex.main"),
         col.main = par("col.main"),
         font.main = par("font.main"),
         ...)
{
  ## Purpose: 'MULTiple FIGures' incl. TITLE and other good defaults
  ## -------------------------------------------------------------------------
  ## Arguments: 
  ##             -- Either ONE of the first 3 arguments --
  ## -------------------------------------------------------------------------
  ## Author: Martin Maechler, 1990 (UW, Seattle) -- 1995
  ## -------------------------------------------------------------------------

  use.row <- missing(mfcol)
  if (use.row)
    if (missing(mfrow)) {
      if (missing(nr.plots))
        stop("must either specify 'nr.plots', 'mfrow' or 'mfcol' !")
      else  mfrow <- n2mfrow (nr.plots)
    }
  oma <- c(tit.wid, 0, tit.wid, 0)
  old.par <<-
    if(use.row) par(mfrow = mfrow, oma= oma, mar = mar, mgp= mgp)
    else        par(mfcol = mfcol, oma= oma, mar = mar, mgp= mgp)
  if(!quiet) cat("Execute\n\t par(old.par) \n later to restore graphical par\n")
  ##---- now go ahead :
  if(!is.R())
      frame()
  if (!is.null(main)) {# Do title *before* first plot!
      if(is.R()) plot.new()
      mtext(sub, side = 1, outer = TRUE,
            line = 0,
            cex = cex.main/2,
            font = font.main, col = col.main, adj=adj.sub, ...)
      mtext(main, side = 3, outer = TRUE,
            line = cex.main, # was tit.wid - 4,
            cex = cex.main,
            font = font.main, col = col.main, ...)
      if(is.R()) par(new=TRUE)# reverse `plot.new()' above
  }
  invisible(list(new.par = par(c("mfrow","mfcol","oma","mar","mgp")),
                 old.par = old.par))
}
p.screeplot.princomp <- function (object, variables = seq(length(object$sdev)), cumulative = TRUE, main = deparse(substitute(object)), ylim = c(0, max(vars) + 0.05), ...) 
{
    len <- length(variables)
    nn <- min(10, len)
    nsmal <- 3
    if (length(names(object$sdev)) > 4) {
        names(object$sdev) <- substring(names(object$sdev), 7)
        nsmal <- 2
    }
    variables <- variables[1:nn]
    vars <- object$sdev^2
    vars <- vars[variables]/sum(vars)
    bp <- barplot(vars, main = main, ylim = ylim, ...)
    cs <- round(cumsum(vars), nsmal)
    cs <- ifelse(cs == 1, "1", substring(cs, 2))
    if (cumulative) 
        text(bp, vars + par("cxy")[2], cs, cex = 0.7)
    invisible(bp)
}
panel.hist <- function(x, ...)
{
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(usr[1:2], 0, 1.5) )
    h <- hist(x, plot = FALSE)
    breaks <- h$breaks; nB <- length(breaks)
    y <- h$counts; y <- y/max(y)
    rect(breaks[-nB], 0, breaks[-1], y, col="cyan", ...)
}
panel.cor <- function(x, y, digits=2, prefix="", cex.cor)
{
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(0, 1, 0, 1))
    r <- abs(cor(x, y, use = "complete.obs"))
    txt <- format(c(r, 0.123456789), digits=digits)[1]
    txt <- paste(prefix, txt, sep="")
    if(missing(cex.cor)) cex <- 0.8/strwidth(txt)
    text(0.5, 0.5, txt, cex = cex * r)
}
plotSymbols <- function(interactive=FALSE) {
  ASCII <- c("\000", sapply(1:255, function(i) parse(text=paste("\"\\", structure(i,class="octmode"), "\"", sep=""))[[1]]));

  intToChar <- function(i) {
    ASCII[i %% 256 + 1];
  }

  interactive <- interactive && interactive();

  i <- 0:255;
  ncol <-16;
  
  top <- 3 + 2*interactive;
  opar <- par(cex.axis=0.7, mar=c(3,3,top,3)+0.1)
  on.exit(par(opar))

  plot(i%%ncol,1+i%/%ncol, pch=i, xlim=c(0,ncol-1), xlab="", ylab="", axes=FALSE);
  axis(1, at=0:15)
  axis(2, at=1:16, labels=0:15*16, las=2)
  axis(3, at=0:15)
  axis(4, at=1:16, labels=0:15*16+15, las=2)
  if (interactive) {
    title(main="Click on a symbol to add it to the data frame. Click in margin to quit!", cex.main=0.8, line=3.5);
  }

  if (interactive) {
    df <- list();
    usr <- par("usr");
    ready <- FALSE;
    while (!ready) {
      click <- locator(n=1);
      x <- click$x;
      y <- click$y - 1;
      ready <- !(x > 0.5 && x < 15.5 && y > 0.5 && y < 15.5);
      if (!ready) {
        x <- round(x);
        y <- round(y);
        z <- 16*y + x;
        ch  <- intToChar(z);
        dec <- as.character(z); 
        hex <- intToHex(z);
        oct <- intToOct(z);
        spc <- paste(rep("0", 2-nchar(hex)), collapse="");
        hex <- paste(spc, hex, sep="");
        spc <- paste(rep("0", 3-nchar(oct)), collapse="");
        oct <- paste(spc, oct, sep="");
        df$ch  <- c(df$ch , ch );
        df$dec <- c(df$dec, dec);
        df$hex <- c(df$hex, hex);
        df$oct <- c(df$oct, oct);

        if (nchar(ch) == 0) ch <- " ";
        spc <- paste(rep(" ", 3-nchar(dec)), collapse="");
        dec <- paste(spc, dec, sep="");
        cat("Selected ASCII character '", ch, "' ", dec, " 0x", hex, " \\", oct, "\n",sep="");
      }
    }
    return(df);
  }

  invisible()
} # plotSymbols()

availColors <- function (indx = 0:6)
{
    for (ii in unique(indx)) {
        is <- 100 * ii + 1:100
        if (min(is) > length(colors())) {
            cat("Maximum value of arg is", floor(length(colors())/100),
                "\n")
            return(NULL)
        }
        foo <- matrix(colors()[is], nrow = 10)
        par(mar = c(3, 3, 0.25, 0.25))
        plot(1:10, 1:10, type = "n", yaxt = "n", xlab = "", ylab = "")
        axis(2, at = 1:10, lab = 10:1)
        for (j in 1:10) {
            for (i in 1:10) {
                points(j, 11 - i, col = foo[i, j], pch = 16,
                  cex = 4)
                text(j, 11 - i - 0.3, foo[i, j], cex = 0.8)
            }
        }
        if (length(indx) > 1 & ii < max(indx))
            readline(paste("Currently showing group", ii, "  CR to continue "))
    }
    invisible(foo)
}

plotSymbolsFonts <- function (fn=1) {
    i <- 0:255
    ncol <- 16
    opar <- par(cex.axis = 0.7, mar = c(3, 3, 3, 3) + 0.1)
    plot(i%%ncol, 1 + i%/%ncol, pch=i, font=fn, xlab = "", ylab = "", 
        axes = FALSE)
    axis(1, at = 0:15)
    axis(2, at = 1:16, labels = 0:15 * 16, las = 2)
    axis(3, at = 0:15)
    axis(4, at = 1:16, labels = 0:15 * 16 + 15, las = 2)
    par(opar)
}
plt <- function(VIEW,f,file="",horizontal = FALSE) { ## C.Hoffmann,  2003-09-16
 ## f MUST NOT contain a call to postscript !!
  if (is.na(VIEW)) VIEW <- "NA"
  if (file=="") file <- "Rplots"
  switch (VIEW,
    "NA"   = NA,
    "see"  = f,
    "eps"  = {f; dev.copy2eps(file=paste(file,".eps",sep=""),horizontal = horizontal, onefile = FALSE, paper = "default")},
    "ps"   =,"ps+p" =
             {postscript(file=paste(file,".ps",sep=""),print.it=VIEW=="ps+p",onefile=FALSE, horizontal = horizontal, paper = "default");
              on.exit({dev.off();dev.set(dev.prev())}); f},
    "pdf"  = {pdf(file=paste(file,".pdf",sep=""));
              on.exit(dev.off()); f},
    print(">>> plt:  Use VIEW=c('NA','see','eps','ps','ps+p','pdf')")
  )
  invisible()
} ## end plt

plotTitStamp <- function (rows, cols, tit="", stampl="", f = function(x) 0, cex = 1.5, 
    reset = TRUE, outer = TRUE, oma = c(2, 2, 4, 2), mar = c(4, 4, 2, 1)) 
{
    oldpar <- par(mfrow = c(rows, cols), oma = oma, mar = mar)
    if (reset) 
        on.exit(par(oldpar))
    f
    L <- 1
    if (length(tit) > 1) { L <- 2; mtext(tit[1], side = 3, line = 2, outer = outer, cex = cex, adj = 0.5);}
    mtext(tit[L], side = 3, line = 2-L, outer = outer, cex = cex, 
        adj = 0.5)
    mtext(paste(stampl, if (nchar(stampl)) 
        ", ", datetime()), side = 1, line = 0, outer = outer, 
        cex = 0.5, adj = 1)
}  # end pltTitStamp

pltTSV <- function(VIEW="see",rows, cols, tit, stampl, f=function(x) 0, cex=1.5,reset=TRUE,outer=TRUE,oma=c(2,2,4,2),mar=c(4,4,2,1),file=stampl,horizontal=TRUE){ ## f MUST NOT contain a call to postscript !!
  plt(VIEW,plotTitStamp(rows, cols, tit, stampl, f=f, cex=cex,reset=reset,outer=outer,oma=oma,mar=mar),file=file,horizontal=horizontal)
} ## end pltTSV

pltCharMat <- function(m,tit) {
  n22 <- n2cCompact(m)
  cM <- charMat(n22)
  xl <- lattice:::extend.limits(range(cM$x),prop=0.07)
  plot(xl,range(cM$y),type="n",main=paste(tit,", ",rev(n22)[1],sep=""))
  text(cM$x,cM$y,cM$tx)
}  ## pltCharMat

pltHist <- function(data,rows=round(sqrt(ncol(data))),cols=ceiling(ncol(data)/rows)) {pltTSV("see",rows,cols,deparse(substitute(data)),"",{for (ii in seq(ncol(data))) hist(data[,ii],main=names(data[ii]),xlab="")}) }  ## pltHist

pltSplomT <- function (data, mainL = deparse(substitute(data)), xlabL = "", 
    hist = c("h", "d", "b"), adjust = 1, hist.col = trellis.par.get("strip.background")$col[5], cex.diag = 1, h.diag=0.4, ...) {
  mxnam <- max(nchar(names(data)))
  lnam  <- ncol(data)
  ce    <- 100*cex.diag*get.gpar()$cex/lnam
  cexd  <- ce/mxnam
  cexn  <- ce/5
  print(splom(~data, as.matrix = TRUE, main = mainL, xlab = paste(xlabL, 
    datetime(), sep = if (nchar(xlabL) > 0) ", " else ""),
    upper.panel = function(x, y, breaks = NULL, ...) {
      ccr <- cor(x, y, use = "complete.obs")
      ccq <- sqrt(max(abs(ccr),0.05))
      grid.text(round(ccr, 2), gp = gpar(cex = cexn*ccq))
    },
    lower.panel = function(x, y, ...) {
      options(show.error.messages = FALSE)
      try(panel.xyplot(x, y, type = c("p", "smooth"), col.line = "red", 
          pch = 3, cex = 1.5/dim(data)[2], ...))
      lo <- try(loess.smooth(y, x, ...))
      if (!inherits(lo,"try-error")) panel.lines(lo$y, lo$x, col.line = "blue", ...)
      options(show.error.messages = TRUE)
    },
    diag.panel = function(x, varname, limits, ...) {
      d <- density(x[!is.na(x)])
      yrng <- range(d$y)
      ylim <- yrng + 0.07 * c(-1, 1) * diff(yrng)
      xlim <- current.panel.limits()$xlim
      pushViewport(viewport(xscale = xlim, yscale = ylim))
      if (hist %in% c("h", "b")) {
        panel.histogram(x[!is.na(x)], breaks = NULL, col = hist.col, type = "density", ...)
      }
      if (hist %in% c("d", "b")) {
        llines(d)
      }
      grid.text(varname,  y=unit(h.diag,"npc"), gp = gpar(cex = cexd))
      popViewport()
    }, varnames = abbreviate(names(data)), pscales = 0 )
  )
}  ## end pltSplomT
T3plot <- function(x,lab=paste("T3 plot of ",deparse(substitute(x))),legend.pos="bottom", cex=0.6, ...) {
  T3 <- function(x,v) {
  # calculation of the 3rd derivative of log(m <- n(v)) for
  # nsimul simulated series, each with ndata observations
  # x: vector with observations (nsimul simulations)
    v <- cbind(v)
    n <- length(x)
    ndata <- n
    m <- nrow(v)
    xx <- matrix(rep(x,m),ncol=m,byrow=FALSE)
    vv <- matrix(rep(v,n),ncol=m,byrow=TRUE)
    sumvec <- rbind((1:ndata)/(1:ndata))
    m0 <- sumvec%*%(1/ndata*exp(xx*vv))
    m1 <- 1/ndata*sumvec%*%(xx*exp(xx*vv))
    m2 <- 1/ndata*sumvec%*%(xx^2*exp(xx*vv))
    m3 <- 1/ndata*sumvec%*%(xx^3*exp(xx*vv))
    (m3*m0-3*m2*m1+2*m1^3/m0)/m0^2
  }

  x1 <- x[is.na(x)==FALSE]
  ndata <- length(x1)
  vmax <- 1
  delta <- 0.05
  nsteps <- trunc(vmax/delta)
  sqrtn <- sqrt(ndata)
  
  #--- values in the interval [-vmax,vmax] for which 3rd derivative
  #--- will be calculated
  
  v <- -vmax+(0:(nsteps-1))*delta
  v <- c(v,0,-v[nsteps:1])
  
  #--- standardization of data
  
  x1 <- (x1-mean(x1))/sqrt(var(x1))
  
  #--- calculation of 3rd derivative Tsimul
  
  Tsimul <- sqrtn*T3(x1,v)
  
  SD <- c(9.61361441746065, 8.64515922634257, 7.79296148487048,
  7.04237226412238, 6.38080584272215,
  5.79744863963072, 5.28301418419464, 4.82953690371646,
  4.43019863437543, 4.07918264344632,
  3.77155061867714, 3.50313856389591, 3.27046787778314,
  3.07066814694318, 2.90140845110933,
  2.76083439189198, 2.64750877045021, 2.56035496977797,
  2.49860362758496, 2.46174487159861,
  2.44948974278318, 2.46174487159861, 2.49860362758496,
  2.56035496977797, 2.64750877045021,
  2.76083439189198, 2.90140845110933, 3.07066814694318,
  3.27046787778314, 3.50313856389591,
  3.77155061867714, 4.07918264344632, 4.43019863437543,
  4.82953690371646, 5.28301418419464,
  5.79744863963072, 6.38080584272215, 7.04237226412238,
  7.79296148487048, 8.64515922634257,
  9.61361441746065)
  
  
  a1 <- 0.7168311; a2 <- -2.327602; a3 <- 3.688362
  
  m <- a1+a2/sqrt(ndata)+a3/ndata
  
  # confidence limits
  
  z1 <- qnorm(0.99)
  Tz1 <- (m+z1)*SD
  
  z5 <- qnorm(0.95)
  Tz5 <- (m+z5)*SD
  
  
  # plot of T3 and confidence limits
  ym <- min(Tsimul,-Tz1)
  plot(v,Tsimul,ylim=c(ym,max(Tsimul,Tz1)),type="l",
  xlab="t",ylab="T3",main=lab)
  lines(v,Tz1,lty=2,col=2)
  lines(v,-Tz1,lty=2,col=2)
  lines(v,Tz5,lty=4,col=3)
  lines(v,-Tz5,lty=4,col=3)
  legend(x=legend.pos,c("5%", "1%"), col = c(2,3), text.col= "black", lty = c(2,4), merge = TRUE, bg='white', cex=cex, ...)
}
".First.lib" <- function(lib, pkg) {
  require("cwhmath")
  require("cwhstring")
}
