R/plotting.R

Defines functions whiskers mylines Pal ColToHex DecToHex SetAlpha DrawBand add.mtext.label myhist mymatplot abline.shade.2 abline.shade abline.pt.slope abline.pts corplot.formula corplot.default corplot my.interaction.plot myboxplot.list myboxplot.data.frame myboxplot.formula myboxplot myforestplot mypairs panel.nothing panel.hist panel.cor mylegend mytiff mypng get.width.height mydev.off myplot.loess myplot

Documented in abline.pts abline.pt.slope abline.shade abline.shade.2 add.mtext.label corplot corplot.default corplot.formula myboxplot myboxplot.data.frame myboxplot.formula myboxplot.list mydev.off myforestplot myhist my.interaction.plot mylegend mylines mymatplot mypairs myplot myplot.loess mypng mytiff panel.cor panel.hist panel.nothing whiskers

myplot <- function(object, ...) UseMethod("myplot") 

# plot x versus fitted
myplot.loess = function(object, xlab="x", ylab="fitted", ...) {
    plot(object$x[order(object$x)], object$fitted[order(object$x)], xlab=xlab, ylab=ylab, ...)    
} 

# one issue with myfigure/mydev.off is that positioning of legend depends on the graphical window size in R
# bg is needed b/c by default the bg is transparent
myfigure=function (mfrow=c(1,1), mfcol=NULL, width=NULL, height=NULL, oma=NULL, mar=NULL, main.outer=FALSE, bg=NULL) {        
    if (!is.null(mfcol)) {
        nrow=mfcol[1]; ncol=mfcol[2]        
    } else {
        nrow=mfrow[1]; ncol=mfrow[2]
    }        
    if(is.null(width) | is.null(height))  tmp=get.width.height(nrow,ncol) else tmp=c(width,height)
 #   unlockBinding(".mydev", getNamespace("kyotil")) #won't pass rcmdcheck 
    eval(eval(substitute(expression(.mydev <<- list(width=tmp[1],height=tmp[2])))))             
    
    if (!is.null(mfcol)) par(mfcol=mfcol) else par(mfrow=mfrow)    
    #needed for dev.copy
    dev.control(displaylist = "enable")
    if (!is.null(oma)) par(oma=oma)
    if (!is.null(mar)) par(mar=mar)    
    if (main.outer) {
        tmp=par()$oma
        tmp[3]=tmp[3]+1
        par(oma=tmp)
    }    
    if(!is.null(bg)) par(bg=bg)
}
mydev.off=function(file="temp", ext=c("pdf"), res=200, mydev=NULL, silent=TRUE) {        
    if (!is.null(mydev)) .mydev=mydev
    exts=unlist(strsplit(ext, ","))
    tmp=strsplit(file,"/")[[1]]
    for (ext in exts) {
        if (ext=="pdf") {
            subfolder=concatList(c(tmp[-length(tmp)], "pdf"), sep="/")
            filename=if(file.exists(subfolder))  subfolder%.%"/"%.%last(tmp) else file
            dev.copy(pdf,        file=filename%.%"."%.%ext, width=.mydev$width, height=.mydev$height, paper="special")
            if (!silent) cat("Saving figure to "%.%paste(filename,sep="")%.%"."%.%ext%.%"\n")        
        } else if (ext=="eps") {
            subfolder=concatList(c(tmp[-length(tmp)], "eps"), sep="/")
            filename=if(file.exists(subfolder))  subfolder%.%"/"%.%last(tmp) else file
            dev.copy(postscript, file=filename%.%"."%.%ext, width=.mydev$width, height=.mydev$height, paper="special", horizontal=FALSE)
            if (!silent) cat("Saving figure to "%.%paste(filename,sep="")%.%"."%.%ext%.%"\n")        
        } else if (ext=="png") {
            subfolder=concatList(c(tmp[-length(tmp)], "png"), sep="/")
            filename=if(file.exists(subfolder))  subfolder%.%"/"%.%last(tmp) else file
            dev.copy(png,    filename=filename%.%"."%.%ext, width=.mydev$width, height=.mydev$height, units="in", res=res)
            if (!silent) cat("Saving figure to "%.%paste(filename,sep="")%.%"."%.%ext%.%"\n")        
        } else if (ext=="tiff") {
            subfolder=concatList(c(tmp[-length(tmp)], "tiff"), sep="/")
            filename=if(file.exists(subfolder))  subfolder%.%"/"%.%last(tmp) else file
            dev.copy(tiff,   filename=filename%.%"."%.%ext, width=.mydev$width, height=.mydev$height, units="in", res=res, compression="jpeg")
            if (!silent) cat("Saving figure to "%.%paste(filename,sep="")%.%"."%.%ext%.%"\n")        
        }
        dev.off()
    }
    # this resets all pars, important when myfigure contains oma or mar
    resetPar <- function() {
        dev.new()
        op <- par(no.readonly = TRUE)
        dev.off()
        op
    }    
    par(resetPar())
}

get.width.height=function(nrow,ncol){
    if (nrow==1 & ncol==1) {width=6.7; height=6.7
    } else if (nrow==1 & ncol==2) {width=9.7; height=5
    } else if (nrow==1 & ncol==3) {width=9.7; height=3.4
    } else if (nrow==1 & ncol==4) {width=14; height=3.4

    } else if (nrow==2 & ncol==3) {width=9.7; height=6.7
    } else if (nrow==2 & ncol==4) {width=13; height=6.7
    } else if (nrow==2 & ncol==2) {width=8; height=8
    } else if (nrow==2 & ncol==1) {width=6.7; height=9.7
    
    } else if (nrow==3 & ncol==6) {width=17.5; height=9
    } else if (nrow==3 & ncol==7) {width=17.5; height=7
    } else if (nrow==3 & ncol==5) {width=15; height=9.6
    } else if (nrow==3 & ncol==4) {width=12; height=9.6
    } else if (nrow==3 & ncol==3) {width=9.7; height=10.3
    } else if (nrow==3 & ncol==1) {width=6; height=9.7
    } else if (nrow==3 & ncol==2) {width=6.7; height=10.3

    } else if (nrow==4 & ncol==1) {width=4; height=13
    } else if (nrow==4 & ncol==2) {width=6; height=13
    } else if (nrow==4 & ncol==3) {width=9; height=12
    } else if (nrow==4 & ncol==4) {width=9.7; height=10.3
    } else if (nrow==4 & ncol==5) {width=15; height=12.5
    } else if (nrow==4 & ncol==6) {width=15; height=10
    } else if (nrow==4 & ncol==7) {width=17.5; height=9
    } else if (nrow==4 & ncol==9) {width=20; height=9
    } else if (nrow==4 & ncol==8) {width=17.5; height=9
    
    } else if (nrow==5 & ncol==1) {width=5; height=13
    } else if (nrow==5 & ncol==2) {width=7; height=15
    } else if (nrow==5 & ncol==3) {width=9; height=15
    } else if (nrow==5 & ncol==4) {width=12; height=15
    } else if (nrow==5 & ncol==5) {width=15; height=15
    } else if (nrow==5 & ncol==6) {width=9; height=8.3

    } else if (nrow==6 & ncol==5) {width=18; height=17
    } else if (nrow==6 & ncol==3) {width=9; height=19
    } else if (nrow==6 & ncol==4) {width=12; height=19

    } else if (nrow==7 & ncol==3) {width=9; height=22
    } else if (nrow==7 & ncol==5) {width=18; height=19

    } else if (nrow==8 & ncol==5) {width=10; height=16
    } else {
        print ("nrow x ncol not supported: "%.%nrow%.%" x "%.%ncol %.% ". Default to width 10, height 10")
        width=10; height=10
    }
    return(c(width,height))
}

##test

#mypdf(mfrow=c(1,3),file="test1x3");plot(1:10,main="LUMX",xlab="t",ylab="y");plot(1:10);plot(1:10);dev.off()
#mypdf(mfrow=c(2,3),file="test2x3");plot(1:10,main="LUMX",xlab="t",ylab="y");plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);dev.off()
#mypdf(mfrow=c(4,4),file="test4x4");plot(1:10,main="LUMX",xlab="t",ylab="y");plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10);plot(1:10,main="Luminex");dev.off()
#mypdf(mfrow=c(1,1),file="test1x1", );plot(1:10,main="LUMX",xlab="t",ylab="y");dev.off()

#    # use convert.ext to convert one format to another
#    # get file name relative to getwd()
#    # .Devices sometimes have "null device", sometimes have "windows"
#    tmp=which(sapply(.Devices, function(x) x=="pdf"))
#    if(length(tmp)==1) {
#        filename=attr(.Devices[[tmp]],"filepath")         
#    }
#    # close pdf device or default device
#    dev.off()
#    # convert file if needed
#    if(png & length(tmp)==1) {
#        system('"C:/Program Files/ImageMagick-7.0.3-Q16/convert.exe" -resize 2000 -density 200 "'%.%getwd()%.%'/'%.%filename%.%'" "'%.%getwd()%.%'/'%.%fileStem(filename)%.%'.png"')
#    }        

# deprecated
# cannot print both to pdf and tiff or print both to screen and pdf, 
mypdf=function (...) mypostscript(ext="pdf",...)
mypng=function(...) mypostscript(ext="png",...)
mytiff=function(...) mypostscript(ext="tiff",...)
mypostscript=function (file="temp", mfrow=c(1,1), mfcol=NULL, width=NULL, height=NULL, ext=c("eps","pdf","png","tiff"), oma=NULL, mar=NULL,main.outer=FALSE, save2file=TRUE, res=200, silent=TRUE, ...) {    
    
    ext=match.arg(ext)
    
    if (!is.null(mfcol)) {
        nrow=mfcol[1]; ncol=mfcol[2]        
    } else {
        nrow=mfrow[1]; ncol=mfrow[2]
    }
    
    #if (nrow>4) warning ("nrow > 4 will not fit a page without making the figures hard to see")
    
    # sca controls how much to scale down for use in a paper
    if(is.null(width) | is.null(height))  tmp=get.width.height(nrow,ncol) else tmp=c(width,height)
    width=tmp[1]; height=tmp[2]
    
    if(save2file){      
        if (ext=="pdf") {
            pdf (paper="special", file=file%.%"."%.%ext, width=width, height=height, ...)
        } else if (ext=="eps") {
            postscript (paper="special", horizontal=FALSE, file=file%.%"."%.%ext, width=width, height=height, ...)
        } else if (ext=="png") {
            png (filename=file%.%"."%.%ext, width=width, height=height, units="in", res=res, ...)
        } else if (ext=="tiff") {
            tiff (filename=file%.%"."%.%ext, width=width, height=height, units="in", res=res, compression="jpeg", ...)
        }
        if (!silent) cat("Saving figure to "%.%paste(file,sep="")%.%"\n")        
    } else {
        if (!silent) print("not saving to file")
    }
    
    if (!is.null(mfcol)) par(mfcol=mfcol)
    else par(mfrow=mfrow)    
    
    if (!is.null(oma)) par(oma=oma)
    if (!is.null(mar)) par(mar=mar)
    
    if (main.outer) {
        tmp=par()$oma
        tmp[3]=tmp[3]+1
        par(oma=tmp)
    }
    
}



# if lty is specified, a line will be drawn
mylegend=function(legend, x, y=NULL, lty=NULL,bty="n", ...) {
    if(is.null(y)) x=switch(x, "topleft", "top", "topright", "left", "center" , "right", "bottomleft", "bottom", "bottomright")
    legend(bty=bty,x=x, y=y, legend=legend, lty=lty, ...)
}


# copied from pairs help page
# if cex.cor is negative, the sign is reversed and the font of cor is fixed. otherwise, by default, the font of cor is proportional to cor
# allow cor to be spearman or pearson
# will generating lots of warnings, ignore them
panel.cor <- function(x, y, digits=2, prefix="", cex.cor, cor., leading0=FALSE, cex.cor.dep=TRUE, ...)
{
    usr <- par("usr"); on.exit(par(usr))
    par(usr = c(0, 1, 0, 1))
    r <- cor(x, y, method=ifelse(missing(cor.), "spearman", cor.), use="pairwise.complete.obs")
    txt <- format(c(r, 0.123456789), digits=digits)[1]
    txt <- paste(prefix, txt, sep="")
    if(!leading0) txt = sub("0","",txt)
    if(missing(cex.cor)) cex.cor <- 2.5
    if(cex.cor.dep) {
        text(0.5, 0.5, txt, cex = cex.cor*ifelse(abs(r)<0.1, sqrt(0.1), sqrt(abs(r)) ))
    } else {
        text(0.5, 0.5, txt, cex = cex.cor) # do this if we don't want cex to depend on correlations
    }
#    print(txt); text(.1, .1, "a"); text(.9, .9, "a")
#    abline(v=1e3)
}
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="cornflowerblue", ...)
#    abline(v=1e3)
#    abline(h=.5)
}
panel.smooth.only=function (x, y, col = par("col"), bg = NA, pch = par("pch"), 
    cex = 1, col.smooth = "red", span = 2/3, iter = 3, ...) 
{
    #points(x, y, pch = pch, col = col, bg = bg, cex = cex)
    ok <- is.finite(x) & is.finite(y)
    if (any(ok)) 
        lines(stats::lowess(x[ok], y[ok], f = span, iter = iter), 
            col = col.smooth, ...)
}

panel.nothing=function(x, ...) {}
# panel.ladder is a copy of panel.smooth with modifications
panel.ladder=function (x, y, col = par("col"), bg = NA, 
    cex = 1, col.smooth = "red", span = 2/3, iter = 3, cex.text=1.2, cex.star=2,
    cor., add.line=T, add.text=T, ...) 
{
    points(x, y, pch = 20, col = col, bg = bg, cex = cex)
    dxy=as.data.frame(cbind(x,y)); dxy=dxy[complete.cases(dxy),]
    r.lm=lm(y~x, dxy) 
    if(add.line) lines(r.lm, col="1", pred.level=NA)#, args.pband=list(col=SetAlpha("blue",1)) )# 
        
    r <- cor(x, y, method=ifelse(missing(cor.), "spearman", cor.), use="pairwise.complete.obs")
    x.1=(x-min(x,na.rm=T))/(max(x,na.rm=T)-min(x,na.rm=T))
    y.1=(y-min(y,na.rm=T))/(max(y,na.rm=T)-min(y,na.rm=T))
    p=suppressWarnings(cor.test(x,y, method = ifelse(missing(cor.), "spearman", cor.))$p.value)
    sig=ifelse (round(p,2)<=0.05,ifelse (p<0.01,  ifelse (p<0.01,"***","**")  ,"*"),"")
    if(add.text) text(0*(max(x,na.rm=T)-min(x,na.rm=T))+min(x,na.rm=T), y = 1*(max(y,na.rm=T)-min(y,na.rm=T))+min(y,na.rm=T), labels = "r = "%.%round(r,2), adj = c(0,1), pos = NULL, offset = 0.5, vfont = NULL, cex = cex.text, col = 2, font = 2)
    if(add.text) text(1*(max(x,na.rm=T)-min(x,na.rm=T))+min(x,na.rm=T), y = 1*(max(y,na.rm=T)-min(y,na.rm=T))+min(y,na.rm=T), labels = sig,                 adj = c(1,1), pos = NULL, offset = 0.5, vfont = NULL, cex = cex.star, col = 2, font = 2)

#    ok <- is.finite(x) & is.finite(y)
#    if (any(ok)) 
#        lines(stats::lowess(x[ok], y[ok], f = span, iter = iter), 
#            col = col.smooth, ...)
}
# when log="xy" is passed in, diag and upper panels do not print properly
# cex.labels controls the cex of diagonal panels text size
mypairs=function(dat, ladder=FALSE, show.data.cloud=TRUE, ladder.add.line=T, ladder.add.text=T, ...){
    if(ladder) { # ladder plot
        .pairs(dat, lower.panel=panel.ladder, upper.panel=NULL, diag.panel=NULL, xaxt="n", yaxt="n", gap=0, add.line=ladder.add.line, add.text=ladder.add.text)
    } else {
        .pairs(dat, lower.panel=if (show.data.cloud) panel.smooth else panel.smooth.only, upper.panel=panel.cor, diag.panel=panel.hist, ...)
    }    
}
# a copy of pairs with only one change that is needed to not draw boxes long the diagonal line
.pairs=function (x, labels, panel = points, ...,
          lower.panel = panel, upper.panel = panel,
          diag.panel = NULL, text.panel = textPanel,
          label.pos = 0.5 + has.diag/3, line.main = 3,
          cex.labels = NULL, font.labels = 1, 
          row1attop = TRUE, gap = 1, log = "", show.axis=TRUE){
    if(doText <- missing(text.panel) || is.function(text.panel))
    textPanel <-
        function(x = 0.5, y = 0.5, txt, cex, font)
        text(x, y, txt, cex = cex, font = font)# replacing txt with parse(text=txt) allows us to print math, but it chokes at space
        #text(x, y, parse(text=txt), cex = cex, font = font)# parse(text=txt) allows us to print math
    
    localAxis <- function(side, x, y, xpd, bg, col=NULL, main, oma, ...) {
      ## Explicitly ignore any color argument passed in as
      ## it was most likely meant for the data points and
      ## not for the axis.
        xpd <- NA
        if(side %% 2L == 1L && xl[j]) xpd <- FALSE
        if(side %% 2L == 0L && yl[i]) xpd <- FALSE
        if(side %% 2L == 1L) Axis(x, side = side, xpd = xpd, ...)
        else Axis(y, side = side, xpd = xpd, ...)
    }
    
    localPlot <- function(..., main, oma, font.main, cex.main) plot(...)
    localLowerPanel <- function(..., main, oma, font.main, cex.main)
        lower.panel(...)
    localUpperPanel <- function(..., main, oma, font.main, cex.main)
        upper.panel(...)
    
    localDiagPanel <- function(..., main, oma, font.main, cex.main)
        diag.panel(...)
    
    dots <- list(...); nmdots <- names(dots)
    if (!is.matrix(x)) {
        x <- as.data.frame(x)
        for(i in seq_along(names(x))) {
            if(is.factor(x[[i]]) || is.logical(x[[i]]))
               x[[i]] <- as.numeric(x[[i]])
            if(!is.numeric(unclass(x[[i]])))
                stop("non-numeric argument to 'pairs'")
        }
    } else if (!is.numeric(x)) stop("non-numeric argument to 'pairs'")
    panel <- match.fun(panel)
    if((has.lower <- !is.null(lower.panel)) && !missing(lower.panel))
        lower.panel <- match.fun(lower.panel)
    if((has.upper <- !is.null(upper.panel)) && !missing(upper.panel))
        upper.panel <- match.fun(upper.panel)
    if((has.diag  <- !is.null( diag.panel)) && !missing( diag.panel))
        diag.panel <- match.fun( diag.panel)
    
    if(row1attop) {
        tmp <- lower.panel; lower.panel <- upper.panel; upper.panel <- tmp
        tmp <- has.lower; has.lower <- has.upper; has.upper <- tmp
    }
    
    nc <- ncol(x)
    if (nc < 2) stop("only one column in the argument to 'pairs'")
    
    # names to print on the diagonal
    if(doText) {
        if (missing(labels)) {
            labels <- colnames(x)
            if (is.null(labels)) labels <- paste("var", 1L:nc)
        }
        else if(is.null(labels)) doText <- FALSE
    }
    
    oma <- if("oma" %in% nmdots) dots$oma
    main <- if("main" %in% nmdots) dots$main
    if (is.null(oma))
    oma <- c(4, 4, if(!is.null(main)) 6 else 4, 4)
    opar <- par(mfrow = c(nc, nc), mar = rep.int(gap/2, 4), oma = oma)
    #myprint(oma,gap)
    on.exit(par(opar))
    dev.hold(); on.exit(dev.flush(), add = TRUE)
    
    xl <- yl <- logical(nc)
    if (is.numeric(log)) xl[log] <- yl[log] <- TRUE
    else {xl[] <- grepl("x", log); yl[] <- grepl("y", log)}
    for (i in if(row1attop) 1L:nc else nc:1L)
        for (j in 1L:nc) {
            l <- paste0(ifelse(xl[j], "x", ""), ifelse(yl[i], "y", ""))
            localPlot(x[, j], x[, i], xlab = "", ylab = "",
                      axes = FALSE, type = "n", ..., log = l)
            if( i==j | (i < j && has.lower) || (i > j && has.upper) ) { 
                if (i!=j) box()# YF: add i==j 
                if(show.axis){
                    if(i == 1  && (!(j %% 2L) || !has.upper || !has.lower ))
                        localAxis(1L + 2L*row1attop, x[, j], x[, i], ...)
                    if(i == nc && (  j %% 2L  || !has.upper || !has.lower ))
                        localAxis(3L - 2L*row1attop, x[, j], x[, i], ...)
                    if(j == 1  && (!(i %% 2L) || !has.upper || !has.lower ))
                        localAxis(2L, x[, j], x[, i], ...)
                    if(j == nc && (  i %% 2L  || !has.upper || !has.lower ))
                        localAxis(4L, x[, j], x[, i], ...)
                }
                mfg <- par("mfg")
                if(i == j) {
                    if (has.diag) localDiagPanel(as.vector(x[, i]), ...)
            if (doText) {
                        par(usr = c(0, 1, 0, 1))
                        if(is.null(cex.labels)) {
                            l.wid <- strwidth(labels, "user")
                            cex.labels <- max(0.8, min(2, .9 / max(l.wid)))
                        }
                        xlp <- if(xl[i]) 10^0.5 else 0.5
                        ylp <- if(yl[j]) 10^label.pos else label.pos
                        text.panel(xlp, ylp, labels[i],
                                   cex = cex.labels, font = font.labels)
                    }
                } else if(i < j)
                    localLowerPanel(as.vector(x[, j]), as.vector(x[, i]), ...)
                else
                    localUpperPanel(as.vector(x[, j]), as.vector(x[, i]), ...)
                if (any(par("mfg") != mfg))
                    stop("the 'panel' function made a new plot")
            } else par(new = FALSE)
    
        }
    if (!is.null(main)) {
        font.main <- if("font.main" %in% nmdots) dots$font.main else par("font.main")
        cex.main <- if("cex.main" %in% nmdots) dots$cex.main else par("cex.main")
        mtext(main, 3, line.main, outer=TRUE, at = 0.5, cex = cex.main, font = font.main)
    }
    invisible(NULL)
}


getMfrow=function (len) {
    ret=NULL
    if (len==1) { 
        ret=c(1,1)
    } else if (len==2) { 
        ret=c(1,2)
    } else if (len==3) { 
        ret=c(1,3)
    } else if (len<=4) { 
        ret=c(2,2)
    } else if (len<=6) { 
        ret=c(2,3)
    } else if (len<=9) { 
        ret=c(3,3)
    } else if (len<=12) { 
        ret=c(3,4)
    } else if (len<=16) { 
        ret=c(4,4)
    } else if (len<=20) { 
        ret=c(4,5)
    } else if (len<=25) { 
        ret=c(5,5)
    }
    ret
}


empty.plot=function () {
    plot(1,1,type="n",xlab="",ylab="",xaxt="n", yaxt="n", bty="n")
}

# dat
myforestplot=function(dat, xlim=NULL, xlab="", main="", col.1="red", col.2="blue",plot.labels=TRUE,order=FALSE,decreasing=FALSE, vline=TRUE,cols=NULL,log="",null.val=NULL) {
    if (order) dat=dat[order(dat[,1],decreasing=decreasing),] 
    p=nrow(dat)    
    # makes no plot, but helps set the x axis later
    plot(c(dat[,2], dat[,3]),rep(1:p,2), xlim=xlim, yaxt="n", xaxt="s", xlab=xlab, ylab="", main="", type="n", cex.main=1.4, axes=F, log=log)
    mtext(side=3, line=3, adj=0, text=main, cex=1.4, font=2, xpd=NA)
    if(is.null(null.val)) {
        if (range(dat[,2:3])[1]>0) null.val=1 else null.val=0 # if all values are greater than 0, 1 is probably the null, otherwise, 0 is probably the null
    }
    if(vline) abline(v=null.val, col="gray")
    if(is.null(cols)) cols=ifelse(dat[,4]<0.05, col.1, col.2)
    points(dat[,1], nrow(dat):1, pch=19, col=cols)
    segments(dat[,2], nrow(dat):1, dat[,3], nrow(dat):1, lwd=2, col=cols)
    axis(1, cex.axis=1.4)
    # add labels
    if (plot.labels) axis(4, at=p:1, rownames(dat), tick=F, las=2, col=1, cex.axis=1, xpd=NA, line=-.5)
}


myboxplot <- function(object, ...) UseMethod("myboxplot") 


# this function may fail sometimes, most likely at eval
# myboxplot.formula and myboxplot.list make a boxplot with data points and do inferences for two group comparions. 
# cex=.5; ylab=""; xlab=""; main=""; box=FALSE; highlight.list=NULL; at=NULL;pch=1;col=1;
# friedman.test.formula is of the form a ~ b | c
myboxplot.formula=function(formula, data, cex=.5, xlab="", ylab="", main="", box=TRUE, at=NULL, na.action=NULL, p.val=NULL,
    pch=1, col=1, test="", friedman.test.formula=NULL, reshape.formula=NULL, reshape.id=NULL, jitter=TRUE, add.interaction=FALSE,  drop.unused.levels = TRUE, bg.pt=NULL, add=FALSE, seed=1, write.p.at.top=FALSE, ...){
    
    save.seed <- try(get(".Random.seed", .GlobalEnv), silent=TRUE) 
    if (inherits(save.seed,"try-error")) {        
        set.seed(1)
        save.seed <- get(".Random.seed", .GlobalEnv)
    }                        
    set.seed(seed)
    
     # removes empty groups formed through model.frame
     mf=model.frame(formula, data)
     response <- attr(attr(mf, "terms"), "response") 
     tmp.dat=split(mf[[response]], mf[-response])
     if(drop.unused.levels) {
         len.n=sapply(tmp.dat, length)
         tmp.dat=tmp.dat[len.n!=0]
     }
     res=boxplot(tmp.dat, range=0, xlab=xlab, at=at, col=NULL, cex=cex, 
        boxlty=if(!box) 0 else NULL,whisklty=if(!box) 0 else NULL,staplelty=if(!box) 0 else NULL,
        #pars = list(boxwex = if(box) 0.8 else 0, staplewex = if(box) 0.5 else 0, outwex = if(box) 0.5 else 0), 
        main=main, ylab=ylab, add=add, ...)
    
    # na.action is key below b/c otherwise pch vector will be out of sync with data when there are missing data
    dat.tmp=model.frame(formula, data, na.action=NULL);# str(dat.tmp); str(data)
    xx=interaction(dat.tmp[,-1]); #str(xx); print(table(xx))
    if(drop.unused.levels) xx=droplevels(xx)
    if(is.null(at)){        
        xx=as.numeric(xx); #print(table(xx))
    } else{
        xx=at[xx]
    }      
    if (add.interaction) jitter=FALSE
    if (jitter) xx=jitter(xx)  
    points(xx, dat.tmp[[1]], cex=cex,pch=pch,col=col, bg=bg.pt)
    
    # restore rng state 
    assign(".Random.seed", save.seed, .GlobalEnv)     
    
    # inference
    # if p.val is passed in, then use that p.val
    x.unique=unique(dat.tmp[[2]])
    if (length(test)>0) {
        sub=""
        pvals=NULL
        if ("t" %in% test) {
            if (is.null(p.val)) p.val=t.test(formula, data)$p.value
            pvals=c(pvals, Student=p.val)
            if (write.p.at.top) sub=paste0("p=",signif(p.val,2)) else sub=sub%.%" Student's t "%.%ifelse(length(test)==1,"p-val ","")%.%signif(p.val,2) 
        }
        if ("w" %in% test) {
            if (is.null(p.val)) p.val=suppressWarnings(wilcox.test(formula, data)$p.value)
            pvals=c(pvals, Wilcoxon=p.val)
            if (write.p.at.top) sub=paste0("p=",signif(p.val,2)) else sub=sub%.%" Wilcoxon "%.%ifelse(length(test)==1,"p-val ","")%.%signif(p.val,2)
        }
        if ("k" %in% test) {
            if (is.null(p.val)) p.val=kruskal.test(formula, data)$p.value
            pvals=c(pvals, Kruskal=p.val)
            if (write.p.at.top) sub=paste0("p=",signif(p.val,2)) else sub=sub%.%" Kruskal "%.%ifelse(length(test)==1,"p-val ","")%.%signif(p.val,2)
        }
        if ("f" %in% test) {
            if (!is.null(friedman.test.formula)) {
            # if there is missing data, this won't work, try the else and supply reshape.formula and reshape.id
                if (is.null(p.val)) p.val=friedman.test(friedman.test.formula, data)$p.value
                pvals=c(pvals, Friedman=p.val)
                if (write.p.at.top) sub=paste0("p=",signif(p.val,2)) else sub=sub%.%" Friedman "%.%ifelse(length(test)==1,"p-val ","")%.%signif(p.val,2)
            } else if (!is.null(reshape.formula) & !is.null(reshape.id)) {
                dat.wide=myreshapewide (reshape.formula, data, idvar = reshape.id)
                #str(dat.wide)# show this so that we know we are using the right data to do the test
                ftest = try(friedman.test (as.matrix(dat.wide[,-(1)])),silent=T)
                if (is.null(p.val)) if (!inherits(ftest,"try-error")) p.val=ftest$p.value else p.val=NA
                pvals=c(pvals, Friedman=p.val)
                if (add.interaction) my.interaction.plot(as.matrix(dat.wide[,-1]), add=T)
                if (write.p.at.top) sub=paste0("p=",signif(p.val,2)) else sub=sub%.%" Friedman "%.%ifelse(length(test)==1,"p-val ","")%.% ifelse (is.na(p.val), "NA", signif(p.val,2))
            } else warning("cannot perform Friedman test without friedman.test.formula or reshape.formula,reshape.id")
        }
        if (write.p.at.top) {
            if (pvals[1]<0.05) title(main=sub, line=.5, font.main=3)
        } else title(sub=sub, line=2.5)
        res$pvals=pvals
    }
    
    invisible(res)
    
}

myboxplot.data.frame=function(object, cex=.5, ylab="", xlab="", main="", box=TRUE, at=NULL, pch=1, col=1, test="", paired=FALSE, ...){
    myboxplot.list(as.list(object), cex=cex, ylab=ylab, xlab=xlab, main=main, box=box, at=at, pch=pch, col=col, test=test, ...)
}
# myboxplot.matrix=function(object, cex=.5, ylab="", xlab="", main="", box=TRUE, at=NULL, pch=1, col=1, test="", paired=FALSE, ...){
#     myboxplot.list(as.list(as.data.frame(object)), cex=cex, ylab=ylab, xlab=xlab, main=main, box=box, at=at, pch=pch, col=col, test=test, ...)
# }

myboxplot.list=function(object, paired=FALSE, ...){
    
    # make a dataframe out of list object
    dat=NULL
    if(is.null(names(object))) names(object)=1:length(object)
    for (i in 1:length(object)) {
        dat=rbind(dat,data.frame(y=object[[i]], x=names(object)[i]))
    }
    
    p.val=NULL
    if (paired) {
        if(length(object)==2) {
            p.val = wilcox.test(object[[1]], object[[2]], paired=TRUE)$p.value
        } else {
            stop("when it is paired, we expect a list of two")
        }
    }
        
    dat$x=factor(dat$x, levels=names(object))
    myboxplot(y~x, dat, p.val=p.val, ...)
    
}


# can use after myboxplot
# both dat must have two columns, each row is dat from one subject
# x.ori=0; xaxislabels=rep("",2); cex.axis=1; add=FALSE; xlab=""; ylab=""; pcol=NULL; lcol=NULL
my.interaction.plot=function(dat, x.ori=0, xaxislabels=rep("",2), cex.axis=1, add=FALSE, xlab="", ylab="", pcol=NULL, lcol=NULL, ...){
    if (!add) plot(0,0,type="n",xlim=c(1,2),ylim=range(dat), ylab=ylab, xlab=xlab, xaxt="n", ...)
    cex=.25; pch=19
    if (is.null(lcol)) lcol=ifelse(dat[,1]>dat[,2],"red","black") else if (length(lcol)==1) lcol=rep(lcol,nrow(dat))
    if (!is.null(pcol)) if (length(pcol)==1) pcol=matrix(pcol,nrow(dat),2)
    for (i in 1:nrow(dat)) {
        points (1+x.ori, dat[i,1], cex=cex, pch=pch, col=ifelse(is.null(pcol), 1, pcol[i,1]))
        points (2+x.ori, dat[i,2], cex=cex, pch=pch, col=ifelse(is.null(pcol), 1, pcol[i,2]))
        lines (1:2+x.ori, dat[i,], lwd=.25, col=lcol[i])
    }
    axis(side=1, at=1:2+x.ori, labels=xaxislabels, cex.axis=cex.axis)
}

# called butterfly.plot, because it is meant to plot two treatment arms at two time points, the two arms are plotted in a mirror fashion, see "by analyte.pdf" for an example
# if dat2 is null: dat is matrix with four columns. each row is one subject, the columns will be plotted side by side, with lines connecting values from one ptid
# if dat2 is not null, dat has two columns, which are plotted side by side with lines connecting them, same for dat2
# if add is true, no plot function will be called
butterfly.plot=function (dat, dat2=NULL, add=FALSE, xaxislabels=rep("",4), x.ori=0, xlab="", ylab="", cex.axis=1, ...){
    if (!add) plot(0,0,type="n",xlim=c(1,4),ylim=range(dat), xaxt="n", xlab=xlab, ylab=ylab, ...)
    for (i in 1:nrow(dat)) {
        lines (1:2+x.ori, dat[i,1:2], lwd=.25, col=ifelse(dat[i,1]<=dat[i,2],"red","black"))
        if (is.null(dat2)) {
            lines (2:3+x.ori, dat[i,2:3], lwd=.25, col="lightgreen")
            lines (3:4+x.ori, dat[i,3:4], lwd=.25, col=ifelse(dat[i,3]<=dat[i,4],"black","red"))
        }
    }
    if (!is.null(dat2)) {
        for (i in 1:nrow(dat2)) {
            lines (3:4+x.ori, dat2[i,1:2], lwd=.25, col=ifelse(dat2[i,1]<=dat2[i,2],"black","red"))
        }
    }
    axis(side=1, at=1:4+x.ori, labels=xaxislabels, cex.axis=cex.axis)
}


corplot <- function(object, ...) UseMethod("corplot") 

corplot.default=function(object,y,...){
    dat=data.frame(object,y)
    names(dat)=c("x1", "x2")
    corplot(x2~x1, dat, ...)
}

# col can be used to highlight some points
corplot.formula=function(formula,data,main="",method=c("pearson","spearman"),col=1,cex=.5,add.diagonal.line=TRUE,add.lm.fit=FALSE,add.loess.fit=FALSE,col.lm=2,add.deming.fit=FALSE,col.deming=4,add=FALSE,
    log="",same.xylim=FALSE,xlim=NULL,ylim=NULL, ...){
    vars=dimnames(attr(terms(formula),"factors"))[[1]]
    cor.=NULL
    if (length(method)>0) {
        cor.=sapply (method, function (method) {
            cor(data[,vars[1]],data[,vars[2]],method=method,use="p")
        })
        tmp=main==""
        main=main%.%ifelse(tmp, "", " (")
        main=main%.%"cor: "%.%concatList(formatDouble(cor.,2),"/")
        main=main%.%ifelse(tmp, "", ")")
    }

    if (!add) {
        if (same.xylim) {
            xlim=range(model.frame(formula, data))
            ylim=range(model.frame(formula, data))
        }
        plot(formula,data,main=main,col=col,cex=cex,log=log,xlim=xlim,ylim=ylim,...)
    } else {
        points(formula,data,main=main,col=col,cex=cex,log=log,...)
    }
    
    if(add.diagonal.line) abline(0,1)
    if(add.lm.fit) {
        fit=lm(formula, data)
        abline(fit,untf=log=="xy", col=col.lm)
    }
    if(add.loess.fit) {
        fit=loess(formula, data)
        mylines(fit$x,fit$fitted,col=col.lm)
    }
    if(add.deming.fit) {
        # this implementation is faster than the one by Therneau, Terry M.
        fit=Deming(model.frame(formula, data)[[2]], model.frame(formula, data)[[1]]) # this function is in Deming.R copied from MethComp package by Bendix Carstensen
        abline(coef(fit)["Intercept"], coef(fit)["Slope"], untf=log=="xy", col=col.deming)   
        # Therneau, Terry M.'s implementation in a loose R file that is in 3software folder, slower than Deming, but may be more generalized?
        #fit <- deming(model.frame(formula, data)[[2]], model.frame(formula, data)[[1]], xstd=c(1,0), ystd=c(1,0))
        #abline(fit, untf=log=="xy", col=col.deming)        
    }
    
    invisible(cor.)
}

abline.pts=function(pt1, pt2=NULL){
    if (is.null(pt2)) {
        if (nrow(pt1)>=2) {
            pt2=pt1[2,]
            pt1=pt1[1,]
        } else {
            stop("wrong input")
        }
    }
    slope=(pt2-pt1)[2]/(pt2-pt1)[1]
    intercept = pt1[2]-slope*pt1[1]
    abline(intercept, slope)
}
#abline.pts(c(1,1), c(2,2))

abline.pt.slope=function(pt1, slope, x2=NULL, ...){
    intercept = pt1[2]-slope*pt1[1]
    if (is.null(x2)) {
        abline(intercept, slope, ...)
    } else {
        pt2=c(x2, intercept+slope*x2)
        lines(c(pt1[1],pt2[1]), c(pt1[2],pt2[2]), ...)
    }
    
}

# put a shade in a rectangle between a point and one of the four quadrants
# pt is a vector of two values
# col is red blue gree
abline.shade=function(pt, type=5, col=c(0,1,0), alpha=0.3){
    usr <- par('usr')   
    # rec: xleft, ybottom, xright, ytop
    # usr: xleft, xright, ybottom, ytop
    # the first four types are quadrant
    if (type==1) {
        rect(pt[1], pt[2], usr[2], usr[4], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=alpha), border=NA) 
    } else if (type==2) {
        rect(pt[1], usr[3], usr[2], pt[2], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=alpha), border=NA) 
    } else if (type==3) {
        rect(usr[1], usr[3], pt[1], pt[2], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=alpha), border=NA) 
    } else if (type==4) {
        rect(usr[1], pt[2], pt[1], usr[4], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=alpha), border=NA) 
    } else if (type==5) {
        # between pt[1] and pt[2] horizontally
        rect(pt[1], usr[3], pt[2], usr[4], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=alpha), border=NA) 
    } else stop("type not recognized")
    
}

# put a shade between two lines
# x is a vector of two values
# col is red blue gree
abline.shade.2=function(x, col=c(0,1,0)){
    usr <- par('usr') 
    rect(x[1], usr[3], x[2], usr[4], col=rgb(red=col[1], blue=col[2], green=col[3], alpha=.5), border=NA) 
}


#abline.pt.slope(c(1,1), 1)
# When impute.missing.for.line is TRUE, lines are drawn even when there are missing values in between two observations
mymatplot=function(x, y, type="b", lty=c(1,2,1,2,1,2), pch=NULL, col=rep(c("darkgray","black"),each=3), xlab=NULL, ylab="", 
    draw.x.axis=TRUE, bg=NA, lwd=1, at=NULL, make.legend=TRUE, legend=NULL, impute.missing.for.line=TRUE,
    legend.x=9, legend.title=NULL, legend.cex=1, legend.lty=lty, legend.inset=0, xaxt="s", y.intersp=1.5, x.intersp=0.3, text.width=NULL, 
    add=FALSE, ...) {
    
    missing.y=FALSE
    if (missing(y)) {
        missing.y=TRUE
        y=x
        x=1:nrow(y)
    } 
    
    # fill in missing values if necessary, i.e. when there are lines to draw
    if (impute.missing.for.line & any(is.na(y)) & type %in% c("l","b")) {
        y.imputed=zoo::na.approx(y, x=x, na.rm=FALSE); rownames(y.imputed)=rownames(y)
        imputed=TRUE
        cat("imputing data ...\n")
    } else {
        imputed=FALSE
        y.imputed=y
    }
    
    if (is.null(xlab)) xlab=names(dimnames(y))[1]
    if (is.null(legend.title)) legend.title=names(dimnames(y))[2]
    # draw line first, then points
    if(type %in% c("l","b")) matplot(x, y.imputed, lty=lty, pch=pch, col=col, xlab=xlab, xaxt=xaxt, ylab=ylab, bg=bg, lwd=lwd, type="l", add=add, ...)
    if(type %in% c("p","b")) matplot(x, y, lty=lty, pch=pch, col=col, xlab=xlab, xaxt=xaxt, ylab=ylab, bg=bg, lwd=lwd, type="p", add=add | type!="p", ...)
    if (xaxt=="n") 
        if(missing.y & draw.x.axis) axis(side=1, at=if(is.null(at)) x else at, labels=if(is.null(at)) rownames(y) else at) else if (draw.x.axis) {
            axis(side=1, at=if(is.null(at)) x else at, labels=if(is.null(at)) x else at)
        }
    if (make.legend) {
        if (is.null(legend)) legend=colnames(y)
        if (length(unique(pch))>1) {
            mylegend(legend, x=legend.x, lty=legend.lty, title=legend.title, col=col, pt.bg=bg, cex=legend.cex, lwd=lwd, inset=legend.inset, y.intersp=y.intersp, x.intersp=x.intersp, text.width=text.width, pch=pch)
        } else {
            mylegend(legend, x=legend.x, lty=legend.lty, title=legend.title, col=col, pt.bg=bg, cex=legend.cex, lwd=lwd, inset=legend.inset, y.intersp=y.intersp, x.intersp=x.intersp, text.width=text.width)
        }
    }
}


myhist=function(x, add.norm=TRUE, col.norm="blue", ...){
    if (!add.norm) hist(x, ...) else {
        hist=hist(x,breaks=30, plot=F)
        dnorm=dnorm(seq(range(x)[1],range(x)[2], length=100),mean(x),sd(x))
        hist(x, freq=F, ylim=range(hist$density, dnorm), ...)
        lines(seq(range(x)[1],range(x)[2], length=100), dnorm, col=col.norm)
    }    
}


# eclipse
# plot.ellipse=function(x0,y0,a=1,b=1,theta=0,alpha=0,add=TRUE,...) {
#     theta <- seq(0, 2 * pi, length=500)
# #    x <- x0 + a * cos(theta)
# #    y <- y0 + b * sin(theta)    
#     x <- x0 + a * cos(theta) * cos(alpha) - b * sin(theta) * sin(alpha)
#     y <- y0 + a * cos(theta) * sin(alpha) + b * sin(theta) * cos(alpha)
#     if(add) {
#         lines(x,y,...)
#     } else plot(x, y, type = "l",...)
# }

add.mtext.label=function(text, cex=1.4, adj=-0.2) mtext(side=3, line=2, adj=adj, text=text, cex=cex, font=2, xpd=NA)


# copied from DescTools, Andri Signorell
# just for check not to bark!
utils::globalVariables(c("hred","hblue"))

lines.lm <- function (x, col = Pal()[1], lwd = 2, lty = "solid",
                      type = "l", n = 100, conf.level = 0.95, args.cband = NULL,
                      pred.level = NA, args.pband = NULL, ...) {
    
  mod <- x$model

  # we take simply the second column of the model data.frame to identify the x variable
  # this will crash, if there are several resps and yield nonsense if there is
  # more than one pred,
  # so check for a simple regression model y ~ x (just one resp, just one pred)

  # Note:
  # The following will not work, because predict does not correctly recognise the newdata data.frame:
  # lines(lm(d.pizza$temperature ~ d.pizza$delivery_min), col=hred, lwd=3)
  # see what happens to the data.frame colnames in: predict(x, newdata=data.frame("d.pizza$delivery_min"=1:20))
  # this predict won't work.
  # always provide data:    y ~ x, data

  # thiss is not a really new problem:
  # http://faustusnotes.wordpress.com/2012/02/16/problems-with-out-of-sample-prediction-using-r/

  # we would only plot lines if there's only one predictor

  pred <- all.vars(formula(x)[[3]])
  if(length(pred) > 1) {
    stop("Can't plot a linear model with more than 1 predictor.")
  }

  # the values of the predictor
  xpred <- x$model[, pred] # modified by YF
  #xpred <- eval(x$call$data)[, pred]

  newx <- data.frame(seq(from = min(xpred, na.rm = TRUE),
                         to = max(xpred, na.rm = TRUE), length = n))

  colnames(newx) <- pred
  fit <- predict(x, newdata = newx)

  if (!(is.na(pred.level) || identical(args.pband, NA)) ) {
    args.pband1 <- list(col = SetAlpha(col, 0.12), border = NA)
    if (!is.null(args.pband))
      args.pband1[names(args.pband)] <- args.pband

    ci <- predict(x, interval="prediction", newdata=newx, level=pred.level) # Vorhersageband
    do.call("DrawBand", c(args.pband1, list(x = c(unlist(newx), rev(unlist(newx)))),
                          list(y = c(ci[,2], rev(ci[,3])))))
  }

  if (!(is.na(conf.level) || identical(args.cband, NA)) ) {
    args.cband1 <- list(col = SetAlpha(col, .2), border = NA)# modified by YF
    if (!is.null(args.cband))
      args.cband1[names(args.cband)] <- args.cband

    ci <- predict(x, interval="confidence", newdata=newx, level=conf.level) # Vertrauensband
    do.call("DrawBand", c(args.cband1, list(x = c(unlist(newx), rev(unlist(newx)))),
                          list(y = c(ci[,2], rev(ci[,3])))))
  }

  lines(y = fit, x = unlist(newx), col = col, lwd = lwd, lty = lty,
        type = type)
}
DrawBand <- function(x, y, col = SetAlpha("grey", 0.5), border = NA) {

  # accept matrices but then only n x y
  if(!identical(dim(y), dim(x))){
    x <- as.matrix(x)
    y <- as.matrix(y)

    if(dim(x)[2] == 1 && dim(y)[2] == 2)
      x <- x[, c(1,1)]
    else if(dim(x)[2] == 2 && dim(y)[2] == 1)
      y <- y[, c(1,1)]
    else
      stop("incompatible dimensions for matrices x and y")

    x <- c(x[,1], rev(x[,2]))
    y <- c(y[,1], rev(y[,2]))

  }

  # adds a band to a plot, normally used for plotting confidence bands
  polygon(x=x, y=y, col = col, border = border)
}
SetAlpha <- function(col, alpha=0.5) {

  if (length(alpha) < length(col)) alpha <- rep(alpha, length.out = length(col))
  if (length(col) < length(alpha)) col <- rep(col, length.out = length(alpha))

  acol <- substr(ColToHex(col), 1, 7)
  acol[!is.na(alpha)] <- paste(acol[!is.na(alpha)], DecToHex(round(alpha[!is.na(alpha)]*255,0)), sep="")
  acol[is.na(col)] <- NA
  return(acol)
}
DecToHex <- function(x) as.hexmode(as.numeric(x))
ColToHex <- function(col, alpha=1) {
  col.rgb <- col2rgb(col)
  col <- apply( col.rgb, 2, function(x) sprintf("#%02X%02X%02X", x[1], x[2], x[3]) )
  if(alpha != 1 ) col <- paste( col, DecToHex( round( alpha * 255, 0)), sep="")
  return(col)
  # old: sprintf("#%02X%02X%02X", col.rgb[1], col.rgb[2], col.rgb[3])
}
Pal <- function(pal, n=100, alpha=1) {

  if(missing(pal)) {
    res <- getOption("palette", default = structure(Pal("Helsana")[c(6,1:5,7:10)] ,
                     name = "Helsana", class = c("palette", "character")) )

  } else {

    palnames <- c("RedToBlack","RedBlackGreen","SteeblueWhite","RedWhiteGreen",
                  "RedWhiteBlue0","RedWhiteBlue1","RedWhiteBlue2","RedWhiteBlue3","Helsana","Tibco","RedGreen1",
                  "Spring","Soap","Maiden","Dark","Accent","Pastel","Fragile","Big","Long","Night","Dawn","Noon","Light")

    if(is.numeric(pal)){
      pal <- palnames[pal]
    }
    big <- c("#800000", "#C00000", "#FF0000", "#FFC0C0",
            "#008000","#00C000","#00FF00","#C0FFC0",
            "#000080","#0000C0", "#0000FF","#C0C0FF",
            "#808000","#C0C000","#FFFF00","#FFFFC0",
            "#008080","#00C0C0","#00FFFF","#C0FFFF",
            "#800080","#C000C0","#FF00FF","#FFC0FF",
            "#C39004","#FF8000","#FFA858","#FFDCA8")

    switch(pal
           , RedToBlack    = res <- colorRampPalette(c("red","yellow","green","blue","black"), space = "rgb")(n)
           , RedBlackGreen = res <- colorRampPalette(c("red", "black", "green"), space = "rgb")(n)
           , SteeblueWhite = res <- colorRampPalette(c("steelblue","white"), space = "rgb")(n)
           , RedWhiteGreen = res <- colorRampPalette(c("red", "white", "green"), space = "rgb")(n)
           , RedWhiteBlue0 = res <- colorRampPalette(c("red", "white", "blue"))(n)
           , RedWhiteBlue1 = res <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D", "#F4A582", "#FDDBC7",
                                              "#FFFFFF", "#D1E5F0", "#92C5DE", "#4393C3", "#2166AC", "#053061"))(n)
           , RedWhiteBlue2 = res <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))(n)
           , RedWhiteBlue3 = res <- colorRampPalette(c(hred, "white", hblue))(n)
           , Helsana       = res <- c("rot"="#9A0941", "orange"="#F08100", "gelb"="#FED037"
                                       , "ecru"="#CAB790", "hellrot"="#D35186", "hellblau"="#8296C4", "hellgruen"="#B3BA12"
                                       , "hellgrau"="#CCCCCC", "dunkelgrau"="#666666", "weiss"="#FFFFFF")
           , Tibco         =  res <- apply( mcol <- matrix(c(
                                       0,91,0, 0,157,69, 253,1,97, 60,120,177,
                           156,205,36, 244,198,7, 254,130,1,
                           96,138,138, 178,113,60
                            ), ncol=3, byrow=TRUE), 1, function(x) rgb(x[1], x[2], x[3], maxColorValue=255))
           , RedGreen1 =  res <- c(rgb(227,0,11, maxColorValue=255), rgb(227,0,11, maxColorValue=255),
                                  rgb(230,56,8, maxColorValue=255), rgb(234,89,1, maxColorValue=255),
                       rgb(236,103,0, maxColorValue=255), rgb(241,132,0, maxColorValue=255),
                       rgb(245,158,0, maxColorValue=255), rgb(251,184,0, maxColorValue=255),
                       rgb(253,195,0, maxColorValue=255), rgb(255,217,0, maxColorValue=255),
                       rgb(203,198,57, maxColorValue=255), rgb(150,172,98, maxColorValue=255),
                       rgb(118,147,108, maxColorValue=255))

           , Spring =  res <- c("#E41A1C", "#377EB8", "#4DAF4A", "#984EA3","#FF7F00", "#FFFF33", "#A65628", "#F781BF", "#999999")
           , Soap =  res <- c("#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3","#A6D854", "#FFD92F", "#E5C494", "#B3B3B3")
           , Maiden =  res <- c("#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072","#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5", "#D9D9D9","#BC80BD","#CCEBC5")
           , Dark =  res <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A","#66A61E", "#E6AB02", "#A6761D", "#666666")
           , Accent =  res <- c("#7FC97F", "#BEAED4", "#FDC086", "#FFFF99","#386CB0", "#F0027F", "#BF5B17", "#666666")
           , Pastel =  res <- c("#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4","#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC", "#F2F2F2")
           , Fragile =  res <- c("#B3E2CD", "#FDCDAC", "#CBD5E8", "#F4CAE4","#E6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC")
           , Big =  res <- big
           , Long =  res <- big[c(12,16,25,24,
                         2,11,6,15,18,26,23,
                         3,10,7,14,19,27,22,
                         4,8,20,28)]
           , Night =  res <- big[seq(1, 28, by=4)]
           , Dawn =  res <- big[seq(2, 28, by=4)]
           , Noon =  res <- big[seq(3, 28, by=4)]
           , Light = res <- big[seq(4, 28, by=4)]

           , GrandBudapest = res < c("#F1BB7B", "#FD6467", "#5B1A18", "#D67236")
           , Moonrise1 = res <- c("#F3DF6C", "#CEAB07", "#D5D5D3", "#24281A")
           , Royal1 = res <- c("#899DA4", "#C93312", "#FAEFD1", "#DC863B")
           , Moonrise2 = res <- c("#798E87","#C27D38", "#CCC591", "#29211F")
           , Cavalcanti = res <- c("#D8B70A", "#02401B","#A2A475", "#81A88D", "#972D15")
           , Royal2 = res <- c("#9A8822", "#F5CDB4", "#F8AFA8", "#FDDDA0", "#74A089")
           , GrandBudapest2 = res <- c("#E6A0C4", "#C6CDF7", "#D8A499", "#7294D4")
           , Moonrise3 = res <- c("#85D4E3", "#F4B5BD", "#9C964A", "#CDC08C", "#FAD77B")
           , Chevalier = res <- c("#446455", "#FDD262", "#D3DDDC", "#C7B19C")
           , Zissou = res <- c("#3B9AB2", "#78B7C5", "#EBCC2A", "#E1AF00", "#F21A00")
           , FantasticFox = res <- c("#DD8D29", "#E2D200", "#46ACC8", "#E58601", "#B40F20")
           , Darjeeling = res <- c("#FF0000", "#00A08A", "#F2AD00", "#F98400", "#5BBCD6")
           , Rushmore = res <- c("#E1BD6D", "#EABE94", "#0B775E", "#35274A", "#F2300F")
           , BottleRocket = res <- c("#A42820", "#5F5647", "#9B110E", "#3F5151", "#4E2A1E", "#550307", "#0C1707")
           , Darjeeling2 = res <- c("#ECCBAE", "#046C9A", "#D69C4E", "#ABDDDE",  "#000000")
    )

    attr(res, "name") <- pal
    class(res) <- append(class(res), "palette")

  }

  if(alpha != 1)
    res <- SetAlpha(res, alpha = alpha)

  return(res)

}

mylines=function(x, y, type = "l", ...) {    
    plot.xy(xy.coords(x[order(x)], y[order(x)]), type=type, ...)
}


# from princurve
whiskers <- function(x, s, ...) {
  graphics::segments(x[, 1], x[, 2], s[, 1], s[, 2], ...)
}

Try the kyotil package in your browser

Any scripts or data that you put into this service are public.

kyotil documentation built on Nov. 28, 2023, 1:09 a.m.