Nothing
R/pl.R
In plgraphics: User Oriented Plotting Functions
Defines functions
cln
cls
cfn
clg
ccl
cch
cnv
cnr
smoothxtrim
smoothpar
markextremes
charSize
plmboxes
pllines
plinnerrange
Documented in
charSize
markextremes
plinnerrange
pllines
plmboxes
smoothpar
smoothxtrim
## =======================================================================
## Plotting functions, low and high-level
## -----------------------------------------------------------------------
pl.control <- #f
function(x = NULL, y = NULL, condvar = NULL, data = NULL, subset = NULL,
transformed = TRUE, distinguishy = TRUE, gensequence = NULL,
csize = NULL, csize.pch = NULL,
psize = NULL, plab = FALSE, pch = NULL, pcol = NULL,
smooth.weights = NULL, smooth.weight = NULL,
markextremes = NULL, smooth = NULL,
xlab = NULL, ylab = NULL, varlabel = NULL,
vcol = NULL, vlty = NULL, vpch = NULL, plscale = NULL, log = NULL,
main = NULL, sub = NULL, .subdefault = NULL, mar = NULL,
## needed because it hides markextremes otherwise
gencoord = TRUE, plargs = pl.envir,
ploptions = NULL, .environment. = parent.frame(),
assign = TRUE, ... )
## get data for plotting, collect and check arguments
## do preparations that are common to all plots
## --------------------------------------------------------------
{
lf.xdt <- function(x, data, dtlab=NULL, title=NULL, xory)
{
if (u.false(x)) return(list())
if (is.matrix(x)) x <- as.data.frame(x)
if (is.atomic(x)) x <- structure(data.frame(x), names=xory)
if (u.isnull(dtlab))
dtlab <- i.def(tit(x), i.def(attr(x, "dname", exact=TRUE), title))
data <- if (u.isnull(data)) x
else {
if (nrow(x)!=NROW(data))
stop("!pl.control! arguments '", xory,
"' and 'data' have different numbers of rows")
cbind(x, data)
}
list(x=x, data=data, dtlab=dtlab)
}
## --------------------------------------------------------
lcall <- match.call()
if (length(lcall$smooth.weight)) {
lcall$smooth.weights <- lcall$smooth.weight
lcall$smooth.weight <- NULL
}
if (length(lcall$reflines)) {
lcall$refline <- lcall$reflines
lcall$smooth.reflines <- NULL
}
## --- ploptions
lcl <- lcall
ploptions <- i.def(ploptions, pl.envir$usr.ploptions)
lnmd <- setdiff(names(default.ploptions), names(ploptions) )
if (length(lnmd)) ploptions <- c(ploptions, default.ploptions[lnmd])
largsplo <- setdiff(names(lcl)[-1],
c("xlab","ylab","mf", ## "csize","markextremes",
i.argPlcontr, i.argPldata))
if (length(largsplo)) { ## set more lpoptions
lcl <- lcl[c("",largsplo)]
lcl[1] <- list(quote(list))
lcl <- as.call(lcl)
lls <- eval(lcl, envir=parent.frame())
ploptions <- ploptions(list=lls, assign=FALSE, setpar=TRUE)
}
##
if ("title"%in%names(lcall)) lcall$main <- lcall$title
if (length(grep("cex", names(lcall)))) {
warning(":pl.control: argument(s) containing 'cex' are probably ",
"misspecified. I replace 'cex' by 'csize'")
names(lcall) <- sub("cex","csize", names(lcall))
}
## ---
lcl <- lcall
## --- data
lmaxchars <- i.getploption("title.maxchars")
ldtlab <- NULL ## data label
if (length(data)) {
if (length(dim(data))==0)
stop("!pl.control! argument 'data' must be a data.frame or a matrix")
if (is.matrix(data)) data <- as.data.frame(data)
ldtlab <- if (length(ltit <- tit(data))) ltit
if (u.isnull(ldtlab) & is.name(lldtl <- substitute(data)))
ldtlab <- as.character(lldtl)
}
## --- get variables and data
lftext <- lform <- NULL
lformarg <- lynames <- lxnames <- NULL
if (length(x)==0 & length(y)==0) x <- data
if (length(x)==0) { ## use y as x
x <- y
y <- NULL
}
if (u.isnull(x))
stop("!pl.control! no data found")
lbyv <- NULL
## argument x
if (is.atomic(x)&&is.character(x)) { ## names of variables
lxnames <- x
lform <- as.formula(paste("~", paste(x,collapse="+")))
} else {
if (is.formula(x)) {
lform <- x
lvars <- getvarnames(x, data=data, transformed=transformed)
lxnames <- attr(lvars, "xvar")
lynames <- attr(lvars, "yvar")
lbyv <- attr(lvars, "byvar")
} else { ## matrix or data.frame
lrr <- lf.xdt(x, data, ldtlab, xory="x") ## deal with different types of arg.
data <- lrr$data
x <- lrr$x
lxnames <- names(x)
ldtlab <- lrr$dtlab
}
if (is.null(lform))
lform <-
as.formula(paste(paste(lynames, collapse="+"), "~",
paste(lxnames, collapse="+")))
lftext <- shortenstring(format(lform), lmaxchars)
}
## y
lyform <- NULL
if (length(y)) {
if (is.atomic(y)&&is.character(y)) { ## names of variables
lynames <- y
} else{
if (is.formula(y)) {
lyform <- y
lynames <- getvarnames(y, data=data, transformed=transformed)
} else { ## matrix or data.frame
lrr <- lf.xdt(y, data, ldtlab, tit(y), "y") ## deal with different types of arg.
data <- lrr$data
y <- lrr$x
lynames <- names(y)
## ldtlab <- i.def(ldtlab, lrr$dtlab)
}
}
## ---
if (u.isnull(lynames)) ## y is formula
lynames <- getvarnames(y, data=data, transformed=transformed)
if (is.null(lyform))
lyform <- as.formula(paste("~", paste(lynames, collapse="+")))
lform <-
if (length(lform)) {
update(lform, as.formula(paste(tail(as.character(lyform),1),"+.~.")))
} else lyform
lftext <- paste(shortenstring(substring(format(lyform),2,100),
lmaxchars/2),
shortenstring(lftext, lmaxchars/2))
}
## condvar, by grouping variable
lbynames <- lbyv
lbyform <- NULL
if (length(condvar)) {
if (is.atomic(condvar)&&is.character(condvar)) { ## names of variables
lbynames <- condvar
} else {
if (is.formula(condvar)) {
lbyform <- condvar
lbynames <-
c(getvarnames(condvar, data=data, transformed=transformed))
} else { ## matrix or data.frame
lrr <- lf.xdt(condvar, data, ldtlab, tit(condvar), "condvar") ## deal with different types of arg.
data <- lrr$data
condvar <- lrr$x
lbynames <- names(condvar)
## ldtlab <- lrr$dtlab
}
}
}
## ----
## only x or y : plot against sequence
if ((u.isnull(lxnames)|u.isnull(lynames))&&u.notfalse(gensequence)) {
data <-
cbind(".sequence."= 1:NROW(data),data)
lynames <- c(lxnames, lynames)
lxnames <- ".sequence."
}
## ---
##- if (length(data)==0 && length(lform)==0)
##- stop("!pl.control! arguments 'x', 'y', and 'data' are all empty")
lftext <- shortenstring(lftext, lmaxchars)
## ---
lformarg <- list(xvar=lxnames,yvar=lynames,
byvar=if(length(lbynames)) lbynames)
lvarnames <- c(lxnames, lynames, lbynames)
## --- data
## ltransformed <- i.def(lcl$transformed, TRUE)
if (!is.null(attr(data,"terms"))) { ## data is model.frame
if (!transformed) {
warning(":pl.control! Raw data not available.",
"I can only use transformed data.")
transformed <- TRUE
}
}
## --- get variables from lform and data
largs <- c(i.argPldata, "transformed")
## variables
if (length(varlabel))
if (length(names(varlabel))==0) {
warning(":pl.control: 'varlabel' must have names")
lcl$varlabel <- varlabel <- NULL
}
## data
if (length(lvarnames)||length(varlabel) ||
any(names(lcl)%in%i.argPldata)) {
lcl <- c(list(quote(getvariables), formula=lformarg, data=data),
as.list(lcl[intersect(largs, names(lcl))]),
envir=.environment.)
lcl <- as.call(lcl)
## environment(lform) <- environment() ## ???
lpldata <- eval(lcl, envir=environment())
## ----
if (inherits(lpldata, "pl-error"))
stop("!pl.control! ", attr(lpldata, "message"))
if (length(lpldata)==0)
stop("!pl.control! No data found")
## set varlabel in a special case
if (length(lxnames)==1 && is.formula(lcx <- lcall$x) && length(lcx)==2)
attr(lpldata[[lxnames]], "varlabel") <- sub("~","",format(lcx))
if (length(lynames)==1 && is.formula(lcy <- lcall$y) && length(lcy)==2)
attr(lpldata[[lynames]], "varlabel") <- sub("~","",format(lcy))
## --- subset
if (length(lcall$subset)) {
lsub <- eval(lcall$subset, data, enclos=parent.frame())
if (sum(lsub)==0)
stop("!plsubset! No data fulfills the selection criteria")
lpldata <- plsubset(lpldata, lsub)
}
## --- attributes of variables
## plrange
if(any(c("vlim","xlim","ylim")%in%names(lcall)))
lpldata <- i.setvlim(lpldata, ...)
## plscale
if (length(log)) plscale <-
ifelse(c(length(grep("x",log)>0),length(grep("y",log)>0)), "log","")
if (lns <- length(plscale)) {
if (length(names(plscale))==0)
if (lns==2)
plscale <-
setNames(c(rep(plscale[1],length(lxnames)),
rep(plscale[2],length(lynames))), lvarnames)
else {
warning(":pl.control: argument 'plscale' not suitable")
plscale <- NULL
}
}
## lvarnames <- attr(lpldata,"variables", exact=TRUE)
if (gencoord & length(lvarnames)) {
ldy <- if (distinguishy) lynames
lpldata[,lvarnames] <-
genvarattributes(lpldata[,lvarnames, drop=FALSE], vnames = ldy,
vcol = vcol, vlty = vlty, vpch = vpch,
plscale = plscale, varlabel = varlabel,
ploptions=ploptions, ...)
lnr <- nrow(lpldata)
lnobs <- lnr-median(sumNA(lpldata[,lvarnames]))
} else lnr <- 0
} else {
lpldata <- NULL
lvarnames <- NULL
lnr <- 0
}
if (lnr==0) {
if (length(data)) {
lnr <- NROW(data)
lnobs <- lnr-median(sumNA(data))
} else {
warning(":pl.control: data not found. I set 'nobs' to 100")
lnobs <- 100
}
}
## -------------------------
## get special variables from original data if they have been set before
lvnm <-
setdiff(intersect(names(data),
c(".pch.",".plab.",".pcol.",".psize.",".smooth.weight.")),
names(lpldata))
if (length(lvnm))
lpldata[,lvnm] <- data[,lvnm, drop=FALSE]
## ----------------------------------------
## labels and plotting character
## priorities: plab , pch , row.names
lpch <- lpldata$".pch."
## default plotting character
if (length(lpch)) {
if (is.factor(lpch)) lpch <- as.numeric(lpch)
if (is.numeric(lpch)) {
if(length(lpna <- setdiff(lpch,c.pchvalues))) {
warning(":plcontrol: pch", paste(lpna, collapse=", "), " do not exist")
lpchunused <- i.def(setdiff(c.pchvalues, c(lpch,0)), 13)
li <- match(lpch, lpna, nomatch=0)
lpch[li>0] <- lpchunused[(li[li>0]-1)%%length(lpchunused) +1] ## recycle!
}
}
if (is.character(lpch) && any(nchar(lpch)>1)) {
warning(":pl.control: 'pch' must be an integer or a single character.",
" Use 'plab' to label points with strings")
lpch <- substr(lpch,1,1)
}
if (is.logical(lpch)) lpch <- as.numeric(lpch)
lpldata$".pch." <- lpch
}
lplab <- lpldata$".plab."
## --- row.names
lrown <- substring(row.names(data),1,3)
if (length(lrown)==0) lrown <- as.character(1:lnr)
lplabel <- lrown
lIplab <- length(lplab)>0 && is.logical(lplab) && all(lplab) ## original arg T
if (lIplab) lpldata$".plab." <- lplab <- lplabel
else
if (length(lplab)) lplabel <- as.character(lplab)
## now, lplabel is always useful
## --- 'by' group
lbyn <- attr(lpldata, "byvar")
for (llv in lbyn)
if (inherits(lpldata[,llv], "factor"))
lpldata[,llv] <- i.factor(lpldata[,llv]) ## drop levels
## ---
if (length(lgroup <- lpldata[[".group."]])) {
lpldata[,".group."] <- i.getgroupopt(lgroup, ploptions)
if (length(llb <- as.character(lcall$group))<=20)
attr(lpldata[[".group."]], "varname") <- llb
}
## smooth.group
lsmgrp <- lpldata$".smooth.group."
if (length(lsmgrp)) {
lpldata[,".smooth.group."] <- i.factor(lsmgrp)
if (length(llb <- as.character(lcall$smooth.group))<=20)
attr(lpldata[[".smooth.group."]], "varname") <- llb
}
## pcol
if (length(lpcol <- lpldata$".pcol.")) lpldata[,".pcol."] <- i.getcolor(lpcol)
## lpldata[,".pcol."] <- i.factor(lpcol) ## !!!
##- if (is.logical(lpcol)) lpldata[,".pcol."] <- lpcol+1
##- else if (is.factor(lpcol)) {
##- lclr <- i.getploption("col")
##- lpldata[,".pcol."] <- lclr[(as.numeric(lpcol)-1)%%length(lclr)+1] ## recycle!
##- }
## ----------------------------------------------------
## more ploptions
## smooth color
lsmcol <- ploptions$smooth.col
lgrcol <- ploptions$group.col
if (is.numeric(lsmcol))
ploptions$smooth.col <- lsmcol <- lgrcol[1+(lsmcol-1)%%lsmcol]
if (length(lsmcol)==1)
ploptions$smooth.col[2] <-
colorpale(lsmcol, ploptions$smooth.pale[1])
## ---
lmardf <- i.getploption("mar")
if (length(lynames)>1) lmardf[4] <- lmardf[2] ## need space at the right
ploptions$mar <- i.def(mar, lmardf)
## --- condprob.range
ploptions$condprob.range <-
if (length(ploptions$condprob.range)==0) {
if (lnobs>50) c(0,0) else c(0.05,0.8)
} else c(ploptions$condprob.range,1)[1:2]
## --- smooth
lsmgrp <- lpldata$".smooth.group."
lsmgrplab <- levels(lsmgrp)
## smooth
##- lnsm <- lnobs
##- lnsmgrp <- length(unique(lsmgrp))
##- if (length(lsmgrp)) lnsm <- lnobs/lnsmgrp
## !!! check if lnsm is large enough
ploptions$smooth <- i.getplopt(smooth)
lrefl <- eval(lcall$refline, enclos=parent.frame())
lrefl <- if (length(lrefl)>1 | is.function(lrefl)) lrefl
## --- main
main <- i.def(lcall$main, "", "", "")
sub <- i.def(sub, i.def(i.getploption("sub"), NULL, ldtlab, NULL))
## ------------------------------------------------------------
## result of pl.control
rr <- list(
pldata = lpldata, ploptions = ploptions,
plfeatures = list(
formula = lform, formulatext = lftext,
nobs = lnobs, transformed = transformed,
pch = lpch, plabel = lplabel, plab = lIplab, ##plabna = lplabna, ???
## smooth.ngroups = lnsmgrp,
smooth.grouplab = lsmgrplab,
reflinecoord = lrefl,
datalabel = ldtlab, main = main, sub = sub, .subdefault = .subdefault,
datetime = date()
)
)
if (u.notfalse(assign)) plassign(list=rr)
rr
} ## end of pl.control
## ===================================================================
i.setvlim <- #f
function(data, vlim=NULL, xlim=NULL, ylim=NULL, ...)
{ ## set plotting limits
lf.checklim <- function(lim, varnames) {
## produce named list with names from 'data'
if (!is.list(lim)) lim <- list(lim)
if (length(lnm <- names(lim))) {
lim <- lim[intersect(lnm, varnames)]
} else {
if (length(lim)==1) lim <- rep(lim, length(varnames))
if (length(lim)==length(varnames))
names(lim) <- varnames
else {
warning(":pl.control/setvlim: 'xlim' or 'ylim' not suitable")
lim <- NULL
}
}
lim
}
## -----------------------------------
if (!u.isnull(vlim)) vlim <- lf.checklim(vlim, names(data))
if (!u.isnull(xlim)) xlim <- lf.checklim(xlim, attr(data, "xvar", exact=TRUE))
if (!u.isnull(ylim)) ylim <- lf.checklim(ylim, attr(data, "yvar", exact=TRUE))
lim <- c(vlim,xlim,ylim)
i.setvarattribute("vlim", lim, data)
}
## ===============================================================
plinnerrange <-
function(innerrange, data, factor = 4.0, FUNC=robrange)
{ ## determine inner plot range
## if innerrange is a list or a matrix, leave it alone
lIcq <- inherits(data, "condquant")
ldt <- cbind( if (lIcq) c(data[,1:3]) else data )
innerrange <- i.def(innerrange, TRUE, TRUE, FALSE)
if (length(innerrange)>1)
if (any(dim(cbind(innerrange))!=c(2,NCOL(ldt)))) {
warning(":plregr/innerrange: unsuitable argument innerrange ")
innerrange <- TRUE
}
if (length(innerrange)==1 && is.logical(innerrange))
innerrange <-
if (innerrange) apply(ldt, 2, FUNC, fac=factor[1]) else
matrix(FALSE, 2, NCOL(ldt))
if ((!is.list(innerrange))&length(innerrange)==2)
innerrange <- as.matrix(innerrange)
innerrange
}
## ---------------------------------------------------------------------
genvarattributes <- #f
function(data, vnames = NULL, vcol = NULL, vlty = NULL, vpch = NULL,
varlabel = NULL, innerrange = NULL,
plscale = NULL, zeroline = NULL, replace = FALSE,
ploptions = NULL, ...)
{
if (!is.data.frame(data)) data <- structure(as.data.frame(data), names="X")
## ---
ltickint <- i.getploption("tickintervals")
## variable names
lnmdata <- colnames(data)
if (anyNA(lnmdata)) colnames(data) <- lnmdata <-
ifelse(is.na(lnmdata), paste("V",1:NCOL(data), sep=""), lnmdata)
##
lrown <- row.names(data)
## varlabel
llb <- NULL
## jitter (prep)
ljt <-
i.def(i.getploption("jitter"),
ifelse(i.getploption("factor.show")=="jitter", "iffactor", FALSE) )
lljt <- length(ljt)
if (lljt)
if (!is.list(ljt))
ljt <- setNames(rep(ljt, ncol(data)), colnames(data))
jitter.factor <- i.getploption("jitter.factor")
## innerrange (prep)
lirfactor <- i.getploption("innerrange.factor")
## multiple y: plotting character, line color and type
if (u.isnull(vnames))
vnames <- union(union(names(vcol),names(vlty)),names(vpch))
lny <- length(vnames)
if (lImulty <- lny>0) { ##
ldt <- data[,vnames, drop=FALSE]
lvpch <-
i.getvarattribute("vpch", vpch, ldt, ploptions$variables.pch, drop=lny>1)
## i.getvarattribute avoids duplicates
lvlty <-
i.getvarattribute("vlty", vlty, ldt, ploptions$variables.lty, drop=lny>1)
lvcol <-
i.getvarattribute("vcol", vcol, ldt, ploptions$variables.lcol, drop=lny>1)
}
## ---------------------------------------------
if (length(plscale)) data <- setvarattributes(data, plscale=plscale)
##
for (lv in lnmdata) {
lvv <- data[,lv]
lcls <- class(lvv)[1]
attr(lvv, "varname") <- lv
lnv <- sum(!duplicated(dropNA(lvv)))
##
if (replace || is.null(attr(lvv, "nvalues", exact=TRUE)))
attr(lvv, "nvalues") <- lnv
## turn character into factor
if (lcls=="character") lvv <- transferAttributes(factor(lvv), lvv)
## if (lv %in% lfacgen) class(lvv) <- c(class(lvv, "usedAsFactor"))
if (lImulty) { ## line color and type, pch
if(lv%in% names(lvcol)) attr(lvv, "vcol") <- unname(lvcol[lv])
if(lv%in% names(lvlty)) attr(lvv, "vlty") <- unname(lvlty[lv])
if(lv%in% names(lvpch)) attr(lvv, "vpch") <- unname(lvpch[lv])
}
if (inherits(lvv, c("factor", "usedAsFactor", "character"))) {
## factor
lvv <- i.factor(lvv)
if (is.null(attr(lvv, "numvalues"))) {
lat <- seq_along(levels(lvv))
if (replace || is.null(attr(lvv, "plrange", exact=TRUE)))
attr(lvv, "plrange") <- c(0.35, max(lat)+0.65)
if (replace || is.null(attr(lvv, "ticksat", exact=TRUE)))
attr(lvv, "ticksat") <- lat
if (replace || is.null(attr(lvv, "ticklabels", exact=TRUE)))
attr(lvv, "ticklabels") <- levels(lvv)
## jitter
if(replace || is.null(attr(lvv, "numvalues", exact=TRUE))) {
lij <- ljt[lv]
lij <- ((u.true(lij) || lij=="iffactor") &
max(table(lvv),rm.na=TRUE)>=i.getploption("jitter.minnobs"))
attr(lvv, "numvalues") <-
if (u.notfalse(lij)) {
ldif <- diff(sort(as.numeric(lvv)))
lamdf <- quantile(ldif[ldif>0], 0.2)*jitter.factor/2
jitter(as.numeric(lvv),
amount=if(is.numeric(lij)) lij else lamdf)
} else as.numeric(lvv)
}
}
attr(lvv, "zeroline") <- i.def(attr(lvv, "zeroline"), FALSE)
} else {
## Date
if (inherits(lvv, c("Date", "times")) &&
is.null(attr(lvv, "numvalues", exact=TRUE)))
lvv <- gendateaxis(setNames(lvv, lrown))
else { ## -----------------
## continuous variable
lvv <-
i.genvattrcont(lvv, attr(lvv, "innerrange", exact=TRUE), lirfactor, ltickint,
replace=replace, ploptions=ploptions)
##- if (replace || is.null(attr(lvv, "zeroline")))
##- attr(lvv, "zeroline") <- i.getplopt(zeroline)
} ## end of continuous variable
}
if (is.null(attr(lvv,"varlabel"))) attr(lvv, "varlabel") <- lv
##- if (lv%in%names(llb)) unname(llb[lv])
data[[lv]] <- lvv
}
if (length(varlabel)) data <- setvarattributes(data, varlabel=varlabel)
if (length(zeroline)) data <- setvarattributes(data, zeroline=zeroline)
data
} ## end genvarattributes
## ---------------------------------------------------------------------
i.genvattrcont <- #f
function(x, innerrange=NULL, innerrange.factor=NULL, tickintervals=NULL,
replace=FALSE, ploptions = NULL, tickscale = NULL)
{
lx <- x
if(inherits(x,"Surv")) {
lx <- x[,1]
if(length(latt <- attributes(lx)))
x <- transferAttributes(x, lx)
}
lattr <- attributes(x)
lnouter <- c(0,0)
lplrg <- lattr[["plrange"]]
## innerrange
lirgx <- lattr[["innerrange"]]
innerrange <- i.def(innerrange, lirgx)
lirg <- i.def(i.getplopt(innerrange), TRUE)
lIirg <- u.notfalse(lirg) | length(lirg)==2
lirf <- i.getplopt(innerrange.factor)
##
ltint <- i.getplopt(tickintervals) ## logical
lvlimsc <- lattr[["vlim"]]
## plscale
lplscale <- lattr[["plscale"]]
if (length(lplscale)) {
if (is.character(lplscale)&&lplscale[1]=="")
lplscale <- NULL
else {
if (length(lplv <- lattr[["plvalues"]])||replace) lx <- lplv
else {
llx <- plscale(lx, lplscale, valuesonly=FALSE, ploptions=ploptions)
lattr <- attributes(llx)
x <- transferAttributes(llx, lx) ## ???
lvlimsc <- i.def(lattr[["vlimscaled"]], lattr[["vlimsc"]])
}
}
}
## plot coordinates
llx <- c(lx)
if (length(lpv <- lattr[["plvalues"]])) llx <- lpv
else if (length(lnv <- lattr[["numvalues"]])) llx <- lnv
##- names(llx) <- names(lx)
## innerrange
if (lIirg & u.true(lirg)) lirg <- c(plinnerrange(TRUE, llx, factor=lirf))
if (!u.notfalse(lirg)) {
lattr[["innerrange"]] <- attr(x, "innerrange") <- lirg <- NULL
lplrg <-
i.extendrange(range(llx, finite=TRUE), i.getploption("innerrange.ext"))
} else { ## lirg is range
if (replace||length(lirgx)!=2)
## vlim overrides innerrange
lirg <- replaceNA(lvlimsc, lirg)
if (length(lirg)) {
lpc <- plcoord(llx, lirg, ploptions=ploptions)
## attributes: avoid a level...
lpca <- attributes(lpc)
attributes(x)[names(lpca)] <- lpca
attributes(lpc) <- NULL
attr(x, "plcoord") <- lpc ## if (replace)
lnouter <- lpca$nouter
if (u.isnull(lnouter)) lnouter <- c(0,0)
lplrg <- lpca$plrange
}
}
## set plrange
## vlim overrides lplrg
attr(x, "plrange") <- lplrg <- replaceNA(lvlimsc, lplrg)
if (lIirg) attr(x, "innerrange") <- lirg
## ticks: cover only inner range!
if (replace || is.null(attr(x, "ticksat", exact=TRUE))) {
lrg <- if (length(lirg)==2) lirg else lplrg
lnouter <- i.def(lattr[["nouter"]], c(0, 0))
lrg <- ifelse(lnouter>0, lrg, lplrg)
ltks <- plticks(lrg, plscale=i.def(tickscale, lplscale),
transformed=TRUE, nouter=lnouter,
tickintervals=ltint, ploptions=ploptions)
if (replace || is.null(attr(x, "ticksat", exact=TRUE)))
attr(x, "ticksat") <- ltks$ticksat
## do not replace ticklabesat if ticksat is set
if (replace || is.null(attr(x, "ticklabelsat", exact=TRUE)))
attr(x, "ticklabelsat") <- ltks$ticklabelsat
if (replace || is.null(attr(x, "ticklabels", exact=TRUE)))
attr(x, "ticklabels") <- ltks$ticklabels
}
x
}
## ==========================================================================
plticks <- #f
function(range, plscale = NULL, transformed = FALSE,
nouter = 0, tickintervals = NULL, ploptions=NULL)
{ ## find suitable tick values and labels
## range is already transformed
ltint <- i.getplopt(tickintervals)
ltint1 <- min(max(ltint[1],3)+sum(nouter>0),20)
if (length(plscale)) { ## --- scaled axis
if (!(is.character(plscale)&&length(plscale)==1))
stop("!plticks! unsuitable ar gument 'plscale'. Must be of mode character")
lat <- prettyscale(range, transformed=transformed, plscale=plscale, n=ltint1) ## logscale?
llab <- attr(lat, "ticklabels", exact=TRUE)
lat <- llabat <- c(lat)
if (length(ltint)>1) {
lps <- prettyscale(range, transformed=transformed, plscale=plscale, n=ltint[2])
if (length(lps)>1) {
llab <- attr(lps, "ticklabels", exact=TRUE)
llabat <- c(lps)
}
}
} else { ## --- no scale
lat <- clipat(pretty(range, n=ltint1, min.n=ltint1-2), range)
llabat <-
if (length(ltint)>1)
clipat(pretty(lat, n=ltint[2], min.n=1), range) else lat
llabat <- clipat(llabat, lat)
if (length(llabat)<2)
llabat <- clipat(pretty(range, n=4, min.n=1), lat) else lat
llab <- NULL
}
list(ticksat=lat, ticklabelsat=llabat, ticklabels=llab)
}
## =====================================================================
plscale <- #f
function(x, plscale = "log10", ticksat = NULL, logscale = NULL,
valuesonly = FALSE, ploptions = NULL)
{
if (is.character(plscale)) {
if (plscale=="") return(x)
lscname <- plscale
if (lscname%in%c("log","log10") && min(x[is.finite(x)])<=0)
lscname <- "logst"
lscfunc <- get(lscname)
} else {
if (!is.function(lscfunc)) stop("!plscale! unsuitable argument 'plscale'")
lscname <- as.character(substitute(plscale))
if (length(lscname)!=1) stop("!plscale! unsuitable argument 'plscale'")
if (lscname%in%pl.envir$pl.scaleFunctions) {
plscale <- lscname
lscfunc <- get(lscname)
} else {
lscfunc <- plscale
plscale <- lscname
attr(plscale, "function") <- lscfunc
}
}
## ---
lx <- i.def(attr(x, "numvalues", exact=TRUE), c(x))
lvlim <- attr(x, "vlim", exact=TRUE)
lplrg <- attr(x, "plrange", exact=TRUE)
if (lscname=="logst") {
lxt <- logst(lx, threshold=attr(lscname, "threshold", exact=TRUE))
if (length(lvlim))
lvlimsc <- logst(lvlim, threshold=attr(lxt, "threshold", exact=TRUE))
attr(lscname, "threshold") <- attr(lxt, "threshold", exact=TRUE)
} else {
lxt <- lscfunc(lx)
lvlimsc <- if (length(lvlim)) lscfunc(lvlim)
}
lvlimsc <- i.def(attr(x, "vlimsc", exact=TRUE), lvlimsc)
if (length(ticksat)) ticksat <- lscfunc(ticksat)
if (valuesonly) return(lxt)
## ---
attr(lxt, "innerrange") <- attr(x, "innerrange")
lxtv <- i.genvattrcont(structure(lxt, vlim=lvlimsc, ticksat=ticksat),
ploptions=ploptions)
## lxtv <- transferAttributes(lxtv, x)
lrg <- replaceNA(lvlimsc, i.def(attr(lxtv, "innerrange"), attr(lxtv, "plrange")))
ltks <- plticks(range=lrg, plscale=lscname, transformed=TRUE,
nouter=attr(lxtv, "nouter", exact=TRUE), ploptions=ploptions)
structure(x, plvalues = lxt,
ticksat=ltks$ticksat, ## ticklabelsat=c(ticksat),
ticklabelsat=ltks$ticklabelsat, ## was NULL
ticklabels=ltks$ticklabels,
plscale = plscale, ##if (lscname=="userfunction") plscale else lfnn,
plrange = lplrg, vlim=lvlim, vlimscaled=lvlimsc)
}
## =====================================================================
prettyscale <- #f
function(x, transformed = FALSE, plscale = "log10", inverse = NULL,
range = NULL, range.transformed = NULL, n = NULL, logscale = NULL)
{
## generate ticks for transformed scale
##- lf.pretty <- fn(i, x) { ## format: avoid common formatting
##- lpr <- pretty(x[i+c(-1,1)], n=7)
##- lpr[which.min(abs(lpr-x[i]))]
##- }
lf.format <- function(x) sapply(as.list(x), format)
lf.cens <- function(x, rg) if (u.isnull(rg)) x else pmax(pmin(x, rg[2]),rg[1])
##---
if (is.character(plscale)) {
lscname <- plscale
if (length(lscname)>1) stop("!plscale! unsuitable argument 'plscale'")
lscfunc <-
if (lscname=="userfunction") attr(plscale, "function", exact=TRUE)
else try(get(lscname))
if (inherits(lscfunc, "try-error")) stop("!plscale! could not find function", lscname)
} else {
if (!is.function(plscale)) stop("!plscale! unsuitable argument 'plscale'")
lscname <- as.character(substitute(plscale))[1]
lscfunc <- plscale
}
## lcall <- match.call()
ln <- i.getploption("tickintervals")
ln1 <- ln[1]+1
ln2 <- if (length(ln)>=2) ln[2] else 3 ## ceiling(n/2)
## --- log according to axTicks
if (lscname%in%c("log","log10","logst") & u.isnull(logscale)) {
lx <- if (transformed) x else lscfunc(pmax(x, 0)) ## the transforming function given by the argument
lrg <- range(lx, finite=TRUE)
if (lscname=="log") lrg <- lrg/log(10)
if (lrg[2]-lrg[1]>1) { ## use R function
ltatlab <-
axTicks(1, usr=lrg,
axp=c(10^floor(lrg), max(3-floor((2.5*diff(lrg)+1)/ln1), 1)),
nintLog=ln1, log=TRUE)
ltatlab <- clipat(ltatlab, 10^lrg)
ltat <- log10(ltatlab)
if (lscname=="log") ltat <- ltat*log(10)
return(structure(ltat, ticklabels=lf.format(ltatlab)))
} ## else - for small range - treat logs by the following
}
## ------------------------------------------------------------
## --- back function
if (lscname=="log") inverse <- exp
if (lscname%in%c("log10", "logst")) inverse <- function(x) 10^x
if (lscname%in%c("log", "log10", "logst")) range <- c(0,Inf)
if (lscname=="sqrt") {
inverse <- function(x) x^2
range <- range.transformed <- c(0, Inf)
}
if (lscname=="qnorm") {
inverse <- pnorm
range.transformed <- c(0, 1)
}
range <- i.def(range, attr(lscfunc, "range", exact=TRUE))
range.transformed <-
i.def(range.transformed, attr(lscfunc, "range.transformed", exact=TRUE))
if (u.isnull(inverse)) {
inverse <- attr(lscfunc, "inverse", exact=TRUE)
if (u.isnull(inverse))
stop("!prettyscale! Inverse transformation function missing")
}
if (is.character(inverse)) inverse <- get(inverse)
## ---
lx <- if (transformed) x else lscfunc(lf.cens(x, range))
lrg <- range(lx, finite=TRUE) ## transformed scale
ld <- diff(lrg)/(ln1-1)
lk <- c(-2,0:(ln1-1),ln1+1)
lk <- lk+0.01*(lk-mean(lk))/ln1 ## correction helps to break ties
ltr <- lf.cens(lrg[1]+ld*lk, range.transformed)
lat <- rep(NA, ln1)
lrw <- inverse(ltr) ## original scale
for (li in 1:ln1) {
lrwx <- lrw[li+c(0,2)]
lpr <- pretty(lrwx+diff(lrwx)*c(-1,1)*0.5, n=ln2)
if (length(range)) lpr <- lf.cens(lpr, range)
## nearest in transformed scale:
lat[li] <- lpr[which.min(abs(lscfunc(lpr)-ltr[li+1]))]
}
lat <- lf.cens(unique(lat), range)
rr <- lscfunc(lat)
##- if (length(lat)<ln1-2) {
##- lcall$n <- ln1
##- rr <- eval(lcall) ## dangerous!
##- }
structure(rr, ticklabels = lf.format(lat))
}
## =====================================================================
plframe <- #f
function(x=NULL, y=NULL, xlab=NULL, ylab=NULL, xlim = NULL, ylim = NULL,
mar = NULL, showlabels = TRUE, plext=NULL, axcol = rep(1,4),
plargs = NULL, ploptions = NULL, marpar = NULL, xy=NULL, ...)
{
## -------------------
lf.getcoord <- function(x, lext) {
lx <- if (is.data.frame(x)) x[,1] else x
if (length(lx)==0)
stop("!plframe! unsuitable argument 'x' or 'y'")
lvlim <- i.def(attr(lx, "vlimscaled"), attr(lx, "vlim", exact=TRUE))
lirg <- lrg <- lplrg <- replaceNA(lvlim, attr(lx,"plrange", exact=TRUE))
## ---
if (is.factor(lx)) { ## raw factor, not yet treated by pl.control
llv <- levels(lx)
lxx <- c(1, length(llv))
if (length(attr(lx,"ticksat", exact=TRUE))==0) {
attr(lx, "ticksat") <- seq_len(length(llv))
attr(lx, "ticklabels") <- llv
}
lrg <- replaceNA(lrg, lxx+(0.5+lext[1:2])*c(-1,1))
} else {
lirg <- if(length(lir <- attr(lx,"innerrange", exact=TRUE)))
replaceNA(replaceNA(lvlim, lir), lplrg)
##- lxx <- i.def(i.def(attr(lx,"numvalues", exact=TRUE),
##- attr(lx,"plcoord", exact=TRUE)), as.numeric(lx))
if (length(attr(lx,"plcoord", exact=TRUE))==0) {
lxx <- i.def(attr(lx,"numvalues", exact=TRUE), as.numeric(lx))
lrg <- replaceNA(lrg, i.extendrange(range(lxx, finite=TRUE), lext))
}
}
list(x = lx, range = lrg, innerrange = lirg)
} ## end of lf.getcoord
## ---------------------
if (is.null(plargs)) plargs <- pl.envir ## get(...
if (length(ploptions)==0) ploptions <- plargs$ploptions
lcsize <- i.getploption("csize")
lext <- rep(i.def(i.getplopt(plext),0.03), length=4)
## --- margins
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, mar=mar, plargs=plargs)
lmar <- marpar$mar
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##
showlabels <- rep(i.def(showlabels, rep(1,4), valuefalse=rep(0,4)),
length=4)
## ---
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x=x, y=y, plargs=plargs, call=match.call(),
envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
plargs <- lxy$plargs
ploptions <- lxy$ploptions
}
if (is.data.frame(y)) y <- y[,1]
##--- plotting coordiates
lcoord <- lf.getcoord(x, lext[1:2])
lx <- lcoord$x
lrgx <- lcoord$range
lirgx <- lcoord$innerrange
lcoord <- lf.getcoord(y, lext[3:4])
ly <- lcoord$x
lrgy <- lcoord$range
lirgy <- lcoord$innerrange
## ---
axcol <- rep(i.def(axcol,1), length=4)
## --- start plot
plot(lrgx, lrgy, xaxs="i", yaxs="i", xlab = "", ylab = "",
type="n", axes=FALSE)
## inner range
lnouterx <- c(attr(lx, "nouter", exact=TRUE),0,0)[1:2]
abline(v=unique(c(lirgx[lnouterx>0], lrgx)),lty=3)
lnoutery <- c(attr(ly, "nouter", exact=TRUE),0,0)[1:2]
abline(h=unique(c(lirgy[lnoutery>0], lrgy)),lty=3)
## --- grid
lgrl <- i.getploption("grid")
if (u.notfalse(lgrl)) {
if (is.atomic(lgrl)) lgrlx <- lgrly <- lgrl
else {
if (length(lgnm <- names(lgrl))) {
lgrlx <-
if (length(lxnm <- attr(lx, "varname", exact=TRUE)) && lxnm%in%lgnm)
lgrl[[lxnm]] else ploptions("grid", ploptions)
lgrly <-
if (length(lynm <- attr(ly, "varname", exact=TRUE)) && lynm%in%lgnm)
lgrl[[lynm]] else ploptions("grid", ploptions)
} else {
if(length(lgrl)!=2) {
warning(":plframe: unsuitable argument 'grid'")
lgrlx <- lgrly <- i.getploption("grid")
} else {
lgrlx <- lgrl[[1]]
lgrly <- lgrl[[2]]
}
}
}
## grid:x
if (u.true(lgrlx)) {
lgrlx <- attr(x,"ticksat", exact=TRUE)
if (length(lgrlx)<2)
lgrlx <- attr(x, "ticksat") <-
pretty(lirgx, i.getploption("tickintervals")[1])
}
lgrlx <- clipat(lgrlx, lirgx)
if (length(lgrlx))
abline(v=lgrlx,
lty=i.getploption("grid.lty"),
lwd=i.getploption("grid.lwd"),
col=i.getploption("grid.col"))
## grid:y
if (u.true(lgrly)) {
lgrly <- attr(y,"ticksat", exact=TRUE)
if (length(lgrly)<2)
lgrly <- attr(ly, "ticksat") <-
pretty(lirgy, i.getploption("tickintervals")[1])
}
## grl <- clipat(lgrly, lirgy)
if (length(lgrly))
abline(h=lgrly,
lty=i.getploption("grid.lty"),
lwd=i.getploption("grid.lwd"),
col=i.getploption("grid.col"))
}
## zero line
lzlx <- attr(x, "zeroline", exact=TRUE)
lzly <- attr(y, "zeroline", exact=TRUE)
if (is.logical(lzlx)) lzlx <- if(lzlx) 0 else NULL
if (is.logical(lzly)) lzly <- if(lzly) 0 else NULL
if (length(lzlx)|length(lzly))
abline(v=lzlx[lzlx>lirgx[1]&lzlx<=lirgx[2]],
h=lzly[lzly>lirgy[1]&lzly<=lirgy[2]],
lty=i.getploption("zeroline.lty"),
lwd=i.getploption("zeroline.lwd"),
col=i.getploption("zeroline.col"))
## bounding boxes
abline(h=unique(c(ifelse(lnoutery>0, lirgy, lrgy), lrgy)), lty=3)
abline(v=unique(c(ifelse(lnouterx>0, lirgx, lrgx), lrgx)), lty=3)
lxrg <- ifelse(lnouterx>0, lirgx, lrgx)
lyrg <- ifelse(lnoutery>0, lirgy, lrgy)
lines(lxrg[c(1,2,2,1,1)], lyrg[c(1,1,2,2,1)])
## --- axes
## need attr("ticksat") -> otherwise, generate it!
laxes <- i.getploption("axes")
if (length(xlab)) attr(lx, "varlabel") <- xlab
if (length(ylab)) attr(ly, "varlabel") <- ylab
if (u.notfalse(laxes)) {
if (u.true(laxes)) laxes <- 1:2
for (lax in laxes) {
laxx <- lax%in%c(1,3)
plaxis(lax, if (laxx) lx else ly, showlabels=showlabels[lax],
range= if (laxx) lxrg else lyrg, col=axcol[lax],
plargs=plargs, marpar=marpar, ...)
}
}
invisible(loldp)
} ## end plframe
## =========================================================================
plaxis <- #f
function(side, x=NULL, showlabels=TRUE, range=NULL, varlabel=NULL, col=1,
tickintervals=NULL, ## sure = NULL,
plargs = NULL, ploptions = NULL, marpar=NULL, ...)
{ ## ------------------------------------------------------------------
if (length(plargs)==0) plargs <- pl.envir ## get(...) ## !!! list in calling fn ?
if (length(ploptions)==0) ploptions <- plargs$ploptions
lcsize <- i.getploption("csize")
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
## outer panel?
lmfg <- par("mfg")
lIouter <-
switch(side, lmfg[1]==lmfg[3], lmfg[2]==1, lmfg[1]==1, lmfg[2]==lmfg[4])
lmgsize <- rep(i.getploption("margin.csize"), length=2)
llabsize <- lcsize*lmgsize[1]
lticksize <- lcsize*lmgsize[2]
lmar <- lcsize*marpar$mar
lmgp <- lcsize*c(marpar$margin.line,0)
lparcex <- lcsize*par("cex")
## ---
lx <- i.def(i.def(attr(x,"numvalues", exact=TRUE),
attr(x,"plcoord", exact=TRUE)), x)
range <- i.def(range, i.def(attr(x, "innerrange", exact=TRUE),
attr(x, "plrange", exact=TRUE)),
valuefalse = range(lx,finite=TRUE))
lat <- attr(x,"ticksat", exact=TRUE)
latsmall <- attr(lat, "small", exact=TRUE)
llabat <- attr(x,"ticklabelsat", exact=TRUE)
llab <- attr(x,"ticklabels", exact=TRUE)
varlabel <-
if (i.def(showlabels))
i.def(i.def(varlabel, attr(x,"varlabel", exact=TRUE), valuefalse=""),
attr(x,"varname", exact=TRUE) )
else ""
col <- i.def(col, 1)
## --- do it!
if( lIouter || showlabels >= 1)
mtext(varlabel, side=side, line=lmgp[1], xpd=TRUE, col=col,
cex=llabsize*lparcex, adj=i.def(attr(varlabel, "adj"), 0.5))
## ticks and tick labels
if (length(lat)<=1) {
ltk <- plticks(range, ploptions=ploptions)
lat <- ltk$ticksat
llabat <- ltk$ticklabelsat
llab <- NULL
}
lat <- clipat(lat, range)
if (showlabels) {
if (length(llabat)) {
if (!is.numeric(llabat)) {
warning(":plaxis: 'ticklabelsat' must be numeric")
llabat <- NULL
}
} else llabat <- lat
if (length(llab)) {
if (NCOL(llabat)>1) { ## labels placed in the middle of intervals
lc <- rbind(apply(llabat, 2, clipat, range=range, clipped=NA))
li <- apply(lc, 1, sumNA) ==2
llabat <- apply(llabat, 2, clipat, range=range, clipped=range)
llabat <- apply(rbind(llabat), 1, mean, na.tm=TRUE)
##- pmin(pmax(llabat[,2],range[1]),range[2]))/2
llabat[li] <- NA
}
if (length(llab)!=length(llabat)) {
if (length(llab)==1) llab <- rep(llab,length(llabat))
else {
warning(":plaxis: 'ticklabel' has wrong length")
llab <- NULL
}
}
}
if (length(llab)==0) llab <- format(llabat)
llabat <- clipat(llabat, range, NA)
li <- is.na(llabat)|is.na(llab)
llabat <- llabat[!li]
llab <- llab[!li]
if (length(llab)==0) llab <- rep("",length(llabat))
}
## --- axes
## tick lengths
ltcl <- i.getploption("ticklength")*par("cex")
if (length(ltcl)<2) ltcl <- rep(c(ltcl,0.5),length=2)*c(1,0)
if (length(ltcl)<4) ltcl <- c(ltcl, c(ltcl[-(1:2)],0.2)[1]*c(1,-1))
axis(side, at=lat, labels=rep("",length(lat)), col=col, tcl=ltcl[1], ...) ## axis without tickmarks
if (ltcl[2]) axis(side, at=lat, labels=rep("",length(lat)),
tcl=ltcl[2], col=col, ...) ## ticks inside
if (length(latsmall)) { ## small ticks
if (ltcl[3]) axis(side, at=latsmall, labels=rep("",length(latsmall)),
tcl=ltcl[3], col=col, ...)
if (ltcl[4]) axis(side, at=latsmall, labels=rep("",length(latsmall)),
tcl=ltcl[4], col=col, ...)
}
if (length(llabat)) ## tick labels
if((showlabels & (lmar[side]>=lmgp[2]+1 | lIouter)) | showlabels>=1)
mtext(llab, side, line=lmgp[2], at=llabat, col=col,
cex=lticksize*lparcex, ...)
invisible()
} ## end plaxis
## ===========================================================================
pltitle <- #f
function(main=NULL, sub=NULL, csize=NULL, csizemin=NULL,
side=3, line=NULL, adj=NULL, outer.margin=NULL, col="black",
doc=NULL, show=NA, plargs = NULL, ploptions = NULL,
marpar = NULL, ...)
{
## Purpose: title
## ----------------------------------------------
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
scale <- 0.6 ## scale factor to get width of a character
minadj <- 0.2
## ---
main <- i.def(main, plargs$plfeatures$main)
sub <- i.def(sub, i.def(plargs$plfeatures$sub, i.getploption("sub")))
## i.def(sub, plargs$sub, valuefalse=NULL) ## paste(":",plargs$sub,sep="")
## if (is.logical(sub)) sub <- if(sub) ":" else NULL
if (u.true(sub)) sub <- ":"
sub <- if (length(sub) && substr(sub,1,1)==":")
paste(substring(sub,2,30), plargs$.subdefault, sep="")
else if (u.notfalse(sub)) as.character(sub)
if (length(main)&&main=="") main <- NULL
if (length(sub)&&sub=="") sub <- NULL
if (length(main)==0 & length(sub)==0) return(invisible(list(main=NULL,sub=NULL)))
if (length(main) && all(sub==main)) sub <- NULL
rr <- c(main=main, sub=sub)
show <- i.def(show, 0.5) ## 0.5 means: only outer margin if first plot
outer.margin <- i.def(outer.margin, par("oma")[3]>0)
if (u.false(show) || (show<1 && outer.margin && 1!=prod(par("mfg")[1:2])) )
return(rr)
## -------------------------------
lf.text <- function(text, csize, csizedef, line=line, adj,
outer.margin=FALSE) {
## calculate text size and write text
if (!is.expression(text)) text <- format(text)
if (length(text)>1) text <- paste(text, collapse=" ")
lcsize <-
i.def(csize, max(csizemin, min(csizedef, lfac/max(nchar(text)))),
valuefalse = 1 )
lmaxchar <- lfac/lcsize
if (nchar(text)>lmaxchar)
text <- paste(substr(text, 1, lmaxchar-3),"...")
ladj <- i.def(adj, max(minadj,0.5*(lcsize>csizemin)), 0.5, minadj)
mtext(text, side, line,
cex = lcsize*ifelse(outer.margin, 1, lparcex),
adj=ladj, outer = outer.margin, col=col, ...)
lcsize
}
## ---------------------------
## mar= needed to obtain consistency
lcsgen <- i.getploption("csize")
##- lparcex <- lcsgen * (if (outer.margin) 1 else par("cex"))
lparcex <- lcsgen * par("cex")
ltadj <- rep(i.def(adj, i.getploption("title.adj"), valuefalse=0.5),
length=3)
## -------------------------
ltcs <- rep(i.def(csize,NA), length=3)
ltcsdef <- rep(i.def(csize, i.getploption("title.csize")), length=3)
## title.csizemin <- csizemin
## tcsmin <- i.def(csizemin, i.getploption("title.csizemin"), valuefalse=0.1)
##
lImain <- length(main) && main!=""
lIsub <- length(sub) && sub%nin%c("",":")
##- lIdoc <- length(doc) && doc!=""
## lmarmax <- if (outer.margin) par("oma")[side] else par("mar")[side]
##- lmarmax <- lmarmax-ltcsdef[2-lImain]
##- llinedef <- sum(ltcsdef*c(lImain, lIsub, lIdoc))
##- line <- min(i.def(line, llinedef), lmarmax)
##- llinedef <- min(i.def(i.getploption("title.line"), Inf),
##- lmarmax-0.1-ltcsdef[2-lImain])
##- lline <- i.def(line, llinedef) ## -0.3: leave some space above title
lside24 <- side%in%c(2,4)
lwid <- if (outer.margin) par("mfg")[4-lside24] else 1
lfac <- lwid * par("pin")[1+lside24]/(par("cin")[1]*par("cex")*scale)
##
## line may be scalar or vector of length 3
lline <- line
if (is.null(line)) ## !!!!!
lline <- c(i.getmarpar(plargs=plargs)$title.line, NA, NA)
if (outer.margin && length(lomast <- marpar$omastart))
lline <- lline+lomast[3] ## in plmatrix, part of oma is used for axes
## lline <- lline*lcsgen
line <- lline[1]
if (lImain) {
## lline <- lline + lIsub*lcsgen*is.na(lline[2])
lcs <- lf.text(main, csize=ltcs[1], csizedef=ltcsdef[1], line=line,
adj=ltadj[1], outer.margin=outer.margin)
line <- max(line-lcs*lparcex,0)
}
if (!is.na(lline[2])) line <- lline[2]
if (lIsub) {
lcs <- lf.text(sub, csize=ltcs[2], csizedef=ltcsdef[2],
line=line, adj=ltadj[2], outer.margin=outer.margin)
if (length(lline)<=2) lline[3] <- max(lline-lcs*lparcex,0)
}
ldoc <- i.def(doc, tit(main))
if (length(ldoc)) {
if (!is.na(lline[3])) line <- lline[3]
if (line>=0 && (!u.isnull(doc)) && doc && length(ldoc))
lf.text(ldoc, csize=ltcs[3], csizedef=ltcsdef[3], adj=ltadj[3],
outer.margin=outer.margin)
}
## invisible(rr)
}
## -----------------------------------------------------------------
plpoints <- #f
function(x = NULL, y = NULL, type = "p", plab = NULL, pch = NULL,
pcol = NULL, col = NULL, lcol = NULL, lty = NULL, lwd = NULL,
psize = NULL, csize = NULL, group = NULL,
plargs = NULL, ploptions = NULL, marpar=NULL, xy=TRUE, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
## intro, needed if formulas are used or data is given or ...
lcl <- match.call()
lcsize <- i.getplopt(csize)
col <- i.def(col, NULL, valuefalse=NULL)
## if (length(col)) { !! changed 22.01
if(u.isnull(pcol)) {
lcl$pcol <- pcol <- col
## lcl$col <- NULL
}
if(u.isnull(lcol)) { ## changed 22.01
lcol <- attr(y,"vcol")
if (length(lcol)==0) lcol <- col
lcl$lcol <- lcol
## lcl$col <- NULL
}
## }
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x, y, plargs, ploptions, call=lcl, envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
ploptions <- lxy$ploptions
plargs <- lxy$plargs
}
pldata <- plargs$pldata
## --- ploptions
## ---
condquant <- i.getploption("condquant")
## ---
if (is.data.frame(x)) x <- x[,1]
lattrx <- attributes(x)
## lx <- i.def(lattrx$plcoord, i.def(lattrx$numvalues, as.numeric(x)))
lx <- i.def(lattrx$numvalues, x)
lIcensx <- inherits(x, "Surv")
if (lIcensx) lx <- lx[,1]
lx <- as.numeric(lx)
if (length(llir <- lattrx[["innerrange"]])) {
lx <- if (length(llpc <- lattrx[["plcoord"]])) llpc
else plcoord(lx, llir, ploptions=ploptions)
} else lx <- i.def(lattrx[["plcoord"]], lx)
lx[is.na(x)] <- NA
##
if (is.data.frame(y)) y <- y[,1]
lattry <- attributes(y)
ly <- i.def(lattry$numvalues, y)
lIcensy <- inherits(y, "Surv")
if (lIcensy) ly <- ly[,1]
ly <- as.numeric(ly)
if (length(llir <- lattry[["innerrange"]])) {
ly <- if (length(llpc <- lattry[["plcoord"]])) llpc
else plcoord(ly, llir, ploptions=ploptions)
} else ly <- i.def(lattry[["plcoord"]], ly)
ly[is.na(y)] <- NA
## condquant
lIcq <- condquant>0 ## condquant representation by bars
lIcqx <- length(lcqx <- lattrx$condquant) >0
lIcqy <- length(lcqy <- lattry$condquant) >0
##
lnr <- length(x)
psize <- i.def(psize, pldata[[".psize."]])
lpsize <-
if (u.isnull(psize)) 1 else sqrt(psize/median(psize, na.rm=TRUE))
if (max(lpsize, na.rm=TRUE)> (lpm <- i.getploption("psize.max"))) {
warning("maximum psize too large. I censor at ", lpm)
lpsize <- pmin(lpsize,lpm)
}
lpsize <- lpsize*lcsize*par("cex")
if (u.isnull(plab)) plab <- pldata[[".plab."]] ## !!! treat like pch ?
## group
lgroup <- i.def(group, pldata[[".group."]], valuefalse=NULL)
if (u.true(lgroup)) {
warning(":plpoints: 'group' not identified")
lgroup <- NULL
}
lattrgrp <- if (length(lgroup))
i.getinlist(attributes(lgroup), i.getgroupopt(lgroup))
if (length(lgroup)==0) lgroup <- rep(1, lnr)
lgrp <- as.numeric(lgroup)
lgrpv <- unique(lgrp)
lgrpn <- max(lgrpv)
## pch
if (u.true(pch)) pch <- NA
pch <-
i.getinlist(pch, pldata[[".pch."]], lattrgrp$group.pch[lgroup],
lattry$vpch, i.getploption("pch")[1])
pch <- rep(i.def(pch, i.getploption("pch"), valuefalse=""), length=lnr)
## color
if (u.true(pcol)) pcol <- NA
pcol <- i.getinlist(pcol, pldata[[".pcol."]], lattrgrp$group.col[lgroup],
lattry$vpcol, i.getploption("pcol")[1])
pcol <- rep(i.def(pcol, i.getploption("pcol"), valuefalse=""), length=lnr)
## lty, lwd
if (u.true(lty)) lty <- NA
lty <- rep( i.getinlist(lty, lattrgrp$group.lty, lattry$vlty,
i.getploption("lty")),
length=lgrpn)
lwd <- i.getinlist(lwd, lattry$vlwd, i.getploption("lwd")) *
i.getploption("linewidth")[lty]
if (u.true(lcol)) lcol <- NA
lcol <-
if (type=="b")
i.getinlist(lcol, lattrgrp$group.col, lattry$vpcol,
i.getploption("pcol")[1])
else i.getinlist(lcol, lattrgrp$group.col, lattry$vcol,
i.getploption("lcol"))
lcol <- rep(lcol, length=lgrpn)
lnobs <- sum(is.finite(lx) & is.finite(ly))
csize.pch <- i.getploption("csize.pch")
csize.pch <- if (is.function(csize.pch)) csize.pch(lnobs)
else i.def(csize.pch, charSize(lnobs))
csize.plab <- csize.pch*i.getploption("csize.plab")
lsplab <- rep(abs(csize.plab*lpsize), length=lnr)
lspch <- rep(csize.pch*lpsize, length=lnr)
## censored
if (lIcensx|lIcensy) {
lstx <-
if (lIcensx) (1+(i.def(lattrx$type, "right")=="left"))*(1-x[,2]) else 0
lsty <-
if (lIcensy) (1+(i.def(lattry$type, "right")=="left"))*(1-y[,2]) else 0
lipch <- lstx+3*lsty
li <- lipch>0
if (any(li)) {
pch[li] <- rep(i.getploption("censored.pch"), length=8)[lipch[li]]
pcol[li] <- colorpale(pcol[li], i.getploption("censored.pale")[1])
lspch[li] <- lspch[li]*i.getploption("censored.size")
}
}
## condquant
if (lIcq & (lIcqx|lIcqy)) {
##- lpale <- rep(c(i.getploption("condquant.pale"), 0.5), length=2)
lpale <- i.def(i.getploption("condquant.pale"), 0.5, valuefalse=1)[1]
lcqpch <- i.getploption("condquant.pch")
lix <- if(lIcqx) lcqx[,"index"]
liy <- if(lIcqy) lcqy[,"index"]
lixy <- union(lix,liy)
if (length(lcqpch)) pch[lixy] <- lcqpch[1] ## pch
##- if (length(lixy)==lnr) lpale <- c(1,lpale[1]) ## all observations are cq
##- pcol[lixy] <- colorpale(pcol[lixy], lpale[1])
if (length(lixy)<lnr) pcol[lixy] <- colorpale(pcol[lixy], lpale)
##
if (lIcqx) {
li <- lix %nin% liy ## why?
if (any(li)) {
lsg <- if(length(lrgx <- lattrx$innerrange))
plcoord(lcqx[li,2:3], range=lrgx, ploptions=ploptions)
else lcqx[li,2:3]
lyy <- ly[lix[li]]
segments(lsg[,1], lyy, lsg[,2], lyy,
col=colorpale(pcol[lix[li]], lpale) )
}
}
if (lIcqy) {
li <- liy %nin% lix
if (any(li)) {
lsg <- if(length(lrgy <- lattry$innerrange))
plcoord(lcqy[li,2:3], range=lrgy, ploptions=ploptions)
else lcqy[li,2:3]
lxx <- lx[liy[li]]
segments(lxx, lsg[,1], lxx, lsg[,2],
col=colorpale(pcol[liy[li]], lpale) )
}
}
}
## ---
lIpl <- (length(plab)>0) && any(!is.na(plab))
plab <- as.character(plab)
## --- plot!
if (lIpl) { ## points with labels
text(lx, ly, plab, cex=lsplab, col=pcol, xpd=TRUE)
lipch <- ifelse(is.na(plab), TRUE, plab=="") ## point is not labelled
} else lipch <- rep(TRUE,length(x))
if (any(lipch)) {
if (type%in%c("l","b")) { ## lines
lx[is.na(ly)] <- NA
ly[is.na(lx)] <- NA
lxy <- cbind(lx,ly)
## points in margin
lnox <- attr(x, "nouter", exact=TRUE)
if(any(lnox>0)) {
lrgx <- attr(x, "innerrange", exact=TRUE)
if(lnox[1])
lxy <- i.lineout(lxy[,1], lxy[,2], lrgx[1], FALSE)
if(lnox[2])
lxy <- i.lineout(lxy[,1], lxy[,2], lrgx[2], TRUE)
lxy[lxy[,1]<lrgx[1]|lxy[,1]>lrgx[2],] <- NA
}
lnoy <- attr(y, "nouter", exact=TRUE)
if(any(lnoy>0)) {
lrgy <- attr(y, "innerrange", exact=TRUE)
if(lnoy[1])
lxy <- i.lineout(lxy[,2], lxy[,1], lrgy[1], FALSE)[,c(2,1,3)]
if(lnoy[2])
lxy <- i.lineout(lxy[,2], lxy[,1], lrgy[2], TRUE)[,c(2,1,3)]
lxy[lxy[,2]<lrgy[1]|lxy[,2]>lrgy[2],] <- NA
}
##
for (lg in lgrpv) {
li <- lgrp==lg
points(lxy[li,1], lxy[li,2], type=type, pch=NA, col=lcol[lg],
lty=lty[lg], lwd=lwd, cex=lspch[lg],
xpd=TRUE, ...)
}
if (type=="l") return()
type <- "p"
}
lipch <- lipch & !is.na(lx)
points(lx[lipch], ly[lipch], type=type, pch=pch[lipch],
cex=lspch[lipch], col=pcol[lipch], xpd=TRUE) ## ??? why is xpd needed?
}
invisible(NULL)
} ## end plpoints
## ---------------------------------------------------------------------
pllines <- function(x=NULL, y=NULL, type="l", ...) {
plpoints(x=x, y=y, type=type, ...)
}
## ---------------------------------------------------------
i.lineout <- #f
function(z, zz, lim, upper) {
## determines indices before which a point on the inner range limit is needed
## and the "other" coordinate
lout <- if(upper) z>lim else z<lim
li0 <- which(c(lout,FALSE) & !c(TRUE,lout))
lzout <- zz
lz <- z[li0-1]
lr <- (lim-lz)/(z[li0]-lz)
lzz0 <- zz[li0-1]+lr*(zz[li0]-zz[li0-1])
li1 <- which(c(FALSE,lout) &! c(lout, TRUE))
lz <- z[li1-1]
lr <- (lim-lz)/(z[li1]-lz)
lzz1 <- zz[li1-1]+lr*(zz[li1]-zz[li1-1])
lii <- order(c(1:length(z), li0-0.6, li1-0.4))
zz[c(li0,li1-1)] <- NA
cbind(z=c(z,rep(lim,length(c(li0,li1))))[lii], zz=c(zz,lzz0,lzz1)[lii],
zout=c(ifelse(lout, lzout, NA), lzz0, lzz1)[lii])
}
## -----------------------------------------------------------------
plbars <- #f
function(x = NULL, y = NULL, midpointwidth = NULL,
plargs = NULL, ploptions = NULL, marpar = NULL, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
lcsize <- i.getploption("csize")
pldata <- plargs$pldata
if (length(x)==0)
x <- plargs$pldata[,c(attr(pldata, "xvar", exact=TRUE),1)[1]]
if (length(y)==0)
y <- plargs$pldata[,c(attr(pldata, "yvar", exact=TRUE),2)[1]]
x <- as.matrix(x)
y <- as.matrix(y)
lxy <- as.matrix(cbind(x,y))
if (!is.numeric(lxy)) {
warning(":plbars: 'x' or 'y' contain non-numeric values. no bars")
return()
}
lnobs <- sum(apply(is.finite(lxy),1,all))
if (lnobs==0) {
warning(":plbars: no observations. no bars")
return()
}
if (NCOL(x)==1) x <- c(x)
if (NCOL(y)==1) y <- c(y)
if (!(is.null(dim(x))&NCOL(y)>=3 | is.null(dim(y))&NCOL(x)>=3)) {
warning(":plbars: unsuitable arguments 'x', 'y'. Either one must have 3 columns.",
" -> no bars.")
return()
}
if (length(lop <- list(...))) {
lop$ploptions <- ploptions
ploptions <- ploptions(list=lop, assign=FALSE)
}
lcol <- i.getploption("bar.col")
llty <- rep(i.getploption("bar.lty"), length=2)
llwd <- rep(i.getploption("bar.lwd"), length=2)
lmpw <- i.def(midpointwidth,
i.getploption("bar.midpointwidth")) * 0.3 * ## llwd[1] *
diff(par("usr")[1:2+2*is.matrix(x)])/ lnobs
if (is.matrix(x)) {
segments(x[,1], y-lmpw, x[,1], y+lmpw, lty=llty, lwd=llwd[1],
col=lcol)
segments(x[,2], y, x[,3], y, lty=llty, lwd=llwd[2], col=lcol)
}
if (is.matrix(y)) {
segments(x-lmpw, y[,1], x+lmpw, y[,1], lty=llty, lwd=llwd[1],
col=lcol)
segments(x, y[,2], x, y[,3], lty=llty, lwd=llwd[2], col=lcol)
}
invisible(NULL)
}
## -----------------------------------------------------------------
plmark <- #f
function(x=NULL, y=NULL, markextremes=NULL, plabel=NULL,
plargs = NULL, ploptions = NULL)
{ ## ---------------------------------
lf.pmark <- function(mprop, x) {
lrk <- (rank(x, na.last="keep")-0.5)/sum(is.finite(x))
lrk<mprop[1] | lrk>1-mprop[2]
}
##
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
plabel <- i.def(i.def(plabel, plargs$plfeatures$plabel), pl.envir$plabel)
if (u.isnull(plabel)) {
warning(":plmark: no plabels found")
return(NULL)
}
if (length(x)==0) x <- plargs$pldata[,1]
lx <- if (is.data.frame(x)) x[,1] else x
ly <- if (is.data.frame(y)) y[,1] else y
lnobs <-
if (u.isnull(ly)) sum(is.finite(lx)) else sum(is.finite(lx)&is.finite(ly))
lmxdef <- ceiling(sqrt(lnobs)/2)/lnobs
lmx <- i.getploption("markextremes")
if(is.function(lmx)) lmx <- lmx(lnobs)
if (is.list(markextremes))
lmx <- lapply(markextremes, function(x) i.def(x, lmxdef))
if (lnmn <- length(lmxnm <- names(lmx))) {
lmxx <- i.def(unlist(lmx[attr(x,"varname", exact=TRUE)]), lmxdef)
lmxy <- i.def(unlist(lmx[attr(y,"varname", exact=TRUE)]), lmxdef)
} else {
if(length(lmx)<=1) lmxx <- lmxy <- i.def(lmx[[1]], lmxdef)
else {
lmxx <- lmx[[1]]
lmxy <- lmx[[2]]
}
}
##- lmxx[is.na(lmxx)] <- lmxdef
##- lmxy[is.na(lmxy)] <- lmxdef
rr <- if (any(unlist(lmx)>0)) {
li <- lf.pmark(rep(lmxx, length=2), lx)
if (length(y)) li <- li | lf.pmark(rep(lmxy, length=2), ly)
ifelse(li, plabel, "")
} else rep("", length(lx)) ## plabel
rr
} ## end plmark
## -----------------------------------------------------------------
plsmooth <- #f
function(x = NULL, y = NULL, ysec = NULL, band=NULL, power = NULL,
group=NULL, weight=NULL,
smooth = TRUE, plargs = NULL, ploptions=NULL, xy=TRUE, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x, y, plargs, ploptions=ploptions,
call=match.call(), envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
ploptions <- lxy$ploptions
}
if (length(x)<i.getploption("smooth.minobs")) {
warning(":plsmooth: too few observations. no smooth")
return() ## lxy[c("x","y")])
}
## pldata <- lxy$plargs$pldata
if (length(group)) {
if (length(group)%nin%c(1,nrow(plargs$pldata)))
warning(":plsmooth: argument 'group' has wrong length. It is ignored.")
else
plargs$pldata[,".smooth.group."] <- group
}
lIsm <- i.getplopt(smooth)
llsm <- lplft$smooth
if (length(smooth)==0 && length(llsm)) lIsm <- llsm
lIband <- i.def(band, i.getploption("smooth.band"))
if (length(band)==0 && length(llsm)) lIband <- llsm>1
lsm <- NULL
if (lIsm) {
power <- i.def(power, 1,1,1)
## lIband <- i.def(i.def(lIband, lIsm>=2), FALSE, TRUE, FALSE)
if (length(lxn <- attr(x, "numvalues", exact=TRUE))) x <- lxn
if (length(lyn <- attr(y, "numvalues", exact=TRUE))) y <- lyn
ly <- if(length(ysec)==0) y else {if (length(y)==0) ysec else cbind(y,ysec)}
##
lsm <- gensmooth(x, ly, band=lIband[1], power=power, weight=weight,
plargs=plargs, ploptions=ploptions)
## --------------
ysecsm <- NULL
if (length(ysec)) { ## separate y and ysec
lny <- NCOL(y) * (length(y)>0) ## ... NCOL(NULL) is 1 !
ysecsm <- lsm[["y"]]
if (lny==0) lsm$y <- NULL else {
lsm$y <- ysecsm[,1:lny]
ysecsm <- ysecsm[,-(1:lny)]
}
}
plsmoothline(lsm, x, y=y, ysec = ysecsm, plargs=plargs, ploptions=ploptions, ...)
}
invisible(lsm)
}
## --------------------------------------------------------------
plsmoothline <- #f
function(smoothline = NULL, x = NULL, y = NULL, ysec = NULL,
smooth.col = NULL, smooth.lty = NULL, smooth.lwd = NULL,
plargs = NULL, ploptions = NULL, marpar = NULL, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
lcsize <- i.getploption("csize")
## --- data
if (u.isnull(smoothline)) {
if (length(x)&&length(y)==length(x))
smoothline <- list(x=x, y=y)
else {
warning(":plsmoothline: no smoothline found")
return()
}
}
if (!is.list(smoothline)) {
warning(":plsmoothline: 'smoothline' is not suitable. No smooth line")
return()
}
##- if (u.isnull(x)&&u.isnull(y)) { ## does not make sense since pldata will not contain smooths
##- lxy <- i.getxy(x, y, plargs, call=match.call(), envir=parent.frame())
##- plargs <- lxy$plargs
##- ploptions <- lxy$ploptions
##- x <- lxy$x
##- y <- lxy$y
##- }
lx <- i.def(smoothline[["x"]], x)
if (length(lx)==0) {
warning(":plsmoothline: no x values. No smooth line")
return()
}
ly <- i.def(smoothline[["y"]], y)
lIy <- length(ly)>0
lIysec <- length(ysec)>0
if (lIy) ly <- as.matrix(ly)
if (lIysec) ysec <- as.matrix(ysec)
if (!(lIy|lIysec)) {
warning(":plsmoothline: neither 'y' nor 'ysec' given. No smooth line")
return()
}
lbd <- smoothline$yband
lIband <- length(lbd)>0
if (length(smooth.col))
ploptions$smooth.col <-
i.def(smooth.col, i.getploption("smooth.col"), valuefalse="black")
if (length(smooth.lty))
ploptions$smooth.lty <-
i.def(smooth.lty, i.getploption("smooth.lty"), valuefalse=1)
if (length(smooth.lwd))
ploptions$smooth.lwd <-
i.def(smooth.lwd, i.getploption("smooth.lwd"), valuefalse=0.1)
lxtrim <- i.getploption("smooth.xtrim")
lrgx <- attr(x,"innerrange", exact=TRUE)
if (length(lsc <- attr(x, "plscale", exact=TRUE)))
lx <- attr(plscale(lx, plscale=lsc), "numvalues", exact=TRUE)
##- if (length(lsc <- attr(y, "plscale", exact=TRUE))) {
##- if (lIy) ly <- as.matrix(attr(plscale(ly, plscale=lsc), "numvalues", exact=TRUE))
##- if (lIysec) ysec <- as.matrix(attr(plscale(ysec, plscale=lsc), "numvalues", exact=TRUE))
##- if (lIband) lbd <- attr(plscale(lbd, plscale=lsc), "numvalues", exact=TRUE)
##- }
## ---
lcol <- i.getploption("smooth.col")
llty <- i.getploption("smooth.lty")
lgrp <- as.numeric(smoothline$group)
if (lInogrp <- length(lgrp)==0 || length(unique(dropNA(lgrp)))<=1) {
lgrp <- rep(1, NROW(lx))
lngrp <- 1
} else {
lngrp <- max(lgrp)
if (length(lcol)<lngrp) {
llcol <- i.getploption("col")
if (length(llcol)>1) llcol <- llcol[-1]
lcol <- rep(i.def(i.getploption("group.col"), llcol,
valuefalse=lcol[1]), length=lngrp)
}
lltydf <- i.getploption("lty")
llty <- rep(i.def(i.getploption("group.lty"),
i.def(lltydf[-1],llty), valuefalse=llty), length=lngrp)
}
##- if (is.numeric(lcol)) {
##- lcl <- i.getoption("colors")
##- lcol <- c(lcl[1],rep(lcl[-1], length=lngrp))[lcol+1]
##- ##[ifelse(lcol==0,1,(lcol-1)%%lngrp+2)]
##- }
## check if ordered
lio <- order(lgrp, lx)[1:sum(is.finite(lx))]
if (length(lio)!=length(lx) || any(lio!=1:length(lio))) {
lx <- lx[lio]
if (lIy) ly <- ly[lio,, drop=FALSE]
if (lIysec) ysec <- ysec[lio,, drop=FALSE]
lgrp <- lgrp[lio]
lngrp <- max(lgrp)
if (lIband) {
lbd <- lbd[lio]
smoothline$ybandindex <- smoothline$ybandindex[lio]
}
}
lx <- clipat(lx, lrgx, clipped=NA)
## may be a 2-vector or a matrix of 2 rows
llwd <- rep(c(i.getploption("smooth.lwd"), 0.7), length=2)
llwid <- i.getploption("linewidth")
lpale <- i.getploption("smooth.pale")
for (lgr in seq_len(lngrp)) {
lig <- which(lgrp==lgr)
lxg <- lx[lig]
lyg <- ly[lig,, drop=FALSE]
lysecg <- ysec[lig,]
if (all(is.na(lyg))&&all(is.na(lysecg))) next
if (1< (lng <- length(lig))) {
lndr <- i.def(smoothline$xtrim, 1) *
round(lng * if(is.function(lxtrim)) lxtrim(lng)
else i.def(lxtrim, 0, smoothxtrim(lng), 0) )
if (lndr) lxg[- ((lndr+1):(lng-lndr)) ] <- NA
lcl <- lcol[lgr] ## lcol[min(lgr,length(lcol))]
llt <- llty[lgr]
llw <- llwd[1]*llwid[llt]
lclp <- if (lInogrp) lcol[2] else lcl
lclp <- i.def(lclp, colorpale(lcl, lpale))
if (lIysec)
matlines(lxg, lysecg, lty=llt, lwd=llwd[2]*llw, col = lclp, ...)
if (lIy) matlines(lxg, lyg, lty=llt, lwd=llw, col=lcl, ...) ## xxx
if (lIband) {
li <- smoothline$ybandindex[lig] ## separate upper and lower smooth
## ??? does this work with re-sorting?
if (any(li))
lines(lxg[li], lbd[lig[li]], lty=llt, lwd=llw/2, col = lcl, ...)
if (any(!li))
lines(lxg[!li], lbd[lig[!li]], lty=llty, lwd=llw/2, col = lcl, ...)
}
}
}
invisible(NULL)
}
## -----------------------------------------------------------------
plrefline <- #f
function(refline, x=NULL, innerrange=NULL, y=NULL,
cutrange = c(x=TRUE, y=FALSE),
plargs = NULL, ploptions = NULL, ...)
{
## draws a reference line (with extended range) and
## band given by reflineyw (only inner range) if requested
lf.irna <- function(x, rg) {
x[x<rg[1]|x>rg[2]] <- NA
x
}
## ---
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
llty <- rep(i.getploption("refline.lty"), length=2)
llwd <- rep(i.getploption("refline.lwd"), length=2)
llcol <- rep(i.getploption("refline.col"), length=2)
lusr <- par("usr")
## ---
if (missing(refline)||u.isnull(refline)) {
warning(":plrefline: argument refline is NULL. No refline")
return()
}
## a single refline is turned into a list of length 1
if (is.list(refline)&&any(c("coefficients", "coef", "x", "y")%in%names(refline)))
refline <- list(refline)
if (!is.list(refline)) refline <- list(refline)
##
for (lirfl in seq_along(refline)) {
lrfl <- refline[[lirfl]]
lrfyb <- NULL
if (is.function(lrfl)) {
if (u.isnull(x)|u.isnull(y)) {
lpldata <- plargs$pldata
if (u.isnull(x))
x <- lpldata[,tail(i.def(attr(lpldata,"xvar", exact=TRUE),2),1)]
if (u.isnull(y))
y <- lpldata[,tail(i.def(attr(lpldata,"yvar", exact=TRUE),1),1)]
if (u.isnull(x)|u.isnull(y)) {
warning(":plrefline: no x and/or y values found for fitting the function")
next
}
}
lrfl <-
if (names(formals(lrfl))[1]=="formula") try(lrfl(y~x))
else try(lrfl(x,y))
if (inherits(lrfl, "try-error")) {
warning(":plrefline: argument refline contains an unsuitable function")
next
}
}
if (is.list(lrfl)&&length(lrfl$coef)) lrfl <- lrfl$coef
if (is.character(x)) x <- plargs$pldata[,x]
if (is.character(y)) y <- plargs$pldata[,y]
if (u.isnull(innerrange)) innerrange <- attr(x, "innerrange", exact=TRUE)
if (length(lxn <- attr(x, "numvalues", exact=TRUE))) x <- lxn
if (length(lyn <- attr(y, "numvalues", exact=TRUE))) y <- lyn
##---
if (is.atomic(lrfl)) {
if (length(lrfl)!=2) {
warning(":plrefline: 'refline' not suitable. No refline")
next
}
lrfx <- seq(lusr[1],lusr[2],
length=i.getploption("functionxvalues"))
lrfy <- lrfl[1]+lrfl[2]*lrfx ## needs correction if lIxir
} else {
lrfx <- lrfl$x
lrfy <- lrfl$y
if (length(lrfx)==0|length(lrfx)!=NROW(lrfy)) {
warning(":plrefline: 'refline' not suitable. No refline")
next
}
if (all(lrfx<lusr[1]|lrfx>lusr[2], na.rm=TRUE)) {
warning(":plrefline: no x coordinates in plot range")
next
}
lrfyb <- lrfl$band
}
lIrfyb <- length(lrfyb)
## ---
## haul lrfl to inner plotrange
if (length(innerrange)>0) {
if (u.isnull(x))
x <- plargs$pldata[, i.def(attr(plargs$pldata,"xvar", exact=TRUE),1)[1]]
if (u.isnull(y))
y <- plargs$pldata[, i.def(attr(plargs$pldata,"yvar", exact=TRUE),1)[2]]
lIxir <- any(attr(x,"nouter", exact=TRUE)>0)
lxir <- attr(x,"innerrange", exact=TRUE)
lIyir <- any(attr(y,"nouter", exact=TRUE)>0)
lyir <- attr(y,"innerrange", exact=TRUE)
cutrange <- rep(i.def(cutrange, TRUE), length=2)
if (lIxir) {
if (i.def(cutrange[1], TRUE)) lrfx <- lf.irna(lrfx, lxir)
else
lrfx <- plcoord(lrfx, range=lxir, ploptions=ploptions)
}
if (lIyir) {
if (i.def(cutrange[2], FALSE)) lrfy <- lf.irna(lrfy, lyir)
else
lrfy <- plcoord(lrfy, range=lyir, ploptions=ploptions)
if (lIrfyb) ## band: values outside inner range -> NA
lrfb <- apply(as.matrix(lrfb),2, lf.irna, rg=lyir)
}
}
## draw reference lines
llt <- rep(i.def(attr(lrfl, "lty", exact=TRUE), llty), length=2)
llw <- rep(i.def(attr(lrfl, "lwd", exact=TRUE), llwd), length=2)
llc <- rep(i.def(attr(lrfl, "lcol", exact=TRUE), llcol), length=2)
matlines(lrfx, lrfy, lty=llt[1], lwd=llw[1], col=llc[1])
if (lIrfyb)
matlines(lrfx, as.matrix(lrfy+lrfyb), lty=llt[2], lwd=llw[2], col=llc[2])
}
invisible(NULL)
}
## =========================================================================
plcoord <- #f
function(x, range=NULL, innerrange.factor=NULL, innerrange.ext=NULL,
plext=NULL, ploptions=NULL)
{
## Purpose: values for plot with limited "inner" plot range
lx <- structure(as.numeric(x), dim=dim(x))
ldtrg <- range(lx, finite=TRUE)
lirfunc <- i.getploption("innerrange.function")
if (is.character(lirfunc)) lirfunc <- get(lirfunc)
innerrange.factor <- i.getplopt(innerrange.factor)
innerrange.ext <- i.getplopt(innerrange.ext)
plext <- i.getplopt(plext)
## ---
if (length(range)>0) {
range <- rep(range, length=2)
## range <- range(range, finite=TRUE)
if ( (!is.na(range[1])&&range[1]>ldtrg[2]) |
(!is.na(range[2])&&range[2]<ldtrg[1]) ) { ## ranges do not overlap
warning(":plcoord: inadequate range. Not used")
range <- NULL
}
}
lrg <- range
if (length(lrg)==0||any(is.na(lrg))) {
lrg <- lirfunc(lx, fac=innerrange.factor)
if (length(lrg)==0) lrg <- ldtrg
if (length(range)) {
li <- !is.na(range)
lrg[li] <- range[li]
}
} else
if (diff(lrg)==0) lrg <- c(-1,1)*lrg
## --------- transformation of data into plcoord
lx[!is.finite(lx)] <- NA
rr <- pmax(pmin(lx,lrg[2]),lrg[1])
lxd <- lx-rr
lnouter <- c(sum(lxd<0, na.rm=TRUE),sum(lxd>0, na.rm=TRUE)) ## lxd is finite
if (sum(lnouter)>0) rr <- rr+lxd/(1+abs(lxd)/(diff(lrg)*innerrange.ext))
## if data fits into extended inner range, then avoid inner range
lrg <- ifelse(lnouter>0, lrg, ldtrg)
##- lrgext <- i.extendrange(lrg, plext)
##- ## inner range must not extend beyond data
##- if (ldtrg[1]>=lrgext[1]) lrg[1] <- ldtrg[1]
##- if (ldtrg[2]<=lrgext[2]) lrg[2] <- ldtrg[2]
##- ## enlarge to cover 'range'
##- lrg <- c(min(lrg[1],range[1]), max(lrg[2],range[2]))
## ---------
## extend range to plotting range
lplrg <- i.extendrange(lrg, ifelse(lnouter>0, innerrange.ext, plext))
## extend inner range if there are no modified points
## lrg <- ifelse(lnouter>0, lrg, lplrg) ## adjust to the needs of plotting
attr(rr,"innerrange") <- lrg
attr(rr,"innerrange.ext") <- innerrange.ext
## needed for transforming further quantities
attr(rr,"nouter") <- lnouter
attr(rr,"plrange") <- lplrg
class(rr) <- class(lx)
rr
}
## -------------------------------------------------------------------
## =====================================================================
gendate <-
function (date=NULL, year=2000, month=1, day=1, hour=0, min=0, sec=0,
data=NULL, format="y-m-d", origin=NULL)
{
## generate time -> chron
## -------------------------------------------------------------
lcall <- match.call()
## ltimeargs <- c("date", "year", "month", "day", "hour", "min", "sec")
ldt <- list(date=NA, year=2000, month=1, day=1, hour=0, min=0, sec=0)
origin <- i.def(origin, c(month=1, day=1, year=i.getploption("date.origin")) )
lnm <- NULL
## --- arguments
largs <- setdiff(names(lcall)[-1], c("data", "format","origin"))
data <- as.data.frame(data)
if (length(largs)==0) stop("!gendate! no date and time variables specified")
inp <-
parse(text = paste("list(", paste(as.list(lcall[largs]), collapse = ","),")"),
keep.source = FALSE)
vars <- try(eval(inp, data, enclos=parent.frame()), silent=TRUE)
if (inherits(vars, "try-error")) {
lvnmiss <- setdiff(largs, names(data))
stop(sub("object", "!gendate! variable (or object)",
attr(vars, "condition")$message),
if (length(lvnmiss)>1)
paste(". \n All of ",
paste(lvnmiss, collapse=", "), "may be unavailable.")
)
}
names(vars) <- largs
ldt[largs] <- vars
ldt <- as.data.frame(ldt)
##
lln <- unique(lapply(ldt, length))
if (length(lln[lln>1])>1)
stop("!gendate! differing lengths of arguments")
## month
if (is.factor(ldt$month)) ldt$month <- as.character(ldt$month)
if (is.character(ldt$month)) {
lmnum <- match(ldt$month, c.months, nomatch=0) ## distiguish NA and nommatch
if (any(lmnum==0, na.rm=TRUE)) lmnum <- match(ldt$month, c.mon, nomatch=0)
if (any(lmnum==0, na.rm=TRUE))
stop("!gendate! inadequate argument 'month'")
ldt$month <- lmnum
}
## --- argument 'date'
date <- ldt$date
if (length(date)&&!all(is.na(date))) { ## get timeargs from date
if (inherits(date, "Date"))
date <- chron::dates(format(date), format="y-m-d", origin=origin)
else {
if (inherits(date,"factor")) date <- as.character(date)
if (is.character(date))
date <- chron::dates(date, format=c(format, "h:m:s"), origin=origin)
}
if (!inherits(date, "times"))
stop("!gendate! argument 'date' not suitable.")
## if (length(setdiff(largs, "date"))==0) return(chron::chron(date))
} else
date <- chron::dates(
paste(ldt$year, ldt$month, floor(as.numeric(ldt$day)), sep="-"),
format="y-m-d", origin=origin)
## ---
##- if (inherits(date, "chron")) ## date already has 'times'
##- return(structure(date, format=i.getploption("date.format")) )
## --- hours, min, sec
## convert too large numbers
if ("sec"%in%largs && any(li <- ldt$sec>=60, na.rm=TRUE)) {
li <- which(li)
ldt$min[li] <- ldt$min[li]+ldt$sec[li]%/%60
ldt$sec[li] <- ldt$sec[li]%%60
}
if ("min"%in%largs && any(li <- ldt$min>=60, na.rm=TRUE)) {
li <- which(li)
ldt$hour[li] <- ldt$hour[li]+ldt$min[li]%/%60
ldt$min[li] <- ldt$min[li]%%60
}
if ("hour"%in%largs && any(li <- ldt$hour>=24, na.rm=TRUE)) {
li <- which(li)
date[li] <- date[li]+ ldt$hour[li]%/%24
ldt$hour[li] <- ldt$hour[li]%%24
}
## convert decimals to lower units
lf.dec <- function(x) round(x,2)-floor(x+0.005) ## not general enough
if ("day"%in%largs && any(0!= (ldec <- lf.dec(ldt$day)), na.rm=TRUE)) {
ldt$day <- floor(ldt$day)
if ("hour"%nin%largs) ldt$hour <- round(ldec*24 + ldt$hour - 0.000005, 5)
}
if (any(0!= (ldec <- lf.dec(ldt$hour)), na.rm=TRUE)) {
ldt$hour <- floor(ldt$hour+0.005)
if ("min"%nin%largs) ldt$min <- round(ldec*60 + ldt$min - 0.0005)
}
if (any(0.001<abs(ldec <- lf.dec(ldt$min)), na.rm=TRUE)) {
ldt$min <- floor(ldt$min+0.005)
if ("sec"%nin%largs) ldt$sec <- round(ldec*60 - 0.5) ## + ldt$sec must be zero
}
##
date <-
chron::chron(date, paste(ldt$hour, ldt$min, ldt$sec, sep=":"),
format=c(dates=format, times="h:m:s"), origin=attr(date,"origin"))
if (length(lnm)) names(date) <- lnm
structure(date, format=i.getploption("date.format"))
} ## end gendate
## =====================================================================
gendateaxis <- #f
function(date=NULL, year=2000, month=1, day=1, hour=0, min=0, sec=0,
data=NULL, format="y-m-d", origin=NULL, ploptions=NULL)
{
## generate time axis.
## resulting tick labels may exceed data range by quite a bit
## -------------------------------------------------------------
lf.seq <- function(x) seq(min(x),max(x))
lf.tickat <-
function(tickunit, tickint, llev, llvlg, ystart, mstart, lnlev) { ## , label=FALSE
## generate ticks in tickint [tickunit] intervals
if (tickunit=="y") return(ystart)
llunit <- match(tickunit, names(lnlev))
llev[[llunit]] <- ltatu <- ## units that may be used
seq(llunit%in%2:3, lnlev[llunit], tickint) ## m and d start at 1
## keep llev component of highest category if higher than tickunit,
## generate levels of lower ones for the whole span PLUS 1 for the end
lv1 <- llev[[llvlg]]
if (llvlg < llunit-1) {
for (ll in (llvlg+1):(llunit-1)) { ## no llunit-1 instead of (llunit-1) !!!?
llev[[ll]] <- llv <- seq(ll%in%2:3, lnlev[ll]) ## m and d start at 1
lv1 <- c(outer(llv, lv1*100, "+"))
}
}
if (llvlg<llunit)
ltatu <- c(outer(ltatu, lv1*100, "+")) ## information for getting label
## ---
if (tickunit=="m") ltat <- mstart[seq(1, length(mstart), tickint)]
else { ## mstart contains start of month for whole year(s). select those needed
llday <- llev[["d"]]
ltat <- c(outer(llday-1, mstart, "+"))
## day starts with 1 [llev[["m"]]]
lmd <- c(outer(llday, 100*(llev[["m"]]), "+"))
ltatu[lmd%in%c(limpossible, limpossible+1)] <- NA
liat <- lmd %nin% (limpossible+1) ## +1: keep tick at end of last day month
ltat <- ltat[liat]
ltatu <- ltatu[liat]
if (tickunit!="d") { ## !!? mit llev arbeiten! oder 1:length(lv1)
ltat <- c(outer(llev[["h"]]/24, ltat, "+"))
if (tickunit!="h") {
ltat <- c(outer(llev[["M"]]/(24*60), ltat, "+"))
if (tickunit=="M") ltat <- ltat[seq(0, length(ltat), tickint)]
else {
ltat <- c(outer(llev[["s"]]/(24*60), ltat, "+"))
if (tickunit=="s") ltat <- ltat[seq(0, length(ltat), tickint)]
else stop("!gendateaxis/lf.tickat! bug")
}}}
ltatu <- ltatu[1:length(ltat)] ## ???
}
if (length(ltat)!=length(ltatu))
warning("debug lf.ticksat: length(ltat)!=length(ltatu)")
## avoid duplicated ticks. select second label
li <- length(ltat)+1-which(duplicated(rev(ltat)))
if (length(li)) {
ltat <- ltat[-li]
ltatu <- ltatu[-li] ## if (label)
}
attr(ltat, "at.inunit") <- ltatu ## if (label)
ltat ## structure(ltat, at.inunit=ltatu)
} ## end lf.tickat
## -----
lnlev <- c(y=100, m=12, d=31, h=24, M=60, s=60)
limpossible <- c(229, 230, 231, 431, 631, 931, 1131) ## non-existing days
## ---------------------------------------
## --- prepare
lcall <- match.call()
ldtk <- i.getploption("date.ticks") ## time level and number of ticks
## gendate
lcall$ploptions <- NULL
lcall[[1]] <- quote(gendate)
mode(lcall) <- "call"
date <- eval(lcall, sys.parent())
## ---------
ldt <- dropNA(date)
if (length(ldt)==0) {
warning("!gendateaxis! no valid dates found. dateaxis not generated")
return(date)
}
lattr <- attributes(date)
lvlab <- lattr$varlabel ## for later use
lorigin <- if (length(lor <- lattr$origin))
julian(as.Date(paste(lor[c("year","month","day")], collapse="-"))) else 0
if (length(lattr)) { ## avoid piling up of attributes
li <-
setdiff(names(lattr),
c("numvalues", "ticksat", "ticklabelsat", "ticklabels", "units") )
attributes(date) <- lattr[li]
}
lndays <- diff(range(ldt))
lidtk <- which(ldtk$limit<lndays)[1] ## which line of ldtk
## -----------------------------------------------------------------
ldate <- data.frame(chron::month.day.year(ldt+lorigin)[c(3,1,2)],
hour = chron::hours(ldt), min = chron::minutes(ldt),
sec = chron::seconds(ldt))
## avoid new day or month or year caused by a midnight obs.
if (diff(range(ldate$hour))!=0)
ldate <- ldate[!(ldate$day==1&ldate$hour==0&ldate$min==0),]
llev <- lapply(ldate, lf.seq) ## how many values of which unit are there?
names(llev) <- names(lnlev)
## which units vary?
lvr <- sapply(llev, length) >1
llvlg <- which(lvr)[1]
llsm <- length(lvr)+1-which(rev(lvr))[1]
##
## lIym <- length(c(unique(ldate$year), unique(ldate$mon)))>2
lyr <- lf.seq(ldate$year)
lystart <- julian(as.Date(paste(lyr,"1-1", sep="-")))-lorigin
lmn <- 1:12 ## if (llvlg>=3) lf.seq(ldate$mon)+1 else 1:12
lyy <- if (length(lyr)==1) lyr else rep(lyr, each=12)
## lmstart <- julian(as.Date(paste(lyy,lmn,"1", sep="-")))-lorigin
lmstart <- julian(as.Date(paste(lyy,lmn,"1", sep="-")))[llev$m]-lorigin
##
ltatsmall <-
c(lf.tickat(ldtk$smallunit[lidtk], ldtk$smallint[lidtk],
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) ) ## ( attr "at.inunit" may be too short. not used here)
ltatbig <-
c(lf.tickat(ldtk$bigunit[lidtk], ldtk$bigint[lidtk],
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) )
llunit <- ldtk$labelunit[lidtk]
llint <- ldtk$labelint[lidtk]
ltatlabel <-
lf.tickat(llunit, llint,
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) ## , label=TRUE
## --- ticklabels
ltatu <- attr(ltatlabel, "at.inunit", exact=TRUE)
lls <- any(ltatu>=100, na.rm=TRUE)
ll <- list(u1 = ltatu%%100, u2 = if (lls) ltatu%/%100, sep=lls)
lf.nabl <- function(x) {x[x=="NA"] <- "";x}
llab <-
switch(llunit,
y = as.character(lyr),
m = paste(c.mon[ll$u1], ll$u2, sep = if(ll$sep) "." else ""),
d = lf.nabl(paste(ll$u1, c.mon[ll$u2], sep=if(ll$sep) " " else "")),
h = paste(ll$u2, ll$u1, sep = if(ll$sep) "|" else ""),
M = paste(ll$u2, ll$u1, sep = if(ll$sep) ":" else ""),
s = paste(ll$u2, ll$u1, sep = if(ll$sep) ":" else ""),
{
warning(":gendateaxis: labels went wrong. check ploptions(\"date.ticks\"")
NULL
}
)
llab[is.na(ltatu)] <- ""
##- if (llunit=="d") {
##- }
if (length(lvlab)==0 ||
(length(l <- attr(lvlab, "setbyuser", exact=TRUE))&&!l) ) {
llv1 <- c("A",names(llev))[llvlg] ## level that does not vary
lvlab <- structure(
switch(llv1,
A = list(), ## "year",
y = as.character(llev[[1]]),
m = paste(c.months[llev[[2]]], llev[[1]]),
d = paste(llev[[3]], c.months[llev[[2]]]),
h = "minute",
M = "second",
"time"),
setbyuser = FALSE)
}
## drop labels outside range
lina <- is.na(clipat(ltatlabel, i.extendrange(unclass(range(ldt))), clipped=NA))
if (any(lina)) {
ltatlabel <- ltatlabel[!lina]
llab <- llab[!lina]
ltatu <- ltatu[!lina]
}
## ticklabelsat
llu <- match(llunit, c("y","m","d","h","M","s"), nomatch=0)
if (llu<llsm) ## turn into interval
ltatlabel <- outer(ltatlabel, c(0, c(365, 30, 1, 0,0)[llu]), "+")
## 1/24, 1/(24*60)
## at.inunit = attr(ltatlabel, "at.inunit") )
if (llunit=="d" & ldtk[lidtk,"labelint"]!=1) { ## drop mark at day 31
li31 <- ltatu%%100==31
li31[length(li31)] <- FALSE ## do not drop at end of scale
llab[li31] <- ""
}
attr(ltatlabel, "at.inunit") <- NULL
structure(date, numvalues=c(unclass(date)),
ticksat=structure(ltatbig, small=ltatsmall),
ticklabelsat=ltatlabel, ticklabels=llab, varlabel=lvlab)
}
## ===========================================================================
i.pchcens <- #f
function(plargs, condquant)
## Delta, nabla, >, <, quadrat : pch= c(24, 25, 62, 60, 32)
{
if (u.isnull(condquant) | !u.isnull(lpc <- plargs$pldata$".pch."))
return(lpc)
##
ploptions <- plargs$ploptions
lpch <- i.getploption("censored.pch", opts=ploptions)
lpc <- rep(i.def(lpch[1],1), nrow(plargs$pldata))
lpc[condquant[,"index"]] <- i.def(lpch[2],3)
lpc
}
## ====================================================================
pllimits <- #f
function(pllim, data, limfac = NULL, FUNC=NULL)
{ ## determine inner plot range
## if pllim is a list or a matrix, leave it alone
lIcq <- inherits(data, "condquant")
ldt <- cbind( if (lIcq) c(data[,1:3]) else data )
pllim <- i.def(pllim, TRUE, TRUE, FALSE)
if (length(pllim)>1)
if (any(dim(cbind(pllim))!=c(2,NCOL(ldt)))) {
warning(":plregr/pllimits: unsuitable argument pllim ")
pllim <- TRUE
}
lfunc <- i.getploption("innerrange.function")
limfac <- i.getploption("innerrange.factor")
##
if (length(pllim)==1 && is.logical(pllim))
pllim <-
if (pllim) apply(ldt, 2, lfunc, fac=limfac) else
matrix(FALSE, 2, NCOL(ldt))
if ((!is.list(pllim))&length(pllim)==2) pllim <- as.matrix(pllim)
pllim
}
## ========================================================================
plsubset <- #f
function(x, subset = NULL, omit = NULL, select = NULL, drop = FALSE,
keeprange = FALSE)
{
## subset, adjusting attributes
## adaptation of subset.data.frame
if (!inherits(x, "data.frame"))
x <- as.data.frame(x=x)
## stop("!plsubset! 'x' must inherit from data.frame")
e <- if (lIsubset <- length(match.call()$subset))
substitute(subset) else substitute(omit)
r <- if (lIsubset & length(e)==0) rep_len(TRUE, nrow(x))
else dropNA(eval(e, x, parent.frame()))
if (is.logical(r)) r <- which(r)
if (is.character(r)) {
ir <- match(r, row.names(x), nomatch=0)
if (all(ir==0))
stop("!plsubset! 'subset' is character, but contains no row.names of 'x'")
if (any(ir==0))
warning(":plsubset: 'subset' contains strings that are no row.names:\n ",
if (sum(ir==0)<=10) paste(r[ir==0], collapse=", ")
else paste(paste(r[ir==0][1:10], collapse=", "), "...")
)
r <- ir[ir!=0]
}
if (!lIsubset) r <- setdiff(1:nrow(x), r) ## omit has been used
rr <- transferAttributes( x[r,, drop=FALSE], x)
if (length(select)) {
nl <- as.list(seq_along(x))
names(nl) <- names(x)
vars <- eval(substitute(select), nl, parent.frame())
rr <- rr[vars,, drop=FALSE]
}
if (nrow(rr)==0) {
warning(":plsubset: Empty subset")
return(rr)
}
## ----- attributes
lf.rgratio <- function(x, r) {
lrx <- diff(range(x, finite=TRUE))
if (lrx>0) diff(range(x[r], finite=TRUE))/lrx else 1
}
for (lj in seq_len(ncol(rr))) {
lxj <- x[,lj]
lattr <- attributes(lxj)
lattr <- lattr[setdiff(names(lattr), "names")]
if (length(lattr)) {
lrgratio <-
if (is.numeric(lxj)) lf.rgratio(lxj, r) else 1
if ("numvalues"%in%names(lattr)) {
lnv <- lattr$numvalues
lnvr <- lnv[r]
lrgratio <- lf.rgratio(lnv, r)
lattr$numvalues <- lnvr
}
if ("plcoord"%in%names(lattr)) {
lpc <- lattr$plcoord
lpcr <- lpc[r]
lrgratio <- lf.rgratio(lpc, r)
lattr$plcoord <- lpcr
}
if (!is.finite(lrgratio)) {
warning(":plsubset: something wrong with attr(...,'numvalues') ",
"or attr(...,'plcoord')")
lrgratio <- 1
}
if ((!keeprange) & lrgratio<i.getploption("subset.rgratio")) {
lats <- c("ticksat","ticklabelsat","ticklabels") ## drop these attributes
lattr <- lattr[setdiff(names(lattr), lats)]
## date variable
if (inherits(lxj, c("Date", "times"))) {
attr(rr[,lj], "numvalues") <- lattr$numvalues
lattr <- attributes(gendateaxis(rr[,lj]))
lattr[names(lattr)] <- lattr
}
## scaled variable
if (length(lpls <- lattr$plscale)) {
lplsc <- plscale(lxj[r], lpls)
lattr[lats] <- attributes(lplsc)[lats]
}
}
attributes(rr[,lj]) <- lattr
## resp. genvarattributes
}
}
rr[,,drop=drop]
}
## ========================================================================
setvarattributes <- #f
function(data, attributes = NULL, list = NULL, ...)
{
data <- as.data.frame(data)
lnmdata <- names(data)
## list <- c(list, list(...))
if (length(list) && !is.list(list))
stop(":setvarattributes: argument 'list' must be a list")
list <- c(list, list(...))
if (length(list)) {
lnames <- names(list)
for (lnm in lnames) {
lls <- as.list(list[[lnm]])
llnm <- names(lls)
if (is.null(llnm)) {
llnm <- lnmdata
lls <- setNames(rep(lls, length(lnmdata)), lnmdata)
}
if (any(linm <- llnm%nin%lnmdata))
stop("!setvarattributes! names of ",lnm," not in ",
"names of 'data': ", paste(llnm[linm], collapse=", "))
for (lnmv in llnm)
attr(data[[lnmv]], lnm) <- lls[[lnmv]]
}
} else if (length(attributes)==0) warning(":setvarattributes: no attributes")
if (length(attributes)) {
if (!is.list(attributes))
stop("!setvarattributes! argument 'attributes' must be a list")
if (is.null(names(attributes))) {
if (length(attributes)!=ncol(data))
stop("!setvarattributes! argument 'attributes' must have names ",
"or be of appropriate length")
names(attributes) <- names(data)
}
lnames <- names(attributes)
if (any(linm <- lnames%nin%names(data)))
stop("!setvarattributes! names of argument 'attributes' not in ",
"names of 'data': ", paste(lnames[linm], collapse=", "))
for (lnm in lnames) {
lattr <- attributes(data[[lnm]])
lattr[names(attributes[[lnm]])] <- attributes[[lnm]]
attributes(data[[lnm]]) <- lattr
if (lnm=="innerrange") {
## call plcoord !!!
}
}
}
invisible(data)
}
## ==========================================================================
plyx <- #f
function(x=NULL, y=NULL, by=NULL, group=NULL, data=NULL, type="p",
panel=NULL,
xlab=NULL, ylab=NULL, xlim = NULL, ylim = NULL,
markextremes=0, rescale=TRUE, mar=NULL, mf=FALSE,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
lf.rg <- function(y) { ## plranges and innerranges
plrg <- i.def(attr(y,"plrange", exact=TRUE), range(y, finite=TRUE))
c(plrg, i.def(attr(y, "innerrange", exact=TRUE), plrg))
}
## --- intro: call pl.control
lcall <- match.call() ## match.call modifies argument names -> sys.call
if (length(plargs)==0) { ## call pl.control
lcall$markextremes <- markextremes
ldtnm <- substitute(data)
ldtnm <- if (is.name(ldtnm))
as.character(ldtnm) else if (length(ldtnm)) format(ldtnm)
lcall$.subdefault <- if (length(ldtnm)<30) ldtnm else ""
lcall[1] <- list(quote(pl.control))
lcall <- as.call(lcall)
plargs <- eval(lcall, envir=parent.frame())
}
## ---
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## --- data
pldata <- plargs$pldata
lnr <- NROW(pldata)
lnobs <-
max(10, median(sapply(pldata,
function(x) sum(is.finite(x)) )) )
lxnm <- attr(pldata,"xvar", exact=TRUE)
if (is.null(lynm <- attr(pldata,"yvar", exact=TRUE))) {
lynm <- tail(lxnm, 1)
lxnm <- head(lxnm, -1)
}
lx <- pldata[,lxnm, drop=FALSE]
lnx <- ncol(lx)
ly <- pldata[,lynm, drop=FALSE]
## why so complicated? I need this when by is active
for (lj in lynm) {
lyj <- ly[[lj]]
lplval <- i.def(attr(lyj, "plvalues", exact=TRUE),
attr(lyj, "numvalues", exact=TRUE))
if (length(lplval)) {
lyj <- transferAttributes(
if(inherits(lyj, "Surv"))
survival::Surv(lplval, lyj[,2],
type=attr(lyj, "type", exact=TRUE)) else lplval,
lyj)
attr(lyj, "plscale") <- NULL
ly[,lj] <- lyj
}
}
lny <- ncol(ly)
## ------------------------------------------------------
## --- 'by' grouping
lnby <- 1
lvby <- attr(pldata, "byvar") ## [[".by."]]
lIby <- length(lvby)>0
lby <- if(lIby) {
if (length(lvby)>1)
warning(":plyx: more than one 'by' variables. I use the first one")
lby <- i.factor(pldata[,lvby]) ## makes sure there is no extra levels
lgrplab <- levels(lby)
lnby <- length(lgrplab)
as.numeric(lby)
## lgrptitline <- i.def(ltitline[2],1)
} else rep(1, nrow(ly))
## --------
## style elements
lIsmooth <- i.getploption("smooth")
lir <- u.true(i.getploption("innerrange"))
##- lIfirst <- TRUE
lplab <- pldata[[".plab."]]
lpch <- pldata[[".pch."]]
lIpch <- length(lpch)>0
lpcol <- pldata[[".pcol."]]
lclr <- i.getploption("col")
lcsize <- i.getploption("csize")
ltadj <- i.getploption("title.adj")
lcsize.pch <- i.getploption("csize.pch") ## need to do this here such that
## csize.pch is fixed and does not vary with 'by' group size
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs/lnby)
plargs$ploptions$csize.pch <- lcsize.pch
##
ltitl <- i.getploption("title.line")
lsmpale <- i.getploption("smooth.pale")[2]
lpsep <- i.getploption("panelsep")
##
panel <- i.getplopt(panel)
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plyx: 'panel' not found. Using 'plgraphics::plpanel'")
panel <- plgraphics::plpanel
}
## --- preparations
lyaxcol <- 1
## inner plotting range
lnoutery <-
as.matrix(sapply(ly, function(x) c(attr(x,"nouter", exact=TRUE),0,0)[1:2]>0 ))
lIinner <- apply(lnoutery, 1, any)
## ranges
lrgy <- sapply(ly, lf.rg)
## ---
if (lny>1) { ## need to examine all y's and possibly reset plrange for ly[,1]
lfs <- i.getploption("factor.show")
if (lfs=="mbox") plargs$ploptions$factor.show <- ploptions$factor.show <- "asis"
if (rescale==0) {
llf <- function(y)
i.def(i.def(attr(y, "plvalues"), attr(y, "numvalues")), y)
lyy <- as.data.frame(lapply(ly, llf))
lplsc <- lapply(ly, function(y) i.def(attr(y, "plscale"), NULL))
lvlim <- sapply(ly, function(y) i.def(attr(y, "vlim"), c(NA,NA)))
if (any(!is.na(lvlim)))
attr(lyy, "vlim") <-
c(min(lvlim[1,], na.rm=TRUE), max(lvlim[2], na.rm=TRUE))
## innerrange?
lir <- lir &&
any(sapply(ly, function(y) length(attr(y, "innerrange"))>0))
lps0 <- all(sapply(lplsc, length)==0)
lplsc <- unique(unlist(lplsc))
ltickscale <- NULL
if (!lps0) {
if (length(lplsc)>1)
warning(":plyx! different plot scales. I cannot keep scales equal")
else ltickscale <- lplsc
}
lyc <- i.genvattrcont(c(unlist(lyy)), ploptions=ploptions,
tickscale=ltickscale)
lattr <-
attributes(lyc)[c("plrange", "ticksat", "ticklabelsat", "ticklabels")]
lirg <- attr(lyc, "innerrange")
lirg <- i.def(lirg, lattr$plrange)
for (lj in 1:lny) {
attr(ly[,lj], "plcoord") <- c(plcoord(lyy[,lj], range=lirg))
latt <- c(lattr, innerrange=list(lirg))
attributes(ly[,lj])[names(latt)] <- latt
}
## ly <- setvarattributes(ly, setNames(rep(list(list(lattr)), lny), lynm))
lrgy <- matrix(lf.rg(lyc),4,lny)
} else { ## rescale !=0
if (rescale<0) { ## do not adjust tick marks etc
lrgyy <- c(min(lrgy[1,]),max(lrgy[2,]),min(lrgy[3,]),max(lrgy[4,]))
for (lj in 1:lny)
attr(ly[,lj], "plcoord") <- plcoord(ly[,lj], range=lrgyy)
}
else ## rescale >0
lrgyy <- lrgy[,1]
attr(ly[,1],"plrange") <- lrgyy[1:2]
## extend the plrange of ly[,1] if needed
##- lrgyy + diff(lrgyy)*c(-1,1)*
##- ifelse(lIinner, i.getploption("innerrange.ext"), 0) ## ploptions$plext
} ## !!! welche attr sollen wirklich gesetzt werden?
attr(ly[,1], "nouter") <- lIinner ## plframe is called for ly[,1], needs attr
} else lir <- lir && length(attr(y, "innerrange"))>0
## end lny>1
## --------------
ly1 <- ly1g <- ly[,1]
lrgy1 <- lrgy[,1]
## mark extremes
lmark <- i.getplopt(markextremes)
if (is.function(lmark)) lmark <- lmark(lnobs)
lmk <- unlist(lmark)
lImark <- length(lmk)>0 && any(ifelse(is.na(lmk),TRUE,lmk>0))
lImark <- is.na(lImark)||lImark
lymark <- if (lImark & lny==1) ly ## cannot mark extremes if lny>1
## --- groups ; smooth lines
lsmcol <- i.getploption("smooth.col")
if(length(lgrp <- pldata[[".group."]])) {
lsmcol <- attr(lgrp, "group.col")
if (length(lsmcol)) lsmcol <- colorpale(lsmcol, lsmpale)
lngrp <- length(lgrp)
} else lngrp <- 1
## --- figure parameters
lmfkeep <- !u.notfalse(mf)
loldp <- par(list("mar","mgp")) ## ,"oma"
if (!i.getploption("keeppar"))
on.exit(par(loldp), add=TRUE, after=FALSE)
marpar <-
i.getmarpar(plargs=plargs, title=if(lngrp>0) " ")
## title.outer=c(lplft$main, lplft$sub))
if (lny>1) marpar$mar[4] <- marpar$mar[2]
## --- multiple figures
lnpgc <- lnpgr <- 1
lnr <- lnx
lnc <- lnby
llmf <- length(mf)
if (lnby>1) { ## by groups
lmpo <- i.getmarpar(TRUE, mar=i.getploption("oma"), plargs=plargs)
loma <- lmpo$mar
##- if (length(lomaarg))
##- if (length(lomaarg)==1) loma[3] <- lomaarg
##- else loma <- rep(lomaarg, length=4)
if (lnx>1) {
lmar <- lpsep + c(marpar$mar[1],0,0,0.8*(lny>1)) +
c(0,0,ltitl[1]-i.def(ltitl[2],0),0)
plargs$ploptions$mframesmax <- i.def(mf, i.getploption("mframesmax"))
if (llmf & u.notfalse(mf))
marpar <-
plmframes(lnx, lnby, reduce=TRUE, mar=lmar, oma=loma,
plargs=plargs)$marpar
lmfig <- list(mfig=par("mfg"))
lnr <- lmfig$mfig[1]
lnc <- lmfig$mfig[2]
lnpgr <- ceiling(lnx/lnr)
lnpgc <- ceiling(lnby/lnc)
} else { ## only 1 x
ltitl <- i.def(i.getploption("title.line")[2], 0.8)
## mframes
if (u.true(mf)) mf <- lnby
lmr <- lpsep + c(0,0,ltitl+1,0)
if (u.notfalse(mf)) {
marpar <-
if (llmf&&prod(mf)>1)
(lmfig <- plmframes(mf[1], if(llmf>=2) mf[2], mft=if(llmf==1) mf,
mar=lmr, oma=loma))$marpar
else i.getmarpar(mar=lmr, plargs=plargs)
}
## plargs$plmarpar$title.line[1] <- ltitl
}
} else { ## no by groups
if (length(mf)&u.notfalse(mf))
marpar <- plmframes(mf, ploptions=ploptions)$marpar
}
lmar <- marpar$mar
par(mar=lcsize*lmar)
lattrc <- c("innerrange","nouter")
lnfgcol <- par("mfg")[4]
## --- restore mfg if only one plot is produced
if ((lnx>1 | lnby>1) & !lmfkeep) {
loldmf <- par(list("mfrow"))
on.exit(par(loldmf), add=TRUE, after=FALSE)
}
## ------------------------------------------------------------------
## --- plot
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (lj in 1:min(lnr, lnx-lr)) {
## --- x variable
lxj <- lx[,lr+lj]
## lxjattr <-
lxjg <- lxjv <- if (!is.factor(lxj))
i.def(attr(lxj, "plcoord", exact=TRUE),
i.def(attr(lxj, "plvalues", exact=TRUE),
i.def(attr(lxj, "numvalues", exact=TRUE), c(lxj))))
else lxj
attributes(lxjg)[lattrc] <- attributes(lxj)[lattrc] ## lxjattr
if (lImark) {
lplab <- plmark(lxj, y=lymark, markextremes=lmark,
plabel=plargs$plfeatures$plabel)
pldata[[".plab."]] <- lplab
plargs$pldata <- pldata
}
lpchg <- lpch
## 'by' grouping
for (ipgc in 1:lnpgc) { ## columns on page
lc <- (ipgc-1)*lnc
for (lig in (lc+1):lnc) { ## 'by' groups
lg <- lig
if(lny>1) {
lpcol <- lyaxcol <- lsmcol <-
i.def(attr(ly1, "vcol", exact=TRUE), lclr[2])
plargs$ploptions$smooth.col <- lsmcol
pldata[".pcol."] <- lpcol
if(!lIpch)
lpchg <-
if (lny>1)
attr(ly1, "pch", exact=TRUE) else i.getploption("pch")[1]
}
## show labels if there will be no panel below the present one
lshow1 <- (lig>lnby-lnfgcol) * !lmfkeep
lshow2 <- 2 - (lngrp>1)
lshow4 <- 2 - (lngrp>1) || lig==lngrp
## do not set it if 'mf' was set F
lop <- plframe(lxj, ly1, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim,
axcol=c(NA,lyaxcol,NA,NA), plargs=plargs, ## mar=lmar,
marpar=marpar, xy=FALSE,
showlabels=c(lshow1,lshow2,0,lshow4)+1)
##- if (lIfirst) {
##- loldp <- c(lop, loldp)
##- if (!i.getploption("keeppar"))
##- on.exit(par(loldp[!duplicated(names(loldp))]))
##- }
lmfg <- par("mfg")
if (prod(lmfg[1:2])==1||lmfkeep) {
pltitle(plargs=plargs, outer.margin=prod(lmfg[3:4])>1&!lmfkeep)
stamp(sure=FALSE, ploptions=ploptions)
}
##- lIfirst <- FALSE
lrgold <- lrgy1
lyg <- ly
## 'by' group
if (lIby) {
if (lmar[3]>=1 | par("mfg")[1]==1)
pltitle(main="", sub=lgrplab[lg], ##paste(lgrpname, lgrplab[lg], sep=" "),
outer.margin=FALSE, xpd=TRUE, adj=ltadj[1], ## line=lgrptitline,
ploptions=ploptions)
li <- which(lby==lg)
lxjg <- lxjv[li]
lyg <- plsubset(ly, li, keeprange=TRUE)
ly1g <- lyg[,1]
plargs$pldata <- pldata[li,]
if (length(lpch)==lnr) lpchg <- lpch[li]
## if (length(lplab)==lnr) lplabg <- lplab[li]
## may be useful for generating a legend of group labels
}
if (lny>1) {
lcol <- ploptions$col <- ploptions$lcol <- ploptions$smooth.col <-
plargs$pldata$".pcol." <-
i.def(attr(ly1g,"vcol", exact=TRUE), lclr[2])
if (lIsmooth) ploptions$smooth.col <- colorpale(lcol, lsmpale)
}
## start plot
panel(lxjg, ly1g, type=type, plargs=plargs, ploptions=ploptions,
marpar=marpar)
## multiple y
lusr <- par("usr")
if (lny>1) {
for (lj in 2:lny) {
lyjg <- lyg[,lj]
lrgj <- lrgy[,lj]
lpcol <- i.def(attr(lyjg, "vcol", exact=TRUE),
lclr[(lj+1)%%(length(lclr)-1)+1])
## the color must reflect the variable
if (!lIpch) lpchg <- attr(lyjg, "pch", exact=TRUE)
if (rescale>0) { ## new user coordinates
lusr[3:4] <- lrgj[1] +
c(0, diff(lrgj[1:2])/diff(lrgold[1:2]) * diff(lusr[3:4]))
par(usr=lusr)
}
if (lIsmooth) {
plargs$ploptions$smooth.col <-
rep(colorpale(lpcol,lsmpale), lngrp)
plsmooth(lxjg, lyjg, plargs=plargs)
}
plpoints(lxjg, lyjg, type=type, plab=lplab, pch=lpchg, col=lpcol,
plargs=plargs, marpar=marpar, xy=FALSE)
lrgold <- lrgj
if (rescale & lj==2) {
plaxis(4, lyjg, range=lrgj, col=lpcol,
tickintervals=i.getploption("tickintervals"),
ploptions=ploptions, marpar=marpar)
}
}
}
}
}
}
}
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plyx
## ==========================================================================
plregr.control <- #f
function(x, data = NULL, xvar = TRUE, transformed = FALSE,
## generate variables used for plotting
weights = NULL, stdresid = TRUE, mar = NULL,
## specify some specific aspects / contents of plots
glm.restype = "working", condquant = TRUE, smresid = TRUE,
partial.resid = NULL, addcomp = NULL, cookdistlines = NULL,
leveragelimit = NULL, condprob.range = NULL,
testlevel = 0.05,
## smooth and refline
refline = TRUE,
smooth = 2, smooth.sim=NULL,
xlabs = NULL, reslabs = NULL, markextremes = NULL,
## multiple frames
mf = TRUE, mfcol = FALSE, multnrow = 0, multncol = 0, marmult = NULL,
oma = NULL, assign = TRUE, ... )
{ ## get data for plotting, collect and check arguments
## do preparations that are common to plregr and plresx
## --------------------------------------------------------------
lcall <- match.call()
## formula(x) inappropriate for merMod
lform <- if (inherits(x, "regrMer")) x$formula else formula(x)
## ... if it inherits from lm ??? whatsthat?
## lmodvdupl <- u.varsin2terms(lform[-2])
lnaaction <- x$na.action
if (!u.isnull(lnaaction)) class(lnaaction) <- "exclude"
x$na.action <- lnaaction
## --- family
lfam <- c(x$distrname, x$family$family, "")[1]
if (lfam=="" & inherits(x, "lm")) lfam <- "gaussian"
lfamgauss <- lfam%in%c("gaussian","Gaussian")
lfamcount <- (lfam%in%c("binomial","poisson")&&length(unique(x$y))<=2) |
inherits(x,"polr") ## lfam=="multinomial"
lcensored <- inherits(x[["y"]], "Surv")
## lnnls <- !inherits(x, "nls")
condquant <- NULL
lcq <- i.getplopt(condquant)
## --- residuals
## --- na.action: always get full data
## residuals first because they fix the number of observations
## lres <- residuals(x)
rtype <- i.def(i.def(if(lfamcount & lcq) "condquant", glm.restype), "working")
if (inherits(x, "survreg"))
lres <- residuals.regrsurvreg(x, type = if (lcq) "condquant")
if (inherits(x, "coxph"))
lres <- residuals.regrcoxph(x, type = if (lcq) "condquant")
if (inherits(x, "polr"))
x$residuals <- lres <- residuals.regrpolr(x, type = if (lcq) "condquant")
if (inherits(x, "lm")) ## !!! should be glm ?
lres <-
if (lfamcount) residuals.regrpolr(x, type=rtype)
else structure(residuals(x, type = rtype), type = rtype)
if (inherits(x, "regrMer"))
lres <- i.naresid.exclude(lnaaction, resid(x))
lres <- as.data.frame(lres)
lmres <- ncol(lres)
lzl <- i.def(i.getploption("zeroline"), 0)
if (u.notfalse(lzl))
for (lj in seq_len(lmres)) attr(lres[,lj], "zeroline") <- lzl
lnobs <- sum(is.finite(lres[,1]))
lIres0 <- all( apply(lres[,1:lmres, drop=FALSE],2,
function(x) all(x==dropNA(x)[1], na.rm=TRUE ) ) )
if (lIres0)
stop("!plregr/plresx! all residuals are equal -> no residual plots")
lnres <- nrow(lres)
## --- ldfres
ldfres <- df.residual(x)
ldfmod <- i.def(x$rank, length(coef(x)))
if (u.isnull(ldfres)) ldfres <- lnres-ldfmod
## --- sigma
lsigma <- x$sigma
if (length(lsigma)==0) lsigma <- c(x$scale, summary(x)$sigma)[1]
if (length(lsigma)==0)
lsigma <-
if (lfamcount) 0
else sqrt(apply(lres^2,2, function(x) sum(x[is.finite(x)]))/ldfres)
x$sigma <- lsigma
## --- standardized residuals
llev <- x$leverage
llevlim <- i.getplopt(leveragelimit)
if (length(llevlim)==1)
llevlim <- c(llevlim, i.getploption("leveragelimit")[2])
lstdres <- attr(lres, "stdresiduals", exact=TRUE)
if (stdresid) { ## not needed for plresx
if (length(lstdres)==0) {
lstdres <- stdresiduals(x, residuals=lres, leveragelimit=llevlim[2])
llev <- attr(lstdres, "leverage", exact=TRUE)
attr(lres, "stdresratio") <- attr(lstdres, "stdresratio", exact=TRUE)
attributes(lstdres)[c("leverage","stdresratio","stddev")] <- NULL
attr(lres, "stdresiduals") <- lstdres
} ## else lstdres <- lres
else llev <- naresid(lnaaction, llev)
if (length(llev)==0) llev <- leverage(x)
}
## residual names
lyexpr <- deparse(lform[[2]])
lynm <- if (nchar(lyexpr)>10) "Y" else lyexpr ##
lrn <- paste("res_", if (lmres>1) colnames(lres) else lynm, sep="")
lresname <-
gsub("\\(",".", gsub("\\)",".", gsub("\\*",".", gsub("/",".", gsub("\\^",".",
lrn)))))
names(lres) <- lresname
## --- fit
lfit <- x$linear.predictor
lfitname <- "linear predictor"
if (inherits(x, "polr")) lfit <- fitted.regrpolr(x, type="link")
else {
if(is.null(lfit)) {
lfit <- fitted(x)
lfitname <- "fitted value"
} else lfit <- naresid(lnaaction, lfit)
}
lfitname <- rep(lfitname, length=lmres)
lfit <- as.data.frame(lfit)
lfit <- genvarattributes(as.data.frame(lfit),
innerrange=i.getploption("innerrange.fit")) ## extra element of ploptions!)
attr(lfit[[1]], "varlabel") <- lfitname
## --- xvar
lxvar <-
if (u.notfalse(xvar)) {
lxf <- if (transformed) lform else {
lx <- all.vars(lform[-2])
if (inherits(x, "nls")) lx <- setdiff(lx, names(coef(x)))
u.asformula(lx)
}
if (!(u.isnull(xvar)|u.true(xvar))) {
if (is.character(xvar)) { ## xvar : names of variables
lxvarf <- u.asformula(setdiff(xvar,"."))
lxf <- if ("."%in%xvar) update(lxf, lxvarf) else lxvarf
}
else {
if (is.formula(xvar)) lxf <- update(lxf, xvar)
else
stop("!plregr.control! Inadequate argument 'xvar'")
}
}
attr(getvarnames(lxf, data=data, transformed=transformed), "xvar")
## lxvraw <- u.allvars(lxvar)
} else NULL
## xvar should now be a character vector of names of variables
## --- prepare pl.control
lcall <- as.list(match.call())[-1]
ladrop <- c("xvar", "glm.restype", "smresid", "partial.resid", "addcomp",
"cookdistlines", "leveragelimit", "smooth", "smooth.sim",
"refline", "testlevel", "xlabs", "reslabs",
"mf", "mfcol", "multnrow", "multncol", "marmult", "oma")
lcall <- c(as.list(quote(pl.control)),
as.list(lcall[setdiff(names(lcall),ladrop)]))
lcall$y <- lres
lcall$markextremes <- markextremes
## --- data
ldata <- x$model
if (length(ldata)&&length(lnaaction))
ldata <- i.naresid.exclude(lnaaction, ldata)
if (length(lxvar)) {
lcall$x <- lxvar
lcall$transformed <- transformed
## lcall$.subdefault <- i.form2char(lform) ## transfer to sub
## --- data argument
if (length(lxvar)||any(names(lcall)%in%i.argPldata)) {
if (length(ldata)==0||!(transformed & all(lxvar%in%names(ldata)))) {
ldata <- data
if (length(ldata)==0) {
##- if (length(x$allvars))
##- ldata <- i.naresid.exclude(lnaaction, x$allvars)
##- else ldata <- getvariables(x$call$formula, eval(x$call$data), transformed=FALSE) ##eva
ldt <- x$allvars
if (is.null(ldt)) ldt <- x$model ## has transformed variables
lxv <- setdiff(lxvar, names(ldt))
ldata <-
if (length(lxv)) {
ldt <- eval(x$call$data)
if ("subset"%in%names(x$call)) ldt <- ldt[row.names(lres),]
ldt
} else i.naresid.exclude(lnaaction, ldt)
}
if (length(ldata)==0) stop("!plregr.control! No data found")
}
##
if (lnres!=nrow(ldata)) {
if (class(lnaaction)%in%c("omit", "exclude")) ldata <- ldata[-lnaaction,]
## if (lnr!=nrow(ldata)) ldata <- x$model ## needs at least a warning!
if (lnres!=nrow(ldata))
stop("!plregr.control! nrow of residuals and data do not agree.")
}
}
##- if (length(lxvmiss <- setdiff(lxvar, names(ldata)))) {
##- ldt <- getvariables(lxvmiss)
##- if (nrow(ldt)!=nrow(ldata))
##- stop("!plregr/plresx! variable(s) ",
##- paste(lxvmiss, collapse=", "), " not suitable - wrong number of rows")
##- ldata <- cbind(ldata,ldt)
##- }
} else {
ldata <- lres ## needed to get number of observations
lcall$x <- NULL
} ## needed to get nobs in pl.control
lcall$data <- ldata
lftext <- i.form2char(lform)
lcall$.subdefault <- lftext
lcall$assign <- FALSE
mode(lcall) <- "call"
## -------------------------------------
plargs <- eval(lcall, parent.frame()) ## pl.control
## -------------------------------------
ploptions <- plargs$ploptions
ploptions$smooth <- i.getplopt(smooth)
plargs$plfeatures$main <- i.def(ploptions$main, i.form2char(lform))
lpldata <- plargs$pldata
ly <- i.def(x[["y"]], if (length(ldata)) ldata[,1, drop=FALSE])
lbinary <-
inherits(x, "glm") && length(unique(ly))==2 ## binary binomial
if (u.true(lfamcount)) ploptions$smooth.iter <- 0
lIcq <- u.true(lcq) & (lbinary|lcensored)
## ---
xvar <- attr(lpldata, "xvar", exact=TRUE)
## margins for multivariate regression !!!
lmmar <- rep(i.getploption("panelsep"), length=4)
lmmar[2] <- i.getplopt(mar)[2] +0.5
if (length(marmult)) ## !!! marmult
lmmar <- ifelse(is.na(lmr <- rep(marmult, length=4)), lmmar, lmr)
lmmar[1] <- i.def(i.getploption("mar")[1], 3)
lmmar[3] <- i.def(i.getploption("mar")[3], 0.5) ##!!!
## -------------------------------------------------------
## attributes for residuals
lres <- genvarattributes(lres, varlabel = lresname, ploptions=ploptions)
if (lmres>1) { ## multivariate
if (u.isnull(lcn <- colnames(lres))) lcn <- 1:ncol(lres)
colnames(lres) <- lcn # paste("res", lcn, sep=".")
}
## mark extreme stdres
lmxdef <- markextremes(lnobs)
if (is.atomic(markextremes)) {
markextremes <- i.def(markextremes, NA)
if (anyNA(markextremes)) markextremes <- lmxdef
markextremes <-
list("(res)"=markextremes, "(fit)"=0, "(lev)"=c(0,max(markextremes)) )
}
lmxres <- i.def(markextremes$"(res)", lmxdef) ## ???
lresplab <-
if (lmxres>0 & stdresid)
apply(lstdres, 2,
function(x) plmark(x, markextremes = lmxres,
plabel=plargs$plfeatures$plabel) )
else NULL
## --- smoothWeights, used for smooth calculation: get from x if needed
lsmwgt <- lpldata[["(smoothWeights)"]] ## possibly only logical
lIsmweights <- is.logical(lsmwgt)&&all(lsmwgt) ## weights explicitly required
if (lIsmweights | (length(lsmwgt)&&all(is.na(lsmwgt))))
lsmwgt <- naresid(lnaaction, x$weights)
lIsmwgt <-
length(lsmwgt)>1 && any(lsmwgt!=dropNA(lsmwgt)[1],na.rm=TRUE)
if (lIsmweights&!lIsmwgt)
warning(":plregr/plresx: no weights found for smooth calculation.")
lpldata[["(smoothWeights)"]] <- ## lsmweights <-
if (lIsmwgt) lsmwgt / mean(lsmwgt[is.finite(lsmwgt)]) else NULL
## --- psize, used as sizes of plotting characters: same as weights
lpsize <- lpldata[[".psize."]] ## possibly only logical
lIpsize <- is.logical(lpsize)&&all(lpsize) ## psize expl. required
if (u.isnull(lpsize) | lIpsize | (length(lpsize)&&all(is.na(lpsize))))
lpsize <- if (length(lsmwgt)) lsmwgt else naresid(lnaaction, x$weights)
lIpsz <-
length(lpsize)>1 && any(lpsize!=dropNA(lpsize)[1],na.rm=TRUE)
if (lIpsize&!lIpsz)
warning(":plregr/plresx: no plot sizes found.")
lpldata[[".psize."]] <-
if (lIpsz) lpsize / mean(lpsize[is.finite(lpsize)]) else NULL
## mahalanobis residuals
lresmahal <- naresid(lnaaction, x$resmahal)
if (lmres>1)
if (u.isnull(lresmahal))
lresmahal <-
mahalanobis(lres,0,
var(apply(lres,2, function(x) ifelse(is.finite(x), x, NA)),
na.rm=TRUE))
## --- simulated residuals
## when using smooth.group , default is 0
lnsims <- i.def(smooth.sim, 19, 19, 0)
if (inherits(x, c("mlm", "polr", "survreg", "coxph", "regrMer"))) lnsims <- 0
if (lmres>1) lnsims <- 0 # !!! not yet programmed for mlm
if (lnsims>0 & !inherits(x, c("lm","glm","lmrob","nls"))) {
warning(":plregr/simresiduals: ",
"I can simulate only for 'lm', 'lmrob', 'nls' and 'glm' objects")
lnsims <- 0
}
lsimres <- NULL
if (lnsims>0) {
lsimres <- if(ploptions("debug"))
simresiduals(x, lnsims, glm.restype=rtype) else
try(simresiduals(x, lnsims, glm.restype=rtype), silent=TRUE)
if (inherits(lsimres, "try-error")) {
warning(":plregr/simresiduals: simresiduals did not work. ",
"No simulated smooths")
lsimres <- NULL
lnsims <- 0
}
} ## !!! ---
## --- multiple frames
mf <- i.def(mf, NULL, TRUE, NULL)
oma <- i.def(oma, NULL, valuefalse=0)
if (length(oma)==2) oma <- c(0,0,oma)
## --- more arguments
reslabs <- i.def(reslabs, NULL, NULL, NULL)
smresid <- i.def(smresid, TRUE)
if (lmres>1) smresid <- FALSE ## !!! muss noch gemacht werden
## -----------------
addcomp <-
i.getinlist(partial.resid, addcomp, i.getploption("regr.addcomp"), TRUE)
##- addcomp <- partial.resid <-
##- i.def(i.def(i.getploption("regr.addcomp"), partial.resid),FALSE, TRUE, FALSE)
## partial.resid <- i.def(partial.resid, TRUE)
cookdistlines <- i.getplopt(cookdistlines)
ploptions$refline <- i.getplopt(refline)
testlevel <- i.getplopt(testlevel)
if (testlevel<=0 | testlevel>=1)
stop("!plregr.control! invalid test level")
## ------------------------------------------------------------
## result of plregr.control
plargs$pldata <- lpldata
plargs$plfeatures$smooth <- i.getplopt(smooth)
rr <-
list(pldata = plargs[[1]], ploptions = plargs[[2]],
plfeatures = plargs[[3]],
regrfeatures = list(
formula = lform,
na.action = lnaaction,
family = lfam, famgauss = lfamgauss, famcount = lfamcount,
df.residual = ldfres, df.model = ldfmod,
fit = lfit,
residuals = lres, resname = lresname, ## stdresname = lstdresname,
## absresname = labsresname, fitname = lfitname,
rescol = lmres, resplab = lresplab,
smresid = smresid,
glm.restype = glm.restype,
resmahal = x$resmahal,
simres = lsimres, ## simstdres <- lsimstdres,
response = ly,
yexpr = lyexpr,
## weights = x$weights,
sigma=lsigma,
leverage = llev,
leveragelimit = llevlim, ## condprob.range = condprob.range,
## linear.predictor = x$linear.predictor,
addcomp = addcomp, partial.resid = partial.resid,
cookdistlines = cookdistlines,
smooth.sim = lnsims,
refline = refline,
testlevel=testlevel,
mf=mf, multnrow = multnrow, multncol = multncol, marmult = lmmar
)
)
if (u.notfalse(assign)) plassign(list=rr)
rr
} ## end plregr.control
## -----------------------------------------------------------------------
i.merprep <- #f
function(x) {
ldfr <- df.residual(x)
lres <- residuals(x)
rr <- list(
## na.aaction = NULL,
family = family(x),
fitfun = "mer",
coefficients = coef(x),
fitted = fitted(x),
sigma = sqrt(sum(lres[is.finite(lres)]^2) / ldfr),
## leverage = NULL,
model = x@frame,
residuals = lres,
call = x@call,
formula = formula(x),
na.action = if (length(lnaaction <- attr(x@frame, "na.action", exact=TRUE)))
structure(lnaaction, class="exclude")
)
class(rr) <-
c("regrMer",
switch(rr$family$family, gaussian="lm", binomial="glm", poisson="glm",
"lm") )
rr
}
## -----------------------------------------------------------------------
plregr <- #f
function(x, data=NULL, plotselect = NULL, xvar = TRUE,
transformed = NULL, sequence=FALSE, weights=NULL,
addcomp = NULL, smooth = 2, smooth.legend = FALSE,
markextremes = NA,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{ ## mar needed because it would otherwise be taken for markextremes
## -------------------------------------------------------------------------
## Author: Werner Stahel, Date: 7 May 93 / 2002
##- argPlregr <- c("x", "data", "plotselect", ## "xvar", "transformed",
##- "sequence", "weights", "addcomp", "smooth.legend")
argPlregr <- c("plotselect", ## "xvar", "transformed", "addcomp",
"smooth.legend")
## ---
if (inherits(x,"mulltinom"))
stop("!plregr! I do not know how to plot residuals of a multinomial regression")
lImer <- inherits(x, "merMod")
if (lImer) x <- i.merprep(x)
## ----------------
if (is.null(plargs)) {
lcall <- match.call()
lcall <- lcall[setdiff(names(lcall),argPlregr)]
lcall$x <- x
## lcall$markextremes <- markextremes
lcall[1] <- list(quote(plgraphics::plregr.control)) ## need plgr:: because
## regr also uses this function
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
## !!! markextremes
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lregrft <- plargs$regrfeatures
## lplft <- plargs$plfeatures
## if (u.isnull(mar)) mar <- c(3,3,1,1)+i.getploption("panelsep")
marpar <- i.getmarpar(plargs=plargs) ## mar=mar,
## -------------------------------------------------------------------
## all these results from plregr.control include the na.action observations
lpldata <- plargs$pldata
lfit <- lregrft$fit
lres <- lregrft$residuals
lmres <- lregrft$rescol
lIcq <- inherits(lres, "condquant")
lresname <- lregrft$resname
lsimres <- lregrft$simres
lnsims <- if (length(lsimres)==0) 0 else ncol(lsimres)
llev <- lregrft$leverage
llevlim <- lregrft$leveragelimit
## lrefline <- i.getploption("refline")
lsimstdres <- lregrft$simstdres
x$na.action <- lnaaction <- lregrft$na.action
## from x
lweights <- naresid(lnaaction, x$weights)
if (c(x$family$family, " ")[1]=="poisson") lweights <- sqrt(lweights)
lIwgt <- length(lweights)>0
## number of observations
lnr <- nrow(lres)
lnna <- apply(lres, 1, function(x) all(is.finite(x)))
lnobs <- sum(lnna)
lregrft <- plargs$regrfeatures
## smooth legend
if (length(names(smooth.legend))==0) {
lsmlegend <- i.def(smooth.legend, NULL, TRUE, NULL)
if (length(lsmlegend)==1)
lsmlegend <-
setNames(rep(lsmlegend,5),
c("yfit","resfit","absresfit","absresweight","(xvar)") )
} else lsmlegend <- smooth.legend
## ---
lsmit <- if (inherits(x, "glm")) 0
else i.getploption("smooth.iter")
plargs$ploptions$smooth.iter <- lsmit
## on.exit(ploptions(loldplo), add=TRUE, after=FALSE)
## -----------------------------------
## plot selection
lplsel <- unlist(
i.plotselect(plotselect, Iwgt=lIwgt,
mult=lmres>1,
famgauss=lregrft$famgauss,
famglm=inherits(x,"glm"),
famcount=lregrft$famcount)
)
lplsel <- lplsel[is.na(lplsel)|lplsel>0]
lnplsel <- length(lplsel)
## standardized residuals
lstdres <- as.data.frame(attr(lres, "stdresiduals", exact=TRUE))
lstrratio <- as.data.frame(attr(lres, "stdresratio", exact=TRUE))
lresplab <- lregrft$resplab
## cat("lresplab ", str(lresplab))
lIrpl <- length(lresplab)>0
if (any(lii <- c("qq","leverage","absresfit","absresweights")%in%names(lplsel))) {
lIabs <- any(lii[3:4])
labsres <- if (lIabs) lstdres
lstdresname <- paste("st.", lresname, sep = "")
labsresname <- paste("|st.",lresname,"|", sep="")
lIqq <- lii[1]
lstdrsc <- if (lIqq) lstdres
##
for (lj in seq_len(lmres)) {
lrsj <- lres[,lj]
## residuals from smooth
if (lregrft$smresid) { ## !!! transfer to plregr.control
lfsm <- gensmooth(lfit[,lj], lrsj, plargs=plargs)
lfsmr <- residuals(lfsm)
if (lna <- sum(is.na(lfsmr)&!is.na(lres[,lj])))
warning(":plregr: residuals from smooth have ",
round(100*lna/lnobs,1), " % additional NAs")
## lstdres[,lj] <-
lrsj <- lfsmr * lstrratio[,lj] ## !!! * f(leverage of smooth)
if (lIcq) {
lcq <- attr(lrsj, "condquant", exact=TRUE)
if (length(lcq)) {
li <- lcq[,"index"]
lcq[,1:4] <- ( lcq[,1:4]-lcq[,1]+lfsmr[li] ) *lstrratio[li,lj]
## attr(lfsmr, "condquant") <- lcq
## attr(lstdres[,lj], "condquant") <- lcq
attr(lrsj, "condquant") <- lcq
}
} else {
##- if (lIcq) {
##- lcq <- attr(lrsj, "condquant", exact=TRUE)
##- if (length(lcq)) {
##- lcq[,1:4] <- lcq[,1:4]*lstrratio[lcq[,"index"],lj]
##- attr(lrsj, "condquant") <- lcq
##- }
##- }
lstdres[,lj] <- lrsj
}
if (lnsims) lsimstdres <- lsimres * lstrratio[,lj] ## index needed for multiv
} ## fi lregrft$smresid
if (lIabs) labsres[,lj] <- abs(lrsj)
if (lIqq) { ## scale smoothed residuals by smoothed scale
lfsm <-
gensmooth(lfit[,lj], abs(lrsj), plargs=plargs, power=0.5)
##- if (lna <- sum(is.na(lsj)&!(is.na(lres[,lj])|is.na(lrsj))))
##- warning(":plregr: residuals from smooth have ",
##- round(100*lna/lnobs,1), " % additional NAs")
lstdrsc[,lj] <- lrsj/lfsm[["ysmorig"]]
}
}
if (lregrft$smresid) {
lstdresname <- paste("st.sm.", lresname, sep = "")
labsresname <- paste("|st.sm.",lresname,"|", sep="")
}
names(lstdres) <- lstdresname
lstdres <- genvarattributes(lstdres, ploptions=ploptions)
if (lIabs) {
labsres <-
genvarattributes(labsres, ploptions=ploptions, varlabel=labsresname)
for (lj in seq_len(lmres))
attr(labsres[,lj], "plrange")[1] <- 0
}
}
## --- multiple frames xxx
lmf <- i.def(lregrft$mf, NULL, TRUE, NULL)
if (length(lmf)) {
if (u.true(lmf)) ## is.logical(lmf)&&lmf)
lmf <- if (lmres>1) {
if (lmres<=4) c(lmres, NA) else lmres
} else lnplsel
## if (lnplsel<=2) lnplsel else c(2)
}
if (length(lmf)==2) {
if (is.na(lmf[1])) {
lmf1 <- ceiling(lnplsel/lmf[2])
if(lmf1>lmf[2]+1) lmf1 <- lmf[2]
lmf[1] <- lmf1
}
if (is.na(lmf[2])) {
lmf1 <- ceiling(lnplsel/lmf[1])
if(lmf1>lmf[1]+1) lmf1 <- lmf[1]
lmf[2] <- lmf1
}
}
## lbyrow <- i.def(ploptions$byrow, FALSE)
## outer margin
##- loma <- c(3,3,2,1)*(length(lmf)>0)
##- lomaarg <- i.getploption("oma") ## i.def(plargs$plmarpar$oma, NULL, valuefalse=NULL)
##- if (length(lomaarg))
##- if (length(lomaarg)==1) loma[3] <- lomaarg
##- else loma <- rep(lomaarg, length=4)
loldpar <- par(c("mar","mgp"))
lmfpar <- NULL
if (length(lmf)&(!is.logical(lmf))) {
lmfpar <- plmframes(mft=lmf, plargs=plargs)
loldpar <- c(loldpar, attr(lmfpar,"oldpar"))
}
loldpar <- loldpar[!duplicated(names(loldpar))]
on.exit(par(loldpar), add=TRUE, after=FALSE)
## --------------------------------------------------------------------
## start plots
if (length(lplsel))
for (liplot in seq_along(lplsel)) {
lpllevel <- lplsel[liplot]
lpls <- names(lpllevel)
## ------------------------------------------------------------
## --- y on fit
if(lpls=="yfit") {
##- lsml <- if (length(lsmlegend["yfit"]))
##- setNames(rep(lsmlegend["yfit"],length(lregrft$yname)),
##- lregrft$yname) else lsmlegend
ly <- lregrft$response ##attr(lpldata, "yvar")
if (length(ly)==0)
warning(":plregr: response not found")
else {
lregrft$smooth <- lpllevel-1
## plargs$parpar$mar <- lmar
lregrft$reflinecoord <- c(x=0,y=1) ## median(lfit[,lj], na.rm=TRUE)
for (lj in seq_len(ncol(ly))) {
lyj <- ly[,lj]
lfj <- lfit[,lj]
if(length(lsimres))
lyj <- structure(data.frame(lyj, lfj+lsimres), primary=1)
plpanel(x=lfj, y=lyj, frame=TRUE, xlab="fitted values",
plargs=plargs)
}
}
## lregrft$reflinecoord <- NULL
}
## ------------------------------------------------------------
## --- Tukey Anscombe plot
if(lpls=="resfit") {
for (lj in seq_len(lmres)) {
lplargs <- plargs
lplargs$plfeatures$smooth <- lpllevel-1
lplargs$plfeatures$reflinecoord <-
c(x=median(lfit[,lj], na.rm=TRUE),y=-1)
lrsj <- lres[,lj]
if(length(lsimres))
lrsj <- structure(data.frame(lres[,lj], lsimres), primary=1)
plpanel(lfit[,lj], lrsj, frame=TRUE,
xlab="fitted values", plargs=lplargs)
}
## lregrft$reflinecoord <- NULL
## par(cex=lcex)
}
## ------------------------------------------------------------
## --- scale plot
if(lpls=="absresfit")
if(length(labsres)==0)
warning(":plregr: No standardized residuals found")
else {
plargs$plfeatures$smooth <- lpllevel-1
for (lj in seq_len(lmres)) {
labsrj <- labsres[,lj, drop=FALSE]
if (lnsims)
labsrj <- structure(data.frame(labsrj, abs(lsimstdres)),
primary=1)
plpanel(lfit[,lj], labsrj, frame=TRUE, xlab="fitted values",
plargs=c(plargs, list(smooth.power=0.5)) ) ## plsmooth needs 'power'
}
## par(cex=lcex)
}
## ------------------------------------------------------------
## --- plot abs. res vs. weights
if(lpls=="absresweights") {
if (length(lweights)!=lnr)
warning(":plregr: no suitable weights found.",
"cannot plot absres on weights")
else { ## copy from absresfit
lwg <- lweights
lwg[lwg<=0] <- NA
lwg <- genvarattributes(data.frame(lwg))
if (attr(lwg[,1], "plrange", exact=TRUE)[1]<0.3)
attr(lwg[,1], "plrange")[1] <- 0
for (lj in seq_len(lmres)) {
labsrj <- labsres[,lj, drop=FALSE]
if (lnsims)
labsrj <- structure(data.frame(labsrj, abs(lsimstdres)), primary=1)
plpanel(lwg, labsrj, frame=TRUE, xlab="weights", ## title=NA,
ylab=paste("|",lresname,"| * sqrt(w)", sep=""),
plargs=c(plargs, list(smooth.power=0.5))) ## plsmooth needs 'power'
}
## par(cex=lcex)
}
}
## ------------------------------------------------------------
## --- normal plot qq plot
if(lpls=="qq") {
lnsims <- if (length(lsimstdres)) ncol(lsimstdres) else 0
if (lnsims)
lsimstdr <-
if (i.def(attr(lsimstdres, "type", exact=TRUE), "resampled")=="resampled")
simresiduals.default(x, nrep=lnsims, simfunction=rnorm,
sigma=apply(lstdrsc, 2, mad, na.rm=TRUE) )
else lsimstdres
for (lj in seq_len(lmres)) {
llr <- lstdrsc[,lj] ## residuals from smooth, smoothly scaled
lio <- order(llr)[seq_len(lnobs)]
llr <- plsubset(llr, lio)[,1]
if (length(lat <- attr(llr, "numvalues", exact=TRUE)))
attr(llr, "numvalues") <- lat[lio]
if (length(lat <- attr(llr, "plcoord", exact=TRUE)))
attr(llr, "plcoord") <- lat[lio]
lIcqj <- length(lcq <- attr(llr, "condquant", exact=TRUE))>0 ##!!! falsch ?
lIcqu <- lIcq | lIcqj
lxx <- qnorm(ppoints(lnobs))
attr(lxx, "zeroline") <- 0
plframe(lxx, llr, xlab = "theoretical quantiles",
ylab = lstdresname[lj], ploptions=ploptions,
xy=FALSE) ## mar=lmar,
if (lnsims>0) {
llcol <- colorpale(i.getploption("smooth.col"),
pale=i.getploption("smooth.pale"))
llty <- tail(i.getploption("smooth.lty"),1)
llwd <- i.getploption("linewidth")[llty]
apply(lsimstdr, 2,
function(x) lines(lxx,sort(x), lty=llty, lwd=llwd,
col=llcol) )
}
plpoints(lxx, llr, plargs=list(pldata=plargs$pldata[lio,]),
ploptions=ploptions, marpar=marpar, xy=FALSE)
lquart <- quantile(llr, c(0.25,0.75), na.rm=TRUE)
## qq line
plrefline(c(0, diff(lquart)/(2*qnorm(0.75))), plargs=plargs)
if(lIcq & lj==lmres)
legend("bottomright",
pch=c(rep(ploptions$censored.pch,length=2)),
legend=c("uncensored","censored"))
## pltitle(plargs=plargs, show=FALSE)
}
}
## ------------------------------------------------------------
## --- leverage plot. If weight are present, use "almost unweighted h"
if(lpls=="leverage")
if ((!is.na(lpllevel))&&lpllevel>0) {
if (lIwgt) llev <- llev/lweights
if (diff(range(llev,finite=TRUE))<0.001)
notice("plregr: all leverage elements equal, no leverage plot")
else {
llevpl <- genvarattributes(
##- data.frame(leverage = plcoord(llev, c(0,llevlim[1]),
data.frame(leverage=llev),innerrange= list(leverage=c(0,llevlim[1])),
ploptions=ploptions)[,1]
attr(llevpl, "plrange")[1] <- 0
lstdres <- genvarattributes(lstdres, varlabel = lstdresname)
## mark extremes
lmx <- i.getplopt(markextremes)
if (is.list(lmx)) lmx <- lmx[["(lev)"]]
if (is.function(lmx)) lmx <- lmx(lnobs)
lmx <- tail(i.def(lmx, 0),1)
if (lImxlev <- lmx>0)
lpllev <- plmark(llev, markextremes=c(0,lmx),
plabel=lregrft$plabel)
##
llevtit <- paste("leverage", if(lIwgt) "(de-weighted)")
ldfmod <- lregrft$df.model
lcookl <- lregrft$cookdistlines
if (i.def(ldfmod, 0)<=1) {
warning(":plregr: model degrees of freedom <=1. No Cook-distance lines")
lcookl <- NULL
}
if (lIcook <- length(lcookl)>0) {
llx <- seq(0, max(llev[is.finite(llev)]-.Machine$double.eps), length=50)
## see formula for curves of constant Cook's distance in terms of
## standardized residuals
llrcd <- outer(sqrt((1-llx)/((ldfmod-1)*llx)), c(lcookl,-lcookl))
}
for (lj in 1:lmres) {
lstrj <- lstdres[,lj]
lplj <- if (lIrpl) lresplab[,lj] else rep("", lnr)
if (lImxlev) {
lplj <- ifelse(lpllev=="", lplj, lpllev)
if (any(lplj!="")) plargs$pldata$.plab. <- lplj
}
if (lIcook) lregrft$reflinecoord <- list(x=llx, y=llrcd)
lplopt <- ploptions(smooth=FALSE, assign=FALSE)
plpanel(llevpl, lstrj, xlab=llevtit,
plargs=plargs, ploptions = lplopt,
frame=TRUE)
lregrft$reflinecoord <- NULL
}
}
## par(cex=lcex)
}
## -----------------------------------------------------------------
## --- multivariate:
## residual matrix for multivariate regr
if(lpls=="resmatrix") {
lpanel <-
function(x, y, indx, indy, pch, col, plab, panelargs=plargs, ...)
plpoints(x,y, plargs=panelargs, marpar=marpar, xy=FALSE)
if (lregrft$rescol>1) {
lpa <- plargs
lpa$pldata <- lpa$residuals
lpa$mar <- NULL
plmatrix(lres, panel=lpanel, plargs=lpa) #main=lregrft$main, pch=lregrft$pch
}
}
## --- mahalanobis residuals
if(lpls=="qqmult") ## qq plot of Mahalanobis lenghts for multivariate regr
if ((!is.na(lpllevel))&&lpllevel>0) {
lresmahal <- lregrft$resmahal
if (is.null(lresmahal)) ## should never happen. generated in plregr.control !!!
lresmahal <-
mahalanobis(lres,0,
var(apply(lres,2, function(x) ifelse(is.finite(x), x, NA)),
na.rm=TRUE))
lxx <- sqrt(qchisq(ppoints(lresmahal),ncol(lres)))
lio <- order(llr)[seq_len(lnobs)]
llr <- transferAttributes(llr[lio], llr) ## may need plsubset
lor <- order(lresmahal)
lyy <- sqrt(lresmahal[lor])
lop <- par(mfrow=c(1,1), oma=c(0,0,2,0))
plframe(lxx,lyy, xlab="sqrt(Chisq.quantiles)",
ylab = "Mahal.oulyingness",
ploptions=ploptions, xy=FALSE)
points(lxx,lyy, type="b") ## !!! plpoints
## !!! needs work!!!
## if (ltxt) text(lxx,lyy, plab[lor]) # else points(lxx,lyy,pch=lplab[lor])
abline(0,1,lty = ploptions$grid.lty, col=ploptions$grid.col)
##- pltitle(plargs=plargs, show=FALSE)
##- stamp(sure=FALSE, ploptions=ploptions)
par(lop)
}
pltitle(plargs=plargs)
stamp(sure=FALSE, ploptions=ploptions)
} ## end lplsel
## ----------------------------------------------------------------
## plot residuals vs. explanatory variables by calling plresx
## ----------------------------------------------------------
plargs$plfeatures$mf <- FALSE ## avoid a new page
## lregrf$ylim <- lylim ## no need to calculate again
## plargs$plmarpar$mar <- lmar + c(0,0,1.5,0)
lxvar <- if (u.notfalse(xvar)) attr(lpldata, "xvar", exact=TRUE)
if (!i.def(sequence, FALSE)) lxvar <- setdiff(lxvar, ".sequence.")
## avoid plot against x in simple regression
if (length(lxx <- setdiff(lxvar, c(".sequence.", ".weights.")))==1 &&
"resfit"%in%names(lplsel)) {
## ltr <- i.def(transformed, FALSE) || lxx%in%
if (lxx %in% names(lpldata)) {
message("plregr: plot of residuals on ", lxx,
" not shown because it is equivalent to 'resfit'")
lxvar <- setdiff(lxvar, lxx)
}
}
if (length(i.def(lxvar, NULL, valuefalse=NULL)))
plresx(x, data=data, resid=lres, xvar=lxvar,
transformed = transformed, sequence=sequence,
weights= if ("weights"%in%names(lplsel)) FALSE else NULL,
addcomp = addcomp, smooth.legend=lsmlegend,
plargs = plargs)
## --- end plregr
invisible(plargs)
}
## ==========================================================================
i.plotselect <- #f
function(plotselect, smooth=2, Iwgt = FALSE, mult = FALSE,
famgauss = TRUE, famglm = FALSE, famcount = FALSE)
{
## plot selection
smooth <- i.getplopt(smooth)
lsmdef <- 1+smooth-famglm
lplsel <- i.getploption("regr.plotselect")
lplsel["resfit"] <- i.def(lplsel["resfit"], lsmdef)
if (length(plotselect)>0) {
lplotsel <- unlist(plotselect)
if (length(lplotsel)!=length(plotselect)) {
warning(":i.plotselect: unsuitable argument.",
"'plotselect' should be a vector")
return(lplsel)
}
lpls <- TRUE
lplnm <- names(plotselect)
if (length(lplnm)==0) {
if (length(plotselect)==length(lplsel))
lplnm <- names(lplsel)
else {
warning(":plregr: Inadequate argument plotselect")
lpls <- FALSE}
}
if (lpls) {
if ("default"%in%lplnm) {
lplnm <- setdiff(lplnm, "default")
lplsel[] <- if (plotselect["default"]==0) 0 else
pmin(lplsel,plotselect["default"])
}
lina <- is.na(match(lplnm,c(names(lplsel),"default")))
if (any(lina)) {
warning(":plregr: Inadequate elements in plotselect: ",
paste(names(plotselect)[lina], collapse=", "))
lplnm <- lplnm[!lina] }
lplsel[lplnm] <- plotselect[lplnm]
}
}
if (!mult) lplsel[c("resmatrix","qqmult")] <- 0
if (is.na(lplsel["yfit"])) lplsel["yfit"] <- 0
if (is.na(lplsel["resfit"]))
lplsel["resfit"] <- lsmdef * (lplsel["yfit"]==0)
if (is.na(lplsel["absresfit"]))
lplsel["absresfit"] <- 2 * !famcount
if (is.na(lplsel["absresweights"]))
lplsel["absresweights"] <- 2 * (famgauss&Iwgt)
if (is.na(lplsel["qq"])) lplsel["qq"] <- famgauss # how about gamma? !!!
lplsel
} ## end i.plotselect
## ==========================================================================
plresx <- #f
function(x, data = NULL, xvar = TRUE, transformed = NULL,
sequence = FALSE, weights = NULL,
addcomp = NULL, smooth = 2, smooth.legend = FALSE,
markextremes = NA,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
## ------------------------------------------------------------
{ ## plresx
lcall <- match.call()
if (length(plargs)==0) {
lac <- as.list(lcall)[-1]
lac$stdresid <- FALSE
ladrop <- c("sequence", "weights", "smooth.legend")
lcall <-
c(list(quote(plregr.control)), lac[setdiff(names(lac), ladrop)])
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
marpar <- i.getmarpar(plargs=plargs)
## -------------------------------------------------------------------
if (inherits(x,"mulltinom"))
stop("!plresx! I do not know how to plot residuals of a mulitnomial regression")
lpldata <- plargs$pldata
lvars <- attr(lpldata, "xvar", exact=TRUE)
## ---
lplft <- plargs$plfeatures
if (u.isnull(transformed))
transformed <- i.def(lplft$transformed, length(xvar)>0)
lregrft <- plargs$regrfeatures
## show reference lines?
lshrefl <- u.notfalse(i.getploption("refline")) & !inherits(x,"coxph")
lres <- lregrft$residuals
lIcq <- inherits(lres, "condquant")
## lform <- lregrft$formula
lsimres <- lregrft$simres
lnsims <- if (is.null(lsimres)) 0 else ncol(lsimres)
lInnls <- !inherits(x, "nls")
lnr <- nrow(lpldata)
lIwgt <- length(lregrft$weights)>0 &
!inherits(x, "glm") ## do not plot against weights for binom,...
lnaaction <- lregrft$na.action
## lweights <- naresid(lnaaction, lregrft$weights)
## --- sequence
lIseq <- i.def(sequence, FALSE, TRUE, FALSE)
if (lIseq) {
if (length(lvars)) {
## is the seqence represented by any other variable?
lseqvar <-
if (length(lvars)>0)
sapply(lpldata[,lvars,drop=FALSE],function(x) {
if (is.factor(x)||is.character(x)) FALSE else {
ld <- diff(x)
sum(ld==0)<0.1*length(x) && (all(ld<=0) | all(ld>=0)) }
} ) else FALSE
lIseq <- !any(lseqvar)
if (!lIseq) warning(paste(":plresx: sequence represented by",
paste(lvars[lseqvar],collapse=", ")))
}
lpldata$".sequence." <- structure(1:lnr, varlabel="sequence", zeroline=FALSE)
lvars <- c(lvars,".sequence.")
}
## --- weights as x variable
lIweights <- i.def(weights, lIwgt, TRUE, FALSE)
if (lIweights)
if (!lIwgt)
warning(":plresx; No weights found.",
" Cannot plot residuals against weights") else {
lpldata[,".weights."] <- naresid(lnaaction, lregrft$weights)
lvars <- c(lvars, ".weights.")
}
## ------------------
if (is.null(lvars)) {
warning(":plresx: I did not find any x variables")
return() }
## terminouterel
lvmod <- all.vars(formula(x)[-2])
if (transformed) {
ltrms <- rownames(attr(terms(x),"factors", exact=TRUE))
lvrs <- u.allvars(ltrms) ## which terms contain which vars?
litrms <- sapply(lvrs, function(x) any(x%in%c(lvars,ltrms)) )
lvmod <- ltrms[litrms | ltrms%in%lvars]
} else {
lvi <- pmatch("(", lvars, nomatch=0)
lvars <-
if (any(lvi>0)) c(unlist(u.allvars(lvars[-lvi])),lvars[lvi])
else unlist(u.allvars(lvars))
}
lnvars <- length(lvars)
terminouterel <- lvars%in%lvmod
lvcomp <- intersect(lvars, lvmod) ## variables that appear in the model
## type
addcomp <- as.logical(i.def(addcomp, FALSE, TRUE, FALSE))
## lpa <- plargs
lInnls <- !inherits(x, "nls")
## -----------------------------------
## fit components for refline
lIcomp <- addcomp|lshrefl ## components needed?
if (lIcomp&&length(lvcomp)&lInnls) { ## fit components
if (length(x$call$data)==0) x$call$data <- lpldata ## in this case,
## only model vars can be used
lcomp <- fitcomp(x, vars=lvcomp, transformed=transformed,
xfromdata=FALSE, se=lshrefl>1)
lcompx <- lcomp$x
lcompy <- if (addcomp) lcomp$comp else -lcomp$comp
lIcompse <- length(lcompse <- lcomp$se)>0
if (addcomp) {
lcompdt <-
fitcomp(x, lpldata, vars=lvcomp, transformed=transformed,
xfromdata=TRUE)$comp
## is added to lres below
}
} else lshrefl <- FALSE
## quantile
lqnt <-
if (length(lregrft$dfres)>0) {
qt(1-lregrft$testlevel/2, lregrft$dfres)
} else qnorm(1-lregrft$testlevel/2)
## --- smooth
lIsmooth <- i.def(smooth, i.def(lregrft$smooth,
i.getploption("smooth"),TRUE) )
plargs$plfeatures$smooth <- lIsmooth
if (length(names(smooth.legend))==0) {
lsmlegend <- i.def(smooth.legend, NULL, TRUE, NULL)
if (length(lsmlegend)==1)
lsmlegend <- setNames(lsmlegend, lvars[1])
} else lsmlegend <-
if("(xvar)"%in%names(smooth.legend))
setNames(smooth.legend, lvars[1]) else smooth.legend
lpanel <- eval(i.getploption("panel"))
if (is.character(lpanel)) lpanel <- get(lpanel, envir=pl.envir)
## --- multivariate ## !!! factors!
if (inherits(x,"mlm")) {
lpmult <- function(x, y, indx, indy, pch, col, panelargs=NULL, ...) {
## lcompx <- lcompy <- NULL
ltin <- terminouterel[indx]
lvx <- lvars[indx]
if (ltin&lshrefl) {
lregrft$reflinecoord <- list(x=lcompx[,lvx], y=lcompy[,lvx,indy])
}
lpanel(x, y, plargs=plargs)
}
plmatrix(lpldata[,lvars,drop=FALSE], lres, panel=lpmult,
##pch=lregrft$plab, plcol=lregrft$lpldata$plcol,
nrow = lregrft$multnrow, ncol = lregrft$multncol,
mar = lregrft$marmult,
plargs=plargs)
return()
}
## ------------------------------------------------------------------
lmf <- i.def(lregrft$mf, NULL, TRUE, NULL)
if (length(lmf)) {
if (u.true(lmf))
lmf <- if (lnvars<=6) lnvars else
min(lnvars,ceiling(lnvars/((lnvars-1)%/%6+1)))
}
loldpar <- par(c("mar","mgp"))
lmfpar <- NULL
if (length(lmf)&(!is.logical(lmf))) {
lmfpar <- plmframes(mft=lmf, plargs=plargs)
loldpar <- c(loldpar, attr(lmfpar,"oldpar"))
}
loldpar <- loldpar[!duplicated(names(loldpar))]
on.exit(par(loldpar), add=TRUE, after=FALSE)
## --------------
lmbox <- i.getploption("factor.show")=="mbox"
lrpl <- lregrft$resplab
if (length(lrpl)>0) lrpl <- lrpl[,1]
lr <- lres
if (lIsmooth && lnsims>0) lr <- structure(cbind(lr, lsimres), primary=1)
lrs <- lr ## need a copy for the case addcomp is true
## ------------------------------------------------------------------
## --- loop --- plresx
for (lj in 1:lnvars) {
lvr <- lvars[lj] ## if (transformed) lvars[lj] else lrawv[lj]
lv <- unname(lvr)
lIcompj <- terminouterel[lj] && lshrefl && lInnls
if (lIcompj) {
lcj <- lcompy[, lvr]
if (lIcompse) lcsej <- lcompse[,lvr]
}
## if (lregrft$partial.resid)
if (lshrefl && addcomp && lIcompj) {
lrs <- lr+lcompdt[, lvr] ## possibly does not work (for condq)
lrs[,1] <- genvarattributes(lrs[,1,drop=FALSE],replace=TRUE,
varlabel=list(paste(attr(lr[,1],"varlabel"),"+ comp_eff")))
attr(lrs, "primary") <- 1 ## simulated smooths...
}
lvv <- lpldata[, lv]
mar <- i.def(plargs[["mar"]], NA) ## c(NA, par("mar")[-1])
## ---
if (u.isnull(attr(lvv, "varlabel"))) attr(lvv, "varlabel") <- lv
lrs1 <- lrs[,1,drop=FALSE]
if (is.factor(lvv)) {
## --- factors
ll <- levels(lvv)
lnl <- length(ll)
if (lIcompj) {
lrfx <- c(outer(0.45*c(-1,1,NA),seq_along(ll),"+"))
lcj1 <- lcj[1:lnl]
lrfy <- c(rbind(lcj1,lcj1,NA))
lrfb <-
if(lIcompse) {
lcsej1 <- lcsej[1:lnl]
lrfb <- c(rbind(lcsej1,lcsej1,NA))
lrfy + cbind(-lrfb,lrfb)
}
lrefline <- list(x=lrfx, y=lrfy, band=lrfb)
}
if (lmbox) {
lmr <- marpar$mar
lmr[1] <- NA
## allow for changing mar[c(1,3)]
plargs$pldata=structure(lpldata, xvar=lv)
plmboxes.default(lvv, lrs1, data=lpldata, mar=lmr, plargs=plargs)
plrefline(lrefline, plargs=plargs)
} else {
lpla <- plargs
lpla$plfeatures$reflinecoord <- lrefline
plframe(lvv,lrs1, plargs=lpla, xy=FALSE)
lpanel(lvv,lrs, plargs=lpla)
}
} else { # ---
## --- continuous explanatory variable
if (lshrefl && lIcompj) {
lrefx <- lcompx[,lvr]
lrefyb <- if (lshrefl>1) outer(lqnt*lcompse[,lvr], c(-1,1))
plargs$plfeatures$reflinecoord <-
list(x=lrefx, y=lcj, band=lrefyb)
}
plpanel(lvv, lrs, plargs=plargs, frame=TRUE) ## title=NA,
} ## ends if factor else
## par(cex=lcex)
}
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plresx
## ==========================================================================
smoothRegr <- #f
function(x, y, weights=NULL, par=NULL, iterations=50, minobs=NULL, ...)
{
minobs <- i.def(minobs, i.getploption("smooth.minobs"), valuefalse=1)
lnx <- sum(is.finite(x))
if (lnx<minobs ) return(NULL)
liter <- max(i.def(iterations, i.getploption("smooth.iter")),0)
lform <- if (is.formula(x)) x else y~x
lpar <- i.def(par,i.getploption("smooth.par"))
if (is.function(lpar)) lpar <- lpar(lnx)
## ----------------------------------------------------------------
lcall <- call("loess", formula=lform, data=data.frame(x=x, y=y),
weights=weights, span=lpar, iterations=max(liter,1),
family=if (liter>0) "symmetric" else "gaussian",
na.action=na.exclude)
if (u.isnull(weights)) lcall$weights <- NULL
lsm <- if (ploptions("debug")) eval(lcall, parent.frame())
else try(eval(lcall), parent.frame(), silent=TRUE)
if (inherits(lsm, "try-error")) {
warning(":smoothRegr: span was too small. Using 0.99")
lcall$span <- 0.99
lsm <- eval(lcall, parent.frame())
}
fitted(lsm)
}
## ========================================================================
gensmooth <- #f
function(x, y, band=FALSE, power=1, resid="difference", weight=NULL,
plargs = NULL, ploptions = NULL, ...)
{
## Purpose: smooth for multiple y : one column from data, the other sim
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 9 Feb 2016, 14:57
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
##
lsmiter <- i.getploption("smooth.iter")
lsmfunc <- i.getploption("smooth.function")
if (is.character(lsmfunc)) lsmfunc <- get(lsmfunc)
if (is.null(lsmfunc)) lsmfunc <- smoothRegr
lIfm <- names(formals(lsmfunc))[1]=="formula"
lsmf <-
if (lIfm) function(x, y, power=1, weights=NULL, par=NULL, iterations=lsmiter, ...)
lsmfunc(I(y^power)~x, weights=weights, par=par, iterations=iterations, ...)
else function(x, y, power=1, weights=NULL, par=NULL, iterations=lsmiter, ...)
lsmfunc(x, y^power, weights=weights, par=par, iterations=iterations, ...)
power <- i.def(power, 1,1,1)
## ---
lnx <- NROW(x)
if (inherits(y, "Surv")) y <- y[,1] ## !!! needs improvement!
ly <- as.matrix(y)
if (nrow(ly)!=lnx) stop("!gensmooth! Incompatible dimensions of 'x' and 'y'")
## if (length(weights)<=1) weights <- rep(1, lnx)
lweights <- i.def(weight, plargs$pldata$".smoothWeights.")
lIwgt <- length(lweights)>0
if (lIwgt&&length(lweights)!=lnx)
stop("!gensmooth! Incompatible dimensions of 'x' and 'weights'")
lgroup <- plargs$pldata$".smooth.group."
if (u.isnull(lgroup)) lgroup <- plargs$pldata$".group."
if (lInogrp <- length(lgroup)<=1) lgroup <- rep(1, lnx)
if (length(lgroup)!=lnx)
stop("!gensmooth! Incompatible dimensions of 'x' and 'group'")
lgrp <- i.factor(lgroup)
if (is.character(resid))
resid <- pmatch(resid, c("difference","ratio"))
if (is.na(resid)) {
warning(":gensmooth: argument 'resid' not suitable.",
" Difference residuals calculated")
resid <- 1
}
lnobs <- median(table(lgrp))
band <- i.def(band, FALSE, TRUE)
lpar <- i.getploption("smooth.par")
if (is.function(lpar)) lpar <- lpar(lnobs)
lparband <- lpar[1]* i.def(lpar[2], 1.5, 1.5, 1)
liter <- i.getploption("smooth.iter")
lminobs <- i.getploption("smooth.minobs")
## data: look for numvalues
lx <- i.def(attr(x,"numvalues", exact=TRUE),x)
## if (inherits(lx, "POSIXt")) lx <- as.numeric(lx)
ly <- apply(ly,2, function(y) i.def(attr(y, "numvalues", exact=TRUE), y))
lnna <- apply(cbind(lx,ly), 1, sumNA)
lx[lnna>0] <- NA
lio <- order(as.numeric(lgrp), lx, na.last=NA) ## order by group
lxo <- lx[lio] # sorted without NA
lyo <- ly[lio,,drop=F]
lgrpo <- lgrp[lio]
lngrp <- length(levels(lgrpo))
lgrpn <- as.numeric(lgrpo)
lwgto <- if(lIwgt) lweights[lio] else NULL
## production
oldopt <- options(warn=-1)
on.exit(options(oldopt), add=TRUE, after=FALSE)
lysm <- array(NA, dim=dim(lyo), dimnames=dimnames(lyo))
## presently only for matrices
if (band) lysmband <- lsmrpos <- lysm[,1]
lsm <- NULL
for (lgr in seq_along(levels(lgrpo))) { ## smooth within groups (if >1)
lig <- which(lgrpn==lgr)
lxg <- lxo[lig]
if (sum(!is.na(lxg))<lminobs) {
notice("gensmooth: too few non-missing observations",
if(lngrp>1) paste(" for group ",lgr) )
next
}
for (j in ncol(lyo):1) {
lsm <- lsmf(as.numeric(lxg), as.numeric(lyo[lig,j]), power=power,
weights=if(lIwgt) lwgto[lig] else NULL,
par=lpar[1], iterations=lsmiter, ...)
if (is.list(lsm)) lsm <- fitted(lsm)
if (length(lsm)==0) {
notice("gensmooth: too few observations for a smooth",
printnotices=ploptions$printnotices)
} else lysm[lig,j] <- lsm^(1/power)
}
## band
if (band & length(lsm)) {
lysmb <- rep(NA, length(lsm))
lsmr <- lyo[lig,1]^power-lsm^power ## residual
lsmrpos[lig] <- lip <- lsmr>=0
## high end
lii <- which(lip)
if(length(lii)) {
lsmrh <- lsmr[lii]
## ligi <- lig[lii]
lsmh <- lsmfunc(lxg[lii], sqrt(lsmrh),
weights=if (lIwgt) lwgto[lig[lii]] else NULL,
par=lparband, iterations=liter)
if (length(lsmh)==0) {
notice("gensmooth: too few observations for a 'high' smooth",
if(lngrp>1) paste(" for group ",lgr),
printnotices=ploptions$printnotices )
} else lysmb[lii] <- lsmh^2
}
## low end
if(length(lii)) {
lii <- which(!lip)
lsmrl <- - lsmr[lii]
## ligi <- lig[lii]
lsml <- lsmfunc(lxg[lii], sqrt(lsmrl),
weights=if (lIwgt) lwgto[lig[lii]] else NULL,
par=lparband, iterations=liter)
if (length(lsml)==0) {
notice("gensmooth: too few observations for a 'low' smooth",
if(lngrp>1) paste(" for group ",lgr),
printnotices=ploptions$printnotices )
} else lysmb[lii] <- - lsml^2
}
## resulting band
lysmband[lig] <- (lysmb + lsm^power)^(1/power)
}
}
lysmin <- matrix(NA, lnx, ncol(lyo), dimnames=list(names(x),colnames(lyo)))
lysmin[lio,] <- lysm
lres <- if (resid==2) ly/lysmin else ly-lysmin
rr <- list(x = lxo, y = lysm, group = if(!lInogrp) i.factor(lgrpo),
index = lio, xorig = x, ysmorig = lysmin, residuals = lres,
xtrim = attr(lsm, "xtrim", exact=TRUE) )
if (band) rr <- c(rr, yband = list(lysmband), ybandindex = list(lsmrpos) )
rr
} ## end gensmooth
## ==========================================================================
smoothLm <- #f
function(x, y, weights = NULL, ...) {
rr <- if (u.isnull(weights)) lm.fit(cbind(1,x), y, ...)$fitted
else lm.wfit(cbind(1,x), y, weights, ...)$fitted
structure(rr, xtrim=0)
}
## smoothRegrrob <- function(x,y,weights,par=3*length(x)^log10(1/2),iter=50)
## =======================================================================
plmatrix <- #f
function(x, y=NULL, data=NULL, panel=NULL, ##panelargs = plargs,
nrow=NULL, ncol=nrow, reduce=TRUE,
xaxmar=NULL, yaxmar=NULL, xlabmar=NULL, ylabmar=NULL,
xlab=NULL, ylab=NULL, ## partial match!?!
mar=NULL, oma=NULL,
diaglabel.csize = NULL, ## csize=NULL, csize needed because otherwise
## csize will be translated into diaglabel.csize
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: pairs with different plotting characters, marks and/or colors
## showing submatrices of the full scatterplot matrix
## possibly on seeral pages
## -------------------------------------------------------------------------
lcall <- match.call()
## lIplargs <- u.isnull(lcall[["plargs"]])
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
lcall$.subdefault <- as.expression(substitute(x)) ##as.character(as.expression(substitute(x)))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (is.name(substitute(data)))
lcall$.subdefault <- as.expression(substitute(data))
data
}
lcall$distinguishy <- FALSE
lcall$gensequence <- FALSE
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, envir=parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## --------------
lf.axis <- function(k, x, axm, labm, txt, ...) {
if (k %in% axm)
plaxis(k, x, varlabel="", ploptions=ploptions, marpar=marpar)
if (k %in% labm) {
lli <- lmline[1] + (k%nin%axm)*diff(lmline) ## diff is negative
mtext(txt, side=k, line=lcsize*lli,
cex=lcsize*marpar$margin.csize[1], ...)
}
}
lf.eq <- function(v1,v2) {
if (is.factor(v1)) is.factor(v2)&&
all(dropNA(as.numeric(v1)==as.numeric(v2)))
else all(dropNA(as.numeric(v1)==as.numeric(v2)))
}
##- lkeeppar <- i.getploption("keeppar")
##- oldpar <- par(c("mar","cex","mgp","oma")) ##, "ask", "mfrow"
## ## lmfg <- par("mfg")
##- if (!lkeeppar) on.exit(par(oldpar))
##---------------------- preparations --------------------------
##- lcl <- match.call()
##- lcall <- sys.call() ## match.call modifies argument names
##- lcnm <- names(lcall)
##- if (length(lcall)!=length(lcl)) stop("bug")
##- names(lcall) <- ifelse(lcnm=="", names(lcl), lcnm)
## margins, will be used by plframe
panel <- i.getplopt(panel)
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plmatrix: 'panel' not found. Using 'plgraphics::plpanel'")
panel <- plgraphics::plpanel
}
if (length(xlab)|length(ylab))
warning(":plmatrix: Arguments 'xlab' and 'ylab' not used. ",
"Set 'varlabel' instead!")
## -----------------------------------------------
## data and bookkeeping
pldata <- plargs$pldata
## if group , generate pcol
if (".group."%in%names(pldata)) {
if (!".pcol."%in%names(pldata))
plargs$pldata[,".pcol."] <- pldata[,".group."]
##- if (!".smooth.group."%in%names(pldata))
##- plargs$pldata[,".smooth.group."] <- pldata[,".group."]
}
## if (is.null(i.getplopt(main))) lplftt$main <- lplftt$datalabel
xvar <- i.def(attr(pldata,"xvar", exact=TRUE), names(pldata))
nv1 <- length(xvar)
lv1 <- lv2 <- 0
if (u.isnull(y)) {
xvar <- c(xvar, attr(pldata,"yvar", exact=TRUE))
nv1 <- length(xvar)
if (reduce) { nv1 <- nv1-1; lv2 <- 1 }
nv2 <- nv1
ldata <- pldata[,xvar]
} else { # cbind y to data for easier preparations
## reduce <- FALSE
if (!is.null(dim(y))) {
yvar <- colnames(y)
ldata <- cbind(pldata[,xvar], as.data.frame(y))
} else {
yvar <- attr(pldata,"yvar", exact=TRUE)
ldata <- pldata[,c(xvar,yvar)]
}
## lformy <- as.formula(paste("~",paste(yvar, collapse="+")))
nv2 <- length(yvar)
lv2 <- length(xvar)
}
lnr <- nrow(ldata)
lnobs <- lnr-mean(sumNA(ldata))
lvsurv <- sapply(ldata, function(x) inherits(x, "Surv") )
if (any(lvsurv)) { ## survival vars
lf.surv <- function(dt) structure(dt[,1], pch=dt[,2]+1)
ldata[lvsurv] <- lapply(ldata[lvsurv], lf.surv)
}
## --- title
##- lIsub <- lplft$sub
##- lImain <- lplft$main
##- lcsizemain <- c(i.getploption("title.csize"),1,1)
##- ## title: how many lines?
lItit <- !( (length(lplft$main)==0||lplft$main=="") &&
(length(lplft$sub)==0||lplft$sub=="") )
##- lltit <- (length(lmain)>0 && lmain!="") * sum(lcsizemain[1:2])
##- if (lltit==0)
##- if(length(lsub)>0&&as.character(lsub)!="") lltit <- lcsizemain[2] ## + 0.2
##- else lltit <- lltit ## +0.2
## set par
## --- position of tick marks and axis labels, oma
xaxmar <- 1+ 2*(1<i.def(xaxmar, 1+(nv1*nv2>1)))
yaxmar <- 2+ 2*(2<i.def(yaxmar, 2+(nv1*nv2>1)))
xlabmar <- i.def(xlabmar, if (nv1*nv2==1) xaxmar else 4-xaxmar )
ylabmar <- i.def(ylabmar, if (nv1*nv2==1) yaxmar else 6-yaxmar )
## ---
lmar <- rep(i.getploption("panelsep"), length=4)
lcsize <- i.getploption("csize")
if (is.function(lcsize)) lcsize <- lcsize(lnobs)
marpar <-
i.getmarpar(mar=mar, axes=c(xaxmar,yaxmar), axlab=c(xlabmar,ylabmar),
title=FALSE, plargs=plargs)
lmline <- marpar$margin.line
lmar <- marpar$mar
## ---
lnrow <- i.getplopt(nrow)
lncol <- i.def(ncol, lnrow)
ploptions$mframesmax <- c(lnrow, lncol)
## ---
if (!u.true(i.getploption("keeppar"))) {
loldp <- par(c("mar","mgp","oma","mfrow"))
on.exit(par(loldp), add=TRUE, after=FALSE)
## on.exit(par(loldp[4:5]), add=TRUE)
}
lshlab <- i.getploption("showlabels")
## ---
lpar <- plmframes(nv2, nv1, mar=marpar$mar, reduce=reduce,
plargs=plargs)
plargs$marpar <- marpar <- lpar$marpar
## ----------------------------------------------
lcsizediag <- i.getplopt(diaglabel.csize)
lmfg <- par("mfg")
lnr <- lmfg[3]
lnc <- lmfg[4]
lnpgr <- ceiling(nv2/lnr)
lnpgc <- ceiling(nv1/lnc)
## csize.pch
lcsize.pch <- i.getploption("csize.pch")
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs)
plargs$ploptions$csize.pch <- ploptions$csize.pch <- lcsize.pch
lipanelargs <-
intersect(names(as.list(args(panel))),
c("indx","indy","type","ticklabels","plargs","ploptions",
"marpar")) # ,names(list(...))
##----------------- plots ----------------------------
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (ipgc in 1:lnpgc) {
lc <- (ipgc-1)*lnc
if (reduce&&((lr+lnr)<=lc)) break
for (jr in 1:lnr) { #-- plot row [j]
jd2 <- lr+jr ## index for y axis
j2 <- lv2 + jd2
if (jd2<=nv2) {
v2 <- ldata[,j2]
lylab <- i.def(i.def(attr(v2,"varlabel", exact=TRUE),
attr(v2,"varname", exact=TRUE)),
paste("V",j2,sep="."), valuefalse="")
}
for (jc in 1:lnc) { #-- plot column [j2-lv2] = 1:nv2
jd1 <- lc+jc
j1 <- lv1 + jd1
if (jd2<=nv2 & jd1<=nv1) {
v1 <- ldata[,j1]
lxlab <- i.def(attr(v1,"varlabel", exact=TRUE),
paste("V",j1,sep="."), valuefalse="")
if (!lf.eq(v1,v2)) { # not diagonal
plframe(v1, v2, xlab="", ylab="", mar=lmar, showlabels=!reduce,
ploptions=ploptions, marpar=marpar, xy=FALSE)
do.call(panel,
c(list(x=v1, y=v2), ## panel must have arguments x and y
list(indx=jd1, indy=jd2, plargs=plargs)[lipanelargs]) )
## panel(v1,v2, indx=jd1, indy=jd2, plargs=plargs)
## llastmfg <- par("mfg")
}
else {
lv0 <- as.numeric(v1)
plot(lv0,lv0, type="n", axes=FALSE, xlab="",ylab="")
uu <- par("usr") # diagonal: print variable name
text(mean(uu[1:2]),mean(uu[3:4]), lylab, cex=lcsizediag) ## no par("cex") here!
}
## usr <- par("usr")
## lat=c(mean(usr[1:2]),mean(usr[3:4]))
if (jr==lnr||jd2==nv2) lf.axis(1, v1, xaxmar, xlabmar, lxlab)
if (jc==1) lf.axis(2, v2, yaxmar, ylabmar, lylab)
if (jr==1) lf.axis(3, v1, xaxmar, xlabmar, lxlab)
if (jc==lnc||jd1==nv1) lf.axis(4, v2, yaxmar, ylabmar, lylab)
if (jr==1&jc==1&lItit)
pltitle(plargs=plargs, show=NA, outer.margin=TRUE, marpar=marpar)
} else frame()
}
}
stamp(sure=FALSE, outer.margin=TRUE)
}
}
## if (lkeeppar)
## par(mfg=llastmfg)
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plmatrix
## ====================================================================
plpanel <- #f
function(x = NULL, y = NULL, indx=NULL, indy=NULL, type="p",
frame = FALSE, title = FALSE,
plargs = NULL, ploptions = NULL, marpar = NULL,
...) ## data=plargs$pldata
{ ## !!!? i.getxy
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
pldata <- plargs$pldata
##
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##
ploptions$stamp <- FALSE
lrefl <- lplft$reflinecoord
lshrefl <- u.notfalse(lrefl) ## i.getploption("refline"))
mbox <- i.getploption("factor.show")=="mbox" &&
max(table(x))>=i.getploption("mbox.minnobs")
lIsm <- i.getploption("smooth")
## intro, needed if formulas are used or data is given or ...
lcall <- match.call()
lxnm <- "x"
lynm <- "y"
if (is.formula(x)|is.formula(y)|
any(c("data","pcol","psize")%in%names(lcall))) {
lcall$assign <- FALSE
lcall$ploptions <- ploptions
if (is.null(lcall$data)) lcall$data <- pldata
lplargs <- do.call(pl.control, as.list(lcall[-1]), envir=parent.frame())
ploptions <- lplargs$ploptions
plargs$pldata <- pldata <- lplargs$pldata
x <- pldata[,lxnm <- attr(pldata, "xvar", exact=TRUE)[1], drop=FALSE]
y <- pldata[,lynm <- attr(pldata, "yvar", exact=TRUE), drop=FALSE]
} else {
## ---
if (length(x)==0) {
x <- pldata[,1, drop=FALSE]
lxnm <- names(pldata)[2]
}
if (length(y)==0) {
y <- pldata[,2, drop=FALSE]
lxnm <- names(pldata)[1]
}
}
if (is.data.frame(x)) x <- x[,1]
if (sum(!is.na(x))==0) {
warning(":plpanel: no finite values of variable ", lxnm,
". Nothing to plot")
return()
}
if (sum(!is.na(as.matrix(y)))==0) {
warning(":plpanel: no finite values of variable(s) ", paste(lynm, collapse=", "),
". Nothing to plot")
return()
}
## lvv <- transferAttributes(i.factor(lvv), lvv)
if (is.character(x)) x <- factor(x) ## !!! attributes!
if (is.character(y)) {
if (NCOL(y)>1) {
warning("!plpanel! multiple y cannot be of type character or factor",
"Using the first column")
y <- y[,1]
}
y <- factor(y)
}
if (length(dropNA(unique(x)))==1) x <- factor(x)
if (is.factor(x)) { lIsm <- FALSE
if (!is.factor(y) & mbox) {
plargs$pldata <- data.frame(x=x,y=y)
plmboxes.default(x, y, plargs=plargs, add=TRUE, ...)
return()
}
} else {
if (is.factor(y) & mbox) {
plargs$pldata <- data.frame(x=y, y=x)
plmboxes.default(y, x, plargs=plargs, add=TRUE, horizontal=TRUE, ...)
return()
}
}
## ---
lys <- NULL
lyp <- y
if (lIsm) {
lIyp <- attr(y, "primary", exact=TRUE)
lIys <- attr(y, "secondary", exact=TRUE)
if (length(lIyp) | length(lIys)) {
lIyp <- i.def(lIyp, 1:NCOL(y))
lIys <- i.def(lIys, setdiff(1:NCOL(y), lIyp))
}
lyp <- if (length(lIyp)) y[,lIyp, drop=FALSE] else y
lys <- if (length(lIys)) y[,lIys] else NULL
}
## ---------------------
## start plotting
if (frame) plframe(x,lyp, ploptions=ploptions, marpar=marpar, ...) ## !!!
## secondary smooths
if (lIsm & length(lys))
plsmooth(x, y=NULL, ysec=lys, band=FALSE, power=lplft$smooth.power,
xy=FALSE, plargs=plargs, ploptions=ploptions)
## refline
if (lshrefl && length(lrfl <- lplft$reflinecoord))
plrefline(lrfl, x=x, y=y, plargs=plargs, ploptions=ploptions)
## points
plpoints(x, lyp, type=type, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE, ...)
## primary smooth
if (lIsm) plsmooth(x, y=lyp, plargs=plargs, ploptions=ploptions, ...)
## title
if (u.notfalse(title)) pltitle(plargs=plargs, show=title)
} ## end plpanel
## ====================================================================
panelSmooth <- #f
function(x, y, indx, indy, plargs = NULL, ...) {
if (length(plargs)==0) plargs <- pl.envir ## get(...)
graphics::panel.smooth(x, y, pch=plargs$plfeatures$pch,
col=plargs$plfeatures$pcol,
cex=i.getploption("csize.pch")*par("cex"), ...)
}
## ==========================================================================
plcond <- #f
function(x, y=NULL, condvar = NULL, data=NULL, panel=NULL, ## panelargs = plargs,
nrow=NULL, ncol=NULL, xaxmar=NULL, yaxmar=NULL, ## xlabmar=NULL, ylabmar=NULL,
## xcondmar=NULL, ycondmar=NULL,
xlab=NULL, ylab=NULL, ## partial match!?!
oma=NULL, ## mar=NULL, csize=NULL,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: pairs with different plotting characters, marks and/or colors
## showing submatrices of the full scatterplot matrix
## possibly on seeral pages
## -------------------------------------------------------------------------
lf.condkey <- function(x, rg, ext) {
lwd <- diff(rg)
lx <- (x-rg[1])/lwd
if (ext>0)
## 0 in the interval, linear beyond until abs(result)>1
clipat(lx/ext - pmin(lx,1)*(lx>0)/ext, c(-1,1), clipped=NA)
else clipat(x, rg, clipped=NA)
}
## --------------------------------------------------------------------
lcall <- match.call()
## lIplargs <- is.null(lcall[["plargs"]])
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
lcall$.subdefault <- as.expression(substitute(x)) ##as.character(as.expression(substitute(x)))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (is.name(substitute(data)))
lcall$.subdefault <- as.expression(substitute(data))
data
}
lcall$distinguishy <- FALSE
lcall$gensequence <- FALSE
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, envir=parent.frame())
## lplft$main <- lmain
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## -----------
pldata <- plargs$pldata
## ----------------
lnobs <- nrow(pldata)
lnint <- rep(i.getploption("plcond.nintervals"),2)
## --------------
## lmain <- plargs$main
## ltitcs <- i.getploption("title.csize")
## title: how many lines?
##- lltit <- (length(lmain)>0&&lmain!="") * sum(ltitcs[1:2])
##- if (lltit==0) {
##- if(length(lsub)>0&&as.character(lsub)!="") lltit <- ltitcs[2] ## + 0.2
##- } else lltit <- lltit ## +0.2
## --- position of tick marks and axis labels, oma
xaxmar <- ifelse(i.def(xaxmar, 1)[1]>1, 3,1)
yaxmar <- ifelse(i.def(yaxmar, 2)[1]>2, 4,2)
##- xlabmar <- i.def(xlabmar, xaxmar)
##- ylabmar <- i.def(ylabmar, yaxmar)
xcondmar <- 4-xaxmar ## i.def(xcondmar, 3)
ycondmar <- 6-yaxmar
## --- data and bookkeeping
lx <- pldata[,i.def(attr(pldata,"xvar", exact=TRUE),1)[1]]
ly <- pldata[,i.def(attr(pldata,"yvar", exact=TRUE),2)[1]]
lxlab <- attr(lx,"varlabel", exact=TRUE)
lylab <- attr(ly,"varlabel", exact=TRUE)
lpcl <- i.def(pldata[[".pcol."]], i.getploption("colors")[1])
lpcol <- rep(rgb(t(col2rgb(lpcl))), length=length(lx))
lpch <- i.def(pldata[[".pch."]], i.getploption("pch")[1])
lpsize <- i.def(pldata[[".psize."]], 1)
lcondv <- c(attr(pldata, "by"), attr(pldata, "by2"))
if (u.isnull(lcondv))
stop("!plcond! no conditioning variable(s) found")
llby <- length(lcondv)
if (llby>2)
warning(":plcond: only the first 2 conditioning variables will be used: ",
paste(lcondv[1:2], collapse=", "))
## ---
lc2vars <- llby>=2
lext <- i.getploption("plcond.extend")
## condition keys
for (li in 1:(1+lc2vars)) {
lv <- pldata[,lcondv[li]]
if (is.numeric(lv)) {
lcutp <- attr(lv, "cutpoints", exact=TRUE)
if (u.isnull(lcutp)) {
lrg <- robrange(lv)
lcutp <- seq(lrg[1],lrg[2], length=lnint[li]+1)
}
lck <- ## a column of paling weights for each conditioning interval
sapply(seq_len(length(lcutp)-1),
function(i) lf.condkey(lv, lcutp[i+0:1], lext)
)
attr(lck, "cutpoints") <- lcutp
} else { ## lv is not numeric
lvn <- as.numeric(lv)
llev <- levels(lv)
lck <- sapply(seq_along(llev), function(i) ifelse(lvn==i, 0, NA) )
attr(lck, "labels") <- llev
}
if (li==1) { ## horizontal axis
lckeyx <- lck
lbyxlab <- attr(lv,"varlabel", exact=TRUE)
} else { ## vertical
lckeyy <- lck
lbyylab <- attr(lv,"varlabel", exact=TRUE)
}
}
if (!lc2vars) { ## only one conditioning v
lckeyy <- matrix(0,1,1)
lbyylab <- NULL
}
lnintx <- ncol(lckeyx)
lninty <- ncol(lckeyy)
## ----- graphical prep
lcsize <- i.getploption("csize")
marpar <- i.getmarpar(plargs=plargs)
lmar <- rep(i.getploption("panelsep"), length=4)
if(!lc2vars) lmar[3] <- i.def(i.getploption("title.line")[2], 0.8)
## space for conditional variables' axes
loma <- i.getploption("oma")
lomadef <- rep(0,4) ## marpar$mar
lomadef[xcondmar] <- lomadef[xcondmar] + 2
lomadef[ycondmar] <- lomadef[ycondmar] + 2
loma <- replaceNA(loma, lomadef)
ploptions$mframesmax <- c(lnintx, lninty)
## ---
if (!u.true(i.getploption("keeppar"))) {
loldp <- par(c("mar","mgp","oma","mfrow"))
on.exit(par(loldp), add=TRUE, after=FALSE)
}
## ---
lpar <- plmframes(if(lc2vars) lninty, if(lc2vars) lnintx,
if(!lc2vars) lnintx, reduce=TRUE, oma=loma,
plargs=plargs) ## !!! plargs not active
## lpar$marpar$mar <- lpar$marpar$mar+c(0,0,0,1) ## !!! Flick!
plargs$marpar <- marpar <- lpar$marpar
lmgp <- lcsize*c(marpar$margin.line,0)
lbylabline <- lmgp[1]
lnumline <- lmgp[2]
## --------------------------------------------
lmfg <- par("mfg")
lnr <- lmfg[3]
lnc <- lmfg[4]
if (lc2vars) {
lnpgr <- ceiling(lninty/lnr)
lnpgc <- ceiling(lnintx/lnc)
} else {
lnpgr <- 1
lnc <- lnr*lnc
lnpgc <- ceiling(lnintx/lnc)
lnr <- 1
}
## cexpch
lcsize.pch <- i.getploption("csize.pch")
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs)
ploptions$csize.pch <- lcsize.pch ##!!! plargs
ploptions$axes <- FALSE ##!!! plargs
##- lipanelargs <-
##- intersect(names(as.list(args(panel))), c("indx","indy","panelargs"))
##
##- ## log
##- if (length(grep("x",log))>0) ldata[ldata[,1:nv1]<=0,1:nv1] <- NA
##- if (length(grep("y",log))>0) ldata[ldata[,lv2+1:nv2]<=0,lv2+1:nv2] <- NA
## --- specific for plcond
lsmooth <- i.getploption("smooth")
lIsmooth <- u.notfalse(lsmooth)
lsmminobs <- i.getploption("smooth.minobs")
lccolors <- i.getploption("plcond.col")
lccl <- col2rgb(lccolors)/255
lccolors <- rgb(t(cbind(lccl, (lccl[,c(1,2,1,2)]+lccl[,c(3,3,4,4)])/2 )) )
lpale <- i.getploption("plcond.pale")
lccsize <- i.getploption("plcond.csize")*par("cex.axis")
lcslab <- i.getploption("csize.lab")*par("cex.lab")
## ---
lcutpx <- attr(lckeyx, "cutpoints", exact=TRUE)
lcnumx <- length(lcutpx)>0
lcutpx <- format(lcutpx, digits=3)
llevx <- attr(lckeyx, "labels", exact=TRUE)
lcutpy <- attr(lckeyy, "cutpoints", exact=TRUE)
lcnumy <- length(lcutpy)>0
lcutpy <- format(lcutpy, digits=3)
llevy <- attr(lckeyy, "labels", exact=TRUE)
panel <- i.def(panel, i.getploption("plcond.panel"))
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plmatrix: 'panel' not found. Using 'plgraphics::plpanelCond'")
panel <- plgraphics::plpanelCond
}
## ------------------------------------
lcsizepl <- par("cin")/par("pin")
ladjfacx <- lcsizepl[1]*0.4
ladjfacy <- lcsizepl[2]*0.3
ljy <- 1
## --------------------------------------------------------------
## plot
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (ipgc in 1:lnpgc) {
lc <- (ipgc-1)*lnc
for (jr in 1:lnr) {
if (lc2vars) ljy <- (lr+lnr+1-jr)
if (lplot <- ljy<=lninty) {
lcky <- lckeyy[,ljy]
lcoly <- lpcol
lcoly[is.na(lcky)] <- NA
lcoly[lcky<0] <- lccolors[3]
lcoly[lcky>0] <- lccolors[4]
}
for (jc in 1:lnc) {
ljx <- lc+jc
if (ljx<=lnintx & lplot) { ## points from neighboring panels : "overlap"
lckx <- lckeyx[,ljx]
lcol <- lcoly
lcol[lckx<0] <- lccolors[1]
lcol[lckx>0] <- lccolors[2]
lcol[lckx<0&lcky<0] <- lccolors[5]
lcol[lckx>0&lcky<0] <- lccolors[6]
lcol[lckx<0&lcky>0] <- lccolors[7]
lcol[lckx>0&lcky>0] <- lccolors[8]
lcol[is.na(lckx)] <- NA
## ---
plframe(lx,ly, xlab="",ylab="", showlabels=FALSE,
plargs=plargs, marpar=marpar, xy=FALSE)
if(any(!is.na(lcol))) {
panel(x=lx, y=ly, ckeyx=lckx, ckeyy=lcky,
pcol=lcol, pch=lpch, psize=lpsize, pale=lpale,
smooth=lIsmooth, smooth.minobs=lsmminobs,
plargs=plargs, ploptions=ploptions)
}
}
lmfg <- par("mfg")
## --- axes
##- if (jr==lnr & xaxmar==1 & jc==1)
if (xaxmar==1&yaxmar==2){
lIax <- lmfg[1:2]==c(lmfg[3],1)
if (lIax[1])
plaxis(1, varlabel=if (lIax[2]) lxlab else "",
ploptions=ploptions, marpar=marpar)
if (lIax[2])
plaxis(2, varlabel=if (lIax[1]) lylab else "",
ploptions=ploptions, marpar=marpar)
} else {## if (xaxmar==3&yaxmar==4) other combinations not yet programmed
lIax <- lmfg[1:2]==c(1,lmfg[4])
if (lIax[1])
plaxis(3, varlabel=if (lIax[2]) lxlab else "",
ploptions=ploptions, marpar=marpar)
if (lIax[2])
plaxis(4, varlabel=if (lIax[1]) lylab else "",
ploptions=ploptions, marpar=marpar)
}
##
if (xcondmar==3 & lmfg[1]==1) {
if (lcnumx) {
ltxt <- lcutpx[ljx]
ladjx <- ladjfacx*nchar(ltxt)
mtext(ltxt, 3, lnumline, adj=-ladjx, cex=lccsize) ## , xpd=TRUE
if (lmfg[2]==lmfg[4])
mtext(lcutpx[ljx+1], 3, lnumline, adj=1, cex=lccsize)
} else mtext(llevx[ljx], 3, lnumline, cex=lccsize)
}
if (ycondmar==4 & lmfg[2]==lmfg[4]) {
if (lcnumy) {
ltxt <- lcutpy[ljy]
ladjy <- ladjfacy*nchar(ltxt)
mtext(lcutpy[ljy], 4, lnumline, adj=-ladjy, cex=lccsize)
if (jr==1) mtext(lcutpy[ljy+1], 4, lnumline, adj=1, cex=lccsize)
} else mtext(llevy[ljy], 4, lnumline, cex=lccsize)
}
if (xcondmar==1) mtext(lbyxlab, 1, lbylabline, cex=lcslab, outer=TRUE)
if (xcondmar==3) mtext(lbyxlab, 3, lbylabline, cex=lcslab, outer=TRUE)
if (ycondmar==2) mtext(lbyylab, 2, lbylabline, cex=lcslab, outer=TRUE)
if (ycondmar==4) mtext(lbyylab, 4, lbylabline, cex=lcslab, outer=TRUE)
}
}
}
}
} ## end plcond
## ---------------------------------------------------------------------------
plpanelCond <- #f
function(x, y, ckeyx, ckeyy, pch = 1, pcol = 1, psize = 1, pale = c(0.2,0.6),
csize=0.8, smooth = NULL, smooth.minobs = NULL,
plargs = NULL, ploptions = NULL, ...)
{
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
lsmminobs <- i.getplopt(smooth.minobs)
ploptions$printnotices <- FALSE
if (all(is.na(pcol)))
pcol <- rep(i.getploption("pch")[1], length=length(x))
lcpl <- (1-abs(ckeyx))*(1-abs(ckeyy))
li <- !is.na(lcpl)
if (sum(li)==0) return()
##
lpale <- pale[1] + diff(pale)*(1-lcpl)
lii <- which(lcpl!=1)
pcol[lii] <- colorpale(pcol[lii], lpale[lii])
lpsize <- psize*ifelse(lcpl==1, 1, csize)
x[!li] <- NA
plpoints(x, y, pcol=pcol, pch=pch, psize=lpsize, plargs=plargs, xy=FALSE)
if (u.notfalse(smooth) & sum(li)>=lsmminobs)
plsmooth(x[li],y[li], weight=lcpl[li], plargs=plargs, ploptions=ploptions, ...)
}
## ====================================================================
plmbox <- #f
function(x, at=0, probs=NULL, outliers=TRUE, na.pos=NULL,
horizontal = FALSE,
width=1, wfac=NULL, minheight= NULL, adj=0.5, extquant=FALSE,
widthfac=c(max=2, med=1.3, medmin=0.3, outl=NA),
colors=c(box="lightblue2",med="blue",na="gray90"), lwd=c(med=3, range=2),
warn=options("warn") )
{
## Purpose: multi-boxplot
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 14 Dec 2013, 10:09
f.box <- function(wid, quant, col, lwmax) {
## if (is.na(col)||col==0) col="white"
if (wid>lwmax) {
if (horizontal) {
polygon(quant, at+lpos*lwmax, col="black")
polygon(quant, at+lpos*lwmax^2/wid, col=col)
} else {
polygon(at+lpos*lwmax, quant, col="black")
polygon(at+lpos*lwmax^2/wid, quant, col=col)
}
} else {
if(wid>0)
{
if (horizontal)
polygon(quant, at+lpos*wid, col=col) else
polygon(at+lpos*wid, quant, col=col)
}
}
}
## -----------------------------------
lq <- lwid <- NULL
lfac <- 0
lx <- as.numeric(x[!is.na(x)])
if (length(lx)==0) {
if (warn>=0) warning(":plmbox: no non-missing data")
return(structure(numeric(0), q=lq, width=lwid))
} else { ## ----
stopifnot(length(width)==1,length(wfac)<=1)
if (u.isnull(probs))
probs <- if (sum(!is.na(x))<20) c(0.1,0.5,1)/2 else
c(0.05,0.1,0.25,0.50,0.75,1)/2
lprobs <- if (all(probs<=0.5)) c(probs,1-probs) else c(probs)
lprobs <- sort(unique(lprobs))
colors <- as.list(colors)
box.col <- colors[["box"]]
if (length(box.col)==1)
box.col <- ifelse(0.25<=head(lprobs,-1) & lprobs[-1]<=0.75, box.col, NA)
## values for degenerate case
lxsd <- IQR(lx)
lfac <- if (u.isnull(wfac)) width*2*lxsd else wfac*length(lx)
# was mad/dnorm(0)
lmed <- median(lx)
lwmed <- width
lrg <- range(lx)
lirg <- i.def(attr(x, "innerrange", exact=TRUE), lrg)
ljrg <- any(lirg!=lrg)
lirgd <- diff(lirg)
loutl <- lx
lwoutl <- widthfac["outl"]
if (diff(lrg) > 0) { ## non-degenerate
if (u.isnull(minheight))
minheight <- if (lxsd==0) lirgd*0.01 else lxsd*0.02
lqpl <- lq <- quinterpol(lx, probs=lprobs, extend=extquant)
lirgext <- attr(x, "innerrange.ext", exact=TRUE)
if (ljrg) { ## transformed coord
lx <- plcoordtrsf(lx, lirg, lirgext)
lrg <- plcoordtrsf(lrg, lirg, lirgext)
lqpl <- plcoordtrsf(lqpl, lirg, lirgext)
}
loutl <- lx[lx<min(lq)|lx>max(lq)]
## ---
lwid <- lfac*diff(lprobs)/pmax(diff(lq), minheight)
lwmax <- widthfac["max"]*0.5 ##*lfac/ifelse(lxsd>0, lxsd, 1) !!! ???
## length of median bar
lnwid <- length(lwid)
lnw1 <- max(ceiling(lnwid/4),2)
lnw2 <- lnwid/2
li <- (floor(lnw2)-lnw1+1):(ceiling(lnw2)+lnw1)
lwmed <- max(widthfac["med"]*min(lwmax,max(nainf.exclude(lwid[li]))),
widthfac["medmin"],na.rm=TRUE)
lpos <- c(-adj,-adj,1-adj,1-adj)
if (is.na(lwoutl)) lwoutl <- 0.1*lwmax
## ---------------------------------------
for (li in 1:(length(lprobs)-1)) {
llq <- lqpl[li+0:1]
if (diff(llq)<minheight) llq <- mean(llq) + c(-0.5,0.5)*minheight
f.box(lwid[li], llq[c(1,2,2,1)], box.col[li], lwmax)
}
} ##
## median
if (horizontal) {
lines(rep(lmed,2), at+lwmed*c(-adj,1-adj), col=colors[["med"]],
lwd=lwd["med"])
lines(lrg, c(at,at), # +linepos*0.01*diff(par("usr")[1:2])*(0.5-adj),
lwd=lwd["range"])
} else {
lines(at+lwmed*c(-adj,1-adj), rep(lmed,2), col=colors[["med"]],
lwd=lwd["med"])
lines(c(at,at), # +linepos*0.01*diff(par("usr")[1:2])*(0.5-adj),
lrg, lwd=lwd["range"])
}
if (outliers&&length(loutl)) {
lat <- rep(at,length(loutl))
if (horizontal)
segments(loutl, lat-lwoutl*adj, loutl, lat+lwoutl*(1-adj)) else
segments(lat-lwoutl*adj, loutl, lat+lwoutl*(1-adj), loutl)
}
}
if (!u.isnull(na.pos)) {
lmna <- mean(is.na(x))
if (lmna) {
ldna <- diff(na.pos)
if (length(ldna)==0 || is.na(ldna) || ldna==0)
stop("!plmbox! argument 'na.pos' not suitable")
lwidna <- lfac*lmna/abs(ldna)
f.box(lwidna, na.pos[c(1,2,2,1)], colors[["na"]], lwmax)
}
}
invisible(structure(lfac/length(x), q=lq, width=lwid))
} ## end plmbox
## ====================================================================
plmboxes <- function(x, ...)
UseMethod("plmboxes")
plmboxes.formula <- #f
function(x, y=NULL, data, ...)
{
ldt <- genvarattributes(getvariables(x, data))
##- l1backback <- length(x[[3]])>1 && as.character(x[[3]][[2]])=="1"
##- if (l1backback)
##- ldt <- data.frame(transferAttributes(ldt[,1]),0,
##- transferAttributes(ldt[,2]))
ldtnm <- substitute(data)
ldtnm <- if (is.name(ldtnm)) as.character(ldtnm) else format(ldtnm)
plmboxes.default(ldt[,attr(ldt,"xvar", exact=TRUE),drop=FALSE],
ldt[,attr(ldt,"yvar", exact=TRUE),drop=FALSE], ldt,
.subdefault = ldtnm, ...) ## if (nchar(ldtnm)<30) ldtnm else ""
}
## ------------------------------------------------------------
plmboxes.default <- #f
function(x=NULL, y=NULL, data=NULL, width = 1, at = NULL,
horizontal = FALSE,
probs = NULL, outliers = TRUE, na = FALSE, backback = NULL,
refline = NULL, add = FALSE,
xlim = NULL, ylim = NULL, axes = TRUE, xlab = NULL, ylab = NULL,
labelsperp = FALSE, xmar = NULL, mar = NULL,
widthfac = NULL, minheight = NULL, colors = NULL, lwd = NULL,
.subdefault = NULL, plargs = NULL, ploptions = NULL, marpar = NULL,
...)
{
## Purpose: multibox plot
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 14 Dec 2013, 23:38
lcall <- match.call()
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
## lcall$.subdefault <- .subdefault ## as.character(substitute(x))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (u.isnull(.subdefault) & is.name(substitute(data)))
lcall$.subdefault <- as.character(substitute(data))
data
}
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions ## was .ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
lcsize <- i.getploption("csize")
## ----------------------------------------------------------------------
pldata <- plargs$pldata
if(is.null(x))
x <- pldata[,i.def(attr(pldata,"xvar", exact=TRUE),1), drop=FALSE]
## may have two columns
else if(!is.data.frame(x)) x <- as.data.frame(x)
if(is.null(y))
y <- pldata[,i.def(attr(pldata,"yvar", exact=TRUE)[1],2),drop=FALSE]
else if(!is.data.frame(y))
y <- setvarattributes(data.frame(y=y), varlabel="Y")[1] ## !!? ok ?
if (!is.numeric(y[,1]))
stop("!plmboxes.default! 'y' must be numeric")
ly <- y[,1]
##- lly <- i.def(i.def(attr(ly, "numvalues"), attr(ly, "plcoord")), ly) ## ??
lly <- i.def(attr(ly, "plvalues"), i.def(attr(ly, "numvalues"), ly)) ## ??
lhoriz <- as.logical(i.def(horizontal, FALSE, valuetrue=TRUE))
## widths
lwfac <- modarg(widthfac, c(max=2, med=1.3, medmin=0.3, outl=NA, sep=0.003))
## colors, line widths
lcol <- modarg(colors, i.getploption("mbox.colors"))
llwd <- modarg(lwd, c(med=3, range=2))
## data
## preliminary
x[,1] <- lx <- i.factor(x[,1]) # unused levels are dropped
llr <- ncol(x)>=2 ## asymmetric mboxes required for binary (second) factor
if (llr) {
x[,2] <- lx2 <- transferAttributes(i.factor(x[,2]),x[,2], except="levels")
if (length(levels(lx2))!=2) {
warning(":plmboxes: second x-variable must be binary. I ignore it.")
x <- x[,1, drop=FALSE]
llr <- FALSE
}
}
llist <- split(lly,x)
llev <- levels(lx)
lng <- length(llev)
lnn <- sapply(llist,length)
lsd <- mean(sapply(llist,mad,na.rm=TRUE),na.rm=TRUE)
width <- rep(width, length=lng)
lfac <- width*lsd/(max(lnn)*(1+llr))
if (u.isnull(minheight)) {
lscales <- sapply(llist, IQR, na.rm=TRUE)
minheight <- median(lscales)*i.getploption("mbox.minheight")
}
## labels
xlab <- i.def(xlab, attr(x[,1],"varlabel", exact=TRUE), valuefalse="")
if (length(xlab)>1) xlab <- xlab[2]
## if (xlab=="1") xlab <- ""
ylab <- i.def(ylab, attr(ly, "varlabel", exact=TRUE), valuefalse="")
## position
if (lnat <- length(at)) {
if (lnat!=lng) {
warning(":plmboxes: 'x' has wrong length")
at <- if (lnat>lng) at[1:lng] else NULL
}
}
if (u.isnull(at)) at <- 1:lng
backback <-
i.getplopt(backback) &&
length(dropNA(unique(x[,1])))==2 && NCOL(x)==1
if (backback) {
llr <- TRUE
lng <- 1
}
lpos <- if(backback) rep(mean(at),2) else at
## probabilities
if (u.isnull(probs))
probs <- if (sum(!is.na(ly))/(lng*(1+llr))<20) c(0.1,0.5,1)/2 else
c(0.05,0.1,0.25,0.50,0.75,1)/2
## box for NA's?
na <- i.def(na, NA)
na.pos <- i.def(na, c(min(lly, na.rm=TRUE)*(1-0.3)-0.3*max(lly, na.rm=TRUE)),
valuefalse=NULL)
if (length(na.pos)==1)
na.pos <- na.pos+ 0.03*diff(range(lly, na.rm=TRUE))*c(-1,1)
lusr <- par("usr")
## plot range
## lrg <- if (add) lusr[3:4] else attr(y, "plrange")
if (add) {
xlim <- lusr[1:2]
ylim <- lusr[3:4]
} else {
lxldf <- i.extendrange(
range(at, na.rm=TRUE) + ## max(diff(at)) *
(max(width[c(1,length(width))]) - 0.7*backback)*c(-1,1)*0.4) ## !!! is 0.4 ok???
## *i.getploption("plext")
xlim <-replaceNA(c(i.def(xlim, NA), NA)[1:2], lxldf)
attributes(xlim) <- attributes(lx)[c("ticksat","ticklabelsat","ticklabels")]
## show NA's of y
if (lIna <- !u.isnull(na.pos)) {
lyat <- lyat[lyat>max(na.pos)]
if (length(lyat)<3)
lyat <- pretty(ly, n=i.def(ploptions$tickintervals, 7))
attr(ly, "plrange") <- range(c(attr(ly, "plrange", exact=TRUE), na.pos))
}
ylim <- i.def(ylim, attr(ly, "plrange", exact=TRUE))
attributes(ylim) <- attributes(ly)[c("ticksat","ticklabelsat","ticklabels")]
## margin pars
lmar <- marpar$mar
lxmardef <- lmar[1+lhoriz]
## the next statement defines the maximal label length usually as 10
lmaxnchar <-
ifelse(is.numeric(labelsperp), min(max(1,labelsperp),20), 10)
lxmar <- c(i.def(xmar, NA), NA,NA)[1:3]
if (is.na(lxmar[1]))
lxmar[1] <-
ifelse(labelsperp,
2 + 0.5*min(max(nchar(llev)), lmaxnchar), lxmardef)
lmar[1+lhoriz] <- lxm1 <- max(lxmar[1], lmar[1+lhoriz], na.rm=TRUE)
lxmline <-
c(ifelse(is.na(lxmar[2]), max(lxm1-1, marpar$margin.line[1]),
lxmar[2]),
ifelse(is.na(lxmar[3]), marpar$margin.line[2], lxmar[3]) )
##
marpar$mar <- lmar
plargs$plmarpar <- marpar
loldp <- par(cex=lcsize*par("cex"), mar=lmar)
if (!i.getploption("keeppar"))
on.exit(par(loldp), add=TRUE, after=FALSE)
## ---
ploptions$axes <- FALSE
if (u.true(ploptions$grid))
ploptions$grid <-
if(lhoriz) list(TRUE, at) else list(at, TRUE)
llev <- levels(x[,1])
attr(lx, "ticklabelsat") <- attr(lx, "ticksat") <- seq_along(llev)
attr(lx, "ticklabels") <- llev
attr(lx, "varlabel") <- structure(attr(lx, "varlabel"), adj=1)
## ---------------------------------
if (lhoriz)
plframe(ly, xlim, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE)
else plframe(xlim, ly, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE)
if (axes) {
lpla <- plargs
lpla$ploptions <- ploptions
lpla$plmarpar$margin.line <- lxmline
plaxis(1+lhoriz, lx, las=2*as.logical(labelsperp),
marpar=marpar, plargs=lpla)
##- mtext(attr(lx, "varlabel"), 1+lhoriz, lxlabline,
##- cex=i.getploption("margin.csize")[1])
if(lIna && anyNA(ly))
mtext("NA", 2-lhoriz, line=lcsize, at=mean(na.pos), las=2)
##- if (backback) {
##- mtext(llev2[1], 1+lhoriz,1, at=0.75)
##- mtext(llev2[2], 1+lhoriz,1, at=1.25)
##- }
## mtext(xlab, side=1+lhoriz, line=ploptions$mar[1+lhoriz]-1)
plaxis(2-lhoriz, x=ly, marpar=marpar, plargs=plargs)
}
} # if (!add)
## ---
if (!u.isnull(refline))
if(lhoriz)
abline(v=refline, col=ploptions$refline.col,
lty=ploptions$refline.lty, lwd=ploptions$refline.lwd)
else
abline(h=refline, col=ploptions$refline.col,
lty=ploptions$refline.lty, lwd=ploptions$refline.lwd)
## ---
lusrd <- diff(par("usr")[1:2])
lsep <- lwfac["sep"]*llr*lusrd
lwoutl <- lwfac["outl"]
if (is.na(lwoutl)) {
lwoutl <- 0.05*lusrd
lwfac["outl"] <- lwoutl/lng
}
if (llr) lwfac[c("medmin","outl")] <- lwfac[c("medmin","outl")] /2
## ------------
lattr <- attributes(ly)
for (li in 1:lng) {
if (is.na(at[li])) next
lli <- llist[[li]]
if (length(lli)) {
attributes(lli) <- lattr
plmbox(lli,lpos[li]-lsep, probs=probs, outliers=outliers,
horizontal=lhoriz,
wfac=lfac[li], adj=1-0.5*(1-llr), na.pos=na.pos,
widthfac=lwfac, colors=lcol, lwd=llwd, warn=-1)
}
if (llr) { ## second half of asymmetrix mbox
llir <- llist[[li+lng]]
if (length(llir)) {
attributes(llir) <- lattr
plmbox(llir,lpos[li]+lsep,probs=probs, outliers=outliers,
horizontal=lhoriz,
wfac=lfac[li], adj=0, na.pos=na.pos,
widthfac=lwfac, colors=lcol, warn=-1)
}
}
}
pltitle(plargs=plargs)
stamp(sure=FALSE)
if (u.notfalse(assign)) plassign(list=plargs)
invisible(at) ##!!? return plargs
} ## end plmboxes
## ====================================================================
plcoordtrsf <- #f
function(x, innerrange, innerrange.ext)
{
llx <- pmax(pmin(x,innerrange[2]),innerrange[1])
lxd <- x-llx
if (any(lxd!=0, na.rm=TRUE))
x <- llx + lxd/(1+abs(lxd)/(diff(innerrange)*innerrange.ext))
x
}
## ====================================================================
plres2x <- #f
function(formula=NULL, reg=NULL, data=NULL, restrict=NULL, size = 1,
xlab = NULL, ylab= NULL, pale = 0.2,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: plot residuals vs. two x`s
## Author: ARu , Date: 11/Jun/91
## Aenderungen: MMae, 30/Jan/92, Dez.94
## --------------------------------------------------------------------------
## Arguments:
## formula z~x+y, where
## x, y coordinates of points given by two vector arguments.
## z gives orientation (by sign)
## and size (by absolute value) of symbol.
## reg regression results
## data data
## you must specify either reg or data
## restrict absolute value which truncates the size.
## The corresponding symbols are marked by stars.
## size the symbols are scaled so that "size" is the size of
## the largest symbol in cm.
## main main title, defaults to the formula
## ... additional arguments for the S-function `plot`
## the function currently only plots z for the first two terms of the
## right hand side of formula
## --------------------------------------------------------------------------
lcall <- match.call()
if (is.null(plargs)) {
lac <- as.list(lcall)[-1]
lac$x <- lac$reg
lac$xvar <- lac$formula
ladrop <- c("formula", "restrict", "size", "reg")
lcall <- c(list(quote(plregr.control)),
lac[setdiff(names(lac), ladrop)])
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
plargs$plmarpar <- marpar <- i.getmarpar(plargs=plargs)
lregrft <- plargs$regrfeatures
## ------------------------------------------------------------------
lz <- lregrft$residuals
pldata <- plargs$pldata
lxvar <- attr(pldata, "xvar", exact=TRUE)
if (length(lz)==0) lz <- attr(pldata, "yvar", exact=TRUE)
##--- restrict z values
lrestr <-
if (any(attr(lz, "nouter", exact=TRUE)>0))
max(abs(attr(lz, "innerrange", exact=TRUE))) else NULL
restrict <- i.def(i.def(restrict, lrestr), NULL, valuefalse=NULL)
if(length(restrict)==0) restr <- FALSE else {
restr <- abs(lz) > restrict
lz <- pmin( pmax( lz, -restrict), restrict) }
## size
size <- i.def(size, 1)
lppin <- par("pin")
lratio <- 2*size * par("cin")[1] / lppin
llwd <- i.getploption("lwd")
lpcol <- pldata[[".pcol."]]
if (length(lpcol)) {
lgrpcol <- i.def(i.getploption("group.col"), i.getploption("col"))
if (is.factor(lpcol)) lpcol <- as.numeric(lpcol)
if (is.numeric(lpcol)) lpcol <- rep(lgrpcol, length=max(lpcol))[lpcol]
} else lpcol <- i.getploption("col")[1]
pldata$".pcol." <- colorpale(lpcol, pale=pale)
## for ...
lzj <- lz[,1]
lzj <- lzj/max(abs(lzj), na.rm = TRUE)
lpanel <-
function(xx, yy, indx, indy, pch, col, plab, lwd, zz, ...) {
lusr <- par("usr")
lfx <- lratio[1] * diff(lusr[1:2])
lfy <- lratio[2] * diff(lusr[3:4])
lsxz <- c(lfx * abs(zz))
lsyz <- c(lfy * zz)
lx <- attr(xx, "plcoord", exact=TRUE)
if (u.isnull(lx)) lx <- xx
ly <- attr(yy, "plcoord", exact=TRUE)
if (u.isnull(ly)) ly <- yy
plpoints(lx, ly, plargs=plargs, marpar=marpar, xy=FALSE)
segments(lx - lsxz, ly - lsyz, lx + lsxz, ly + lsyz,
lwd = llwd, col=col, xpd=TRUE)
##--- mark restricted observations: ---
if(any(restr)) {
points((xx - lsxz)[restr], (yy - lsyz)[restr], pch= 8, mkh = 1/40,
xpd=TRUE)
points((xx + lsxz)[restr], (yy + lsyz)[restr], pch= 8, mkh = 1/40,
xpd=TRUE)
}
}
ljx <- lxvar[1]
lx <- pldata[,ljx]
##- llrg <- attr(lx, "plrange")
##- attr(lx, "plrange") <- llrg + c(-1,1)*diff(llrg)* 2*lratio
ljy <- lxvar[2]
ly <- pldata[,ljy]
##- llrg <- attr(ly, "plrange")
##- attr(ly, "plrange") <- llrg + c(-1,1)*diff(llrg)* 2*lratio
##--
##---------------
## lplxx <- i.getploption("plsymbolext") * 2 * size
lplext <- i.getploption("plext") + 0.05*size
plframe(lx, ly, xlab=xlab[1], ylab=ylab[1], plext=lplext,
ploptions=ploptions, xy=FALSE) ## !!!? marpar
##--- draw symbols: ---
lpanel(lx, ly, zz=lzj, lwd=llwd, col=lpcol)
lmain <- lregrft$main
if (length(lmain)==0)
lmain <-
paste(attr(lzj, "varlabel", exact=TRUE), "~", lregrft$formula[2])
pltitle(lmain, outer.margin=FALSE) ## , csize=lregrft$csize.main
stamp(sure=FALSE, ploptions=ploptions)
if (u.notfalse(assign)) plassign(list=plargs)
## "plres2x done"
} ## end plres2x
## ==========================================================================
plmframes <- #f
function(mfrow=NULL, mfcol=NULL, mft=NULL, byrow=TRUE, reduce = FALSE,
oma=NULL, mar=NULL, mgp=NULL, plargs=NULL, ploptions=NULL, ...)
{
## Purpose: par(mfrow...)
## Author: Werner Stahel, 1994 / 2001
lf.mft2mf <- function(mft, din) { ## split mfg into nrowmax and ncolmax
mfrow <- max(1, ceiling(sqrt(mft*0.8*ldin[2]/ldin[1])) )
## 0.8: landscape preferred
lmcol <- ceiling(mft/mfrow)
c(ceiling(mft/lmcol), lmcol)
}
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
lmar <- i.getplopt(mar)
## requested quantities
ldin <- par("din")
lmfg0 <- if (length(mft)) lf.mft2mf(mft, ldin)
lmfg <- if (length(mfrow))
if (length(mfrow)>=2) mfrow[1:2] else c(i.def(mfrow, 0), i.def(mfcol,0))
lmfg <- if (all(lmfg<=0)) c(lmfg0,1,1)[1:2] else pmax(1,lmfg)
## nrowmax, ncolmax
lmfgmax <- i.getploption("mframesmax")
if (length(lmfgmax)==1)
lmfgmax <- if (lmfgmax==0) lmfg else lf.mft2mf(lmfgmax, ldin)
lmfgsug <- lmfg
lnpg <- ceiling(lmfg/lmfgmax)
lmfgsug <- ceiling(lmfg/lnpg)
if (reduce) lmfg <- lmfgsug
lnpmax <- max(lmfg)
## margin pars
marpar <- i.getmarpar(mar=lmar, oma=oma, plargs=plargs)
lmar <- replaceNA(rep(c(marpar$mar,NA,NA,NA,NA), length=4),
i.getploption("mar.default"))
if(reduce) lmar <- rep(lps <- i.getploption("panelsep"), length=4)
lmgp <- c(marpar$margin.line,0)
lImain <- !(length(lplft$main)==0||lplft$main=="")
lIsub <- !(length(lplft$sub)==0||lplft$sub%in%c("",":"))
ltl <- c(i.getploption("title.line", ploptions), 0.2)
## reduce if subtitle is empty !!!
lcx <- ifelse(max(lmfg)>2, 0.66, ifelse(prod(lmfg)>2, 0.83, 1))
## outer margin should not depend on number of panels.
## reverse size reduction contained in plain R
lomadef <- max(
c(lImain*(ltl[1]-ltl[2]), lIsub*ltl[2]) +
rep(c(i.getploption("title.csize"),1), length=2)/lcx )
## 0.83 may be par("cex") after
if(lomadef>0) lomadef <- lomadef+0.5/lcx
loma <- replaceNA(i.getplopt(oma),
c(0,0, lomadef, i.getploption("stamp")/lcx))
if(reduce) {
marpar$omastart <- marpar$mar - lps
loma <- loma + marpar$mar
}
loldp <-
if(byrow)
par(mfrow=lmfg, oma=loma, mar=lmar, mgp=lmgp, ...)
else par(mfcol=lmfg, oma=loma, mar=lmar, mgp=lmgp, ...)
par(new=FALSE)
invisible(
structure(list(marpar=marpar, mar=lmar, oma=loma, mfig = lmfg,
mrow = if (byrow) lmfg, mcol = if(!byrow) lmfg,
mfigsug = lmfgsug, npages = lnpg),
oldpar=loldp)
)
}
## ==========================================================================
stamp <- #f
function(sure=TRUE, outer.margin = NULL,
project=getOption("project"), step=getOption("step"),
stamp=NULL, line=NULL, ploptions=NULL, ...)
{
## Purpose: plot date and project information
## -------------------------------------------------------------------------
## Arguments:
## sure if F, the function only plots its thing if getOption("stamp")>0
## outer if T, the date is written in the outer margin
## project project title
## step title of step of data analysis
## ... arguments to mtext , e.g., line=3
## -------------------------------------------------------------------------
## Author: Werner Stahel, Date: 13 Aug 96, 09:00
stamp <- i.def(stamp, i.getploption("stamp"))
if (length(outer.margin)==0) outer.margin <- par("oma")[4]>0
t.txt <- date()
## llong <- nchar(t.txt)>23
t.txt <- paste(substring(t.txt,5,10),",",
substring(t.txt,23,24),
if(stamp>1)
paste("/", substring(t.txt,12,16),sep=""),
sep="")
if (length(project)>0 && project!="")
t.txt <- paste(t.txt, project, sep=" | ")
if (length(step)>0 && step!="")
t.txt <- paste(t.txt, step, sep=" | ")
if( sure | stamp==2 || ( stamp==1 & (
## last figure on page :
{ t.tfg <- par("mfg") ; all(t.tfg[1:2]==t.tfg[3:4]) }
|| u.true(outer.margin) ) )) {
lline <-
i.def(line,
max(( if(outer.margin) par("oma") else par("mar") )[4] - 1.2,
0.2) )
mtext(t.txt, 4, line=lline, cex = 0.6, adj = 0, outer = outer.margin, ...)
}
invisible(t.txt)
}
## ===========================================================================
legendr <- #f
function(x=0.05,y=0.95,legend, ...) {
lusr <- par("usr")
lx <- lusr[1] + x*diff(lusr[1:2])
ly <- lusr[3] + y*diff(lusr[3:4])
legend(lx,ly,legend, ...)
}
## ======================================================================
ploptions <- #f
function (x=NULL, ploptions = NULL, list=NULL, default=NULL,
assign=TRUE, ...)
{ ##
lpldef <- get("default.ploptions", pos=pl.envir)
loldo <- ploptions
if (u.isnull(loldo)) loldo <- get("usr.ploptions", pos=pl.envir)
else if (length(ploptions)==1 && is.numeric(ploptions)) {
if (ploptions==1) loldo <- get("usr.ploptions", pos=pl.envir)
else {
if (ploptions>1) loldo <- get("ploptions", pos=pl.envir)
else stop("!ploptions! invalid argument 'ploptions'")
}
}
lnewo <- loldo
##
largs <- c(list, list(...))
##
if (!u.isnull(x)) { ## asking for options
if(!is.character(x)) {
warning(":ploptions: First argument 'x' must be of mode character")
return(NULL)
}
return(if(length(x)==1) loldo[[x]] else loldo[x])
}
## --- get default values
if (length(default) && u.notfalse(default)) {
if (u.true(default)) default <- "all"
if (!is.character(default))
stop("!ploptions! Argument 'default' must be of mode character or logical")
if (default[1]=="all") largs = c(lpldef, largs)
## resets all available components
else {
if (default[1]=="unset") {
largs <- c(lpldef[names(lpldef)%nin%names(loldo)], largs)
default <- default[-1]
}
if (any(default!=""))
largs <- c(largs, lpldef[default[default%in%names(lpldef)]])
}
}
## ---
else if (is.null(largs)) return(ploptions)
## --- set options
## check
if (length(largs)) largs <- check.ploption(list=largs)
if (length(largs)) lnewo[names(largs)] <- largs
lo <- intersect(names(largs),names(loldo))
if (length(lo)) attr(lnewo, "old") <- loldo[lo]
## assign
if (assign==1) plassign("usr.ploptions", lnewo)
else if (assign>1) plassign("ploptions", lnewo)
invisible(lnewo)
}
## end of ploptions
## ---------------
plassign <- #f
function(x = NULL, value = NULL, list = NULL)
{
if (length(list)) {
x <- c(x, names(list))
value <- c(list(value),list)
for (li in seq_along(x)) assign(x[li], list[[li]], pos=pl.envir)
}
else assign(x, value, pos=pl.envir)
}
## ====================================================================
##- current <- #f
##- function (x = NULL, list = NULL, assign=TRUE, ...)
##- { ##
##- ploptions(x = x, list = list,
##- ploptions = get("ploptions", pos=pl.envir),
##- assign = 2, ...)
##- }
##- lnewc <- as.list( loldc <- current )
##- ##
##- if (!u.isnull(x)) { ## asking for options
##- if(!is.character(x)) {
##- warning(":current: First argument 'x' must be of mode character")
##- return(NULL)
##- }
##- return(if(length(x)==1) loldc[[x]] else loldc[c])
##- }
##- ## --- set components
##- largs <- c(list, list(...))
##- lnames <- c(names(largs))
##- if (assign) for (lnm in lnames) current[[lnm]] <- largs[[lnm]]
##- lnewc[lnames] <- largs
##- invisible(lnewc)
##- }
## ====================================================================
plmarginpar <- #f
function(plargs=pl.envir, csize=NULL)
{
marpar <- i.getmarpar(plargs=plargs)
ploptions <- plargs$ploptions
lcsize <- i.getplopt(csize)
loldp <- par(mar=lcsize*marpar$mar,
## oma=marpar$oma, changing oma sets a new page
mgp=c(lcsize*marpar$margin.line,0),
cex=lcsize*par("cex"))
## workaround a problem with changing margin pars
lusr <- par("usr")
try(points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",
xpd=TRUE) , silent=TRUE)
invisible(loldp)
}
## ====================================================================
i.getploption <- #f
function(opt, opts=NULL)
{
## opt is character, opts list or NULL
lpldef <- get("default.ploptions", pos=pl.envir)
if (is.null(opts))
opts <- get("ploptions", envir=parent.frame()) ## list in calling fn
if (is.function(opts)) opts <- NULL
if (is.null(opts))
opts <- get("ploptions", pos=pl.envir) ## list in calling fn
## ---
lopt <- opts[[opt]]
if (is.null(lopt)||(!is.function(lopt))&&all(is.na(lopt))) ## NULL or NA
lopt <- ploptions(opt)
else {lopt <- check.ploption(opt, lopt)
if (length(lopt)) lopt <- lopt[[1]]
}
if (length(lopt)==0) lopt <- lpldef[[opt]]
lopt
}
## ---------------------------------------------------
i.getplopt <- #f
function(opt, opts = NULL) {
lpldef <- get("default.ploptions", pos=pl.envir)
if (is.null(opts))
opts <- get("ploptions", envir=parent.frame()) ## list in calling fn
lnam <- as.character(substitute(opt))
lopt <- opt
if (is.function(opts)) opts <- NULL
if (u.isnull(lopt)||(is.atomic(lopt)&&all(is.na(lopt))))
lopt <- opts[[lnam]]
if (u.isnull(lopt)||(is.atomic(lopt)&&all(is.na(lopt))))
lopt <- ploptions(lnam)
else unlist(check.ploption(lnam, lopt)) ## check
if (u.isnull(lopt)) lopt <- lpldef[[lnam]]
lopt
}
## --------------------------------------------------------------------------
i.getgroupopt <- #f
function(group, ploptions=NULL)
{ ## get point and line characteristics
if (!is.numeric(group)) group <- factor(group)
ln <- if(is.numeric(group)) max(group) else length(levels(group))
lcol <- i.getploption("col")
lgcol <- i.getploption("group.col")
lgcol <- i.def(lgcol, lcol[-1], valuefalse=rep(lcol[1],ln))
lpch <- i.getploption("pch")
lgpch <- i.getploption("group.pch")
lgpch <- i.def(lgpch, lpch[-1], valuefalse=rep(lpch[1],ln))
llty <- i.getploption("lty")
lglty <- i.getploption("group.lty")
lglty <- i.def(lglty, llty[-1], rep(valuefalse=llty[1],ln))
structure(group, group.col=lgcol, group.pch=lgpch, group.lty=lglty)
}
## -------------------------------------------------------------------------
i.getcolor <- #f
function(col, ploptions=NULL)
{ ## get color
lcolors <- i.getploption("colors")
lncol <- length(lcolors)
if (is.numeric(col)|is.logical(col)) lcolors[1+(col-1)%%lncol]
else {
if (is.character(col)) if (any(col%nin%colors())) col <- factor(col)
if (is.factor(col)) lcolors[2+(as.numeric(col)-1)%%(lncol-1)] else col
}
}
## --------------------------------------------------------------------------
i.getxy <- #f
function(x=NULL, y=NULL, plargs=NULL, ploptions=NULL, call=NULL, envir = NULL)
{
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
pldata <- plargs$pldata
if (is.formula(x)|is.formula(y) |
any(c("data","pcol","pch","psize","group")%in%names(call))) {
call$assign <- FALSE
call$ploptions <- i.def(ploptions, plargs$ploptions)
if (u.isnull(x)|u.isnull(y)) {
call$data <- pldata ## attributes should be obtained from this dataset
if (u.isnull(x)) call$x <- pldata[,attr(pldata, "xvar", exact=TRUE)]
if (u.isnull(y)) call$y <- pldata[,attr(pldata, "yvar", exact=TRUE)]
}
call$gencoord <- FALSE ## i.getxy is called by low level pl functions
call$ploptions <- ploptions
plargs <- do.call(pl.control, as.list(call[-1]), envir=envir)
ploptions <- plargs$ploptions
pldata <- plargs$pldata
x <- pldata[,attr(pldata, "xvar", exact=TRUE)]
y <- pldata[,attr(pldata, "yvar", exact=TRUE)]
} else {
## ---
## x or y not explicit
if (u.isnull(x)) x <- pldata[,c(attr(pldata, "xvar", exact=TRUE),1)[1]]
if (lnox <- u.isnull(x))
warning(":[low level pl fn]: no x values found")
if (u.isnull(y)) y <- pldata[,c(attr(pldata, "yvar", exact=TRUE),2)[1]]
if (lnoy <- u.isnull(y))
warning(":[low level pl fn]: no y values found")
if (lnox|lnoy) return(NULL)
##- if (length(x)==0) x <- pldata[,1]
##- if (length(y)==0) y <- pldata[,2]
}
list(x=x, y=y, plargs=plargs, ploptions=ploptions)
}
## -------------------------------------------------------
i.getmarpar <- #f
function(marpar=NULL, mar=NULL, axes=NULL, axlab=axes,
title=TRUE, title.line=NULL,
plargs=pl.envir, ploptions=NULL, ...)
{ ## get graphical parameters that control plot margins
if (is.null(ploptions)) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
axes <- i.getplopt(axes, ploptions)
##
lmcs <- rep(i.getploption("margin.csize", ploptions), length=2)
lex <- i.getploption("margin.exp", ploptions) * lmcs[1]
lml <- i.getploption("margin.line", ploptions)
## ltcs <- rep(i.getploption("title.csize", ploptions), length=2)
## space for title
ltl <- c(i.getplopt(title.line, ploptions),0.2)
## title.line will be modified if sub is empty
ltl <- ltl - (length(lplft$sub)&&lplft$sub!="")*(ltl[2]-0.2)
ltm <- ifelse(u.notfalse(title), max(ltl), 0)
lIstamp <- i.getploption("stamp")
lmaxes <-
ifelse((1:4)%in%axlab, lml[1] + ifelse((1:4)%nin%axes, diff(lml), 0),
ifelse((1:4)%in%axes, lml[2], 0))
lmar <- pmax(lmaxes) + c(0,0, ltm, lIstamp*0.7) + lex
if (length(mar)) lmar <- replaceNA(mar, lmar)
structure(list(mar=lmar, title.line=ltl, margin.line=lml), class="i.marpar")
}
## -----------------------------------------------------------------------
charSize <- function(n) min(1.5/log10(n),2)
markextremes <- function(n) ceiling(sqrt(n)/2)/n
smoothpar <- function(n) c(min(1.8/n^0.2, 0.98), 1.5)
smoothxtrim <- function(n, c=2) 1.6^(log10(n)*c)/n
## ======================================================================
## checking functions
check.ploption <- #f
function(optname, value, list=NULL) {
if (is.null(list)) list <- setNames(list(value), optname)
lnl <- length(list)
loptnames <- names(list)
for (lil in seq_len(lnl)) {
lnm <- loptnames[lil]
lvalue <- list[[lnm]]
lcheck <- ploptionsCheck[[lnm]]
if (length(lcheck)) {
## if (is.list(lcheck)) {
if (!is.list(lcheck[[1]])) lcheck <- list(lcheck)
lnopt <- length(lcheck)
lmsg <- rep("", lnopt)
for (lj in seq_len(lnopt)) {
lch <- lcheck[[lj]]
lfn <- get(lch[[1]])
lmsg[lj] <- lmsgj <-
switch(paste("v",length(lch),sep=""), v0="", v1=lfn(lvalue),
v2=lfn(lvalue, lch[[2]]), v3=lfn(lvalue, lch[[2]], lch[[3]]),
v4=lfn(lvalue, lch[[2]], lch[[3]], lch[[4]]),"")
if (lmsgj=="") break
}
## }
if (all(lmsg!="")) {
warning(":check.ploption: argument '", lnm,
"' not suitable. It should\n ",
paste(lmsg, collapse=" -- or \n "),
"\n instead of (str())", immediate.=TRUE)
str(lvalue)
list[lnm] <- NULL
}
}
}
## return components that passed the test
list
}
## -----------------------------------------------------------
check.color <- #f
function(x, dummy) {
if (is.atomic(x) && is.character(x)) {
lpal <- ploptions("colors") ## palette()
lx <- try(palette(c(x,"black")), silent=TRUE)
## palette asks for at least 2 colors
palette(lpal) ## restore palette
if (inherits(lx, "try-error"))
return("consist of known color names")
else return("")
}
else {
if(is.atomic(x) && is.numeric(x)) {
if(all(x>=0 )) return("") ## & x<=length(palette())
else return("if numeric, be >=0") ## and <=length(palette())
}
else {
if (is.matrix(x)) {
if (!any(li <- apply(x, 2, function(x) x<0 | x>255))) return("")
return(
paste("be a matrix with 3 rows with numbers in [0, 255]",
if (length(x)>1) paste("\n columns ",paste(li, collapse=", "),
" out of range")) )
}
}
}
"be a (vector of) color name(s) or an rgb matrix"
}
##---------
check.numrange <- #f
function(x, range, na.ok=TRUE, length=NA) {
if (is.function(x)) return("be numeric (not a function)")
if (!is.na(length)) {
if (length > length(x))
return(paste("have length at least ",length))
}
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!(is.numeric(x)|is.logical(x))) return("be numeric")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(range))) return("")
range <- ifelse(is.na(range), c(-Inf,Inf), range)
if (!any(li <- x<range[1]|x>range[2], na.rm=TRUE)) return("")
paste("be within [",paste(range, collapse=", "),"]",
if (length(x)>1) paste("\n violated for element(s) ",
paste(which(li), collapse=", ")))
}
check.numvalues <- #f
function(x, values=NA, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!(is.numeric(x)|is.logical(x))) return("be numeric")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(values))) return("")
if (any(li <- (!is.na(x) & (x %nin% values))))
return(paste("have values in [",
paste(values[1:min(5, length(values))], collapse=", "),
if (length(values)>5) ",...", "]",
if (length(x)>1) paste("\n violated for elements ",
paste(li, collapse=", "))) )
""
}
check.char <- #f
function(x, values, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!is.character(x)) return("be of mode character")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(values))) return("")
if (!any(li <- (!is.na(x) & (x %nin% values)))) return("")
paste("have values in [",
paste(values[1:min(5, length(values))], collapse=", "),
if (length(values)>5) ",...", "]",
if (length(x)>1) paste("\n violated for elements ",
paste(li, collapse=", ")))
}
check.logical <- #f
function(x, values, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || (is.atomic(x)&&all(is.na(x)))) ) return("")
if ((is.logical(x) | (is.numeric(x))) && !all(is.na(x)) ) return("")
"be of mode logical (or interpretable as such)"
}
check.list <- #f
function(x) {
if (is.list(x)) return("")
"be a list"
}
check.listnum <- #f
function(x, values=NA, na.ok=TRUE) {
if (is.list(x)) {
lchk <- lapply(x, function(xx) check.numvalues(xx, values, na.ok) )
if (all(lchk=="")) return("")
return(paste("if a list, all components must be numeric"))
}
"be a list"
}
check.function <- #f
function(x, values, na.ok=TRUE) {
if (is.function(x)) return("")
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (is.character(x)) {
lfn <- try(get(x), silent=TRUE)
if (inherits(lfn, "try-error"))
return(paste("be a function or the name of an existing function.\n '",
lfn, "' is not available.") )
else return("")
}
"be a function or the name of an existing function."
}
## ----------------------------------------------------------------------
cnr <- function(range=NA, na.ok=TRUE, length=NA)
list("check.numrange", range=range, na.ok=na.ok, length=length)
cnv <- function(values=NA) list("check.numvalues", values=values)
cch <- function(values=NA) list("check.char", values=values)
ccl <- function() list("check.color", NULL)
clg <- function(na.ok=TRUE) list("check.logical", na.ok=na.ok)
cfn <- function() list("check.function", NULL)
cls <- function() list("check.list")
cln <- function(values=NA) list("check.listnum", values=values)
## ---------------------------------------------------------------------
c.pchvalues <- c(0:25,33:120)
c.ltyvalues <- 1:6
## ==========================================================================
c.colors <- c("black","red","blue","darkgreen", ##"deepskyblue3",
"orange","purple","deepskyblue2","green3","coral4",
"pink3", "aquamarine3", "brown2") ## "darkgoldenrod3", "burlywood",
t.ncol <- length(c.colors)
t.col <- 1:t.ncol
## visualize the colors, possibly to improve the definition
##- palette(c.colors)
##- plot(0:1, c(1,length(ly <-1:length(c.colors))), type="n")
##- for (lj in 1:length(ly)) lines(0:1, rep(lj,2), col=lj, lty=1)
##- c.colors <- c("black","red","blue","darkgreen","brown","orange","purple",
##- "olivedrab", "burlywood", "violet")
c.dateticks <- data.frame(
limit =c(30*365,3800,3.1*365,370,190, 65, 35, 10, 5, 3, 1,.33,.16,.09),
smallunit = I(c( "y","y","m","m","m","d","d","d","h","h","h","h","M","M")),
smallint = c( 1 , 1 , 3 , 1 , 1 , 10, 5 , 1 , 12, 3 , 1 , 1 , 30, 15),
bigunit = I(c( "y","y","y","m","m","m","d","d","d","h","h","h","h","M")),
bigint = c( 5 , 2 , 1 , 3 , 3 , 1 , 10, 5 , 1 ,12 , 3 , 3 , 1 , 30),
labelunit = I(c( "y","y","y","m","m","m","d","d","d","d","h","h","h","h")),
labelint = c( 5 , 5 , 1 , 6 , 3 , 1 , 10, 5 , 1 , 1 , 6, 6 , 1 , 1 )
)
## ----------------------------------------------------------------------
usr.ploptions <- default.ploptions <-
list(
keeppar = FALSE,
colors = c.colors, pale = 0.3,
linewidth = c(solid=1, dash=1.3, dot=1.7,
dashDot=1.3, dashLong=1.2, dashLongDot=1.15),
csize = 1,
ticklength = c(-0.5, 0, 0.2, -0.2),
tickintervals = c(7,4),
## basic
pch = 1:18, csize.pch=charSize, csize.plab=0.7, ## !?
psize.max = 3,
lty=c.ltyvalues, lwd=1, col=t.col, pcol=t.col, lcol=t.col,
##
innerrange = TRUE, innerrange.factor=4, innerrange.ext=0.1,
innerrange.function = "robrange",
plext=0.05, markextremes = markextremes, ## is a function...
## variables
variables.pch=1:18, variables.col=c.colors, variables.lty=c.ltyvalues,
variables.lcol=c.colors,
## censored
censored.pch = c(62, 60, 2, 23, 23, 6, 23, 23),
## >, <, Delta, q,q, nabla, q,quadrat
censored.size=1.3, censored.pale = 0.3,
## group
group.pch=TRUE, group.col=TRUE, group.lty=TRUE,
group.lcol=TRUE,
## title (mtext)
title.line=c(2,0.8), title.adj = c(0.5,0.97,0.03),
title.csize=c(1.3,1), title.csizemin=0.6, title.maxchars=80,
sub = TRUE,
##
xlab = "", ylab = "",
mframesmax = 30,
panel = "plpanel",
## frame
axes = 1:2,
mar = c(3,3,2,1)+0.2, mar.default = c(3,3,2,1)+0.2,
oma=rep(NA,4), oma.default=c(0,0,2,0)+0.2,
margin.csize = c(1.2, 1), margin.line = c(2,0.8),
margin.exp = c(1,0.8),
panelsep = 0.5,
date.origin = 1970, date.format=c("y-m-d", "h:m:s"),
## time axes
##- timerangelim =
##- list(year=c(4,20), month=c(4,6), day=c(4,10), hour=4, min=4),
date.ticks = c.dateticks,
## grid
grid = TRUE, grid.lty = 1, grid.lwd = 1, grid.col = "gray75",
zeroline = TRUE, zeroline.lty = 1, zeroline.lwd = 1,
zeroline.col = "gray50",
## refline
refline = TRUE,
refline.lty = c(4,6), refline.lwd = c(1,0.7), refline.col = "darkgreen",
## smooth
smooth = TRUE,
smooth.function = "smoothRegr", smooth.par = smoothpar, smooth.iter = 50,
smooth.minobs = 8, smooth.band = FALSE,
## smoothline
smooth.lty = 1, smooth.lwd = c(2, 0.7),
smooth.col = "blue", smooth.pale = c(0.7,-0.3),
smooth.xtrim = smoothxtrim,
## bars
bar.midpointwidth = 1, bar.lty = 1, bar.lwd = c(2,1), bar.col = "burlywood4",
## factors
factor.show = "mbox", backback = TRUE,
mbox.minnobs = 6, mbox.minheight = 0.02,
mbox.colors = c(box="lightblue",med="blue",na="gray90",refline="magenta"),
jitter = NA, jitter.minnobs = 6, jitter.factor = 0.8,
## condquant
condquant = TRUE, condprob.range = c(0,1), condquant.pale = c(0.5, 0.5),
condquant.pch = c(3,4),
## plmatrix
diaglabel.csize = 1.5,
## plcond options
plcond.panel = plpanelCond,
plcond.nintervals = 5, plcond.extend=0.5, ## condvarExtend,
plcond.col = c("darkgreen", "coral3", "blue", "magenta3"),
plcond.pale = c(0.2,0.7), plcond.csize = 0.8,
## subset
subset.rgratio = 0.9,
## plregr
functionxvalues = 51,
regr.plotselect = c( yfit=0, resfit=NA, absresfit = NA,
absresweights = NA, qq = NA,
leverage = 1, resmatrix = 1, qqmult = 1),
regr.addcomp = FALSE,
leveragelimit = c(NA, 0.99),
cookdistlines = 1:2,
stamp=1, doc=TRUE,
printnotices = TRUE, debug = FALSE )
## -----------------------------------------------------------------------
ploptionsCheck <-
list(
keeppar = clg(),
colors=ccl(), pale = cnr(c(-1,1)),
linewidth = cnr(c(0.1,5)), csize = cnr(c(0.1,5)),
ticklength = cnr(c(-2,2)),
tickintervals = cnr(c(2,20)),
## basic
pch = cnv(c.pchvalues),
csize.pch = list(cfn(),cnr(c(0.1,5))), csize.plab=cnr(c(0.1,5)),
lty=cnv(c.ltyvalues), lwd=cnr(c(0.1,5)),
col=list(cnr(c(0,t.ncol)), ccl()), lcol=list(cnr(c(0,t.ncol)), ccl()),
pcol=list(cnr(c(0,t.ncol)), ccl()),
## group
group.pch=cnv(c.pchvalues),
group.col=list(clg(),ccl()), group.lty=list(clg(),cnv(c.ltyvalues)),
group.lcol=list(clg(),ccl()),
## variables
variables.pch=cnv(c.pchvalues), variables.col=ccl(),
variables.lty=cnv(c.ltyvalues),
variables.lcol=list(cnr(c(0,t.ncol)), ccl()),
## censored
censored.pch = cnv(c.pchvalues),
censored.size=cnr(c(0.1,5)), censored.pale = cnr(c(0,1)),
## frame
panelsep=cnr(c(0,3)),
## title
title.csize=cnr(c(0.1,5)), title.csizemin=cnr(c(0.1,2)), title.adj = cnr(c(-0.2,1.2)),
title.line=cnr(c(-5,5)), title.maxchars=cnr(c(5,200)),
sub = list(clg(),cch()),
axes=list(cnr(c(1:4), na.ok=TRUE),clg()),
mar=cnr(c(0,20), na.ok=TRUE), mar.default=cnr(c(0,20), na.ok=FALSE),
oma=cnr(c(0,10), na.ok=TRUE), oma.default=cnr(c(0,10), na.ok=FALSE),
mgp=cnr(c(0,5), na.ok=FALSE, length=3),
panel=list(cfn(),cch()),
date.origin = cnr(c(1900,2050)), date.format = cch(),
stamp=list(clg(),cnr(c(-1,2))),
mframesmax = cnr(c(4,100)),
innerrange = list(clg(),cnr()), innerrange.factor=cnr(c(0.5,10)),
innerrange.ext = cnr(c(0,0.5)),
plext = cnr(c(0,0.5)), markextremes = list(cfn(), cnr(c(0,0.5))),
## plcond options
plcond.panel = cfn(),
plcond.ninterval = cnr(0,50), plcond.extend=list(cfn(), cnr(c(0,10))),
plcond.col = list(cnr(c(0,t.ncol)), ccl()),
plcond.pale = cnr(c(0,1)), plcond.csize = cnr(c(0,3)),
## plcond.mix = cnr(c(0,1)),
zeroline = list(clg(),cnr()),
zeroline.lty = cnv(c.ltyvalues), zeroline.lwd = cnr(c(0.1,5)),
zeroline.col = list(cnr(c(0,t.ncol)), ccl()),
## refline
refline = list(cls(), clg(),cnr(0,2),cfn()),
refline.lty = cnv(c.ltyvalues), refline.lwd = cnr(c(0.1,5)),
refline.col = list(cnr(c(0,t.ncol)), ccl()),
## smoothline
smooth.lty = cnv(c.ltyvalues), smooth.lwd = cnr(c(0.1,5)),
smooth.col = list(cnr(c(0,t.ncol)), ccl()), smooth.pale = cnr(c(-1,1)),
smooth = clg(),
smooth.function = cfn(), smooth.par = list(cfn(), cnr(c(0,2))),
smooth.minobs = cnr(c(3,20)), smooth.band = clg(),
## bars
bar.lty = cnv(c.ltyvalues), bar.lwd = cnr(c(0.1,5)),
bar.col = list(cnr(c(0,t.ncol)), ccl()),
bar.midpointwidth = cnr(c(0.1,5)),
## factors
factor.show = cch(c("mbox","jitter","asis","")), backback = clg(),
mbox.minnobs = cnr(c(1,Inf)), mbox.minheight = cnr(c(0,0.1)),
mbox.colors = ccl(),
jitter = clg(), jitter.minnobs = cnr(c(1,Inf)),
jitter.factor = cnr(c(0.1,1)),
## time axes
## subset
subset.rgratio = cnr(c(0.1,1)),
## condquant
condquant = clg(), condquant.pale = cnr(c(0,1)),
condquant.pch = cnv(c.pchvalues),
condprob.range = cnr(c(0,1)),
## plmatrix
diaglabel.csize = cnr(c(0.2,10)),
## plregr
functionxvalues = cnr(c(5,500)),
smooth.xtrim = list(cfn(), cnr(c(0,0.4), na.ok=FALSE)),
regr.plotselect = cnr(), regr.addcomp = clg(),
leveragelimit = cnr(c(0.05,0.99999)), cookdistlines = cnr(c(0.05, 5)),
printnotices = clg(), debug = clg()
)
## --------------------------------------------------------------------------
pl.envir <- new.env()
pl.envir$ploptions <- pl.envir$usr.ploptions <- default.ploptions
pl.envir$pl.scaleFunctions <- c("log","log10","logst","sqrt","asinp","logit","qnorm")
## ======================================================================
i.argPldata <- c("psize", "plab", "pch", "pcol",
"by", "group", "smooth.group", "smooth.weights", "smooth.weight")
i.argPlcontr <-
c("x", "y", "data", "transformed", "subset", ## "csize", "markextremes",
"vcol", "vlty", "vpch", "plscale", ## "smooth",
"main", "sub", ".subdefault", ## "mar",
"xlab", "ylab", "varlabel",
"ploptions", ".environment.")
i.argPlregr <- c("plotselect", "sequence", "addcomp", "smooth.legend")
Try the plgraphics package in your browser
Any scripts or data that you put into this service are public.
plgraphics documentation built on Oct. 19, 2023, 3 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions cln cls cfn clg ccl cch cnv cnr smoothxtrim smoothpar markextremes charSize plmboxes pllines plinnerrange
Documented in charSize markextremes plinnerrange pllines plmboxes smoothpar smoothxtrim
## =======================================================================
## Plotting functions, low and high-level
## -----------------------------------------------------------------------
pl.control <- #f
function(x = NULL, y = NULL, condvar = NULL, data = NULL, subset = NULL,
transformed = TRUE, distinguishy = TRUE, gensequence = NULL,
csize = NULL, csize.pch = NULL,
psize = NULL, plab = FALSE, pch = NULL, pcol = NULL,
smooth.weights = NULL, smooth.weight = NULL,
markextremes = NULL, smooth = NULL,
xlab = NULL, ylab = NULL, varlabel = NULL,
vcol = NULL, vlty = NULL, vpch = NULL, plscale = NULL, log = NULL,
main = NULL, sub = NULL, .subdefault = NULL, mar = NULL,
## needed because it hides markextremes otherwise
gencoord = TRUE, plargs = pl.envir,
ploptions = NULL, .environment. = parent.frame(),
assign = TRUE, ... )
## get data for plotting, collect and check arguments
## do preparations that are common to all plots
## --------------------------------------------------------------
{
lf.xdt <- function(x, data, dtlab=NULL, title=NULL, xory)
{
if (u.false(x)) return(list())
if (is.matrix(x)) x <- as.data.frame(x)
if (is.atomic(x)) x <- structure(data.frame(x), names=xory)
if (u.isnull(dtlab))
dtlab <- i.def(tit(x), i.def(attr(x, "dname", exact=TRUE), title))
data <- if (u.isnull(data)) x
else {
if (nrow(x)!=NROW(data))
stop("!pl.control! arguments '", xory,
"' and 'data' have different numbers of rows")
cbind(x, data)
}
list(x=x, data=data, dtlab=dtlab)
}
## --------------------------------------------------------
lcall <- match.call()
if (length(lcall$smooth.weight)) {
lcall$smooth.weights <- lcall$smooth.weight
lcall$smooth.weight <- NULL
}
if (length(lcall$reflines)) {
lcall$refline <- lcall$reflines
lcall$smooth.reflines <- NULL
}
## --- ploptions
lcl <- lcall
ploptions <- i.def(ploptions, pl.envir$usr.ploptions)
lnmd <- setdiff(names(default.ploptions), names(ploptions) )
if (length(lnmd)) ploptions <- c(ploptions, default.ploptions[lnmd])
largsplo <- setdiff(names(lcl)[-1],
c("xlab","ylab","mf", ## "csize","markextremes",
i.argPlcontr, i.argPldata))
if (length(largsplo)) { ## set more lpoptions
lcl <- lcl[c("",largsplo)]
lcl[1] <- list(quote(list))
lcl <- as.call(lcl)
lls <- eval(lcl, envir=parent.frame())
ploptions <- ploptions(list=lls, assign=FALSE, setpar=TRUE)
}
##
if ("title"%in%names(lcall)) lcall$main <- lcall$title
if (length(grep("cex", names(lcall)))) {
warning(":pl.control: argument(s) containing 'cex' are probably ",
"misspecified. I replace 'cex' by 'csize'")
names(lcall) <- sub("cex","csize", names(lcall))
}
## ---
lcl <- lcall
## --- data
lmaxchars <- i.getploption("title.maxchars")
ldtlab <- NULL ## data label
if (length(data)) {
if (length(dim(data))==0)
stop("!pl.control! argument 'data' must be a data.frame or a matrix")
if (is.matrix(data)) data <- as.data.frame(data)
ldtlab <- if (length(ltit <- tit(data))) ltit
if (u.isnull(ldtlab) & is.name(lldtl <- substitute(data)))
ldtlab <- as.character(lldtl)
}
## --- get variables and data
lftext <- lform <- NULL
lformarg <- lynames <- lxnames <- NULL
if (length(x)==0 & length(y)==0) x <- data
if (length(x)==0) { ## use y as x
x <- y
y <- NULL
}
if (u.isnull(x))
stop("!pl.control! no data found")
lbyv <- NULL
## argument x
if (is.atomic(x)&&is.character(x)) { ## names of variables
lxnames <- x
lform <- as.formula(paste("~", paste(x,collapse="+")))
} else {
if (is.formula(x)) {
lform <- x
lvars <- getvarnames(x, data=data, transformed=transformed)
lxnames <- attr(lvars, "xvar")
lynames <- attr(lvars, "yvar")
lbyv <- attr(lvars, "byvar")
} else { ## matrix or data.frame
lrr <- lf.xdt(x, data, ldtlab, xory="x") ## deal with different types of arg.
data <- lrr$data
x <- lrr$x
lxnames <- names(x)
ldtlab <- lrr$dtlab
}
if (is.null(lform))
lform <-
as.formula(paste(paste(lynames, collapse="+"), "~",
paste(lxnames, collapse="+")))
lftext <- shortenstring(format(lform), lmaxchars)
}
## y
lyform <- NULL
if (length(y)) {
if (is.atomic(y)&&is.character(y)) { ## names of variables
lynames <- y
} else{
if (is.formula(y)) {
lyform <- y
lynames <- getvarnames(y, data=data, transformed=transformed)
} else { ## matrix or data.frame
lrr <- lf.xdt(y, data, ldtlab, tit(y), "y") ## deal with different types of arg.
data <- lrr$data
y <- lrr$x
lynames <- names(y)
## ldtlab <- i.def(ldtlab, lrr$dtlab)
}
}
## ---
if (u.isnull(lynames)) ## y is formula
lynames <- getvarnames(y, data=data, transformed=transformed)
if (is.null(lyform))
lyform <- as.formula(paste("~", paste(lynames, collapse="+")))
lform <-
if (length(lform)) {
update(lform, as.formula(paste(tail(as.character(lyform),1),"+.~.")))
} else lyform
lftext <- paste(shortenstring(substring(format(lyform),2,100),
lmaxchars/2),
shortenstring(lftext, lmaxchars/2))
}
## condvar, by grouping variable
lbynames <- lbyv
lbyform <- NULL
if (length(condvar)) {
if (is.atomic(condvar)&&is.character(condvar)) { ## names of variables
lbynames <- condvar
} else {
if (is.formula(condvar)) {
lbyform <- condvar
lbynames <-
c(getvarnames(condvar, data=data, transformed=transformed))
} else { ## matrix or data.frame
lrr <- lf.xdt(condvar, data, ldtlab, tit(condvar), "condvar") ## deal with different types of arg.
data <- lrr$data
condvar <- lrr$x
lbynames <- names(condvar)
## ldtlab <- lrr$dtlab
}
}
}
## ----
## only x or y : plot against sequence
if ((u.isnull(lxnames)|u.isnull(lynames))&&u.notfalse(gensequence)) {
data <-
cbind(".sequence."= 1:NROW(data),data)
lynames <- c(lxnames, lynames)
lxnames <- ".sequence."
}
## ---
##- if (length(data)==0 && length(lform)==0)
##- stop("!pl.control! arguments 'x', 'y', and 'data' are all empty")
lftext <- shortenstring(lftext, lmaxchars)
## ---
lformarg <- list(xvar=lxnames,yvar=lynames,
byvar=if(length(lbynames)) lbynames)
lvarnames <- c(lxnames, lynames, lbynames)
## --- data
## ltransformed <- i.def(lcl$transformed, TRUE)
if (!is.null(attr(data,"terms"))) { ## data is model.frame
if (!transformed) {
warning(":pl.control! Raw data not available.",
"I can only use transformed data.")
transformed <- TRUE
}
}
## --- get variables from lform and data
largs <- c(i.argPldata, "transformed")
## variables
if (length(varlabel))
if (length(names(varlabel))==0) {
warning(":pl.control: 'varlabel' must have names")
lcl$varlabel <- varlabel <- NULL
}
## data
if (length(lvarnames)||length(varlabel) ||
any(names(lcl)%in%i.argPldata)) {
lcl <- c(list(quote(getvariables), formula=lformarg, data=data),
as.list(lcl[intersect(largs, names(lcl))]),
envir=.environment.)
lcl <- as.call(lcl)
## environment(lform) <- environment() ## ???
lpldata <- eval(lcl, envir=environment())
## ----
if (inherits(lpldata, "pl-error"))
stop("!pl.control! ", attr(lpldata, "message"))
if (length(lpldata)==0)
stop("!pl.control! No data found")
## set varlabel in a special case
if (length(lxnames)==1 && is.formula(lcx <- lcall$x) && length(lcx)==2)
attr(lpldata[[lxnames]], "varlabel") <- sub("~","",format(lcx))
if (length(lynames)==1 && is.formula(lcy <- lcall$y) && length(lcy)==2)
attr(lpldata[[lynames]], "varlabel") <- sub("~","",format(lcy))
## --- subset
if (length(lcall$subset)) {
lsub <- eval(lcall$subset, data, enclos=parent.frame())
if (sum(lsub)==0)
stop("!plsubset! No data fulfills the selection criteria")
lpldata <- plsubset(lpldata, lsub)
}
## --- attributes of variables
## plrange
if(any(c("vlim","xlim","ylim")%in%names(lcall)))
lpldata <- i.setvlim(lpldata, ...)
## plscale
if (length(log)) plscale <-
ifelse(c(length(grep("x",log)>0),length(grep("y",log)>0)), "log","")
if (lns <- length(plscale)) {
if (length(names(plscale))==0)
if (lns==2)
plscale <-
setNames(c(rep(plscale[1],length(lxnames)),
rep(plscale[2],length(lynames))), lvarnames)
else {
warning(":pl.control: argument 'plscale' not suitable")
plscale <- NULL
}
}
## lvarnames <- attr(lpldata,"variables", exact=TRUE)
if (gencoord & length(lvarnames)) {
ldy <- if (distinguishy) lynames
lpldata[,lvarnames] <-
genvarattributes(lpldata[,lvarnames, drop=FALSE], vnames = ldy,
vcol = vcol, vlty = vlty, vpch = vpch,
plscale = plscale, varlabel = varlabel,
ploptions=ploptions, ...)
lnr <- nrow(lpldata)
lnobs <- lnr-median(sumNA(lpldata[,lvarnames]))
} else lnr <- 0
} else {
lpldata <- NULL
lvarnames <- NULL
lnr <- 0
}
if (lnr==0) {
if (length(data)) {
lnr <- NROW(data)
lnobs <- lnr-median(sumNA(data))
} else {
warning(":pl.control: data not found. I set 'nobs' to 100")
lnobs <- 100
}
}
## -------------------------
## get special variables from original data if they have been set before
lvnm <-
setdiff(intersect(names(data),
c(".pch.",".plab.",".pcol.",".psize.",".smooth.weight.")),
names(lpldata))
if (length(lvnm))
lpldata[,lvnm] <- data[,lvnm, drop=FALSE]
## ----------------------------------------
## labels and plotting character
## priorities: plab , pch , row.names
lpch <- lpldata$".pch."
## default plotting character
if (length(lpch)) {
if (is.factor(lpch)) lpch <- as.numeric(lpch)
if (is.numeric(lpch)) {
if(length(lpna <- setdiff(lpch,c.pchvalues))) {
warning(":plcontrol: pch", paste(lpna, collapse=", "), " do not exist")
lpchunused <- i.def(setdiff(c.pchvalues, c(lpch,0)), 13)
li <- match(lpch, lpna, nomatch=0)
lpch[li>0] <- lpchunused[(li[li>0]-1)%%length(lpchunused) +1] ## recycle!
}
}
if (is.character(lpch) && any(nchar(lpch)>1)) {
warning(":pl.control: 'pch' must be an integer or a single character.",
" Use 'plab' to label points with strings")
lpch <- substr(lpch,1,1)
}
if (is.logical(lpch)) lpch <- as.numeric(lpch)
lpldata$".pch." <- lpch
}
lplab <- lpldata$".plab."
## --- row.names
lrown <- substring(row.names(data),1,3)
if (length(lrown)==0) lrown <- as.character(1:lnr)
lplabel <- lrown
lIplab <- length(lplab)>0 && is.logical(lplab) && all(lplab) ## original arg T
if (lIplab) lpldata$".plab." <- lplab <- lplabel
else
if (length(lplab)) lplabel <- as.character(lplab)
## now, lplabel is always useful
## --- 'by' group
lbyn <- attr(lpldata, "byvar")
for (llv in lbyn)
if (inherits(lpldata[,llv], "factor"))
lpldata[,llv] <- i.factor(lpldata[,llv]) ## drop levels
## ---
if (length(lgroup <- lpldata[[".group."]])) {
lpldata[,".group."] <- i.getgroupopt(lgroup, ploptions)
if (length(llb <- as.character(lcall$group))<=20)
attr(lpldata[[".group."]], "varname") <- llb
}
## smooth.group
lsmgrp <- lpldata$".smooth.group."
if (length(lsmgrp)) {
lpldata[,".smooth.group."] <- i.factor(lsmgrp)
if (length(llb <- as.character(lcall$smooth.group))<=20)
attr(lpldata[[".smooth.group."]], "varname") <- llb
}
## pcol
if (length(lpcol <- lpldata$".pcol.")) lpldata[,".pcol."] <- i.getcolor(lpcol)
## lpldata[,".pcol."] <- i.factor(lpcol) ## !!!
##- if (is.logical(lpcol)) lpldata[,".pcol."] <- lpcol+1
##- else if (is.factor(lpcol)) {
##- lclr <- i.getploption("col")
##- lpldata[,".pcol."] <- lclr[(as.numeric(lpcol)-1)%%length(lclr)+1] ## recycle!
##- }
## ----------------------------------------------------
## more ploptions
## smooth color
lsmcol <- ploptions$smooth.col
lgrcol <- ploptions$group.col
if (is.numeric(lsmcol))
ploptions$smooth.col <- lsmcol <- lgrcol[1+(lsmcol-1)%%lsmcol]
if (length(lsmcol)==1)
ploptions$smooth.col[2] <-
colorpale(lsmcol, ploptions$smooth.pale[1])
## ---
lmardf <- i.getploption("mar")
if (length(lynames)>1) lmardf[4] <- lmardf[2] ## need space at the right
ploptions$mar <- i.def(mar, lmardf)
## --- condprob.range
ploptions$condprob.range <-
if (length(ploptions$condprob.range)==0) {
if (lnobs>50) c(0,0) else c(0.05,0.8)
} else c(ploptions$condprob.range,1)[1:2]
## --- smooth
lsmgrp <- lpldata$".smooth.group."
lsmgrplab <- levels(lsmgrp)
## smooth
##- lnsm <- lnobs
##- lnsmgrp <- length(unique(lsmgrp))
##- if (length(lsmgrp)) lnsm <- lnobs/lnsmgrp
## !!! check if lnsm is large enough
ploptions$smooth <- i.getplopt(smooth)
lrefl <- eval(lcall$refline, enclos=parent.frame())
lrefl <- if (length(lrefl)>1 | is.function(lrefl)) lrefl
## --- main
main <- i.def(lcall$main, "", "", "")
sub <- i.def(sub, i.def(i.getploption("sub"), NULL, ldtlab, NULL))
## ------------------------------------------------------------
## result of pl.control
rr <- list(
pldata = lpldata, ploptions = ploptions,
plfeatures = list(
formula = lform, formulatext = lftext,
nobs = lnobs, transformed = transformed,
pch = lpch, plabel = lplabel, plab = lIplab, ##plabna = lplabna, ???
## smooth.ngroups = lnsmgrp,
smooth.grouplab = lsmgrplab,
reflinecoord = lrefl,
datalabel = ldtlab, main = main, sub = sub, .subdefault = .subdefault,
datetime = date()
)
)
if (u.notfalse(assign)) plassign(list=rr)
rr
} ## end of pl.control
## ===================================================================
i.setvlim <- #f
function(data, vlim=NULL, xlim=NULL, ylim=NULL, ...)
{ ## set plotting limits
lf.checklim <- function(lim, varnames) {
## produce named list with names from 'data'
if (!is.list(lim)) lim <- list(lim)
if (length(lnm <- names(lim))) {
lim <- lim[intersect(lnm, varnames)]
} else {
if (length(lim)==1) lim <- rep(lim, length(varnames))
if (length(lim)==length(varnames))
names(lim) <- varnames
else {
warning(":pl.control/setvlim: 'xlim' or 'ylim' not suitable")
lim <- NULL
}
}
lim
}
## -----------------------------------
if (!u.isnull(vlim)) vlim <- lf.checklim(vlim, names(data))
if (!u.isnull(xlim)) xlim <- lf.checklim(xlim, attr(data, "xvar", exact=TRUE))
if (!u.isnull(ylim)) ylim <- lf.checklim(ylim, attr(data, "yvar", exact=TRUE))
lim <- c(vlim,xlim,ylim)
i.setvarattribute("vlim", lim, data)
}
## ===============================================================
plinnerrange <-
function(innerrange, data, factor = 4.0, FUNC=robrange)
{ ## determine inner plot range
## if innerrange is a list or a matrix, leave it alone
lIcq <- inherits(data, "condquant")
ldt <- cbind( if (lIcq) c(data[,1:3]) else data )
innerrange <- i.def(innerrange, TRUE, TRUE, FALSE)
if (length(innerrange)>1)
if (any(dim(cbind(innerrange))!=c(2,NCOL(ldt)))) {
warning(":plregr/innerrange: unsuitable argument innerrange ")
innerrange <- TRUE
}
if (length(innerrange)==1 && is.logical(innerrange))
innerrange <-
if (innerrange) apply(ldt, 2, FUNC, fac=factor[1]) else
matrix(FALSE, 2, NCOL(ldt))
if ((!is.list(innerrange))&length(innerrange)==2)
innerrange <- as.matrix(innerrange)
innerrange
}
## ---------------------------------------------------------------------
genvarattributes <- #f
function(data, vnames = NULL, vcol = NULL, vlty = NULL, vpch = NULL,
varlabel = NULL, innerrange = NULL,
plscale = NULL, zeroline = NULL, replace = FALSE,
ploptions = NULL, ...)
{
if (!is.data.frame(data)) data <- structure(as.data.frame(data), names="X")
## ---
ltickint <- i.getploption("tickintervals")
## variable names
lnmdata <- colnames(data)
if (anyNA(lnmdata)) colnames(data) <- lnmdata <-
ifelse(is.na(lnmdata), paste("V",1:NCOL(data), sep=""), lnmdata)
##
lrown <- row.names(data)
## varlabel
llb <- NULL
## jitter (prep)
ljt <-
i.def(i.getploption("jitter"),
ifelse(i.getploption("factor.show")=="jitter", "iffactor", FALSE) )
lljt <- length(ljt)
if (lljt)
if (!is.list(ljt))
ljt <- setNames(rep(ljt, ncol(data)), colnames(data))
jitter.factor <- i.getploption("jitter.factor")
## innerrange (prep)
lirfactor <- i.getploption("innerrange.factor")
## multiple y: plotting character, line color and type
if (u.isnull(vnames))
vnames <- union(union(names(vcol),names(vlty)),names(vpch))
lny <- length(vnames)
if (lImulty <- lny>0) { ##
ldt <- data[,vnames, drop=FALSE]
lvpch <-
i.getvarattribute("vpch", vpch, ldt, ploptions$variables.pch, drop=lny>1)
## i.getvarattribute avoids duplicates
lvlty <-
i.getvarattribute("vlty", vlty, ldt, ploptions$variables.lty, drop=lny>1)
lvcol <-
i.getvarattribute("vcol", vcol, ldt, ploptions$variables.lcol, drop=lny>1)
}
## ---------------------------------------------
if (length(plscale)) data <- setvarattributes(data, plscale=plscale)
##
for (lv in lnmdata) {
lvv <- data[,lv]
lcls <- class(lvv)[1]
attr(lvv, "varname") <- lv
lnv <- sum(!duplicated(dropNA(lvv)))
##
if (replace || is.null(attr(lvv, "nvalues", exact=TRUE)))
attr(lvv, "nvalues") <- lnv
## turn character into factor
if (lcls=="character") lvv <- transferAttributes(factor(lvv), lvv)
## if (lv %in% lfacgen) class(lvv) <- c(class(lvv, "usedAsFactor"))
if (lImulty) { ## line color and type, pch
if(lv%in% names(lvcol)) attr(lvv, "vcol") <- unname(lvcol[lv])
if(lv%in% names(lvlty)) attr(lvv, "vlty") <- unname(lvlty[lv])
if(lv%in% names(lvpch)) attr(lvv, "vpch") <- unname(lvpch[lv])
}
if (inherits(lvv, c("factor", "usedAsFactor", "character"))) {
## factor
lvv <- i.factor(lvv)
if (is.null(attr(lvv, "numvalues"))) {
lat <- seq_along(levels(lvv))
if (replace || is.null(attr(lvv, "plrange", exact=TRUE)))
attr(lvv, "plrange") <- c(0.35, max(lat)+0.65)
if (replace || is.null(attr(lvv, "ticksat", exact=TRUE)))
attr(lvv, "ticksat") <- lat
if (replace || is.null(attr(lvv, "ticklabels", exact=TRUE)))
attr(lvv, "ticklabels") <- levels(lvv)
## jitter
if(replace || is.null(attr(lvv, "numvalues", exact=TRUE))) {
lij <- ljt[lv]
lij <- ((u.true(lij) || lij=="iffactor") &
max(table(lvv),rm.na=TRUE)>=i.getploption("jitter.minnobs"))
attr(lvv, "numvalues") <-
if (u.notfalse(lij)) {
ldif <- diff(sort(as.numeric(lvv)))
lamdf <- quantile(ldif[ldif>0], 0.2)*jitter.factor/2
jitter(as.numeric(lvv),
amount=if(is.numeric(lij)) lij else lamdf)
} else as.numeric(lvv)
}
}
attr(lvv, "zeroline") <- i.def(attr(lvv, "zeroline"), FALSE)
} else {
## Date
if (inherits(lvv, c("Date", "times")) &&
is.null(attr(lvv, "numvalues", exact=TRUE)))
lvv <- gendateaxis(setNames(lvv, lrown))
else { ## -----------------
## continuous variable
lvv <-
i.genvattrcont(lvv, attr(lvv, "innerrange", exact=TRUE), lirfactor, ltickint,
replace=replace, ploptions=ploptions)
##- if (replace || is.null(attr(lvv, "zeroline")))
##- attr(lvv, "zeroline") <- i.getplopt(zeroline)
} ## end of continuous variable
}
if (is.null(attr(lvv,"varlabel"))) attr(lvv, "varlabel") <- lv
##- if (lv%in%names(llb)) unname(llb[lv])
data[[lv]] <- lvv
}
if (length(varlabel)) data <- setvarattributes(data, varlabel=varlabel)
if (length(zeroline)) data <- setvarattributes(data, zeroline=zeroline)
data
} ## end genvarattributes
## ---------------------------------------------------------------------
i.genvattrcont <- #f
function(x, innerrange=NULL, innerrange.factor=NULL, tickintervals=NULL,
replace=FALSE, ploptions = NULL, tickscale = NULL)
{
lx <- x
if(inherits(x,"Surv")) {
lx <- x[,1]
if(length(latt <- attributes(lx)))
x <- transferAttributes(x, lx)
}
lattr <- attributes(x)
lnouter <- c(0,0)
lplrg <- lattr[["plrange"]]
## innerrange
lirgx <- lattr[["innerrange"]]
innerrange <- i.def(innerrange, lirgx)
lirg <- i.def(i.getplopt(innerrange), TRUE)
lIirg <- u.notfalse(lirg) | length(lirg)==2
lirf <- i.getplopt(innerrange.factor)
##
ltint <- i.getplopt(tickintervals) ## logical
lvlimsc <- lattr[["vlim"]]
## plscale
lplscale <- lattr[["plscale"]]
if (length(lplscale)) {
if (is.character(lplscale)&&lplscale[1]=="")
lplscale <- NULL
else {
if (length(lplv <- lattr[["plvalues"]])||replace) lx <- lplv
else {
llx <- plscale(lx, lplscale, valuesonly=FALSE, ploptions=ploptions)
lattr <- attributes(llx)
x <- transferAttributes(llx, lx) ## ???
lvlimsc <- i.def(lattr[["vlimscaled"]], lattr[["vlimsc"]])
}
}
}
## plot coordinates
llx <- c(lx)
if (length(lpv <- lattr[["plvalues"]])) llx <- lpv
else if (length(lnv <- lattr[["numvalues"]])) llx <- lnv
##- names(llx) <- names(lx)
## innerrange
if (lIirg & u.true(lirg)) lirg <- c(plinnerrange(TRUE, llx, factor=lirf))
if (!u.notfalse(lirg)) {
lattr[["innerrange"]] <- attr(x, "innerrange") <- lirg <- NULL
lplrg <-
i.extendrange(range(llx, finite=TRUE), i.getploption("innerrange.ext"))
} else { ## lirg is range
if (replace||length(lirgx)!=2)
## vlim overrides innerrange
lirg <- replaceNA(lvlimsc, lirg)
if (length(lirg)) {
lpc <- plcoord(llx, lirg, ploptions=ploptions)
## attributes: avoid a level...
lpca <- attributes(lpc)
attributes(x)[names(lpca)] <- lpca
attributes(lpc) <- NULL
attr(x, "plcoord") <- lpc ## if (replace)
lnouter <- lpca$nouter
if (u.isnull(lnouter)) lnouter <- c(0,0)
lplrg <- lpca$plrange
}
}
## set plrange
## vlim overrides lplrg
attr(x, "plrange") <- lplrg <- replaceNA(lvlimsc, lplrg)
if (lIirg) attr(x, "innerrange") <- lirg
## ticks: cover only inner range!
if (replace || is.null(attr(x, "ticksat", exact=TRUE))) {
lrg <- if (length(lirg)==2) lirg else lplrg
lnouter <- i.def(lattr[["nouter"]], c(0, 0))
lrg <- ifelse(lnouter>0, lrg, lplrg)
ltks <- plticks(lrg, plscale=i.def(tickscale, lplscale),
transformed=TRUE, nouter=lnouter,
tickintervals=ltint, ploptions=ploptions)
if (replace || is.null(attr(x, "ticksat", exact=TRUE)))
attr(x, "ticksat") <- ltks$ticksat
## do not replace ticklabesat if ticksat is set
if (replace || is.null(attr(x, "ticklabelsat", exact=TRUE)))
attr(x, "ticklabelsat") <- ltks$ticklabelsat
if (replace || is.null(attr(x, "ticklabels", exact=TRUE)))
attr(x, "ticklabels") <- ltks$ticklabels
}
x
}
## ==========================================================================
plticks <- #f
function(range, plscale = NULL, transformed = FALSE,
nouter = 0, tickintervals = NULL, ploptions=NULL)
{ ## find suitable tick values and labels
## range is already transformed
ltint <- i.getplopt(tickintervals)
ltint1 <- min(max(ltint[1],3)+sum(nouter>0),20)
if (length(plscale)) { ## --- scaled axis
if (!(is.character(plscale)&&length(plscale)==1))
stop("!plticks! unsuitable ar gument 'plscale'. Must be of mode character")
lat <- prettyscale(range, transformed=transformed, plscale=plscale, n=ltint1) ## logscale?
llab <- attr(lat, "ticklabels", exact=TRUE)
lat <- llabat <- c(lat)
if (length(ltint)>1) {
lps <- prettyscale(range, transformed=transformed, plscale=plscale, n=ltint[2])
if (length(lps)>1) {
llab <- attr(lps, "ticklabels", exact=TRUE)
llabat <- c(lps)
}
}
} else { ## --- no scale
lat <- clipat(pretty(range, n=ltint1, min.n=ltint1-2), range)
llabat <-
if (length(ltint)>1)
clipat(pretty(lat, n=ltint[2], min.n=1), range) else lat
llabat <- clipat(llabat, lat)
if (length(llabat)<2)
llabat <- clipat(pretty(range, n=4, min.n=1), lat) else lat
llab <- NULL
}
list(ticksat=lat, ticklabelsat=llabat, ticklabels=llab)
}
## =====================================================================
plscale <- #f
function(x, plscale = "log10", ticksat = NULL, logscale = NULL,
valuesonly = FALSE, ploptions = NULL)
{
if (is.character(plscale)) {
if (plscale=="") return(x)
lscname <- plscale
if (lscname%in%c("log","log10") && min(x[is.finite(x)])<=0)
lscname <- "logst"
lscfunc <- get(lscname)
} else {
if (!is.function(lscfunc)) stop("!plscale! unsuitable argument 'plscale'")
lscname <- as.character(substitute(plscale))
if (length(lscname)!=1) stop("!plscale! unsuitable argument 'plscale'")
if (lscname%in%pl.envir$pl.scaleFunctions) {
plscale <- lscname
lscfunc <- get(lscname)
} else {
lscfunc <- plscale
plscale <- lscname
attr(plscale, "function") <- lscfunc
}
}
## ---
lx <- i.def(attr(x, "numvalues", exact=TRUE), c(x))
lvlim <- attr(x, "vlim", exact=TRUE)
lplrg <- attr(x, "plrange", exact=TRUE)
if (lscname=="logst") {
lxt <- logst(lx, threshold=attr(lscname, "threshold", exact=TRUE))
if (length(lvlim))
lvlimsc <- logst(lvlim, threshold=attr(lxt, "threshold", exact=TRUE))
attr(lscname, "threshold") <- attr(lxt, "threshold", exact=TRUE)
} else {
lxt <- lscfunc(lx)
lvlimsc <- if (length(lvlim)) lscfunc(lvlim)
}
lvlimsc <- i.def(attr(x, "vlimsc", exact=TRUE), lvlimsc)
if (length(ticksat)) ticksat <- lscfunc(ticksat)
if (valuesonly) return(lxt)
## ---
attr(lxt, "innerrange") <- attr(x, "innerrange")
lxtv <- i.genvattrcont(structure(lxt, vlim=lvlimsc, ticksat=ticksat),
ploptions=ploptions)
## lxtv <- transferAttributes(lxtv, x)
lrg <- replaceNA(lvlimsc, i.def(attr(lxtv, "innerrange"), attr(lxtv, "plrange")))
ltks <- plticks(range=lrg, plscale=lscname, transformed=TRUE,
nouter=attr(lxtv, "nouter", exact=TRUE), ploptions=ploptions)
structure(x, plvalues = lxt,
ticksat=ltks$ticksat, ## ticklabelsat=c(ticksat),
ticklabelsat=ltks$ticklabelsat, ## was NULL
ticklabels=ltks$ticklabels,
plscale = plscale, ##if (lscname=="userfunction") plscale else lfnn,
plrange = lplrg, vlim=lvlim, vlimscaled=lvlimsc)
}
## =====================================================================
prettyscale <- #f
function(x, transformed = FALSE, plscale = "log10", inverse = NULL,
range = NULL, range.transformed = NULL, n = NULL, logscale = NULL)
{
## generate ticks for transformed scale
##- lf.pretty <- fn(i, x) { ## format: avoid common formatting
##- lpr <- pretty(x[i+c(-1,1)], n=7)
##- lpr[which.min(abs(lpr-x[i]))]
##- }
lf.format <- function(x) sapply(as.list(x), format)
lf.cens <- function(x, rg) if (u.isnull(rg)) x else pmax(pmin(x, rg[2]),rg[1])
##---
if (is.character(plscale)) {
lscname <- plscale
if (length(lscname)>1) stop("!plscale! unsuitable argument 'plscale'")
lscfunc <-
if (lscname=="userfunction") attr(plscale, "function", exact=TRUE)
else try(get(lscname))
if (inherits(lscfunc, "try-error")) stop("!plscale! could not find function", lscname)
} else {
if (!is.function(plscale)) stop("!plscale! unsuitable argument 'plscale'")
lscname <- as.character(substitute(plscale))[1]
lscfunc <- plscale
}
## lcall <- match.call()
ln <- i.getploption("tickintervals")
ln1 <- ln[1]+1
ln2 <- if (length(ln)>=2) ln[2] else 3 ## ceiling(n/2)
## --- log according to axTicks
if (lscname%in%c("log","log10","logst") & u.isnull(logscale)) {
lx <- if (transformed) x else lscfunc(pmax(x, 0)) ## the transforming function given by the argument
lrg <- range(lx, finite=TRUE)
if (lscname=="log") lrg <- lrg/log(10)
if (lrg[2]-lrg[1]>1) { ## use R function
ltatlab <-
axTicks(1, usr=lrg,
axp=c(10^floor(lrg), max(3-floor((2.5*diff(lrg)+1)/ln1), 1)),
nintLog=ln1, log=TRUE)
ltatlab <- clipat(ltatlab, 10^lrg)
ltat <- log10(ltatlab)
if (lscname=="log") ltat <- ltat*log(10)
return(structure(ltat, ticklabels=lf.format(ltatlab)))
} ## else - for small range - treat logs by the following
}
## ------------------------------------------------------------
## --- back function
if (lscname=="log") inverse <- exp
if (lscname%in%c("log10", "logst")) inverse <- function(x) 10^x
if (lscname%in%c("log", "log10", "logst")) range <- c(0,Inf)
if (lscname=="sqrt") {
inverse <- function(x) x^2
range <- range.transformed <- c(0, Inf)
}
if (lscname=="qnorm") {
inverse <- pnorm
range.transformed <- c(0, 1)
}
range <- i.def(range, attr(lscfunc, "range", exact=TRUE))
range.transformed <-
i.def(range.transformed, attr(lscfunc, "range.transformed", exact=TRUE))
if (u.isnull(inverse)) {
inverse <- attr(lscfunc, "inverse", exact=TRUE)
if (u.isnull(inverse))
stop("!prettyscale! Inverse transformation function missing")
}
if (is.character(inverse)) inverse <- get(inverse)
## ---
lx <- if (transformed) x else lscfunc(lf.cens(x, range))
lrg <- range(lx, finite=TRUE) ## transformed scale
ld <- diff(lrg)/(ln1-1)
lk <- c(-2,0:(ln1-1),ln1+1)
lk <- lk+0.01*(lk-mean(lk))/ln1 ## correction helps to break ties
ltr <- lf.cens(lrg[1]+ld*lk, range.transformed)
lat <- rep(NA, ln1)
lrw <- inverse(ltr) ## original scale
for (li in 1:ln1) {
lrwx <- lrw[li+c(0,2)]
lpr <- pretty(lrwx+diff(lrwx)*c(-1,1)*0.5, n=ln2)
if (length(range)) lpr <- lf.cens(lpr, range)
## nearest in transformed scale:
lat[li] <- lpr[which.min(abs(lscfunc(lpr)-ltr[li+1]))]
}
lat <- lf.cens(unique(lat), range)
rr <- lscfunc(lat)
##- if (length(lat)<ln1-2) {
##- lcall$n <- ln1
##- rr <- eval(lcall) ## dangerous!
##- }
structure(rr, ticklabels = lf.format(lat))
}
## =====================================================================
plframe <- #f
function(x=NULL, y=NULL, xlab=NULL, ylab=NULL, xlim = NULL, ylim = NULL,
mar = NULL, showlabels = TRUE, plext=NULL, axcol = rep(1,4),
plargs = NULL, ploptions = NULL, marpar = NULL, xy=NULL, ...)
{
## -------------------
lf.getcoord <- function(x, lext) {
lx <- if (is.data.frame(x)) x[,1] else x
if (length(lx)==0)
stop("!plframe! unsuitable argument 'x' or 'y'")
lvlim <- i.def(attr(lx, "vlimscaled"), attr(lx, "vlim", exact=TRUE))
lirg <- lrg <- lplrg <- replaceNA(lvlim, attr(lx,"plrange", exact=TRUE))
## ---
if (is.factor(lx)) { ## raw factor, not yet treated by pl.control
llv <- levels(lx)
lxx <- c(1, length(llv))
if (length(attr(lx,"ticksat", exact=TRUE))==0) {
attr(lx, "ticksat") <- seq_len(length(llv))
attr(lx, "ticklabels") <- llv
}
lrg <- replaceNA(lrg, lxx+(0.5+lext[1:2])*c(-1,1))
} else {
lirg <- if(length(lir <- attr(lx,"innerrange", exact=TRUE)))
replaceNA(replaceNA(lvlim, lir), lplrg)
##- lxx <- i.def(i.def(attr(lx,"numvalues", exact=TRUE),
##- attr(lx,"plcoord", exact=TRUE)), as.numeric(lx))
if (length(attr(lx,"plcoord", exact=TRUE))==0) {
lxx <- i.def(attr(lx,"numvalues", exact=TRUE), as.numeric(lx))
lrg <- replaceNA(lrg, i.extendrange(range(lxx, finite=TRUE), lext))
}
}
list(x = lx, range = lrg, innerrange = lirg)
} ## end of lf.getcoord
## ---------------------
if (is.null(plargs)) plargs <- pl.envir ## get(...
if (length(ploptions)==0) ploptions <- plargs$ploptions
lcsize <- i.getploption("csize")
lext <- rep(i.def(i.getplopt(plext),0.03), length=4)
## --- margins
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, mar=mar, plargs=plargs)
lmar <- marpar$mar
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##
showlabels <- rep(i.def(showlabels, rep(1,4), valuefalse=rep(0,4)),
length=4)
## ---
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x=x, y=y, plargs=plargs, call=match.call(),
envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
plargs <- lxy$plargs
ploptions <- lxy$ploptions
}
if (is.data.frame(y)) y <- y[,1]
##--- plotting coordiates
lcoord <- lf.getcoord(x, lext[1:2])
lx <- lcoord$x
lrgx <- lcoord$range
lirgx <- lcoord$innerrange
lcoord <- lf.getcoord(y, lext[3:4])
ly <- lcoord$x
lrgy <- lcoord$range
lirgy <- lcoord$innerrange
## ---
axcol <- rep(i.def(axcol,1), length=4)
## --- start plot
plot(lrgx, lrgy, xaxs="i", yaxs="i", xlab = "", ylab = "",
type="n", axes=FALSE)
## inner range
lnouterx <- c(attr(lx, "nouter", exact=TRUE),0,0)[1:2]
abline(v=unique(c(lirgx[lnouterx>0], lrgx)),lty=3)
lnoutery <- c(attr(ly, "nouter", exact=TRUE),0,0)[1:2]
abline(h=unique(c(lirgy[lnoutery>0], lrgy)),lty=3)
## --- grid
lgrl <- i.getploption("grid")
if (u.notfalse(lgrl)) {
if (is.atomic(lgrl)) lgrlx <- lgrly <- lgrl
else {
if (length(lgnm <- names(lgrl))) {
lgrlx <-
if (length(lxnm <- attr(lx, "varname", exact=TRUE)) && lxnm%in%lgnm)
lgrl[[lxnm]] else ploptions("grid", ploptions)
lgrly <-
if (length(lynm <- attr(ly, "varname", exact=TRUE)) && lynm%in%lgnm)
lgrl[[lynm]] else ploptions("grid", ploptions)
} else {
if(length(lgrl)!=2) {
warning(":plframe: unsuitable argument 'grid'")
lgrlx <- lgrly <- i.getploption("grid")
} else {
lgrlx <- lgrl[[1]]
lgrly <- lgrl[[2]]
}
}
}
## grid:x
if (u.true(lgrlx)) {
lgrlx <- attr(x,"ticksat", exact=TRUE)
if (length(lgrlx)<2)
lgrlx <- attr(x, "ticksat") <-
pretty(lirgx, i.getploption("tickintervals")[1])
}
lgrlx <- clipat(lgrlx, lirgx)
if (length(lgrlx))
abline(v=lgrlx,
lty=i.getploption("grid.lty"),
lwd=i.getploption("grid.lwd"),
col=i.getploption("grid.col"))
## grid:y
if (u.true(lgrly)) {
lgrly <- attr(y,"ticksat", exact=TRUE)
if (length(lgrly)<2)
lgrly <- attr(ly, "ticksat") <-
pretty(lirgy, i.getploption("tickintervals")[1])
}
## grl <- clipat(lgrly, lirgy)
if (length(lgrly))
abline(h=lgrly,
lty=i.getploption("grid.lty"),
lwd=i.getploption("grid.lwd"),
col=i.getploption("grid.col"))
}
## zero line
lzlx <- attr(x, "zeroline", exact=TRUE)
lzly <- attr(y, "zeroline", exact=TRUE)
if (is.logical(lzlx)) lzlx <- if(lzlx) 0 else NULL
if (is.logical(lzly)) lzly <- if(lzly) 0 else NULL
if (length(lzlx)|length(lzly))
abline(v=lzlx[lzlx>lirgx[1]&lzlx<=lirgx[2]],
h=lzly[lzly>lirgy[1]&lzly<=lirgy[2]],
lty=i.getploption("zeroline.lty"),
lwd=i.getploption("zeroline.lwd"),
col=i.getploption("zeroline.col"))
## bounding boxes
abline(h=unique(c(ifelse(lnoutery>0, lirgy, lrgy), lrgy)), lty=3)
abline(v=unique(c(ifelse(lnouterx>0, lirgx, lrgx), lrgx)), lty=3)
lxrg <- ifelse(lnouterx>0, lirgx, lrgx)
lyrg <- ifelse(lnoutery>0, lirgy, lrgy)
lines(lxrg[c(1,2,2,1,1)], lyrg[c(1,1,2,2,1)])
## --- axes
## need attr("ticksat") -> otherwise, generate it!
laxes <- i.getploption("axes")
if (length(xlab)) attr(lx, "varlabel") <- xlab
if (length(ylab)) attr(ly, "varlabel") <- ylab
if (u.notfalse(laxes)) {
if (u.true(laxes)) laxes <- 1:2
for (lax in laxes) {
laxx <- lax%in%c(1,3)
plaxis(lax, if (laxx) lx else ly, showlabels=showlabels[lax],
range= if (laxx) lxrg else lyrg, col=axcol[lax],
plargs=plargs, marpar=marpar, ...)
}
}
invisible(loldp)
} ## end plframe
## =========================================================================
plaxis <- #f
function(side, x=NULL, showlabels=TRUE, range=NULL, varlabel=NULL, col=1,
tickintervals=NULL, ## sure = NULL,
plargs = NULL, ploptions = NULL, marpar=NULL, ...)
{ ## ------------------------------------------------------------------
if (length(plargs)==0) plargs <- pl.envir ## get(...) ## !!! list in calling fn ?
if (length(ploptions)==0) ploptions <- plargs$ploptions
lcsize <- i.getploption("csize")
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
## outer panel?
lmfg <- par("mfg")
lIouter <-
switch(side, lmfg[1]==lmfg[3], lmfg[2]==1, lmfg[1]==1, lmfg[2]==lmfg[4])
lmgsize <- rep(i.getploption("margin.csize"), length=2)
llabsize <- lcsize*lmgsize[1]
lticksize <- lcsize*lmgsize[2]
lmar <- lcsize*marpar$mar
lmgp <- lcsize*c(marpar$margin.line,0)
lparcex <- lcsize*par("cex")
## ---
lx <- i.def(i.def(attr(x,"numvalues", exact=TRUE),
attr(x,"plcoord", exact=TRUE)), x)
range <- i.def(range, i.def(attr(x, "innerrange", exact=TRUE),
attr(x, "plrange", exact=TRUE)),
valuefalse = range(lx,finite=TRUE))
lat <- attr(x,"ticksat", exact=TRUE)
latsmall <- attr(lat, "small", exact=TRUE)
llabat <- attr(x,"ticklabelsat", exact=TRUE)
llab <- attr(x,"ticklabels", exact=TRUE)
varlabel <-
if (i.def(showlabels))
i.def(i.def(varlabel, attr(x,"varlabel", exact=TRUE), valuefalse=""),
attr(x,"varname", exact=TRUE) )
else ""
col <- i.def(col, 1)
## --- do it!
if( lIouter || showlabels >= 1)
mtext(varlabel, side=side, line=lmgp[1], xpd=TRUE, col=col,
cex=llabsize*lparcex, adj=i.def(attr(varlabel, "adj"), 0.5))
## ticks and tick labels
if (length(lat)<=1) {
ltk <- plticks(range, ploptions=ploptions)
lat <- ltk$ticksat
llabat <- ltk$ticklabelsat
llab <- NULL
}
lat <- clipat(lat, range)
if (showlabels) {
if (length(llabat)) {
if (!is.numeric(llabat)) {
warning(":plaxis: 'ticklabelsat' must be numeric")
llabat <- NULL
}
} else llabat <- lat
if (length(llab)) {
if (NCOL(llabat)>1) { ## labels placed in the middle of intervals
lc <- rbind(apply(llabat, 2, clipat, range=range, clipped=NA))
li <- apply(lc, 1, sumNA) ==2
llabat <- apply(llabat, 2, clipat, range=range, clipped=range)
llabat <- apply(rbind(llabat), 1, mean, na.tm=TRUE)
##- pmin(pmax(llabat[,2],range[1]),range[2]))/2
llabat[li] <- NA
}
if (length(llab)!=length(llabat)) {
if (length(llab)==1) llab <- rep(llab,length(llabat))
else {
warning(":plaxis: 'ticklabel' has wrong length")
llab <- NULL
}
}
}
if (length(llab)==0) llab <- format(llabat)
llabat <- clipat(llabat, range, NA)
li <- is.na(llabat)|is.na(llab)
llabat <- llabat[!li]
llab <- llab[!li]
if (length(llab)==0) llab <- rep("",length(llabat))
}
## --- axes
## tick lengths
ltcl <- i.getploption("ticklength")*par("cex")
if (length(ltcl)<2) ltcl <- rep(c(ltcl,0.5),length=2)*c(1,0)
if (length(ltcl)<4) ltcl <- c(ltcl, c(ltcl[-(1:2)],0.2)[1]*c(1,-1))
axis(side, at=lat, labels=rep("",length(lat)), col=col, tcl=ltcl[1], ...) ## axis without tickmarks
if (ltcl[2]) axis(side, at=lat, labels=rep("",length(lat)),
tcl=ltcl[2], col=col, ...) ## ticks inside
if (length(latsmall)) { ## small ticks
if (ltcl[3]) axis(side, at=latsmall, labels=rep("",length(latsmall)),
tcl=ltcl[3], col=col, ...)
if (ltcl[4]) axis(side, at=latsmall, labels=rep("",length(latsmall)),
tcl=ltcl[4], col=col, ...)
}
if (length(llabat)) ## tick labels
if((showlabels & (lmar[side]>=lmgp[2]+1 | lIouter)) | showlabels>=1)
mtext(llab, side, line=lmgp[2], at=llabat, col=col,
cex=lticksize*lparcex, ...)
invisible()
} ## end plaxis
## ===========================================================================
pltitle <- #f
function(main=NULL, sub=NULL, csize=NULL, csizemin=NULL,
side=3, line=NULL, adj=NULL, outer.margin=NULL, col="black",
doc=NULL, show=NA, plargs = NULL, ploptions = NULL,
marpar = NULL, ...)
{
## Purpose: title
## ----------------------------------------------
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
scale <- 0.6 ## scale factor to get width of a character
minadj <- 0.2
## ---
main <- i.def(main, plargs$plfeatures$main)
sub <- i.def(sub, i.def(plargs$plfeatures$sub, i.getploption("sub")))
## i.def(sub, plargs$sub, valuefalse=NULL) ## paste(":",plargs$sub,sep="")
## if (is.logical(sub)) sub <- if(sub) ":" else NULL
if (u.true(sub)) sub <- ":"
sub <- if (length(sub) && substr(sub,1,1)==":")
paste(substring(sub,2,30), plargs$.subdefault, sep="")
else if (u.notfalse(sub)) as.character(sub)
if (length(main)&&main=="") main <- NULL
if (length(sub)&&sub=="") sub <- NULL
if (length(main)==0 & length(sub)==0) return(invisible(list(main=NULL,sub=NULL)))
if (length(main) && all(sub==main)) sub <- NULL
rr <- c(main=main, sub=sub)
show <- i.def(show, 0.5) ## 0.5 means: only outer margin if first plot
outer.margin <- i.def(outer.margin, par("oma")[3]>0)
if (u.false(show) || (show<1 && outer.margin && 1!=prod(par("mfg")[1:2])) )
return(rr)
## -------------------------------
lf.text <- function(text, csize, csizedef, line=line, adj,
outer.margin=FALSE) {
## calculate text size and write text
if (!is.expression(text)) text <- format(text)
if (length(text)>1) text <- paste(text, collapse=" ")
lcsize <-
i.def(csize, max(csizemin, min(csizedef, lfac/max(nchar(text)))),
valuefalse = 1 )
lmaxchar <- lfac/lcsize
if (nchar(text)>lmaxchar)
text <- paste(substr(text, 1, lmaxchar-3),"...")
ladj <- i.def(adj, max(minadj,0.5*(lcsize>csizemin)), 0.5, minadj)
mtext(text, side, line,
cex = lcsize*ifelse(outer.margin, 1, lparcex),
adj=ladj, outer = outer.margin, col=col, ...)
lcsize
}
## ---------------------------
## mar= needed to obtain consistency
lcsgen <- i.getploption("csize")
##- lparcex <- lcsgen * (if (outer.margin) 1 else par("cex"))
lparcex <- lcsgen * par("cex")
ltadj <- rep(i.def(adj, i.getploption("title.adj"), valuefalse=0.5),
length=3)
## -------------------------
ltcs <- rep(i.def(csize,NA), length=3)
ltcsdef <- rep(i.def(csize, i.getploption("title.csize")), length=3)
## title.csizemin <- csizemin
## tcsmin <- i.def(csizemin, i.getploption("title.csizemin"), valuefalse=0.1)
##
lImain <- length(main) && main!=""
lIsub <- length(sub) && sub%nin%c("",":")
##- lIdoc <- length(doc) && doc!=""
## lmarmax <- if (outer.margin) par("oma")[side] else par("mar")[side]
##- lmarmax <- lmarmax-ltcsdef[2-lImain]
##- llinedef <- sum(ltcsdef*c(lImain, lIsub, lIdoc))
##- line <- min(i.def(line, llinedef), lmarmax)
##- llinedef <- min(i.def(i.getploption("title.line"), Inf),
##- lmarmax-0.1-ltcsdef[2-lImain])
##- lline <- i.def(line, llinedef) ## -0.3: leave some space above title
lside24 <- side%in%c(2,4)
lwid <- if (outer.margin) par("mfg")[4-lside24] else 1
lfac <- lwid * par("pin")[1+lside24]/(par("cin")[1]*par("cex")*scale)
##
## line may be scalar or vector of length 3
lline <- line
if (is.null(line)) ## !!!!!
lline <- c(i.getmarpar(plargs=plargs)$title.line, NA, NA)
if (outer.margin && length(lomast <- marpar$omastart))
lline <- lline+lomast[3] ## in plmatrix, part of oma is used for axes
## lline <- lline*lcsgen
line <- lline[1]
if (lImain) {
## lline <- lline + lIsub*lcsgen*is.na(lline[2])
lcs <- lf.text(main, csize=ltcs[1], csizedef=ltcsdef[1], line=line,
adj=ltadj[1], outer.margin=outer.margin)
line <- max(line-lcs*lparcex,0)
}
if (!is.na(lline[2])) line <- lline[2]
if (lIsub) {
lcs <- lf.text(sub, csize=ltcs[2], csizedef=ltcsdef[2],
line=line, adj=ltadj[2], outer.margin=outer.margin)
if (length(lline)<=2) lline[3] <- max(lline-lcs*lparcex,0)
}
ldoc <- i.def(doc, tit(main))
if (length(ldoc)) {
if (!is.na(lline[3])) line <- lline[3]
if (line>=0 && (!u.isnull(doc)) && doc && length(ldoc))
lf.text(ldoc, csize=ltcs[3], csizedef=ltcsdef[3], adj=ltadj[3],
outer.margin=outer.margin)
}
## invisible(rr)
}
## -----------------------------------------------------------------
plpoints <- #f
function(x = NULL, y = NULL, type = "p", plab = NULL, pch = NULL,
pcol = NULL, col = NULL, lcol = NULL, lty = NULL, lwd = NULL,
psize = NULL, csize = NULL, group = NULL,
plargs = NULL, ploptions = NULL, marpar=NULL, xy=TRUE, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
## intro, needed if formulas are used or data is given or ...
lcl <- match.call()
lcsize <- i.getplopt(csize)
col <- i.def(col, NULL, valuefalse=NULL)
## if (length(col)) { !! changed 22.01
if(u.isnull(pcol)) {
lcl$pcol <- pcol <- col
## lcl$col <- NULL
}
if(u.isnull(lcol)) { ## changed 22.01
lcol <- attr(y,"vcol")
if (length(lcol)==0) lcol <- col
lcl$lcol <- lcol
## lcl$col <- NULL
}
## }
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x, y, plargs, ploptions, call=lcl, envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
ploptions <- lxy$ploptions
plargs <- lxy$plargs
}
pldata <- plargs$pldata
## --- ploptions
## ---
condquant <- i.getploption("condquant")
## ---
if (is.data.frame(x)) x <- x[,1]
lattrx <- attributes(x)
## lx <- i.def(lattrx$plcoord, i.def(lattrx$numvalues, as.numeric(x)))
lx <- i.def(lattrx$numvalues, x)
lIcensx <- inherits(x, "Surv")
if (lIcensx) lx <- lx[,1]
lx <- as.numeric(lx)
if (length(llir <- lattrx[["innerrange"]])) {
lx <- if (length(llpc <- lattrx[["plcoord"]])) llpc
else plcoord(lx, llir, ploptions=ploptions)
} else lx <- i.def(lattrx[["plcoord"]], lx)
lx[is.na(x)] <- NA
##
if (is.data.frame(y)) y <- y[,1]
lattry <- attributes(y)
ly <- i.def(lattry$numvalues, y)
lIcensy <- inherits(y, "Surv")
if (lIcensy) ly <- ly[,1]
ly <- as.numeric(ly)
if (length(llir <- lattry[["innerrange"]])) {
ly <- if (length(llpc <- lattry[["plcoord"]])) llpc
else plcoord(ly, llir, ploptions=ploptions)
} else ly <- i.def(lattry[["plcoord"]], ly)
ly[is.na(y)] <- NA
## condquant
lIcq <- condquant>0 ## condquant representation by bars
lIcqx <- length(lcqx <- lattrx$condquant) >0
lIcqy <- length(lcqy <- lattry$condquant) >0
##
lnr <- length(x)
psize <- i.def(psize, pldata[[".psize."]])
lpsize <-
if (u.isnull(psize)) 1 else sqrt(psize/median(psize, na.rm=TRUE))
if (max(lpsize, na.rm=TRUE)> (lpm <- i.getploption("psize.max"))) {
warning("maximum psize too large. I censor at ", lpm)
lpsize <- pmin(lpsize,lpm)
}
lpsize <- lpsize*lcsize*par("cex")
if (u.isnull(plab)) plab <- pldata[[".plab."]] ## !!! treat like pch ?
## group
lgroup <- i.def(group, pldata[[".group."]], valuefalse=NULL)
if (u.true(lgroup)) {
warning(":plpoints: 'group' not identified")
lgroup <- NULL
}
lattrgrp <- if (length(lgroup))
i.getinlist(attributes(lgroup), i.getgroupopt(lgroup))
if (length(lgroup)==0) lgroup <- rep(1, lnr)
lgrp <- as.numeric(lgroup)
lgrpv <- unique(lgrp)
lgrpn <- max(lgrpv)
## pch
if (u.true(pch)) pch <- NA
pch <-
i.getinlist(pch, pldata[[".pch."]], lattrgrp$group.pch[lgroup],
lattry$vpch, i.getploption("pch")[1])
pch <- rep(i.def(pch, i.getploption("pch"), valuefalse=""), length=lnr)
## color
if (u.true(pcol)) pcol <- NA
pcol <- i.getinlist(pcol, pldata[[".pcol."]], lattrgrp$group.col[lgroup],
lattry$vpcol, i.getploption("pcol")[1])
pcol <- rep(i.def(pcol, i.getploption("pcol"), valuefalse=""), length=lnr)
## lty, lwd
if (u.true(lty)) lty <- NA
lty <- rep( i.getinlist(lty, lattrgrp$group.lty, lattry$vlty,
i.getploption("lty")),
length=lgrpn)
lwd <- i.getinlist(lwd, lattry$vlwd, i.getploption("lwd")) *
i.getploption("linewidth")[lty]
if (u.true(lcol)) lcol <- NA
lcol <-
if (type=="b")
i.getinlist(lcol, lattrgrp$group.col, lattry$vpcol,
i.getploption("pcol")[1])
else i.getinlist(lcol, lattrgrp$group.col, lattry$vcol,
i.getploption("lcol"))
lcol <- rep(lcol, length=lgrpn)
lnobs <- sum(is.finite(lx) & is.finite(ly))
csize.pch <- i.getploption("csize.pch")
csize.pch <- if (is.function(csize.pch)) csize.pch(lnobs)
else i.def(csize.pch, charSize(lnobs))
csize.plab <- csize.pch*i.getploption("csize.plab")
lsplab <- rep(abs(csize.plab*lpsize), length=lnr)
lspch <- rep(csize.pch*lpsize, length=lnr)
## censored
if (lIcensx|lIcensy) {
lstx <-
if (lIcensx) (1+(i.def(lattrx$type, "right")=="left"))*(1-x[,2]) else 0
lsty <-
if (lIcensy) (1+(i.def(lattry$type, "right")=="left"))*(1-y[,2]) else 0
lipch <- lstx+3*lsty
li <- lipch>0
if (any(li)) {
pch[li] <- rep(i.getploption("censored.pch"), length=8)[lipch[li]]
pcol[li] <- colorpale(pcol[li], i.getploption("censored.pale")[1])
lspch[li] <- lspch[li]*i.getploption("censored.size")
}
}
## condquant
if (lIcq & (lIcqx|lIcqy)) {
##- lpale <- rep(c(i.getploption("condquant.pale"), 0.5), length=2)
lpale <- i.def(i.getploption("condquant.pale"), 0.5, valuefalse=1)[1]
lcqpch <- i.getploption("condquant.pch")
lix <- if(lIcqx) lcqx[,"index"]
liy <- if(lIcqy) lcqy[,"index"]
lixy <- union(lix,liy)
if (length(lcqpch)) pch[lixy] <- lcqpch[1] ## pch
##- if (length(lixy)==lnr) lpale <- c(1,lpale[1]) ## all observations are cq
##- pcol[lixy] <- colorpale(pcol[lixy], lpale[1])
if (length(lixy)<lnr) pcol[lixy] <- colorpale(pcol[lixy], lpale)
##
if (lIcqx) {
li <- lix %nin% liy ## why?
if (any(li)) {
lsg <- if(length(lrgx <- lattrx$innerrange))
plcoord(lcqx[li,2:3], range=lrgx, ploptions=ploptions)
else lcqx[li,2:3]
lyy <- ly[lix[li]]
segments(lsg[,1], lyy, lsg[,2], lyy,
col=colorpale(pcol[lix[li]], lpale) )
}
}
if (lIcqy) {
li <- liy %nin% lix
if (any(li)) {
lsg <- if(length(lrgy <- lattry$innerrange))
plcoord(lcqy[li,2:3], range=lrgy, ploptions=ploptions)
else lcqy[li,2:3]
lxx <- lx[liy[li]]
segments(lxx, lsg[,1], lxx, lsg[,2],
col=colorpale(pcol[liy[li]], lpale) )
}
}
}
## ---
lIpl <- (length(plab)>0) && any(!is.na(plab))
plab <- as.character(plab)
## --- plot!
if (lIpl) { ## points with labels
text(lx, ly, plab, cex=lsplab, col=pcol, xpd=TRUE)
lipch <- ifelse(is.na(plab), TRUE, plab=="") ## point is not labelled
} else lipch <- rep(TRUE,length(x))
if (any(lipch)) {
if (type%in%c("l","b")) { ## lines
lx[is.na(ly)] <- NA
ly[is.na(lx)] <- NA
lxy <- cbind(lx,ly)
## points in margin
lnox <- attr(x, "nouter", exact=TRUE)
if(any(lnox>0)) {
lrgx <- attr(x, "innerrange", exact=TRUE)
if(lnox[1])
lxy <- i.lineout(lxy[,1], lxy[,2], lrgx[1], FALSE)
if(lnox[2])
lxy <- i.lineout(lxy[,1], lxy[,2], lrgx[2], TRUE)
lxy[lxy[,1]<lrgx[1]|lxy[,1]>lrgx[2],] <- NA
}
lnoy <- attr(y, "nouter", exact=TRUE)
if(any(lnoy>0)) {
lrgy <- attr(y, "innerrange", exact=TRUE)
if(lnoy[1])
lxy <- i.lineout(lxy[,2], lxy[,1], lrgy[1], FALSE)[,c(2,1,3)]
if(lnoy[2])
lxy <- i.lineout(lxy[,2], lxy[,1], lrgy[2], TRUE)[,c(2,1,3)]
lxy[lxy[,2]<lrgy[1]|lxy[,2]>lrgy[2],] <- NA
}
##
for (lg in lgrpv) {
li <- lgrp==lg
points(lxy[li,1], lxy[li,2], type=type, pch=NA, col=lcol[lg],
lty=lty[lg], lwd=lwd, cex=lspch[lg],
xpd=TRUE, ...)
}
if (type=="l") return()
type <- "p"
}
lipch <- lipch & !is.na(lx)
points(lx[lipch], ly[lipch], type=type, pch=pch[lipch],
cex=lspch[lipch], col=pcol[lipch], xpd=TRUE) ## ??? why is xpd needed?
}
invisible(NULL)
} ## end plpoints
## ---------------------------------------------------------------------
pllines <- function(x=NULL, y=NULL, type="l", ...) {
plpoints(x=x, y=y, type=type, ...)
}
## ---------------------------------------------------------
i.lineout <- #f
function(z, zz, lim, upper) {
## determines indices before which a point on the inner range limit is needed
## and the "other" coordinate
lout <- if(upper) z>lim else z<lim
li0 <- which(c(lout,FALSE) & !c(TRUE,lout))
lzout <- zz
lz <- z[li0-1]
lr <- (lim-lz)/(z[li0]-lz)
lzz0 <- zz[li0-1]+lr*(zz[li0]-zz[li0-1])
li1 <- which(c(FALSE,lout) &! c(lout, TRUE))
lz <- z[li1-1]
lr <- (lim-lz)/(z[li1]-lz)
lzz1 <- zz[li1-1]+lr*(zz[li1]-zz[li1-1])
lii <- order(c(1:length(z), li0-0.6, li1-0.4))
zz[c(li0,li1-1)] <- NA
cbind(z=c(z,rep(lim,length(c(li0,li1))))[lii], zz=c(zz,lzz0,lzz1)[lii],
zout=c(ifelse(lout, lzout, NA), lzz0, lzz1)[lii])
}
## -----------------------------------------------------------------
plbars <- #f
function(x = NULL, y = NULL, midpointwidth = NULL,
plargs = NULL, ploptions = NULL, marpar = NULL, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
lcsize <- i.getploption("csize")
pldata <- plargs$pldata
if (length(x)==0)
x <- plargs$pldata[,c(attr(pldata, "xvar", exact=TRUE),1)[1]]
if (length(y)==0)
y <- plargs$pldata[,c(attr(pldata, "yvar", exact=TRUE),2)[1]]
x <- as.matrix(x)
y <- as.matrix(y)
lxy <- as.matrix(cbind(x,y))
if (!is.numeric(lxy)) {
warning(":plbars: 'x' or 'y' contain non-numeric values. no bars")
return()
}
lnobs <- sum(apply(is.finite(lxy),1,all))
if (lnobs==0) {
warning(":plbars: no observations. no bars")
return()
}
if (NCOL(x)==1) x <- c(x)
if (NCOL(y)==1) y <- c(y)
if (!(is.null(dim(x))&NCOL(y)>=3 | is.null(dim(y))&NCOL(x)>=3)) {
warning(":plbars: unsuitable arguments 'x', 'y'. Either one must have 3 columns.",
" -> no bars.")
return()
}
if (length(lop <- list(...))) {
lop$ploptions <- ploptions
ploptions <- ploptions(list=lop, assign=FALSE)
}
lcol <- i.getploption("bar.col")
llty <- rep(i.getploption("bar.lty"), length=2)
llwd <- rep(i.getploption("bar.lwd"), length=2)
lmpw <- i.def(midpointwidth,
i.getploption("bar.midpointwidth")) * 0.3 * ## llwd[1] *
diff(par("usr")[1:2+2*is.matrix(x)])/ lnobs
if (is.matrix(x)) {
segments(x[,1], y-lmpw, x[,1], y+lmpw, lty=llty, lwd=llwd[1],
col=lcol)
segments(x[,2], y, x[,3], y, lty=llty, lwd=llwd[2], col=lcol)
}
if (is.matrix(y)) {
segments(x-lmpw, y[,1], x+lmpw, y[,1], lty=llty, lwd=llwd[1],
col=lcol)
segments(x, y[,2], x, y[,3], lty=llty, lwd=llwd[2], col=lcol)
}
invisible(NULL)
}
## -----------------------------------------------------------------
plmark <- #f
function(x=NULL, y=NULL, markextremes=NULL, plabel=NULL,
plargs = NULL, ploptions = NULL)
{ ## ---------------------------------
lf.pmark <- function(mprop, x) {
lrk <- (rank(x, na.last="keep")-0.5)/sum(is.finite(x))
lrk<mprop[1] | lrk>1-mprop[2]
}
##
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
plabel <- i.def(i.def(plabel, plargs$plfeatures$plabel), pl.envir$plabel)
if (u.isnull(plabel)) {
warning(":plmark: no plabels found")
return(NULL)
}
if (length(x)==0) x <- plargs$pldata[,1]
lx <- if (is.data.frame(x)) x[,1] else x
ly <- if (is.data.frame(y)) y[,1] else y
lnobs <-
if (u.isnull(ly)) sum(is.finite(lx)) else sum(is.finite(lx)&is.finite(ly))
lmxdef <- ceiling(sqrt(lnobs)/2)/lnobs
lmx <- i.getploption("markextremes")
if(is.function(lmx)) lmx <- lmx(lnobs)
if (is.list(markextremes))
lmx <- lapply(markextremes, function(x) i.def(x, lmxdef))
if (lnmn <- length(lmxnm <- names(lmx))) {
lmxx <- i.def(unlist(lmx[attr(x,"varname", exact=TRUE)]), lmxdef)
lmxy <- i.def(unlist(lmx[attr(y,"varname", exact=TRUE)]), lmxdef)
} else {
if(length(lmx)<=1) lmxx <- lmxy <- i.def(lmx[[1]], lmxdef)
else {
lmxx <- lmx[[1]]
lmxy <- lmx[[2]]
}
}
##- lmxx[is.na(lmxx)] <- lmxdef
##- lmxy[is.na(lmxy)] <- lmxdef
rr <- if (any(unlist(lmx)>0)) {
li <- lf.pmark(rep(lmxx, length=2), lx)
if (length(y)) li <- li | lf.pmark(rep(lmxy, length=2), ly)
ifelse(li, plabel, "")
} else rep("", length(lx)) ## plabel
rr
} ## end plmark
## -----------------------------------------------------------------
plsmooth <- #f
function(x = NULL, y = NULL, ysec = NULL, band=NULL, power = NULL,
group=NULL, weight=NULL,
smooth = TRUE, plargs = NULL, ploptions=NULL, xy=TRUE, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
if (is.null(xy)||u.notfalse(xy)) {
lxy <- i.getxy(x, y, plargs, ploptions=ploptions,
call=match.call(), envir=parent.frame())
if (is.null(lxy)) return()
x <- lxy$x
y <- lxy$y
ploptions <- lxy$ploptions
}
if (length(x)<i.getploption("smooth.minobs")) {
warning(":plsmooth: too few observations. no smooth")
return() ## lxy[c("x","y")])
}
## pldata <- lxy$plargs$pldata
if (length(group)) {
if (length(group)%nin%c(1,nrow(plargs$pldata)))
warning(":plsmooth: argument 'group' has wrong length. It is ignored.")
else
plargs$pldata[,".smooth.group."] <- group
}
lIsm <- i.getplopt(smooth)
llsm <- lplft$smooth
if (length(smooth)==0 && length(llsm)) lIsm <- llsm
lIband <- i.def(band, i.getploption("smooth.band"))
if (length(band)==0 && length(llsm)) lIband <- llsm>1
lsm <- NULL
if (lIsm) {
power <- i.def(power, 1,1,1)
## lIband <- i.def(i.def(lIband, lIsm>=2), FALSE, TRUE, FALSE)
if (length(lxn <- attr(x, "numvalues", exact=TRUE))) x <- lxn
if (length(lyn <- attr(y, "numvalues", exact=TRUE))) y <- lyn
ly <- if(length(ysec)==0) y else {if (length(y)==0) ysec else cbind(y,ysec)}
##
lsm <- gensmooth(x, ly, band=lIband[1], power=power, weight=weight,
plargs=plargs, ploptions=ploptions)
## --------------
ysecsm <- NULL
if (length(ysec)) { ## separate y and ysec
lny <- NCOL(y) * (length(y)>0) ## ... NCOL(NULL) is 1 !
ysecsm <- lsm[["y"]]
if (lny==0) lsm$y <- NULL else {
lsm$y <- ysecsm[,1:lny]
ysecsm <- ysecsm[,-(1:lny)]
}
}
plsmoothline(lsm, x, y=y, ysec = ysecsm, plargs=plargs, ploptions=ploptions, ...)
}
invisible(lsm)
}
## --------------------------------------------------------------
plsmoothline <- #f
function(smoothline = NULL, x = NULL, y = NULL, ysec = NULL,
smooth.col = NULL, smooth.lty = NULL, smooth.lwd = NULL,
plargs = NULL, ploptions = NULL, marpar = NULL, ...)
{
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##- ## workaround a problem with changing margin pars
##- lusr <- par("usr")
##- points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",xpd=TRUE)
##- }
lcsize <- i.getploption("csize")
## --- data
if (u.isnull(smoothline)) {
if (length(x)&&length(y)==length(x))
smoothline <- list(x=x, y=y)
else {
warning(":plsmoothline: no smoothline found")
return()
}
}
if (!is.list(smoothline)) {
warning(":plsmoothline: 'smoothline' is not suitable. No smooth line")
return()
}
##- if (u.isnull(x)&&u.isnull(y)) { ## does not make sense since pldata will not contain smooths
##- lxy <- i.getxy(x, y, plargs, call=match.call(), envir=parent.frame())
##- plargs <- lxy$plargs
##- ploptions <- lxy$ploptions
##- x <- lxy$x
##- y <- lxy$y
##- }
lx <- i.def(smoothline[["x"]], x)
if (length(lx)==0) {
warning(":plsmoothline: no x values. No smooth line")
return()
}
ly <- i.def(smoothline[["y"]], y)
lIy <- length(ly)>0
lIysec <- length(ysec)>0
if (lIy) ly <- as.matrix(ly)
if (lIysec) ysec <- as.matrix(ysec)
if (!(lIy|lIysec)) {
warning(":plsmoothline: neither 'y' nor 'ysec' given. No smooth line")
return()
}
lbd <- smoothline$yband
lIband <- length(lbd)>0
if (length(smooth.col))
ploptions$smooth.col <-
i.def(smooth.col, i.getploption("smooth.col"), valuefalse="black")
if (length(smooth.lty))
ploptions$smooth.lty <-
i.def(smooth.lty, i.getploption("smooth.lty"), valuefalse=1)
if (length(smooth.lwd))
ploptions$smooth.lwd <-
i.def(smooth.lwd, i.getploption("smooth.lwd"), valuefalse=0.1)
lxtrim <- i.getploption("smooth.xtrim")
lrgx <- attr(x,"innerrange", exact=TRUE)
if (length(lsc <- attr(x, "plscale", exact=TRUE)))
lx <- attr(plscale(lx, plscale=lsc), "numvalues", exact=TRUE)
##- if (length(lsc <- attr(y, "plscale", exact=TRUE))) {
##- if (lIy) ly <- as.matrix(attr(plscale(ly, plscale=lsc), "numvalues", exact=TRUE))
##- if (lIysec) ysec <- as.matrix(attr(plscale(ysec, plscale=lsc), "numvalues", exact=TRUE))
##- if (lIband) lbd <- attr(plscale(lbd, plscale=lsc), "numvalues", exact=TRUE)
##- }
## ---
lcol <- i.getploption("smooth.col")
llty <- i.getploption("smooth.lty")
lgrp <- as.numeric(smoothline$group)
if (lInogrp <- length(lgrp)==0 || length(unique(dropNA(lgrp)))<=1) {
lgrp <- rep(1, NROW(lx))
lngrp <- 1
} else {
lngrp <- max(lgrp)
if (length(lcol)<lngrp) {
llcol <- i.getploption("col")
if (length(llcol)>1) llcol <- llcol[-1]
lcol <- rep(i.def(i.getploption("group.col"), llcol,
valuefalse=lcol[1]), length=lngrp)
}
lltydf <- i.getploption("lty")
llty <- rep(i.def(i.getploption("group.lty"),
i.def(lltydf[-1],llty), valuefalse=llty), length=lngrp)
}
##- if (is.numeric(lcol)) {
##- lcl <- i.getoption("colors")
##- lcol <- c(lcl[1],rep(lcl[-1], length=lngrp))[lcol+1]
##- ##[ifelse(lcol==0,1,(lcol-1)%%lngrp+2)]
##- }
## check if ordered
lio <- order(lgrp, lx)[1:sum(is.finite(lx))]
if (length(lio)!=length(lx) || any(lio!=1:length(lio))) {
lx <- lx[lio]
if (lIy) ly <- ly[lio,, drop=FALSE]
if (lIysec) ysec <- ysec[lio,, drop=FALSE]
lgrp <- lgrp[lio]
lngrp <- max(lgrp)
if (lIband) {
lbd <- lbd[lio]
smoothline$ybandindex <- smoothline$ybandindex[lio]
}
}
lx <- clipat(lx, lrgx, clipped=NA)
## may be a 2-vector or a matrix of 2 rows
llwd <- rep(c(i.getploption("smooth.lwd"), 0.7), length=2)
llwid <- i.getploption("linewidth")
lpale <- i.getploption("smooth.pale")
for (lgr in seq_len(lngrp)) {
lig <- which(lgrp==lgr)
lxg <- lx[lig]
lyg <- ly[lig,, drop=FALSE]
lysecg <- ysec[lig,]
if (all(is.na(lyg))&&all(is.na(lysecg))) next
if (1< (lng <- length(lig))) {
lndr <- i.def(smoothline$xtrim, 1) *
round(lng * if(is.function(lxtrim)) lxtrim(lng)
else i.def(lxtrim, 0, smoothxtrim(lng), 0) )
if (lndr) lxg[- ((lndr+1):(lng-lndr)) ] <- NA
lcl <- lcol[lgr] ## lcol[min(lgr,length(lcol))]
llt <- llty[lgr]
llw <- llwd[1]*llwid[llt]
lclp <- if (lInogrp) lcol[2] else lcl
lclp <- i.def(lclp, colorpale(lcl, lpale))
if (lIysec)
matlines(lxg, lysecg, lty=llt, lwd=llwd[2]*llw, col = lclp, ...)
if (lIy) matlines(lxg, lyg, lty=llt, lwd=llw, col=lcl, ...) ## xxx
if (lIband) {
li <- smoothline$ybandindex[lig] ## separate upper and lower smooth
## ??? does this work with re-sorting?
if (any(li))
lines(lxg[li], lbd[lig[li]], lty=llt, lwd=llw/2, col = lcl, ...)
if (any(!li))
lines(lxg[!li], lbd[lig[!li]], lty=llty, lwd=llw/2, col = lcl, ...)
}
}
}
invisible(NULL)
}
## -----------------------------------------------------------------
plrefline <- #f
function(refline, x=NULL, innerrange=NULL, y=NULL,
cutrange = c(x=TRUE, y=FALSE),
plargs = NULL, ploptions = NULL, ...)
{
## draws a reference line (with extended range) and
## band given by reflineyw (only inner range) if requested
lf.irna <- function(x, rg) {
x[x<rg[1]|x>rg[2]] <- NA
x
}
## ---
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
llty <- rep(i.getploption("refline.lty"), length=2)
llwd <- rep(i.getploption("refline.lwd"), length=2)
llcol <- rep(i.getploption("refline.col"), length=2)
lusr <- par("usr")
## ---
if (missing(refline)||u.isnull(refline)) {
warning(":plrefline: argument refline is NULL. No refline")
return()
}
## a single refline is turned into a list of length 1
if (is.list(refline)&&any(c("coefficients", "coef", "x", "y")%in%names(refline)))
refline <- list(refline)
if (!is.list(refline)) refline <- list(refline)
##
for (lirfl in seq_along(refline)) {
lrfl <- refline[[lirfl]]
lrfyb <- NULL
if (is.function(lrfl)) {
if (u.isnull(x)|u.isnull(y)) {
lpldata <- plargs$pldata
if (u.isnull(x))
x <- lpldata[,tail(i.def(attr(lpldata,"xvar", exact=TRUE),2),1)]
if (u.isnull(y))
y <- lpldata[,tail(i.def(attr(lpldata,"yvar", exact=TRUE),1),1)]
if (u.isnull(x)|u.isnull(y)) {
warning(":plrefline: no x and/or y values found for fitting the function")
next
}
}
lrfl <-
if (names(formals(lrfl))[1]=="formula") try(lrfl(y~x))
else try(lrfl(x,y))
if (inherits(lrfl, "try-error")) {
warning(":plrefline: argument refline contains an unsuitable function")
next
}
}
if (is.list(lrfl)&&length(lrfl$coef)) lrfl <- lrfl$coef
if (is.character(x)) x <- plargs$pldata[,x]
if (is.character(y)) y <- plargs$pldata[,y]
if (u.isnull(innerrange)) innerrange <- attr(x, "innerrange", exact=TRUE)
if (length(lxn <- attr(x, "numvalues", exact=TRUE))) x <- lxn
if (length(lyn <- attr(y, "numvalues", exact=TRUE))) y <- lyn
##---
if (is.atomic(lrfl)) {
if (length(lrfl)!=2) {
warning(":plrefline: 'refline' not suitable. No refline")
next
}
lrfx <- seq(lusr[1],lusr[2],
length=i.getploption("functionxvalues"))
lrfy <- lrfl[1]+lrfl[2]*lrfx ## needs correction if lIxir
} else {
lrfx <- lrfl$x
lrfy <- lrfl$y
if (length(lrfx)==0|length(lrfx)!=NROW(lrfy)) {
warning(":plrefline: 'refline' not suitable. No refline")
next
}
if (all(lrfx<lusr[1]|lrfx>lusr[2], na.rm=TRUE)) {
warning(":plrefline: no x coordinates in plot range")
next
}
lrfyb <- lrfl$band
}
lIrfyb <- length(lrfyb)
## ---
## haul lrfl to inner plotrange
if (length(innerrange)>0) {
if (u.isnull(x))
x <- plargs$pldata[, i.def(attr(plargs$pldata,"xvar", exact=TRUE),1)[1]]
if (u.isnull(y))
y <- plargs$pldata[, i.def(attr(plargs$pldata,"yvar", exact=TRUE),1)[2]]
lIxir <- any(attr(x,"nouter", exact=TRUE)>0)
lxir <- attr(x,"innerrange", exact=TRUE)
lIyir <- any(attr(y,"nouter", exact=TRUE)>0)
lyir <- attr(y,"innerrange", exact=TRUE)
cutrange <- rep(i.def(cutrange, TRUE), length=2)
if (lIxir) {
if (i.def(cutrange[1], TRUE)) lrfx <- lf.irna(lrfx, lxir)
else
lrfx <- plcoord(lrfx, range=lxir, ploptions=ploptions)
}
if (lIyir) {
if (i.def(cutrange[2], FALSE)) lrfy <- lf.irna(lrfy, lyir)
else
lrfy <- plcoord(lrfy, range=lyir, ploptions=ploptions)
if (lIrfyb) ## band: values outside inner range -> NA
lrfb <- apply(as.matrix(lrfb),2, lf.irna, rg=lyir)
}
}
## draw reference lines
llt <- rep(i.def(attr(lrfl, "lty", exact=TRUE), llty), length=2)
llw <- rep(i.def(attr(lrfl, "lwd", exact=TRUE), llwd), length=2)
llc <- rep(i.def(attr(lrfl, "lcol", exact=TRUE), llcol), length=2)
matlines(lrfx, lrfy, lty=llt[1], lwd=llw[1], col=llc[1])
if (lIrfyb)
matlines(lrfx, as.matrix(lrfy+lrfyb), lty=llt[2], lwd=llw[2], col=llc[2])
}
invisible(NULL)
}
## =========================================================================
plcoord <- #f
function(x, range=NULL, innerrange.factor=NULL, innerrange.ext=NULL,
plext=NULL, ploptions=NULL)
{
## Purpose: values for plot with limited "inner" plot range
lx <- structure(as.numeric(x), dim=dim(x))
ldtrg <- range(lx, finite=TRUE)
lirfunc <- i.getploption("innerrange.function")
if (is.character(lirfunc)) lirfunc <- get(lirfunc)
innerrange.factor <- i.getplopt(innerrange.factor)
innerrange.ext <- i.getplopt(innerrange.ext)
plext <- i.getplopt(plext)
## ---
if (length(range)>0) {
range <- rep(range, length=2)
## range <- range(range, finite=TRUE)
if ( (!is.na(range[1])&&range[1]>ldtrg[2]) |
(!is.na(range[2])&&range[2]<ldtrg[1]) ) { ## ranges do not overlap
warning(":plcoord: inadequate range. Not used")
range <- NULL
}
}
lrg <- range
if (length(lrg)==0||any(is.na(lrg))) {
lrg <- lirfunc(lx, fac=innerrange.factor)
if (length(lrg)==0) lrg <- ldtrg
if (length(range)) {
li <- !is.na(range)
lrg[li] <- range[li]
}
} else
if (diff(lrg)==0) lrg <- c(-1,1)*lrg
## --------- transformation of data into plcoord
lx[!is.finite(lx)] <- NA
rr <- pmax(pmin(lx,lrg[2]),lrg[1])
lxd <- lx-rr
lnouter <- c(sum(lxd<0, na.rm=TRUE),sum(lxd>0, na.rm=TRUE)) ## lxd is finite
if (sum(lnouter)>0) rr <- rr+lxd/(1+abs(lxd)/(diff(lrg)*innerrange.ext))
## if data fits into extended inner range, then avoid inner range
lrg <- ifelse(lnouter>0, lrg, ldtrg)
##- lrgext <- i.extendrange(lrg, plext)
##- ## inner range must not extend beyond data
##- if (ldtrg[1]>=lrgext[1]) lrg[1] <- ldtrg[1]
##- if (ldtrg[2]<=lrgext[2]) lrg[2] <- ldtrg[2]
##- ## enlarge to cover 'range'
##- lrg <- c(min(lrg[1],range[1]), max(lrg[2],range[2]))
## ---------
## extend range to plotting range
lplrg <- i.extendrange(lrg, ifelse(lnouter>0, innerrange.ext, plext))
## extend inner range if there are no modified points
## lrg <- ifelse(lnouter>0, lrg, lplrg) ## adjust to the needs of plotting
attr(rr,"innerrange") <- lrg
attr(rr,"innerrange.ext") <- innerrange.ext
## needed for transforming further quantities
attr(rr,"nouter") <- lnouter
attr(rr,"plrange") <- lplrg
class(rr) <- class(lx)
rr
}
## -------------------------------------------------------------------
## =====================================================================
gendate <-
function (date=NULL, year=2000, month=1, day=1, hour=0, min=0, sec=0,
data=NULL, format="y-m-d", origin=NULL)
{
## generate time -> chron
## -------------------------------------------------------------
lcall <- match.call()
## ltimeargs <- c("date", "year", "month", "day", "hour", "min", "sec")
ldt <- list(date=NA, year=2000, month=1, day=1, hour=0, min=0, sec=0)
origin <- i.def(origin, c(month=1, day=1, year=i.getploption("date.origin")) )
lnm <- NULL
## --- arguments
largs <- setdiff(names(lcall)[-1], c("data", "format","origin"))
data <- as.data.frame(data)
if (length(largs)==0) stop("!gendate! no date and time variables specified")
inp <-
parse(text = paste("list(", paste(as.list(lcall[largs]), collapse = ","),")"),
keep.source = FALSE)
vars <- try(eval(inp, data, enclos=parent.frame()), silent=TRUE)
if (inherits(vars, "try-error")) {
lvnmiss <- setdiff(largs, names(data))
stop(sub("object", "!gendate! variable (or object)",
attr(vars, "condition")$message),
if (length(lvnmiss)>1)
paste(". \n All of ",
paste(lvnmiss, collapse=", "), "may be unavailable.")
)
}
names(vars) <- largs
ldt[largs] <- vars
ldt <- as.data.frame(ldt)
##
lln <- unique(lapply(ldt, length))
if (length(lln[lln>1])>1)
stop("!gendate! differing lengths of arguments")
## month
if (is.factor(ldt$month)) ldt$month <- as.character(ldt$month)
if (is.character(ldt$month)) {
lmnum <- match(ldt$month, c.months, nomatch=0) ## distiguish NA and nommatch
if (any(lmnum==0, na.rm=TRUE)) lmnum <- match(ldt$month, c.mon, nomatch=0)
if (any(lmnum==0, na.rm=TRUE))
stop("!gendate! inadequate argument 'month'")
ldt$month <- lmnum
}
## --- argument 'date'
date <- ldt$date
if (length(date)&&!all(is.na(date))) { ## get timeargs from date
if (inherits(date, "Date"))
date <- chron::dates(format(date), format="y-m-d", origin=origin)
else {
if (inherits(date,"factor")) date <- as.character(date)
if (is.character(date))
date <- chron::dates(date, format=c(format, "h:m:s"), origin=origin)
}
if (!inherits(date, "times"))
stop("!gendate! argument 'date' not suitable.")
## if (length(setdiff(largs, "date"))==0) return(chron::chron(date))
} else
date <- chron::dates(
paste(ldt$year, ldt$month, floor(as.numeric(ldt$day)), sep="-"),
format="y-m-d", origin=origin)
## ---
##- if (inherits(date, "chron")) ## date already has 'times'
##- return(structure(date, format=i.getploption("date.format")) )
## --- hours, min, sec
## convert too large numbers
if ("sec"%in%largs && any(li <- ldt$sec>=60, na.rm=TRUE)) {
li <- which(li)
ldt$min[li] <- ldt$min[li]+ldt$sec[li]%/%60
ldt$sec[li] <- ldt$sec[li]%%60
}
if ("min"%in%largs && any(li <- ldt$min>=60, na.rm=TRUE)) {
li <- which(li)
ldt$hour[li] <- ldt$hour[li]+ldt$min[li]%/%60
ldt$min[li] <- ldt$min[li]%%60
}
if ("hour"%in%largs && any(li <- ldt$hour>=24, na.rm=TRUE)) {
li <- which(li)
date[li] <- date[li]+ ldt$hour[li]%/%24
ldt$hour[li] <- ldt$hour[li]%%24
}
## convert decimals to lower units
lf.dec <- function(x) round(x,2)-floor(x+0.005) ## not general enough
if ("day"%in%largs && any(0!= (ldec <- lf.dec(ldt$day)), na.rm=TRUE)) {
ldt$day <- floor(ldt$day)
if ("hour"%nin%largs) ldt$hour <- round(ldec*24 + ldt$hour - 0.000005, 5)
}
if (any(0!= (ldec <- lf.dec(ldt$hour)), na.rm=TRUE)) {
ldt$hour <- floor(ldt$hour+0.005)
if ("min"%nin%largs) ldt$min <- round(ldec*60 + ldt$min - 0.0005)
}
if (any(0.001<abs(ldec <- lf.dec(ldt$min)), na.rm=TRUE)) {
ldt$min <- floor(ldt$min+0.005)
if ("sec"%nin%largs) ldt$sec <- round(ldec*60 - 0.5) ## + ldt$sec must be zero
}
##
date <-
chron::chron(date, paste(ldt$hour, ldt$min, ldt$sec, sep=":"),
format=c(dates=format, times="h:m:s"), origin=attr(date,"origin"))
if (length(lnm)) names(date) <- lnm
structure(date, format=i.getploption("date.format"))
} ## end gendate
## =====================================================================
gendateaxis <- #f
function(date=NULL, year=2000, month=1, day=1, hour=0, min=0, sec=0,
data=NULL, format="y-m-d", origin=NULL, ploptions=NULL)
{
## generate time axis.
## resulting tick labels may exceed data range by quite a bit
## -------------------------------------------------------------
lf.seq <- function(x) seq(min(x),max(x))
lf.tickat <-
function(tickunit, tickint, llev, llvlg, ystart, mstart, lnlev) { ## , label=FALSE
## generate ticks in tickint [tickunit] intervals
if (tickunit=="y") return(ystart)
llunit <- match(tickunit, names(lnlev))
llev[[llunit]] <- ltatu <- ## units that may be used
seq(llunit%in%2:3, lnlev[llunit], tickint) ## m and d start at 1
## keep llev component of highest category if higher than tickunit,
## generate levels of lower ones for the whole span PLUS 1 for the end
lv1 <- llev[[llvlg]]
if (llvlg < llunit-1) {
for (ll in (llvlg+1):(llunit-1)) { ## no llunit-1 instead of (llunit-1) !!!?
llev[[ll]] <- llv <- seq(ll%in%2:3, lnlev[ll]) ## m and d start at 1
lv1 <- c(outer(llv, lv1*100, "+"))
}
}
if (llvlg<llunit)
ltatu <- c(outer(ltatu, lv1*100, "+")) ## information for getting label
## ---
if (tickunit=="m") ltat <- mstart[seq(1, length(mstart), tickint)]
else { ## mstart contains start of month for whole year(s). select those needed
llday <- llev[["d"]]
ltat <- c(outer(llday-1, mstart, "+"))
## day starts with 1 [llev[["m"]]]
lmd <- c(outer(llday, 100*(llev[["m"]]), "+"))
ltatu[lmd%in%c(limpossible, limpossible+1)] <- NA
liat <- lmd %nin% (limpossible+1) ## +1: keep tick at end of last day month
ltat <- ltat[liat]
ltatu <- ltatu[liat]
if (tickunit!="d") { ## !!? mit llev arbeiten! oder 1:length(lv1)
ltat <- c(outer(llev[["h"]]/24, ltat, "+"))
if (tickunit!="h") {
ltat <- c(outer(llev[["M"]]/(24*60), ltat, "+"))
if (tickunit=="M") ltat <- ltat[seq(0, length(ltat), tickint)]
else {
ltat <- c(outer(llev[["s"]]/(24*60), ltat, "+"))
if (tickunit=="s") ltat <- ltat[seq(0, length(ltat), tickint)]
else stop("!gendateaxis/lf.tickat! bug")
}}}
ltatu <- ltatu[1:length(ltat)] ## ???
}
if (length(ltat)!=length(ltatu))
warning("debug lf.ticksat: length(ltat)!=length(ltatu)")
## avoid duplicated ticks. select second label
li <- length(ltat)+1-which(duplicated(rev(ltat)))
if (length(li)) {
ltat <- ltat[-li]
ltatu <- ltatu[-li] ## if (label)
}
attr(ltat, "at.inunit") <- ltatu ## if (label)
ltat ## structure(ltat, at.inunit=ltatu)
} ## end lf.tickat
## -----
lnlev <- c(y=100, m=12, d=31, h=24, M=60, s=60)
limpossible <- c(229, 230, 231, 431, 631, 931, 1131) ## non-existing days
## ---------------------------------------
## --- prepare
lcall <- match.call()
ldtk <- i.getploption("date.ticks") ## time level and number of ticks
## gendate
lcall$ploptions <- NULL
lcall[[1]] <- quote(gendate)
mode(lcall) <- "call"
date <- eval(lcall, sys.parent())
## ---------
ldt <- dropNA(date)
if (length(ldt)==0) {
warning("!gendateaxis! no valid dates found. dateaxis not generated")
return(date)
}
lattr <- attributes(date)
lvlab <- lattr$varlabel ## for later use
lorigin <- if (length(lor <- lattr$origin))
julian(as.Date(paste(lor[c("year","month","day")], collapse="-"))) else 0
if (length(lattr)) { ## avoid piling up of attributes
li <-
setdiff(names(lattr),
c("numvalues", "ticksat", "ticklabelsat", "ticklabels", "units") )
attributes(date) <- lattr[li]
}
lndays <- diff(range(ldt))
lidtk <- which(ldtk$limit<lndays)[1] ## which line of ldtk
## -----------------------------------------------------------------
ldate <- data.frame(chron::month.day.year(ldt+lorigin)[c(3,1,2)],
hour = chron::hours(ldt), min = chron::minutes(ldt),
sec = chron::seconds(ldt))
## avoid new day or month or year caused by a midnight obs.
if (diff(range(ldate$hour))!=0)
ldate <- ldate[!(ldate$day==1&ldate$hour==0&ldate$min==0),]
llev <- lapply(ldate, lf.seq) ## how many values of which unit are there?
names(llev) <- names(lnlev)
## which units vary?
lvr <- sapply(llev, length) >1
llvlg <- which(lvr)[1]
llsm <- length(lvr)+1-which(rev(lvr))[1]
##
## lIym <- length(c(unique(ldate$year), unique(ldate$mon)))>2
lyr <- lf.seq(ldate$year)
lystart <- julian(as.Date(paste(lyr,"1-1", sep="-")))-lorigin
lmn <- 1:12 ## if (llvlg>=3) lf.seq(ldate$mon)+1 else 1:12
lyy <- if (length(lyr)==1) lyr else rep(lyr, each=12)
## lmstart <- julian(as.Date(paste(lyy,lmn,"1", sep="-")))-lorigin
lmstart <- julian(as.Date(paste(lyy,lmn,"1", sep="-")))[llev$m]-lorigin
##
ltatsmall <-
c(lf.tickat(ldtk$smallunit[lidtk], ldtk$smallint[lidtk],
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) ) ## ( attr "at.inunit" may be too short. not used here)
ltatbig <-
c(lf.tickat(ldtk$bigunit[lidtk], ldtk$bigint[lidtk],
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) )
llunit <- ldtk$labelunit[lidtk]
llint <- ldtk$labelint[lidtk]
ltatlabel <-
lf.tickat(llunit, llint,
llev=llev, llvlg=llvlg, ystart=lystart, mstart=lmstart,
lnlev=lnlev) ## , label=TRUE
## --- ticklabels
ltatu <- attr(ltatlabel, "at.inunit", exact=TRUE)
lls <- any(ltatu>=100, na.rm=TRUE)
ll <- list(u1 = ltatu%%100, u2 = if (lls) ltatu%/%100, sep=lls)
lf.nabl <- function(x) {x[x=="NA"] <- "";x}
llab <-
switch(llunit,
y = as.character(lyr),
m = paste(c.mon[ll$u1], ll$u2, sep = if(ll$sep) "." else ""),
d = lf.nabl(paste(ll$u1, c.mon[ll$u2], sep=if(ll$sep) " " else "")),
h = paste(ll$u2, ll$u1, sep = if(ll$sep) "|" else ""),
M = paste(ll$u2, ll$u1, sep = if(ll$sep) ":" else ""),
s = paste(ll$u2, ll$u1, sep = if(ll$sep) ":" else ""),
{
warning(":gendateaxis: labels went wrong. check ploptions(\"date.ticks\"")
NULL
}
)
llab[is.na(ltatu)] <- ""
##- if (llunit=="d") {
##- }
if (length(lvlab)==0 ||
(length(l <- attr(lvlab, "setbyuser", exact=TRUE))&&!l) ) {
llv1 <- c("A",names(llev))[llvlg] ## level that does not vary
lvlab <- structure(
switch(llv1,
A = list(), ## "year",
y = as.character(llev[[1]]),
m = paste(c.months[llev[[2]]], llev[[1]]),
d = paste(llev[[3]], c.months[llev[[2]]]),
h = "minute",
M = "second",
"time"),
setbyuser = FALSE)
}
## drop labels outside range
lina <- is.na(clipat(ltatlabel, i.extendrange(unclass(range(ldt))), clipped=NA))
if (any(lina)) {
ltatlabel <- ltatlabel[!lina]
llab <- llab[!lina]
ltatu <- ltatu[!lina]
}
## ticklabelsat
llu <- match(llunit, c("y","m","d","h","M","s"), nomatch=0)
if (llu<llsm) ## turn into interval
ltatlabel <- outer(ltatlabel, c(0, c(365, 30, 1, 0,0)[llu]), "+")
## 1/24, 1/(24*60)
## at.inunit = attr(ltatlabel, "at.inunit") )
if (llunit=="d" & ldtk[lidtk,"labelint"]!=1) { ## drop mark at day 31
li31 <- ltatu%%100==31
li31[length(li31)] <- FALSE ## do not drop at end of scale
llab[li31] <- ""
}
attr(ltatlabel, "at.inunit") <- NULL
structure(date, numvalues=c(unclass(date)),
ticksat=structure(ltatbig, small=ltatsmall),
ticklabelsat=ltatlabel, ticklabels=llab, varlabel=lvlab)
}
## ===========================================================================
i.pchcens <- #f
function(plargs, condquant)
## Delta, nabla, >, <, quadrat : pch= c(24, 25, 62, 60, 32)
{
if (u.isnull(condquant) | !u.isnull(lpc <- plargs$pldata$".pch."))
return(lpc)
##
ploptions <- plargs$ploptions
lpch <- i.getploption("censored.pch", opts=ploptions)
lpc <- rep(i.def(lpch[1],1), nrow(plargs$pldata))
lpc[condquant[,"index"]] <- i.def(lpch[2],3)
lpc
}
## ====================================================================
pllimits <- #f
function(pllim, data, limfac = NULL, FUNC=NULL)
{ ## determine inner plot range
## if pllim is a list or a matrix, leave it alone
lIcq <- inherits(data, "condquant")
ldt <- cbind( if (lIcq) c(data[,1:3]) else data )
pllim <- i.def(pllim, TRUE, TRUE, FALSE)
if (length(pllim)>1)
if (any(dim(cbind(pllim))!=c(2,NCOL(ldt)))) {
warning(":plregr/pllimits: unsuitable argument pllim ")
pllim <- TRUE
}
lfunc <- i.getploption("innerrange.function")
limfac <- i.getploption("innerrange.factor")
##
if (length(pllim)==1 && is.logical(pllim))
pllim <-
if (pllim) apply(ldt, 2, lfunc, fac=limfac) else
matrix(FALSE, 2, NCOL(ldt))
if ((!is.list(pllim))&length(pllim)==2) pllim <- as.matrix(pllim)
pllim
}
## ========================================================================
plsubset <- #f
function(x, subset = NULL, omit = NULL, select = NULL, drop = FALSE,
keeprange = FALSE)
{
## subset, adjusting attributes
## adaptation of subset.data.frame
if (!inherits(x, "data.frame"))
x <- as.data.frame(x=x)
## stop("!plsubset! 'x' must inherit from data.frame")
e <- if (lIsubset <- length(match.call()$subset))
substitute(subset) else substitute(omit)
r <- if (lIsubset & length(e)==0) rep_len(TRUE, nrow(x))
else dropNA(eval(e, x, parent.frame()))
if (is.logical(r)) r <- which(r)
if (is.character(r)) {
ir <- match(r, row.names(x), nomatch=0)
if (all(ir==0))
stop("!plsubset! 'subset' is character, but contains no row.names of 'x'")
if (any(ir==0))
warning(":plsubset: 'subset' contains strings that are no row.names:\n ",
if (sum(ir==0)<=10) paste(r[ir==0], collapse=", ")
else paste(paste(r[ir==0][1:10], collapse=", "), "...")
)
r <- ir[ir!=0]
}
if (!lIsubset) r <- setdiff(1:nrow(x), r) ## omit has been used
rr <- transferAttributes( x[r,, drop=FALSE], x)
if (length(select)) {
nl <- as.list(seq_along(x))
names(nl) <- names(x)
vars <- eval(substitute(select), nl, parent.frame())
rr <- rr[vars,, drop=FALSE]
}
if (nrow(rr)==0) {
warning(":plsubset: Empty subset")
return(rr)
}
## ----- attributes
lf.rgratio <- function(x, r) {
lrx <- diff(range(x, finite=TRUE))
if (lrx>0) diff(range(x[r], finite=TRUE))/lrx else 1
}
for (lj in seq_len(ncol(rr))) {
lxj <- x[,lj]
lattr <- attributes(lxj)
lattr <- lattr[setdiff(names(lattr), "names")]
if (length(lattr)) {
lrgratio <-
if (is.numeric(lxj)) lf.rgratio(lxj, r) else 1
if ("numvalues"%in%names(lattr)) {
lnv <- lattr$numvalues
lnvr <- lnv[r]
lrgratio <- lf.rgratio(lnv, r)
lattr$numvalues <- lnvr
}
if ("plcoord"%in%names(lattr)) {
lpc <- lattr$plcoord
lpcr <- lpc[r]
lrgratio <- lf.rgratio(lpc, r)
lattr$plcoord <- lpcr
}
if (!is.finite(lrgratio)) {
warning(":plsubset: something wrong with attr(...,'numvalues') ",
"or attr(...,'plcoord')")
lrgratio <- 1
}
if ((!keeprange) & lrgratio<i.getploption("subset.rgratio")) {
lats <- c("ticksat","ticklabelsat","ticklabels") ## drop these attributes
lattr <- lattr[setdiff(names(lattr), lats)]
## date variable
if (inherits(lxj, c("Date", "times"))) {
attr(rr[,lj], "numvalues") <- lattr$numvalues
lattr <- attributes(gendateaxis(rr[,lj]))
lattr[names(lattr)] <- lattr
}
## scaled variable
if (length(lpls <- lattr$plscale)) {
lplsc <- plscale(lxj[r], lpls)
lattr[lats] <- attributes(lplsc)[lats]
}
}
attributes(rr[,lj]) <- lattr
## resp. genvarattributes
}
}
rr[,,drop=drop]
}
## ========================================================================
setvarattributes <- #f
function(data, attributes = NULL, list = NULL, ...)
{
data <- as.data.frame(data)
lnmdata <- names(data)
## list <- c(list, list(...))
if (length(list) && !is.list(list))
stop(":setvarattributes: argument 'list' must be a list")
list <- c(list, list(...))
if (length(list)) {
lnames <- names(list)
for (lnm in lnames) {
lls <- as.list(list[[lnm]])
llnm <- names(lls)
if (is.null(llnm)) {
llnm <- lnmdata
lls <- setNames(rep(lls, length(lnmdata)), lnmdata)
}
if (any(linm <- llnm%nin%lnmdata))
stop("!setvarattributes! names of ",lnm," not in ",
"names of 'data': ", paste(llnm[linm], collapse=", "))
for (lnmv in llnm)
attr(data[[lnmv]], lnm) <- lls[[lnmv]]
}
} else if (length(attributes)==0) warning(":setvarattributes: no attributes")
if (length(attributes)) {
if (!is.list(attributes))
stop("!setvarattributes! argument 'attributes' must be a list")
if (is.null(names(attributes))) {
if (length(attributes)!=ncol(data))
stop("!setvarattributes! argument 'attributes' must have names ",
"or be of appropriate length")
names(attributes) <- names(data)
}
lnames <- names(attributes)
if (any(linm <- lnames%nin%names(data)))
stop("!setvarattributes! names of argument 'attributes' not in ",
"names of 'data': ", paste(lnames[linm], collapse=", "))
for (lnm in lnames) {
lattr <- attributes(data[[lnm]])
lattr[names(attributes[[lnm]])] <- attributes[[lnm]]
attributes(data[[lnm]]) <- lattr
if (lnm=="innerrange") {
## call plcoord !!!
}
}
}
invisible(data)
}
## ==========================================================================
plyx <- #f
function(x=NULL, y=NULL, by=NULL, group=NULL, data=NULL, type="p",
panel=NULL,
xlab=NULL, ylab=NULL, xlim = NULL, ylim = NULL,
markextremes=0, rescale=TRUE, mar=NULL, mf=FALSE,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
lf.rg <- function(y) { ## plranges and innerranges
plrg <- i.def(attr(y,"plrange", exact=TRUE), range(y, finite=TRUE))
c(plrg, i.def(attr(y, "innerrange", exact=TRUE), plrg))
}
## --- intro: call pl.control
lcall <- match.call() ## match.call modifies argument names -> sys.call
if (length(plargs)==0) { ## call pl.control
lcall$markextremes <- markextremes
ldtnm <- substitute(data)
ldtnm <- if (is.name(ldtnm))
as.character(ldtnm) else if (length(ldtnm)) format(ldtnm)
lcall$.subdefault <- if (length(ldtnm)<30) ldtnm else ""
lcall[1] <- list(quote(pl.control))
lcall <- as.call(lcall)
plargs <- eval(lcall, envir=parent.frame())
}
## ---
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## --- data
pldata <- plargs$pldata
lnr <- NROW(pldata)
lnobs <-
max(10, median(sapply(pldata,
function(x) sum(is.finite(x)) )) )
lxnm <- attr(pldata,"xvar", exact=TRUE)
if (is.null(lynm <- attr(pldata,"yvar", exact=TRUE))) {
lynm <- tail(lxnm, 1)
lxnm <- head(lxnm, -1)
}
lx <- pldata[,lxnm, drop=FALSE]
lnx <- ncol(lx)
ly <- pldata[,lynm, drop=FALSE]
## why so complicated? I need this when by is active
for (lj in lynm) {
lyj <- ly[[lj]]
lplval <- i.def(attr(lyj, "plvalues", exact=TRUE),
attr(lyj, "numvalues", exact=TRUE))
if (length(lplval)) {
lyj <- transferAttributes(
if(inherits(lyj, "Surv"))
survival::Surv(lplval, lyj[,2],
type=attr(lyj, "type", exact=TRUE)) else lplval,
lyj)
attr(lyj, "plscale") <- NULL
ly[,lj] <- lyj
}
}
lny <- ncol(ly)
## ------------------------------------------------------
## --- 'by' grouping
lnby <- 1
lvby <- attr(pldata, "byvar") ## [[".by."]]
lIby <- length(lvby)>0
lby <- if(lIby) {
if (length(lvby)>1)
warning(":plyx: more than one 'by' variables. I use the first one")
lby <- i.factor(pldata[,lvby]) ## makes sure there is no extra levels
lgrplab <- levels(lby)
lnby <- length(lgrplab)
as.numeric(lby)
## lgrptitline <- i.def(ltitline[2],1)
} else rep(1, nrow(ly))
## --------
## style elements
lIsmooth <- i.getploption("smooth")
lir <- u.true(i.getploption("innerrange"))
##- lIfirst <- TRUE
lplab <- pldata[[".plab."]]
lpch <- pldata[[".pch."]]
lIpch <- length(lpch)>0
lpcol <- pldata[[".pcol."]]
lclr <- i.getploption("col")
lcsize <- i.getploption("csize")
ltadj <- i.getploption("title.adj")
lcsize.pch <- i.getploption("csize.pch") ## need to do this here such that
## csize.pch is fixed and does not vary with 'by' group size
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs/lnby)
plargs$ploptions$csize.pch <- lcsize.pch
##
ltitl <- i.getploption("title.line")
lsmpale <- i.getploption("smooth.pale")[2]
lpsep <- i.getploption("panelsep")
##
panel <- i.getplopt(panel)
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plyx: 'panel' not found. Using 'plgraphics::plpanel'")
panel <- plgraphics::plpanel
}
## --- preparations
lyaxcol <- 1
## inner plotting range
lnoutery <-
as.matrix(sapply(ly, function(x) c(attr(x,"nouter", exact=TRUE),0,0)[1:2]>0 ))
lIinner <- apply(lnoutery, 1, any)
## ranges
lrgy <- sapply(ly, lf.rg)
## ---
if (lny>1) { ## need to examine all y's and possibly reset plrange for ly[,1]
lfs <- i.getploption("factor.show")
if (lfs=="mbox") plargs$ploptions$factor.show <- ploptions$factor.show <- "asis"
if (rescale==0) {
llf <- function(y)
i.def(i.def(attr(y, "plvalues"), attr(y, "numvalues")), y)
lyy <- as.data.frame(lapply(ly, llf))
lplsc <- lapply(ly, function(y) i.def(attr(y, "plscale"), NULL))
lvlim <- sapply(ly, function(y) i.def(attr(y, "vlim"), c(NA,NA)))
if (any(!is.na(lvlim)))
attr(lyy, "vlim") <-
c(min(lvlim[1,], na.rm=TRUE), max(lvlim[2], na.rm=TRUE))
## innerrange?
lir <- lir &&
any(sapply(ly, function(y) length(attr(y, "innerrange"))>0))
lps0 <- all(sapply(lplsc, length)==0)
lplsc <- unique(unlist(lplsc))
ltickscale <- NULL
if (!lps0) {
if (length(lplsc)>1)
warning(":plyx! different plot scales. I cannot keep scales equal")
else ltickscale <- lplsc
}
lyc <- i.genvattrcont(c(unlist(lyy)), ploptions=ploptions,
tickscale=ltickscale)
lattr <-
attributes(lyc)[c("plrange", "ticksat", "ticklabelsat", "ticklabels")]
lirg <- attr(lyc, "innerrange")
lirg <- i.def(lirg, lattr$plrange)
for (lj in 1:lny) {
attr(ly[,lj], "plcoord") <- c(plcoord(lyy[,lj], range=lirg))
latt <- c(lattr, innerrange=list(lirg))
attributes(ly[,lj])[names(latt)] <- latt
}
## ly <- setvarattributes(ly, setNames(rep(list(list(lattr)), lny), lynm))
lrgy <- matrix(lf.rg(lyc),4,lny)
} else { ## rescale !=0
if (rescale<0) { ## do not adjust tick marks etc
lrgyy <- c(min(lrgy[1,]),max(lrgy[2,]),min(lrgy[3,]),max(lrgy[4,]))
for (lj in 1:lny)
attr(ly[,lj], "plcoord") <- plcoord(ly[,lj], range=lrgyy)
}
else ## rescale >0
lrgyy <- lrgy[,1]
attr(ly[,1],"plrange") <- lrgyy[1:2]
## extend the plrange of ly[,1] if needed
##- lrgyy + diff(lrgyy)*c(-1,1)*
##- ifelse(lIinner, i.getploption("innerrange.ext"), 0) ## ploptions$plext
} ## !!! welche attr sollen wirklich gesetzt werden?
attr(ly[,1], "nouter") <- lIinner ## plframe is called for ly[,1], needs attr
} else lir <- lir && length(attr(y, "innerrange"))>0
## end lny>1
## --------------
ly1 <- ly1g <- ly[,1]
lrgy1 <- lrgy[,1]
## mark extremes
lmark <- i.getplopt(markextremes)
if (is.function(lmark)) lmark <- lmark(lnobs)
lmk <- unlist(lmark)
lImark <- length(lmk)>0 && any(ifelse(is.na(lmk),TRUE,lmk>0))
lImark <- is.na(lImark)||lImark
lymark <- if (lImark & lny==1) ly ## cannot mark extremes if lny>1
## --- groups ; smooth lines
lsmcol <- i.getploption("smooth.col")
if(length(lgrp <- pldata[[".group."]])) {
lsmcol <- attr(lgrp, "group.col")
if (length(lsmcol)) lsmcol <- colorpale(lsmcol, lsmpale)
lngrp <- length(lgrp)
} else lngrp <- 1
## --- figure parameters
lmfkeep <- !u.notfalse(mf)
loldp <- par(list("mar","mgp")) ## ,"oma"
if (!i.getploption("keeppar"))
on.exit(par(loldp), add=TRUE, after=FALSE)
marpar <-
i.getmarpar(plargs=plargs, title=if(lngrp>0) " ")
## title.outer=c(lplft$main, lplft$sub))
if (lny>1) marpar$mar[4] <- marpar$mar[2]
## --- multiple figures
lnpgc <- lnpgr <- 1
lnr <- lnx
lnc <- lnby
llmf <- length(mf)
if (lnby>1) { ## by groups
lmpo <- i.getmarpar(TRUE, mar=i.getploption("oma"), plargs=plargs)
loma <- lmpo$mar
##- if (length(lomaarg))
##- if (length(lomaarg)==1) loma[3] <- lomaarg
##- else loma <- rep(lomaarg, length=4)
if (lnx>1) {
lmar <- lpsep + c(marpar$mar[1],0,0,0.8*(lny>1)) +
c(0,0,ltitl[1]-i.def(ltitl[2],0),0)
plargs$ploptions$mframesmax <- i.def(mf, i.getploption("mframesmax"))
if (llmf & u.notfalse(mf))
marpar <-
plmframes(lnx, lnby, reduce=TRUE, mar=lmar, oma=loma,
plargs=plargs)$marpar
lmfig <- list(mfig=par("mfg"))
lnr <- lmfig$mfig[1]
lnc <- lmfig$mfig[2]
lnpgr <- ceiling(lnx/lnr)
lnpgc <- ceiling(lnby/lnc)
} else { ## only 1 x
ltitl <- i.def(i.getploption("title.line")[2], 0.8)
## mframes
if (u.true(mf)) mf <- lnby
lmr <- lpsep + c(0,0,ltitl+1,0)
if (u.notfalse(mf)) {
marpar <-
if (llmf&&prod(mf)>1)
(lmfig <- plmframes(mf[1], if(llmf>=2) mf[2], mft=if(llmf==1) mf,
mar=lmr, oma=loma))$marpar
else i.getmarpar(mar=lmr, plargs=plargs)
}
## plargs$plmarpar$title.line[1] <- ltitl
}
} else { ## no by groups
if (length(mf)&u.notfalse(mf))
marpar <- plmframes(mf, ploptions=ploptions)$marpar
}
lmar <- marpar$mar
par(mar=lcsize*lmar)
lattrc <- c("innerrange","nouter")
lnfgcol <- par("mfg")[4]
## --- restore mfg if only one plot is produced
if ((lnx>1 | lnby>1) & !lmfkeep) {
loldmf <- par(list("mfrow"))
on.exit(par(loldmf), add=TRUE, after=FALSE)
}
## ------------------------------------------------------------------
## --- plot
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (lj in 1:min(lnr, lnx-lr)) {
## --- x variable
lxj <- lx[,lr+lj]
## lxjattr <-
lxjg <- lxjv <- if (!is.factor(lxj))
i.def(attr(lxj, "plcoord", exact=TRUE),
i.def(attr(lxj, "plvalues", exact=TRUE),
i.def(attr(lxj, "numvalues", exact=TRUE), c(lxj))))
else lxj
attributes(lxjg)[lattrc] <- attributes(lxj)[lattrc] ## lxjattr
if (lImark) {
lplab <- plmark(lxj, y=lymark, markextremes=lmark,
plabel=plargs$plfeatures$plabel)
pldata[[".plab."]] <- lplab
plargs$pldata <- pldata
}
lpchg <- lpch
## 'by' grouping
for (ipgc in 1:lnpgc) { ## columns on page
lc <- (ipgc-1)*lnc
for (lig in (lc+1):lnc) { ## 'by' groups
lg <- lig
if(lny>1) {
lpcol <- lyaxcol <- lsmcol <-
i.def(attr(ly1, "vcol", exact=TRUE), lclr[2])
plargs$ploptions$smooth.col <- lsmcol
pldata[".pcol."] <- lpcol
if(!lIpch)
lpchg <-
if (lny>1)
attr(ly1, "pch", exact=TRUE) else i.getploption("pch")[1]
}
## show labels if there will be no panel below the present one
lshow1 <- (lig>lnby-lnfgcol) * !lmfkeep
lshow2 <- 2 - (lngrp>1)
lshow4 <- 2 - (lngrp>1) || lig==lngrp
## do not set it if 'mf' was set F
lop <- plframe(lxj, ly1, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim,
axcol=c(NA,lyaxcol,NA,NA), plargs=plargs, ## mar=lmar,
marpar=marpar, xy=FALSE,
showlabels=c(lshow1,lshow2,0,lshow4)+1)
##- if (lIfirst) {
##- loldp <- c(lop, loldp)
##- if (!i.getploption("keeppar"))
##- on.exit(par(loldp[!duplicated(names(loldp))]))
##- }
lmfg <- par("mfg")
if (prod(lmfg[1:2])==1||lmfkeep) {
pltitle(plargs=plargs, outer.margin=prod(lmfg[3:4])>1&!lmfkeep)
stamp(sure=FALSE, ploptions=ploptions)
}
##- lIfirst <- FALSE
lrgold <- lrgy1
lyg <- ly
## 'by' group
if (lIby) {
if (lmar[3]>=1 | par("mfg")[1]==1)
pltitle(main="", sub=lgrplab[lg], ##paste(lgrpname, lgrplab[lg], sep=" "),
outer.margin=FALSE, xpd=TRUE, adj=ltadj[1], ## line=lgrptitline,
ploptions=ploptions)
li <- which(lby==lg)
lxjg <- lxjv[li]
lyg <- plsubset(ly, li, keeprange=TRUE)
ly1g <- lyg[,1]
plargs$pldata <- pldata[li,]
if (length(lpch)==lnr) lpchg <- lpch[li]
## if (length(lplab)==lnr) lplabg <- lplab[li]
## may be useful for generating a legend of group labels
}
if (lny>1) {
lcol <- ploptions$col <- ploptions$lcol <- ploptions$smooth.col <-
plargs$pldata$".pcol." <-
i.def(attr(ly1g,"vcol", exact=TRUE), lclr[2])
if (lIsmooth) ploptions$smooth.col <- colorpale(lcol, lsmpale)
}
## start plot
panel(lxjg, ly1g, type=type, plargs=plargs, ploptions=ploptions,
marpar=marpar)
## multiple y
lusr <- par("usr")
if (lny>1) {
for (lj in 2:lny) {
lyjg <- lyg[,lj]
lrgj <- lrgy[,lj]
lpcol <- i.def(attr(lyjg, "vcol", exact=TRUE),
lclr[(lj+1)%%(length(lclr)-1)+1])
## the color must reflect the variable
if (!lIpch) lpchg <- attr(lyjg, "pch", exact=TRUE)
if (rescale>0) { ## new user coordinates
lusr[3:4] <- lrgj[1] +
c(0, diff(lrgj[1:2])/diff(lrgold[1:2]) * diff(lusr[3:4]))
par(usr=lusr)
}
if (lIsmooth) {
plargs$ploptions$smooth.col <-
rep(colorpale(lpcol,lsmpale), lngrp)
plsmooth(lxjg, lyjg, plargs=plargs)
}
plpoints(lxjg, lyjg, type=type, plab=lplab, pch=lpchg, col=lpcol,
plargs=plargs, marpar=marpar, xy=FALSE)
lrgold <- lrgj
if (rescale & lj==2) {
plaxis(4, lyjg, range=lrgj, col=lpcol,
tickintervals=i.getploption("tickintervals"),
ploptions=ploptions, marpar=marpar)
}
}
}
}
}
}
}
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plyx
## ==========================================================================
plregr.control <- #f
function(x, data = NULL, xvar = TRUE, transformed = FALSE,
## generate variables used for plotting
weights = NULL, stdresid = TRUE, mar = NULL,
## specify some specific aspects / contents of plots
glm.restype = "working", condquant = TRUE, smresid = TRUE,
partial.resid = NULL, addcomp = NULL, cookdistlines = NULL,
leveragelimit = NULL, condprob.range = NULL,
testlevel = 0.05,
## smooth and refline
refline = TRUE,
smooth = 2, smooth.sim=NULL,
xlabs = NULL, reslabs = NULL, markextremes = NULL,
## multiple frames
mf = TRUE, mfcol = FALSE, multnrow = 0, multncol = 0, marmult = NULL,
oma = NULL, assign = TRUE, ... )
{ ## get data for plotting, collect and check arguments
## do preparations that are common to plregr and plresx
## --------------------------------------------------------------
lcall <- match.call()
## formula(x) inappropriate for merMod
lform <- if (inherits(x, "regrMer")) x$formula else formula(x)
## ... if it inherits from lm ??? whatsthat?
## lmodvdupl <- u.varsin2terms(lform[-2])
lnaaction <- x$na.action
if (!u.isnull(lnaaction)) class(lnaaction) <- "exclude"
x$na.action <- lnaaction
## --- family
lfam <- c(x$distrname, x$family$family, "")[1]
if (lfam=="" & inherits(x, "lm")) lfam <- "gaussian"
lfamgauss <- lfam%in%c("gaussian","Gaussian")
lfamcount <- (lfam%in%c("binomial","poisson")&&length(unique(x$y))<=2) |
inherits(x,"polr") ## lfam=="multinomial"
lcensored <- inherits(x[["y"]], "Surv")
## lnnls <- !inherits(x, "nls")
condquant <- NULL
lcq <- i.getplopt(condquant)
## --- residuals
## --- na.action: always get full data
## residuals first because they fix the number of observations
## lres <- residuals(x)
rtype <- i.def(i.def(if(lfamcount & lcq) "condquant", glm.restype), "working")
if (inherits(x, "survreg"))
lres <- residuals.regrsurvreg(x, type = if (lcq) "condquant")
if (inherits(x, "coxph"))
lres <- residuals.regrcoxph(x, type = if (lcq) "condquant")
if (inherits(x, "polr"))
x$residuals <- lres <- residuals.regrpolr(x, type = if (lcq) "condquant")
if (inherits(x, "lm")) ## !!! should be glm ?
lres <-
if (lfamcount) residuals.regrpolr(x, type=rtype)
else structure(residuals(x, type = rtype), type = rtype)
if (inherits(x, "regrMer"))
lres <- i.naresid.exclude(lnaaction, resid(x))
lres <- as.data.frame(lres)
lmres <- ncol(lres)
lzl <- i.def(i.getploption("zeroline"), 0)
if (u.notfalse(lzl))
for (lj in seq_len(lmres)) attr(lres[,lj], "zeroline") <- lzl
lnobs <- sum(is.finite(lres[,1]))
lIres0 <- all( apply(lres[,1:lmres, drop=FALSE],2,
function(x) all(x==dropNA(x)[1], na.rm=TRUE ) ) )
if (lIres0)
stop("!plregr/plresx! all residuals are equal -> no residual plots")
lnres <- nrow(lres)
## --- ldfres
ldfres <- df.residual(x)
ldfmod <- i.def(x$rank, length(coef(x)))
if (u.isnull(ldfres)) ldfres <- lnres-ldfmod
## --- sigma
lsigma <- x$sigma
if (length(lsigma)==0) lsigma <- c(x$scale, summary(x)$sigma)[1]
if (length(lsigma)==0)
lsigma <-
if (lfamcount) 0
else sqrt(apply(lres^2,2, function(x) sum(x[is.finite(x)]))/ldfres)
x$sigma <- lsigma
## --- standardized residuals
llev <- x$leverage
llevlim <- i.getplopt(leveragelimit)
if (length(llevlim)==1)
llevlim <- c(llevlim, i.getploption("leveragelimit")[2])
lstdres <- attr(lres, "stdresiduals", exact=TRUE)
if (stdresid) { ## not needed for plresx
if (length(lstdres)==0) {
lstdres <- stdresiduals(x, residuals=lres, leveragelimit=llevlim[2])
llev <- attr(lstdres, "leverage", exact=TRUE)
attr(lres, "stdresratio") <- attr(lstdres, "stdresratio", exact=TRUE)
attributes(lstdres)[c("leverage","stdresratio","stddev")] <- NULL
attr(lres, "stdresiduals") <- lstdres
} ## else lstdres <- lres
else llev <- naresid(lnaaction, llev)
if (length(llev)==0) llev <- leverage(x)
}
## residual names
lyexpr <- deparse(lform[[2]])
lynm <- if (nchar(lyexpr)>10) "Y" else lyexpr ##
lrn <- paste("res_", if (lmres>1) colnames(lres) else lynm, sep="")
lresname <-
gsub("\\(",".", gsub("\\)",".", gsub("\\*",".", gsub("/",".", gsub("\\^",".",
lrn)))))
names(lres) <- lresname
## --- fit
lfit <- x$linear.predictor
lfitname <- "linear predictor"
if (inherits(x, "polr")) lfit <- fitted.regrpolr(x, type="link")
else {
if(is.null(lfit)) {
lfit <- fitted(x)
lfitname <- "fitted value"
} else lfit <- naresid(lnaaction, lfit)
}
lfitname <- rep(lfitname, length=lmres)
lfit <- as.data.frame(lfit)
lfit <- genvarattributes(as.data.frame(lfit),
innerrange=i.getploption("innerrange.fit")) ## extra element of ploptions!)
attr(lfit[[1]], "varlabel") <- lfitname
## --- xvar
lxvar <-
if (u.notfalse(xvar)) {
lxf <- if (transformed) lform else {
lx <- all.vars(lform[-2])
if (inherits(x, "nls")) lx <- setdiff(lx, names(coef(x)))
u.asformula(lx)
}
if (!(u.isnull(xvar)|u.true(xvar))) {
if (is.character(xvar)) { ## xvar : names of variables
lxvarf <- u.asformula(setdiff(xvar,"."))
lxf <- if ("."%in%xvar) update(lxf, lxvarf) else lxvarf
}
else {
if (is.formula(xvar)) lxf <- update(lxf, xvar)
else
stop("!plregr.control! Inadequate argument 'xvar'")
}
}
attr(getvarnames(lxf, data=data, transformed=transformed), "xvar")
## lxvraw <- u.allvars(lxvar)
} else NULL
## xvar should now be a character vector of names of variables
## --- prepare pl.control
lcall <- as.list(match.call())[-1]
ladrop <- c("xvar", "glm.restype", "smresid", "partial.resid", "addcomp",
"cookdistlines", "leveragelimit", "smooth", "smooth.sim",
"refline", "testlevel", "xlabs", "reslabs",
"mf", "mfcol", "multnrow", "multncol", "marmult", "oma")
lcall <- c(as.list(quote(pl.control)),
as.list(lcall[setdiff(names(lcall),ladrop)]))
lcall$y <- lres
lcall$markextremes <- markextremes
## --- data
ldata <- x$model
if (length(ldata)&&length(lnaaction))
ldata <- i.naresid.exclude(lnaaction, ldata)
if (length(lxvar)) {
lcall$x <- lxvar
lcall$transformed <- transformed
## lcall$.subdefault <- i.form2char(lform) ## transfer to sub
## --- data argument
if (length(lxvar)||any(names(lcall)%in%i.argPldata)) {
if (length(ldata)==0||!(transformed & all(lxvar%in%names(ldata)))) {
ldata <- data
if (length(ldata)==0) {
##- if (length(x$allvars))
##- ldata <- i.naresid.exclude(lnaaction, x$allvars)
##- else ldata <- getvariables(x$call$formula, eval(x$call$data), transformed=FALSE) ##eva
ldt <- x$allvars
if (is.null(ldt)) ldt <- x$model ## has transformed variables
lxv <- setdiff(lxvar, names(ldt))
ldata <-
if (length(lxv)) {
ldt <- eval(x$call$data)
if ("subset"%in%names(x$call)) ldt <- ldt[row.names(lres),]
ldt
} else i.naresid.exclude(lnaaction, ldt)
}
if (length(ldata)==0) stop("!plregr.control! No data found")
}
##
if (lnres!=nrow(ldata)) {
if (class(lnaaction)%in%c("omit", "exclude")) ldata <- ldata[-lnaaction,]
## if (lnr!=nrow(ldata)) ldata <- x$model ## needs at least a warning!
if (lnres!=nrow(ldata))
stop("!plregr.control! nrow of residuals and data do not agree.")
}
}
##- if (length(lxvmiss <- setdiff(lxvar, names(ldata)))) {
##- ldt <- getvariables(lxvmiss)
##- if (nrow(ldt)!=nrow(ldata))
##- stop("!plregr/plresx! variable(s) ",
##- paste(lxvmiss, collapse=", "), " not suitable - wrong number of rows")
##- ldata <- cbind(ldata,ldt)
##- }
} else {
ldata <- lres ## needed to get number of observations
lcall$x <- NULL
} ## needed to get nobs in pl.control
lcall$data <- ldata
lftext <- i.form2char(lform)
lcall$.subdefault <- lftext
lcall$assign <- FALSE
mode(lcall) <- "call"
## -------------------------------------
plargs <- eval(lcall, parent.frame()) ## pl.control
## -------------------------------------
ploptions <- plargs$ploptions
ploptions$smooth <- i.getplopt(smooth)
plargs$plfeatures$main <- i.def(ploptions$main, i.form2char(lform))
lpldata <- plargs$pldata
ly <- i.def(x[["y"]], if (length(ldata)) ldata[,1, drop=FALSE])
lbinary <-
inherits(x, "glm") && length(unique(ly))==2 ## binary binomial
if (u.true(lfamcount)) ploptions$smooth.iter <- 0
lIcq <- u.true(lcq) & (lbinary|lcensored)
## ---
xvar <- attr(lpldata, "xvar", exact=TRUE)
## margins for multivariate regression !!!
lmmar <- rep(i.getploption("panelsep"), length=4)
lmmar[2] <- i.getplopt(mar)[2] +0.5
if (length(marmult)) ## !!! marmult
lmmar <- ifelse(is.na(lmr <- rep(marmult, length=4)), lmmar, lmr)
lmmar[1] <- i.def(i.getploption("mar")[1], 3)
lmmar[3] <- i.def(i.getploption("mar")[3], 0.5) ##!!!
## -------------------------------------------------------
## attributes for residuals
lres <- genvarattributes(lres, varlabel = lresname, ploptions=ploptions)
if (lmres>1) { ## multivariate
if (u.isnull(lcn <- colnames(lres))) lcn <- 1:ncol(lres)
colnames(lres) <- lcn # paste("res", lcn, sep=".")
}
## mark extreme stdres
lmxdef <- markextremes(lnobs)
if (is.atomic(markextremes)) {
markextremes <- i.def(markextremes, NA)
if (anyNA(markextremes)) markextremes <- lmxdef
markextremes <-
list("(res)"=markextremes, "(fit)"=0, "(lev)"=c(0,max(markextremes)) )
}
lmxres <- i.def(markextremes$"(res)", lmxdef) ## ???
lresplab <-
if (lmxres>0 & stdresid)
apply(lstdres, 2,
function(x) plmark(x, markextremes = lmxres,
plabel=plargs$plfeatures$plabel) )
else NULL
## --- smoothWeights, used for smooth calculation: get from x if needed
lsmwgt <- lpldata[["(smoothWeights)"]] ## possibly only logical
lIsmweights <- is.logical(lsmwgt)&&all(lsmwgt) ## weights explicitly required
if (lIsmweights | (length(lsmwgt)&&all(is.na(lsmwgt))))
lsmwgt <- naresid(lnaaction, x$weights)
lIsmwgt <-
length(lsmwgt)>1 && any(lsmwgt!=dropNA(lsmwgt)[1],na.rm=TRUE)
if (lIsmweights&!lIsmwgt)
warning(":plregr/plresx: no weights found for smooth calculation.")
lpldata[["(smoothWeights)"]] <- ## lsmweights <-
if (lIsmwgt) lsmwgt / mean(lsmwgt[is.finite(lsmwgt)]) else NULL
## --- psize, used as sizes of plotting characters: same as weights
lpsize <- lpldata[[".psize."]] ## possibly only logical
lIpsize <- is.logical(lpsize)&&all(lpsize) ## psize expl. required
if (u.isnull(lpsize) | lIpsize | (length(lpsize)&&all(is.na(lpsize))))
lpsize <- if (length(lsmwgt)) lsmwgt else naresid(lnaaction, x$weights)
lIpsz <-
length(lpsize)>1 && any(lpsize!=dropNA(lpsize)[1],na.rm=TRUE)
if (lIpsize&!lIpsz)
warning(":plregr/plresx: no plot sizes found.")
lpldata[[".psize."]] <-
if (lIpsz) lpsize / mean(lpsize[is.finite(lpsize)]) else NULL
## mahalanobis residuals
lresmahal <- naresid(lnaaction, x$resmahal)
if (lmres>1)
if (u.isnull(lresmahal))
lresmahal <-
mahalanobis(lres,0,
var(apply(lres,2, function(x) ifelse(is.finite(x), x, NA)),
na.rm=TRUE))
## --- simulated residuals
## when using smooth.group , default is 0
lnsims <- i.def(smooth.sim, 19, 19, 0)
if (inherits(x, c("mlm", "polr", "survreg", "coxph", "regrMer"))) lnsims <- 0
if (lmres>1) lnsims <- 0 # !!! not yet programmed for mlm
if (lnsims>0 & !inherits(x, c("lm","glm","lmrob","nls"))) {
warning(":plregr/simresiduals: ",
"I can simulate only for 'lm', 'lmrob', 'nls' and 'glm' objects")
lnsims <- 0
}
lsimres <- NULL
if (lnsims>0) {
lsimres <- if(ploptions("debug"))
simresiduals(x, lnsims, glm.restype=rtype) else
try(simresiduals(x, lnsims, glm.restype=rtype), silent=TRUE)
if (inherits(lsimres, "try-error")) {
warning(":plregr/simresiduals: simresiduals did not work. ",
"No simulated smooths")
lsimres <- NULL
lnsims <- 0
}
} ## !!! ---
## --- multiple frames
mf <- i.def(mf, NULL, TRUE, NULL)
oma <- i.def(oma, NULL, valuefalse=0)
if (length(oma)==2) oma <- c(0,0,oma)
## --- more arguments
reslabs <- i.def(reslabs, NULL, NULL, NULL)
smresid <- i.def(smresid, TRUE)
if (lmres>1) smresid <- FALSE ## !!! muss noch gemacht werden
## -----------------
addcomp <-
i.getinlist(partial.resid, addcomp, i.getploption("regr.addcomp"), TRUE)
##- addcomp <- partial.resid <-
##- i.def(i.def(i.getploption("regr.addcomp"), partial.resid),FALSE, TRUE, FALSE)
## partial.resid <- i.def(partial.resid, TRUE)
cookdistlines <- i.getplopt(cookdistlines)
ploptions$refline <- i.getplopt(refline)
testlevel <- i.getplopt(testlevel)
if (testlevel<=0 | testlevel>=1)
stop("!plregr.control! invalid test level")
## ------------------------------------------------------------
## result of plregr.control
plargs$pldata <- lpldata
plargs$plfeatures$smooth <- i.getplopt(smooth)
rr <-
list(pldata = plargs[[1]], ploptions = plargs[[2]],
plfeatures = plargs[[3]],
regrfeatures = list(
formula = lform,
na.action = lnaaction,
family = lfam, famgauss = lfamgauss, famcount = lfamcount,
df.residual = ldfres, df.model = ldfmod,
fit = lfit,
residuals = lres, resname = lresname, ## stdresname = lstdresname,
## absresname = labsresname, fitname = lfitname,
rescol = lmres, resplab = lresplab,
smresid = smresid,
glm.restype = glm.restype,
resmahal = x$resmahal,
simres = lsimres, ## simstdres <- lsimstdres,
response = ly,
yexpr = lyexpr,
## weights = x$weights,
sigma=lsigma,
leverage = llev,
leveragelimit = llevlim, ## condprob.range = condprob.range,
## linear.predictor = x$linear.predictor,
addcomp = addcomp, partial.resid = partial.resid,
cookdistlines = cookdistlines,
smooth.sim = lnsims,
refline = refline,
testlevel=testlevel,
mf=mf, multnrow = multnrow, multncol = multncol, marmult = lmmar
)
)
if (u.notfalse(assign)) plassign(list=rr)
rr
} ## end plregr.control
## -----------------------------------------------------------------------
i.merprep <- #f
function(x) {
ldfr <- df.residual(x)
lres <- residuals(x)
rr <- list(
## na.aaction = NULL,
family = family(x),
fitfun = "mer",
coefficients = coef(x),
fitted = fitted(x),
sigma = sqrt(sum(lres[is.finite(lres)]^2) / ldfr),
## leverage = NULL,
model = x@frame,
residuals = lres,
call = x@call,
formula = formula(x),
na.action = if (length(lnaaction <- attr(x@frame, "na.action", exact=TRUE)))
structure(lnaaction, class="exclude")
)
class(rr) <-
c("regrMer",
switch(rr$family$family, gaussian="lm", binomial="glm", poisson="glm",
"lm") )
rr
}
## -----------------------------------------------------------------------
plregr <- #f
function(x, data=NULL, plotselect = NULL, xvar = TRUE,
transformed = NULL, sequence=FALSE, weights=NULL,
addcomp = NULL, smooth = 2, smooth.legend = FALSE,
markextremes = NA,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{ ## mar needed because it would otherwise be taken for markextremes
## -------------------------------------------------------------------------
## Author: Werner Stahel, Date: 7 May 93 / 2002
##- argPlregr <- c("x", "data", "plotselect", ## "xvar", "transformed",
##- "sequence", "weights", "addcomp", "smooth.legend")
argPlregr <- c("plotselect", ## "xvar", "transformed", "addcomp",
"smooth.legend")
## ---
if (inherits(x,"mulltinom"))
stop("!plregr! I do not know how to plot residuals of a multinomial regression")
lImer <- inherits(x, "merMod")
if (lImer) x <- i.merprep(x)
## ----------------
if (is.null(plargs)) {
lcall <- match.call()
lcall <- lcall[setdiff(names(lcall),argPlregr)]
lcall$x <- x
## lcall$markextremes <- markextremes
lcall[1] <- list(quote(plgraphics::plregr.control)) ## need plgr:: because
## regr also uses this function
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
## !!! markextremes
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lregrft <- plargs$regrfeatures
## lplft <- plargs$plfeatures
## if (u.isnull(mar)) mar <- c(3,3,1,1)+i.getploption("panelsep")
marpar <- i.getmarpar(plargs=plargs) ## mar=mar,
## -------------------------------------------------------------------
## all these results from plregr.control include the na.action observations
lpldata <- plargs$pldata
lfit <- lregrft$fit
lres <- lregrft$residuals
lmres <- lregrft$rescol
lIcq <- inherits(lres, "condquant")
lresname <- lregrft$resname
lsimres <- lregrft$simres
lnsims <- if (length(lsimres)==0) 0 else ncol(lsimres)
llev <- lregrft$leverage
llevlim <- lregrft$leveragelimit
## lrefline <- i.getploption("refline")
lsimstdres <- lregrft$simstdres
x$na.action <- lnaaction <- lregrft$na.action
## from x
lweights <- naresid(lnaaction, x$weights)
if (c(x$family$family, " ")[1]=="poisson") lweights <- sqrt(lweights)
lIwgt <- length(lweights)>0
## number of observations
lnr <- nrow(lres)
lnna <- apply(lres, 1, function(x) all(is.finite(x)))
lnobs <- sum(lnna)
lregrft <- plargs$regrfeatures
## smooth legend
if (length(names(smooth.legend))==0) {
lsmlegend <- i.def(smooth.legend, NULL, TRUE, NULL)
if (length(lsmlegend)==1)
lsmlegend <-
setNames(rep(lsmlegend,5),
c("yfit","resfit","absresfit","absresweight","(xvar)") )
} else lsmlegend <- smooth.legend
## ---
lsmit <- if (inherits(x, "glm")) 0
else i.getploption("smooth.iter")
plargs$ploptions$smooth.iter <- lsmit
## on.exit(ploptions(loldplo), add=TRUE, after=FALSE)
## -----------------------------------
## plot selection
lplsel <- unlist(
i.plotselect(plotselect, Iwgt=lIwgt,
mult=lmres>1,
famgauss=lregrft$famgauss,
famglm=inherits(x,"glm"),
famcount=lregrft$famcount)
)
lplsel <- lplsel[is.na(lplsel)|lplsel>0]
lnplsel <- length(lplsel)
## standardized residuals
lstdres <- as.data.frame(attr(lres, "stdresiduals", exact=TRUE))
lstrratio <- as.data.frame(attr(lres, "stdresratio", exact=TRUE))
lresplab <- lregrft$resplab
## cat("lresplab ", str(lresplab))
lIrpl <- length(lresplab)>0
if (any(lii <- c("qq","leverage","absresfit","absresweights")%in%names(lplsel))) {
lIabs <- any(lii[3:4])
labsres <- if (lIabs) lstdres
lstdresname <- paste("st.", lresname, sep = "")
labsresname <- paste("|st.",lresname,"|", sep="")
lIqq <- lii[1]
lstdrsc <- if (lIqq) lstdres
##
for (lj in seq_len(lmres)) {
lrsj <- lres[,lj]
## residuals from smooth
if (lregrft$smresid) { ## !!! transfer to plregr.control
lfsm <- gensmooth(lfit[,lj], lrsj, plargs=plargs)
lfsmr <- residuals(lfsm)
if (lna <- sum(is.na(lfsmr)&!is.na(lres[,lj])))
warning(":plregr: residuals from smooth have ",
round(100*lna/lnobs,1), " % additional NAs")
## lstdres[,lj] <-
lrsj <- lfsmr * lstrratio[,lj] ## !!! * f(leverage of smooth)
if (lIcq) {
lcq <- attr(lrsj, "condquant", exact=TRUE)
if (length(lcq)) {
li <- lcq[,"index"]
lcq[,1:4] <- ( lcq[,1:4]-lcq[,1]+lfsmr[li] ) *lstrratio[li,lj]
## attr(lfsmr, "condquant") <- lcq
## attr(lstdres[,lj], "condquant") <- lcq
attr(lrsj, "condquant") <- lcq
}
} else {
##- if (lIcq) {
##- lcq <- attr(lrsj, "condquant", exact=TRUE)
##- if (length(lcq)) {
##- lcq[,1:4] <- lcq[,1:4]*lstrratio[lcq[,"index"],lj]
##- attr(lrsj, "condquant") <- lcq
##- }
##- }
lstdres[,lj] <- lrsj
}
if (lnsims) lsimstdres <- lsimres * lstrratio[,lj] ## index needed for multiv
} ## fi lregrft$smresid
if (lIabs) labsres[,lj] <- abs(lrsj)
if (lIqq) { ## scale smoothed residuals by smoothed scale
lfsm <-
gensmooth(lfit[,lj], abs(lrsj), plargs=plargs, power=0.5)
##- if (lna <- sum(is.na(lsj)&!(is.na(lres[,lj])|is.na(lrsj))))
##- warning(":plregr: residuals from smooth have ",
##- round(100*lna/lnobs,1), " % additional NAs")
lstdrsc[,lj] <- lrsj/lfsm[["ysmorig"]]
}
}
if (lregrft$smresid) {
lstdresname <- paste("st.sm.", lresname, sep = "")
labsresname <- paste("|st.sm.",lresname,"|", sep="")
}
names(lstdres) <- lstdresname
lstdres <- genvarattributes(lstdres, ploptions=ploptions)
if (lIabs) {
labsres <-
genvarattributes(labsres, ploptions=ploptions, varlabel=labsresname)
for (lj in seq_len(lmres))
attr(labsres[,lj], "plrange")[1] <- 0
}
}
## --- multiple frames xxx
lmf <- i.def(lregrft$mf, NULL, TRUE, NULL)
if (length(lmf)) {
if (u.true(lmf)) ## is.logical(lmf)&&lmf)
lmf <- if (lmres>1) {
if (lmres<=4) c(lmres, NA) else lmres
} else lnplsel
## if (lnplsel<=2) lnplsel else c(2)
}
if (length(lmf)==2) {
if (is.na(lmf[1])) {
lmf1 <- ceiling(lnplsel/lmf[2])
if(lmf1>lmf[2]+1) lmf1 <- lmf[2]
lmf[1] <- lmf1
}
if (is.na(lmf[2])) {
lmf1 <- ceiling(lnplsel/lmf[1])
if(lmf1>lmf[1]+1) lmf1 <- lmf[1]
lmf[2] <- lmf1
}
}
## lbyrow <- i.def(ploptions$byrow, FALSE)
## outer margin
##- loma <- c(3,3,2,1)*(length(lmf)>0)
##- lomaarg <- i.getploption("oma") ## i.def(plargs$plmarpar$oma, NULL, valuefalse=NULL)
##- if (length(lomaarg))
##- if (length(lomaarg)==1) loma[3] <- lomaarg
##- else loma <- rep(lomaarg, length=4)
loldpar <- par(c("mar","mgp"))
lmfpar <- NULL
if (length(lmf)&(!is.logical(lmf))) {
lmfpar <- plmframes(mft=lmf, plargs=plargs)
loldpar <- c(loldpar, attr(lmfpar,"oldpar"))
}
loldpar <- loldpar[!duplicated(names(loldpar))]
on.exit(par(loldpar), add=TRUE, after=FALSE)
## --------------------------------------------------------------------
## start plots
if (length(lplsel))
for (liplot in seq_along(lplsel)) {
lpllevel <- lplsel[liplot]
lpls <- names(lpllevel)
## ------------------------------------------------------------
## --- y on fit
if(lpls=="yfit") {
##- lsml <- if (length(lsmlegend["yfit"]))
##- setNames(rep(lsmlegend["yfit"],length(lregrft$yname)),
##- lregrft$yname) else lsmlegend
ly <- lregrft$response ##attr(lpldata, "yvar")
if (length(ly)==0)
warning(":plregr: response not found")
else {
lregrft$smooth <- lpllevel-1
## plargs$parpar$mar <- lmar
lregrft$reflinecoord <- c(x=0,y=1) ## median(lfit[,lj], na.rm=TRUE)
for (lj in seq_len(ncol(ly))) {
lyj <- ly[,lj]
lfj <- lfit[,lj]
if(length(lsimres))
lyj <- structure(data.frame(lyj, lfj+lsimres), primary=1)
plpanel(x=lfj, y=lyj, frame=TRUE, xlab="fitted values",
plargs=plargs)
}
}
## lregrft$reflinecoord <- NULL
}
## ------------------------------------------------------------
## --- Tukey Anscombe plot
if(lpls=="resfit") {
for (lj in seq_len(lmres)) {
lplargs <- plargs
lplargs$plfeatures$smooth <- lpllevel-1
lplargs$plfeatures$reflinecoord <-
c(x=median(lfit[,lj], na.rm=TRUE),y=-1)
lrsj <- lres[,lj]
if(length(lsimres))
lrsj <- structure(data.frame(lres[,lj], lsimres), primary=1)
plpanel(lfit[,lj], lrsj, frame=TRUE,
xlab="fitted values", plargs=lplargs)
}
## lregrft$reflinecoord <- NULL
## par(cex=lcex)
}
## ------------------------------------------------------------
## --- scale plot
if(lpls=="absresfit")
if(length(labsres)==0)
warning(":plregr: No standardized residuals found")
else {
plargs$plfeatures$smooth <- lpllevel-1
for (lj in seq_len(lmres)) {
labsrj <- labsres[,lj, drop=FALSE]
if (lnsims)
labsrj <- structure(data.frame(labsrj, abs(lsimstdres)),
primary=1)
plpanel(lfit[,lj], labsrj, frame=TRUE, xlab="fitted values",
plargs=c(plargs, list(smooth.power=0.5)) ) ## plsmooth needs 'power'
}
## par(cex=lcex)
}
## ------------------------------------------------------------
## --- plot abs. res vs. weights
if(lpls=="absresweights") {
if (length(lweights)!=lnr)
warning(":plregr: no suitable weights found.",
"cannot plot absres on weights")
else { ## copy from absresfit
lwg <- lweights
lwg[lwg<=0] <- NA
lwg <- genvarattributes(data.frame(lwg))
if (attr(lwg[,1], "plrange", exact=TRUE)[1]<0.3)
attr(lwg[,1], "plrange")[1] <- 0
for (lj in seq_len(lmres)) {
labsrj <- labsres[,lj, drop=FALSE]
if (lnsims)
labsrj <- structure(data.frame(labsrj, abs(lsimstdres)), primary=1)
plpanel(lwg, labsrj, frame=TRUE, xlab="weights", ## title=NA,
ylab=paste("|",lresname,"| * sqrt(w)", sep=""),
plargs=c(plargs, list(smooth.power=0.5))) ## plsmooth needs 'power'
}
## par(cex=lcex)
}
}
## ------------------------------------------------------------
## --- normal plot qq plot
if(lpls=="qq") {
lnsims <- if (length(lsimstdres)) ncol(lsimstdres) else 0
if (lnsims)
lsimstdr <-
if (i.def(attr(lsimstdres, "type", exact=TRUE), "resampled")=="resampled")
simresiduals.default(x, nrep=lnsims, simfunction=rnorm,
sigma=apply(lstdrsc, 2, mad, na.rm=TRUE) )
else lsimstdres
for (lj in seq_len(lmres)) {
llr <- lstdrsc[,lj] ## residuals from smooth, smoothly scaled
lio <- order(llr)[seq_len(lnobs)]
llr <- plsubset(llr, lio)[,1]
if (length(lat <- attr(llr, "numvalues", exact=TRUE)))
attr(llr, "numvalues") <- lat[lio]
if (length(lat <- attr(llr, "plcoord", exact=TRUE)))
attr(llr, "plcoord") <- lat[lio]
lIcqj <- length(lcq <- attr(llr, "condquant", exact=TRUE))>0 ##!!! falsch ?
lIcqu <- lIcq | lIcqj
lxx <- qnorm(ppoints(lnobs))
attr(lxx, "zeroline") <- 0
plframe(lxx, llr, xlab = "theoretical quantiles",
ylab = lstdresname[lj], ploptions=ploptions,
xy=FALSE) ## mar=lmar,
if (lnsims>0) {
llcol <- colorpale(i.getploption("smooth.col"),
pale=i.getploption("smooth.pale"))
llty <- tail(i.getploption("smooth.lty"),1)
llwd <- i.getploption("linewidth")[llty]
apply(lsimstdr, 2,
function(x) lines(lxx,sort(x), lty=llty, lwd=llwd,
col=llcol) )
}
plpoints(lxx, llr, plargs=list(pldata=plargs$pldata[lio,]),
ploptions=ploptions, marpar=marpar, xy=FALSE)
lquart <- quantile(llr, c(0.25,0.75), na.rm=TRUE)
## qq line
plrefline(c(0, diff(lquart)/(2*qnorm(0.75))), plargs=plargs)
if(lIcq & lj==lmres)
legend("bottomright",
pch=c(rep(ploptions$censored.pch,length=2)),
legend=c("uncensored","censored"))
## pltitle(plargs=plargs, show=FALSE)
}
}
## ------------------------------------------------------------
## --- leverage plot. If weight are present, use "almost unweighted h"
if(lpls=="leverage")
if ((!is.na(lpllevel))&&lpllevel>0) {
if (lIwgt) llev <- llev/lweights
if (diff(range(llev,finite=TRUE))<0.001)
notice("plregr: all leverage elements equal, no leverage plot")
else {
llevpl <- genvarattributes(
##- data.frame(leverage = plcoord(llev, c(0,llevlim[1]),
data.frame(leverage=llev),innerrange= list(leverage=c(0,llevlim[1])),
ploptions=ploptions)[,1]
attr(llevpl, "plrange")[1] <- 0
lstdres <- genvarattributes(lstdres, varlabel = lstdresname)
## mark extremes
lmx <- i.getplopt(markextremes)
if (is.list(lmx)) lmx <- lmx[["(lev)"]]
if (is.function(lmx)) lmx <- lmx(lnobs)
lmx <- tail(i.def(lmx, 0),1)
if (lImxlev <- lmx>0)
lpllev <- plmark(llev, markextremes=c(0,lmx),
plabel=lregrft$plabel)
##
llevtit <- paste("leverage", if(lIwgt) "(de-weighted)")
ldfmod <- lregrft$df.model
lcookl <- lregrft$cookdistlines
if (i.def(ldfmod, 0)<=1) {
warning(":plregr: model degrees of freedom <=1. No Cook-distance lines")
lcookl <- NULL
}
if (lIcook <- length(lcookl)>0) {
llx <- seq(0, max(llev[is.finite(llev)]-.Machine$double.eps), length=50)
## see formula for curves of constant Cook's distance in terms of
## standardized residuals
llrcd <- outer(sqrt((1-llx)/((ldfmod-1)*llx)), c(lcookl,-lcookl))
}
for (lj in 1:lmres) {
lstrj <- lstdres[,lj]
lplj <- if (lIrpl) lresplab[,lj] else rep("", lnr)
if (lImxlev) {
lplj <- ifelse(lpllev=="", lplj, lpllev)
if (any(lplj!="")) plargs$pldata$.plab. <- lplj
}
if (lIcook) lregrft$reflinecoord <- list(x=llx, y=llrcd)
lplopt <- ploptions(smooth=FALSE, assign=FALSE)
plpanel(llevpl, lstrj, xlab=llevtit,
plargs=plargs, ploptions = lplopt,
frame=TRUE)
lregrft$reflinecoord <- NULL
}
}
## par(cex=lcex)
}
## -----------------------------------------------------------------
## --- multivariate:
## residual matrix for multivariate regr
if(lpls=="resmatrix") {
lpanel <-
function(x, y, indx, indy, pch, col, plab, panelargs=plargs, ...)
plpoints(x,y, plargs=panelargs, marpar=marpar, xy=FALSE)
if (lregrft$rescol>1) {
lpa <- plargs
lpa$pldata <- lpa$residuals
lpa$mar <- NULL
plmatrix(lres, panel=lpanel, plargs=lpa) #main=lregrft$main, pch=lregrft$pch
}
}
## --- mahalanobis residuals
if(lpls=="qqmult") ## qq plot of Mahalanobis lenghts for multivariate regr
if ((!is.na(lpllevel))&&lpllevel>0) {
lresmahal <- lregrft$resmahal
if (is.null(lresmahal)) ## should never happen. generated in plregr.control !!!
lresmahal <-
mahalanobis(lres,0,
var(apply(lres,2, function(x) ifelse(is.finite(x), x, NA)),
na.rm=TRUE))
lxx <- sqrt(qchisq(ppoints(lresmahal),ncol(lres)))
lio <- order(llr)[seq_len(lnobs)]
llr <- transferAttributes(llr[lio], llr) ## may need plsubset
lor <- order(lresmahal)
lyy <- sqrt(lresmahal[lor])
lop <- par(mfrow=c(1,1), oma=c(0,0,2,0))
plframe(lxx,lyy, xlab="sqrt(Chisq.quantiles)",
ylab = "Mahal.oulyingness",
ploptions=ploptions, xy=FALSE)
points(lxx,lyy, type="b") ## !!! plpoints
## !!! needs work!!!
## if (ltxt) text(lxx,lyy, plab[lor]) # else points(lxx,lyy,pch=lplab[lor])
abline(0,1,lty = ploptions$grid.lty, col=ploptions$grid.col)
##- pltitle(plargs=plargs, show=FALSE)
##- stamp(sure=FALSE, ploptions=ploptions)
par(lop)
}
pltitle(plargs=plargs)
stamp(sure=FALSE, ploptions=ploptions)
} ## end lplsel
## ----------------------------------------------------------------
## plot residuals vs. explanatory variables by calling plresx
## ----------------------------------------------------------
plargs$plfeatures$mf <- FALSE ## avoid a new page
## lregrf$ylim <- lylim ## no need to calculate again
## plargs$plmarpar$mar <- lmar + c(0,0,1.5,0)
lxvar <- if (u.notfalse(xvar)) attr(lpldata, "xvar", exact=TRUE)
if (!i.def(sequence, FALSE)) lxvar <- setdiff(lxvar, ".sequence.")
## avoid plot against x in simple regression
if (length(lxx <- setdiff(lxvar, c(".sequence.", ".weights.")))==1 &&
"resfit"%in%names(lplsel)) {
## ltr <- i.def(transformed, FALSE) || lxx%in%
if (lxx %in% names(lpldata)) {
message("plregr: plot of residuals on ", lxx,
" not shown because it is equivalent to 'resfit'")
lxvar <- setdiff(lxvar, lxx)
}
}
if (length(i.def(lxvar, NULL, valuefalse=NULL)))
plresx(x, data=data, resid=lres, xvar=lxvar,
transformed = transformed, sequence=sequence,
weights= if ("weights"%in%names(lplsel)) FALSE else NULL,
addcomp = addcomp, smooth.legend=lsmlegend,
plargs = plargs)
## --- end plregr
invisible(plargs)
}
## ==========================================================================
i.plotselect <- #f
function(plotselect, smooth=2, Iwgt = FALSE, mult = FALSE,
famgauss = TRUE, famglm = FALSE, famcount = FALSE)
{
## plot selection
smooth <- i.getplopt(smooth)
lsmdef <- 1+smooth-famglm
lplsel <- i.getploption("regr.plotselect")
lplsel["resfit"] <- i.def(lplsel["resfit"], lsmdef)
if (length(plotselect)>0) {
lplotsel <- unlist(plotselect)
if (length(lplotsel)!=length(plotselect)) {
warning(":i.plotselect: unsuitable argument.",
"'plotselect' should be a vector")
return(lplsel)
}
lpls <- TRUE
lplnm <- names(plotselect)
if (length(lplnm)==0) {
if (length(plotselect)==length(lplsel))
lplnm <- names(lplsel)
else {
warning(":plregr: Inadequate argument plotselect")
lpls <- FALSE}
}
if (lpls) {
if ("default"%in%lplnm) {
lplnm <- setdiff(lplnm, "default")
lplsel[] <- if (plotselect["default"]==0) 0 else
pmin(lplsel,plotselect["default"])
}
lina <- is.na(match(lplnm,c(names(lplsel),"default")))
if (any(lina)) {
warning(":plregr: Inadequate elements in plotselect: ",
paste(names(plotselect)[lina], collapse=", "))
lplnm <- lplnm[!lina] }
lplsel[lplnm] <- plotselect[lplnm]
}
}
if (!mult) lplsel[c("resmatrix","qqmult")] <- 0
if (is.na(lplsel["yfit"])) lplsel["yfit"] <- 0
if (is.na(lplsel["resfit"]))
lplsel["resfit"] <- lsmdef * (lplsel["yfit"]==0)
if (is.na(lplsel["absresfit"]))
lplsel["absresfit"] <- 2 * !famcount
if (is.na(lplsel["absresweights"]))
lplsel["absresweights"] <- 2 * (famgauss&Iwgt)
if (is.na(lplsel["qq"])) lplsel["qq"] <- famgauss # how about gamma? !!!
lplsel
} ## end i.plotselect
## ==========================================================================
plresx <- #f
function(x, data = NULL, xvar = TRUE, transformed = NULL,
sequence = FALSE, weights = NULL,
addcomp = NULL, smooth = 2, smooth.legend = FALSE,
markextremes = NA,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
## ------------------------------------------------------------
{ ## plresx
lcall <- match.call()
if (length(plargs)==0) {
lac <- as.list(lcall)[-1]
lac$stdresid <- FALSE
ladrop <- c("sequence", "weights", "smooth.legend")
lcall <-
c(list(quote(plregr.control)), lac[setdiff(names(lac), ladrop)])
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
marpar <- i.getmarpar(plargs=plargs)
## -------------------------------------------------------------------
if (inherits(x,"mulltinom"))
stop("!plresx! I do not know how to plot residuals of a mulitnomial regression")
lpldata <- plargs$pldata
lvars <- attr(lpldata, "xvar", exact=TRUE)
## ---
lplft <- plargs$plfeatures
if (u.isnull(transformed))
transformed <- i.def(lplft$transformed, length(xvar)>0)
lregrft <- plargs$regrfeatures
## show reference lines?
lshrefl <- u.notfalse(i.getploption("refline")) & !inherits(x,"coxph")
lres <- lregrft$residuals
lIcq <- inherits(lres, "condquant")
## lform <- lregrft$formula
lsimres <- lregrft$simres
lnsims <- if (is.null(lsimres)) 0 else ncol(lsimres)
lInnls <- !inherits(x, "nls")
lnr <- nrow(lpldata)
lIwgt <- length(lregrft$weights)>0 &
!inherits(x, "glm") ## do not plot against weights for binom,...
lnaaction <- lregrft$na.action
## lweights <- naresid(lnaaction, lregrft$weights)
## --- sequence
lIseq <- i.def(sequence, FALSE, TRUE, FALSE)
if (lIseq) {
if (length(lvars)) {
## is the seqence represented by any other variable?
lseqvar <-
if (length(lvars)>0)
sapply(lpldata[,lvars,drop=FALSE],function(x) {
if (is.factor(x)||is.character(x)) FALSE else {
ld <- diff(x)
sum(ld==0)<0.1*length(x) && (all(ld<=0) | all(ld>=0)) }
} ) else FALSE
lIseq <- !any(lseqvar)
if (!lIseq) warning(paste(":plresx: sequence represented by",
paste(lvars[lseqvar],collapse=", ")))
}
lpldata$".sequence." <- structure(1:lnr, varlabel="sequence", zeroline=FALSE)
lvars <- c(lvars,".sequence.")
}
## --- weights as x variable
lIweights <- i.def(weights, lIwgt, TRUE, FALSE)
if (lIweights)
if (!lIwgt)
warning(":plresx; No weights found.",
" Cannot plot residuals against weights") else {
lpldata[,".weights."] <- naresid(lnaaction, lregrft$weights)
lvars <- c(lvars, ".weights.")
}
## ------------------
if (is.null(lvars)) {
warning(":plresx: I did not find any x variables")
return() }
## terminouterel
lvmod <- all.vars(formula(x)[-2])
if (transformed) {
ltrms <- rownames(attr(terms(x),"factors", exact=TRUE))
lvrs <- u.allvars(ltrms) ## which terms contain which vars?
litrms <- sapply(lvrs, function(x) any(x%in%c(lvars,ltrms)) )
lvmod <- ltrms[litrms | ltrms%in%lvars]
} else {
lvi <- pmatch("(", lvars, nomatch=0)
lvars <-
if (any(lvi>0)) c(unlist(u.allvars(lvars[-lvi])),lvars[lvi])
else unlist(u.allvars(lvars))
}
lnvars <- length(lvars)
terminouterel <- lvars%in%lvmod
lvcomp <- intersect(lvars, lvmod) ## variables that appear in the model
## type
addcomp <- as.logical(i.def(addcomp, FALSE, TRUE, FALSE))
## lpa <- plargs
lInnls <- !inherits(x, "nls")
## -----------------------------------
## fit components for refline
lIcomp <- addcomp|lshrefl ## components needed?
if (lIcomp&&length(lvcomp)&lInnls) { ## fit components
if (length(x$call$data)==0) x$call$data <- lpldata ## in this case,
## only model vars can be used
lcomp <- fitcomp(x, vars=lvcomp, transformed=transformed,
xfromdata=FALSE, se=lshrefl>1)
lcompx <- lcomp$x
lcompy <- if (addcomp) lcomp$comp else -lcomp$comp
lIcompse <- length(lcompse <- lcomp$se)>0
if (addcomp) {
lcompdt <-
fitcomp(x, lpldata, vars=lvcomp, transformed=transformed,
xfromdata=TRUE)$comp
## is added to lres below
}
} else lshrefl <- FALSE
## quantile
lqnt <-
if (length(lregrft$dfres)>0) {
qt(1-lregrft$testlevel/2, lregrft$dfres)
} else qnorm(1-lregrft$testlevel/2)
## --- smooth
lIsmooth <- i.def(smooth, i.def(lregrft$smooth,
i.getploption("smooth"),TRUE) )
plargs$plfeatures$smooth <- lIsmooth
if (length(names(smooth.legend))==0) {
lsmlegend <- i.def(smooth.legend, NULL, TRUE, NULL)
if (length(lsmlegend)==1)
lsmlegend <- setNames(lsmlegend, lvars[1])
} else lsmlegend <-
if("(xvar)"%in%names(smooth.legend))
setNames(smooth.legend, lvars[1]) else smooth.legend
lpanel <- eval(i.getploption("panel"))
if (is.character(lpanel)) lpanel <- get(lpanel, envir=pl.envir)
## --- multivariate ## !!! factors!
if (inherits(x,"mlm")) {
lpmult <- function(x, y, indx, indy, pch, col, panelargs=NULL, ...) {
## lcompx <- lcompy <- NULL
ltin <- terminouterel[indx]
lvx <- lvars[indx]
if (ltin&lshrefl) {
lregrft$reflinecoord <- list(x=lcompx[,lvx], y=lcompy[,lvx,indy])
}
lpanel(x, y, plargs=plargs)
}
plmatrix(lpldata[,lvars,drop=FALSE], lres, panel=lpmult,
##pch=lregrft$plab, plcol=lregrft$lpldata$plcol,
nrow = lregrft$multnrow, ncol = lregrft$multncol,
mar = lregrft$marmult,
plargs=plargs)
return()
}
## ------------------------------------------------------------------
lmf <- i.def(lregrft$mf, NULL, TRUE, NULL)
if (length(lmf)) {
if (u.true(lmf))
lmf <- if (lnvars<=6) lnvars else
min(lnvars,ceiling(lnvars/((lnvars-1)%/%6+1)))
}
loldpar <- par(c("mar","mgp"))
lmfpar <- NULL
if (length(lmf)&(!is.logical(lmf))) {
lmfpar <- plmframes(mft=lmf, plargs=plargs)
loldpar <- c(loldpar, attr(lmfpar,"oldpar"))
}
loldpar <- loldpar[!duplicated(names(loldpar))]
on.exit(par(loldpar), add=TRUE, after=FALSE)
## --------------
lmbox <- i.getploption("factor.show")=="mbox"
lrpl <- lregrft$resplab
if (length(lrpl)>0) lrpl <- lrpl[,1]
lr <- lres
if (lIsmooth && lnsims>0) lr <- structure(cbind(lr, lsimres), primary=1)
lrs <- lr ## need a copy for the case addcomp is true
## ------------------------------------------------------------------
## --- loop --- plresx
for (lj in 1:lnvars) {
lvr <- lvars[lj] ## if (transformed) lvars[lj] else lrawv[lj]
lv <- unname(lvr)
lIcompj <- terminouterel[lj] && lshrefl && lInnls
if (lIcompj) {
lcj <- lcompy[, lvr]
if (lIcompse) lcsej <- lcompse[,lvr]
}
## if (lregrft$partial.resid)
if (lshrefl && addcomp && lIcompj) {
lrs <- lr+lcompdt[, lvr] ## possibly does not work (for condq)
lrs[,1] <- genvarattributes(lrs[,1,drop=FALSE],replace=TRUE,
varlabel=list(paste(attr(lr[,1],"varlabel"),"+ comp_eff")))
attr(lrs, "primary") <- 1 ## simulated smooths...
}
lvv <- lpldata[, lv]
mar <- i.def(plargs[["mar"]], NA) ## c(NA, par("mar")[-1])
## ---
if (u.isnull(attr(lvv, "varlabel"))) attr(lvv, "varlabel") <- lv
lrs1 <- lrs[,1,drop=FALSE]
if (is.factor(lvv)) {
## --- factors
ll <- levels(lvv)
lnl <- length(ll)
if (lIcompj) {
lrfx <- c(outer(0.45*c(-1,1,NA),seq_along(ll),"+"))
lcj1 <- lcj[1:lnl]
lrfy <- c(rbind(lcj1,lcj1,NA))
lrfb <-
if(lIcompse) {
lcsej1 <- lcsej[1:lnl]
lrfb <- c(rbind(lcsej1,lcsej1,NA))
lrfy + cbind(-lrfb,lrfb)
}
lrefline <- list(x=lrfx, y=lrfy, band=lrfb)
}
if (lmbox) {
lmr <- marpar$mar
lmr[1] <- NA
## allow for changing mar[c(1,3)]
plargs$pldata=structure(lpldata, xvar=lv)
plmboxes.default(lvv, lrs1, data=lpldata, mar=lmr, plargs=plargs)
plrefline(lrefline, plargs=plargs)
} else {
lpla <- plargs
lpla$plfeatures$reflinecoord <- lrefline
plframe(lvv,lrs1, plargs=lpla, xy=FALSE)
lpanel(lvv,lrs, plargs=lpla)
}
} else { # ---
## --- continuous explanatory variable
if (lshrefl && lIcompj) {
lrefx <- lcompx[,lvr]
lrefyb <- if (lshrefl>1) outer(lqnt*lcompse[,lvr], c(-1,1))
plargs$plfeatures$reflinecoord <-
list(x=lrefx, y=lcj, band=lrefyb)
}
plpanel(lvv, lrs, plargs=plargs, frame=TRUE) ## title=NA,
} ## ends if factor else
## par(cex=lcex)
}
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plresx
## ==========================================================================
smoothRegr <- #f
function(x, y, weights=NULL, par=NULL, iterations=50, minobs=NULL, ...)
{
minobs <- i.def(minobs, i.getploption("smooth.minobs"), valuefalse=1)
lnx <- sum(is.finite(x))
if (lnx<minobs ) return(NULL)
liter <- max(i.def(iterations, i.getploption("smooth.iter")),0)
lform <- if (is.formula(x)) x else y~x
lpar <- i.def(par,i.getploption("smooth.par"))
if (is.function(lpar)) lpar <- lpar(lnx)
## ----------------------------------------------------------------
lcall <- call("loess", formula=lform, data=data.frame(x=x, y=y),
weights=weights, span=lpar, iterations=max(liter,1),
family=if (liter>0) "symmetric" else "gaussian",
na.action=na.exclude)
if (u.isnull(weights)) lcall$weights <- NULL
lsm <- if (ploptions("debug")) eval(lcall, parent.frame())
else try(eval(lcall), parent.frame(), silent=TRUE)
if (inherits(lsm, "try-error")) {
warning(":smoothRegr: span was too small. Using 0.99")
lcall$span <- 0.99
lsm <- eval(lcall, parent.frame())
}
fitted(lsm)
}
## ========================================================================
gensmooth <- #f
function(x, y, band=FALSE, power=1, resid="difference", weight=NULL,
plargs = NULL, ploptions = NULL, ...)
{
## Purpose: smooth for multiple y : one column from data, the other sim
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 9 Feb 2016, 14:57
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
##
lsmiter <- i.getploption("smooth.iter")
lsmfunc <- i.getploption("smooth.function")
if (is.character(lsmfunc)) lsmfunc <- get(lsmfunc)
if (is.null(lsmfunc)) lsmfunc <- smoothRegr
lIfm <- names(formals(lsmfunc))[1]=="formula"
lsmf <-
if (lIfm) function(x, y, power=1, weights=NULL, par=NULL, iterations=lsmiter, ...)
lsmfunc(I(y^power)~x, weights=weights, par=par, iterations=iterations, ...)
else function(x, y, power=1, weights=NULL, par=NULL, iterations=lsmiter, ...)
lsmfunc(x, y^power, weights=weights, par=par, iterations=iterations, ...)
power <- i.def(power, 1,1,1)
## ---
lnx <- NROW(x)
if (inherits(y, "Surv")) y <- y[,1] ## !!! needs improvement!
ly <- as.matrix(y)
if (nrow(ly)!=lnx) stop("!gensmooth! Incompatible dimensions of 'x' and 'y'")
## if (length(weights)<=1) weights <- rep(1, lnx)
lweights <- i.def(weight, plargs$pldata$".smoothWeights.")
lIwgt <- length(lweights)>0
if (lIwgt&&length(lweights)!=lnx)
stop("!gensmooth! Incompatible dimensions of 'x' and 'weights'")
lgroup <- plargs$pldata$".smooth.group."
if (u.isnull(lgroup)) lgroup <- plargs$pldata$".group."
if (lInogrp <- length(lgroup)<=1) lgroup <- rep(1, lnx)
if (length(lgroup)!=lnx)
stop("!gensmooth! Incompatible dimensions of 'x' and 'group'")
lgrp <- i.factor(lgroup)
if (is.character(resid))
resid <- pmatch(resid, c("difference","ratio"))
if (is.na(resid)) {
warning(":gensmooth: argument 'resid' not suitable.",
" Difference residuals calculated")
resid <- 1
}
lnobs <- median(table(lgrp))
band <- i.def(band, FALSE, TRUE)
lpar <- i.getploption("smooth.par")
if (is.function(lpar)) lpar <- lpar(lnobs)
lparband <- lpar[1]* i.def(lpar[2], 1.5, 1.5, 1)
liter <- i.getploption("smooth.iter")
lminobs <- i.getploption("smooth.minobs")
## data: look for numvalues
lx <- i.def(attr(x,"numvalues", exact=TRUE),x)
## if (inherits(lx, "POSIXt")) lx <- as.numeric(lx)
ly <- apply(ly,2, function(y) i.def(attr(y, "numvalues", exact=TRUE), y))
lnna <- apply(cbind(lx,ly), 1, sumNA)
lx[lnna>0] <- NA
lio <- order(as.numeric(lgrp), lx, na.last=NA) ## order by group
lxo <- lx[lio] # sorted without NA
lyo <- ly[lio,,drop=F]
lgrpo <- lgrp[lio]
lngrp <- length(levels(lgrpo))
lgrpn <- as.numeric(lgrpo)
lwgto <- if(lIwgt) lweights[lio] else NULL
## production
oldopt <- options(warn=-1)
on.exit(options(oldopt), add=TRUE, after=FALSE)
lysm <- array(NA, dim=dim(lyo), dimnames=dimnames(lyo))
## presently only for matrices
if (band) lysmband <- lsmrpos <- lysm[,1]
lsm <- NULL
for (lgr in seq_along(levels(lgrpo))) { ## smooth within groups (if >1)
lig <- which(lgrpn==lgr)
lxg <- lxo[lig]
if (sum(!is.na(lxg))<lminobs) {
notice("gensmooth: too few non-missing observations",
if(lngrp>1) paste(" for group ",lgr) )
next
}
for (j in ncol(lyo):1) {
lsm <- lsmf(as.numeric(lxg), as.numeric(lyo[lig,j]), power=power,
weights=if(lIwgt) lwgto[lig] else NULL,
par=lpar[1], iterations=lsmiter, ...)
if (is.list(lsm)) lsm <- fitted(lsm)
if (length(lsm)==0) {
notice("gensmooth: too few observations for a smooth",
printnotices=ploptions$printnotices)
} else lysm[lig,j] <- lsm^(1/power)
}
## band
if (band & length(lsm)) {
lysmb <- rep(NA, length(lsm))
lsmr <- lyo[lig,1]^power-lsm^power ## residual
lsmrpos[lig] <- lip <- lsmr>=0
## high end
lii <- which(lip)
if(length(lii)) {
lsmrh <- lsmr[lii]
## ligi <- lig[lii]
lsmh <- lsmfunc(lxg[lii], sqrt(lsmrh),
weights=if (lIwgt) lwgto[lig[lii]] else NULL,
par=lparband, iterations=liter)
if (length(lsmh)==0) {
notice("gensmooth: too few observations for a 'high' smooth",
if(lngrp>1) paste(" for group ",lgr),
printnotices=ploptions$printnotices )
} else lysmb[lii] <- lsmh^2
}
## low end
if(length(lii)) {
lii <- which(!lip)
lsmrl <- - lsmr[lii]
## ligi <- lig[lii]
lsml <- lsmfunc(lxg[lii], sqrt(lsmrl),
weights=if (lIwgt) lwgto[lig[lii]] else NULL,
par=lparband, iterations=liter)
if (length(lsml)==0) {
notice("gensmooth: too few observations for a 'low' smooth",
if(lngrp>1) paste(" for group ",lgr),
printnotices=ploptions$printnotices )
} else lysmb[lii] <- - lsml^2
}
## resulting band
lysmband[lig] <- (lysmb + lsm^power)^(1/power)
}
}
lysmin <- matrix(NA, lnx, ncol(lyo), dimnames=list(names(x),colnames(lyo)))
lysmin[lio,] <- lysm
lres <- if (resid==2) ly/lysmin else ly-lysmin
rr <- list(x = lxo, y = lysm, group = if(!lInogrp) i.factor(lgrpo),
index = lio, xorig = x, ysmorig = lysmin, residuals = lres,
xtrim = attr(lsm, "xtrim", exact=TRUE) )
if (band) rr <- c(rr, yband = list(lysmband), ybandindex = list(lsmrpos) )
rr
} ## end gensmooth
## ==========================================================================
smoothLm <- #f
function(x, y, weights = NULL, ...) {
rr <- if (u.isnull(weights)) lm.fit(cbind(1,x), y, ...)$fitted
else lm.wfit(cbind(1,x), y, weights, ...)$fitted
structure(rr, xtrim=0)
}
## smoothRegrrob <- function(x,y,weights,par=3*length(x)^log10(1/2),iter=50)
## =======================================================================
plmatrix <- #f
function(x, y=NULL, data=NULL, panel=NULL, ##panelargs = plargs,
nrow=NULL, ncol=nrow, reduce=TRUE,
xaxmar=NULL, yaxmar=NULL, xlabmar=NULL, ylabmar=NULL,
xlab=NULL, ylab=NULL, ## partial match!?!
mar=NULL, oma=NULL,
diaglabel.csize = NULL, ## csize=NULL, csize needed because otherwise
## csize will be translated into diaglabel.csize
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: pairs with different plotting characters, marks and/or colors
## showing submatrices of the full scatterplot matrix
## possibly on seeral pages
## -------------------------------------------------------------------------
lcall <- match.call()
## lIplargs <- u.isnull(lcall[["plargs"]])
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
lcall$.subdefault <- as.expression(substitute(x)) ##as.character(as.expression(substitute(x)))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (is.name(substitute(data)))
lcall$.subdefault <- as.expression(substitute(data))
data
}
lcall$distinguishy <- FALSE
lcall$gensequence <- FALSE
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, envir=parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## --------------
lf.axis <- function(k, x, axm, labm, txt, ...) {
if (k %in% axm)
plaxis(k, x, varlabel="", ploptions=ploptions, marpar=marpar)
if (k %in% labm) {
lli <- lmline[1] + (k%nin%axm)*diff(lmline) ## diff is negative
mtext(txt, side=k, line=lcsize*lli,
cex=lcsize*marpar$margin.csize[1], ...)
}
}
lf.eq <- function(v1,v2) {
if (is.factor(v1)) is.factor(v2)&&
all(dropNA(as.numeric(v1)==as.numeric(v2)))
else all(dropNA(as.numeric(v1)==as.numeric(v2)))
}
##- lkeeppar <- i.getploption("keeppar")
##- oldpar <- par(c("mar","cex","mgp","oma")) ##, "ask", "mfrow"
## ## lmfg <- par("mfg")
##- if (!lkeeppar) on.exit(par(oldpar))
##---------------------- preparations --------------------------
##- lcl <- match.call()
##- lcall <- sys.call() ## match.call modifies argument names
##- lcnm <- names(lcall)
##- if (length(lcall)!=length(lcl)) stop("bug")
##- names(lcall) <- ifelse(lcnm=="", names(lcl), lcnm)
## margins, will be used by plframe
panel <- i.getplopt(panel)
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plmatrix: 'panel' not found. Using 'plgraphics::plpanel'")
panel <- plgraphics::plpanel
}
if (length(xlab)|length(ylab))
warning(":plmatrix: Arguments 'xlab' and 'ylab' not used. ",
"Set 'varlabel' instead!")
## -----------------------------------------------
## data and bookkeeping
pldata <- plargs$pldata
## if group , generate pcol
if (".group."%in%names(pldata)) {
if (!".pcol."%in%names(pldata))
plargs$pldata[,".pcol."] <- pldata[,".group."]
##- if (!".smooth.group."%in%names(pldata))
##- plargs$pldata[,".smooth.group."] <- pldata[,".group."]
}
## if (is.null(i.getplopt(main))) lplftt$main <- lplftt$datalabel
xvar <- i.def(attr(pldata,"xvar", exact=TRUE), names(pldata))
nv1 <- length(xvar)
lv1 <- lv2 <- 0
if (u.isnull(y)) {
xvar <- c(xvar, attr(pldata,"yvar", exact=TRUE))
nv1 <- length(xvar)
if (reduce) { nv1 <- nv1-1; lv2 <- 1 }
nv2 <- nv1
ldata <- pldata[,xvar]
} else { # cbind y to data for easier preparations
## reduce <- FALSE
if (!is.null(dim(y))) {
yvar <- colnames(y)
ldata <- cbind(pldata[,xvar], as.data.frame(y))
} else {
yvar <- attr(pldata,"yvar", exact=TRUE)
ldata <- pldata[,c(xvar,yvar)]
}
## lformy <- as.formula(paste("~",paste(yvar, collapse="+")))
nv2 <- length(yvar)
lv2 <- length(xvar)
}
lnr <- nrow(ldata)
lnobs <- lnr-mean(sumNA(ldata))
lvsurv <- sapply(ldata, function(x) inherits(x, "Surv") )
if (any(lvsurv)) { ## survival vars
lf.surv <- function(dt) structure(dt[,1], pch=dt[,2]+1)
ldata[lvsurv] <- lapply(ldata[lvsurv], lf.surv)
}
## --- title
##- lIsub <- lplft$sub
##- lImain <- lplft$main
##- lcsizemain <- c(i.getploption("title.csize"),1,1)
##- ## title: how many lines?
lItit <- !( (length(lplft$main)==0||lplft$main=="") &&
(length(lplft$sub)==0||lplft$sub=="") )
##- lltit <- (length(lmain)>0 && lmain!="") * sum(lcsizemain[1:2])
##- if (lltit==0)
##- if(length(lsub)>0&&as.character(lsub)!="") lltit <- lcsizemain[2] ## + 0.2
##- else lltit <- lltit ## +0.2
## set par
## --- position of tick marks and axis labels, oma
xaxmar <- 1+ 2*(1<i.def(xaxmar, 1+(nv1*nv2>1)))
yaxmar <- 2+ 2*(2<i.def(yaxmar, 2+(nv1*nv2>1)))
xlabmar <- i.def(xlabmar, if (nv1*nv2==1) xaxmar else 4-xaxmar )
ylabmar <- i.def(ylabmar, if (nv1*nv2==1) yaxmar else 6-yaxmar )
## ---
lmar <- rep(i.getploption("panelsep"), length=4)
lcsize <- i.getploption("csize")
if (is.function(lcsize)) lcsize <- lcsize(lnobs)
marpar <-
i.getmarpar(mar=mar, axes=c(xaxmar,yaxmar), axlab=c(xlabmar,ylabmar),
title=FALSE, plargs=plargs)
lmline <- marpar$margin.line
lmar <- marpar$mar
## ---
lnrow <- i.getplopt(nrow)
lncol <- i.def(ncol, lnrow)
ploptions$mframesmax <- c(lnrow, lncol)
## ---
if (!u.true(i.getploption("keeppar"))) {
loldp <- par(c("mar","mgp","oma","mfrow"))
on.exit(par(loldp), add=TRUE, after=FALSE)
## on.exit(par(loldp[4:5]), add=TRUE)
}
lshlab <- i.getploption("showlabels")
## ---
lpar <- plmframes(nv2, nv1, mar=marpar$mar, reduce=reduce,
plargs=plargs)
plargs$marpar <- marpar <- lpar$marpar
## ----------------------------------------------
lcsizediag <- i.getplopt(diaglabel.csize)
lmfg <- par("mfg")
lnr <- lmfg[3]
lnc <- lmfg[4]
lnpgr <- ceiling(nv2/lnr)
lnpgc <- ceiling(nv1/lnc)
## csize.pch
lcsize.pch <- i.getploption("csize.pch")
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs)
plargs$ploptions$csize.pch <- ploptions$csize.pch <- lcsize.pch
lipanelargs <-
intersect(names(as.list(args(panel))),
c("indx","indy","type","ticklabels","plargs","ploptions",
"marpar")) # ,names(list(...))
##----------------- plots ----------------------------
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (ipgc in 1:lnpgc) {
lc <- (ipgc-1)*lnc
if (reduce&&((lr+lnr)<=lc)) break
for (jr in 1:lnr) { #-- plot row [j]
jd2 <- lr+jr ## index for y axis
j2 <- lv2 + jd2
if (jd2<=nv2) {
v2 <- ldata[,j2]
lylab <- i.def(i.def(attr(v2,"varlabel", exact=TRUE),
attr(v2,"varname", exact=TRUE)),
paste("V",j2,sep="."), valuefalse="")
}
for (jc in 1:lnc) { #-- plot column [j2-lv2] = 1:nv2
jd1 <- lc+jc
j1 <- lv1 + jd1
if (jd2<=nv2 & jd1<=nv1) {
v1 <- ldata[,j1]
lxlab <- i.def(attr(v1,"varlabel", exact=TRUE),
paste("V",j1,sep="."), valuefalse="")
if (!lf.eq(v1,v2)) { # not diagonal
plframe(v1, v2, xlab="", ylab="", mar=lmar, showlabels=!reduce,
ploptions=ploptions, marpar=marpar, xy=FALSE)
do.call(panel,
c(list(x=v1, y=v2), ## panel must have arguments x and y
list(indx=jd1, indy=jd2, plargs=plargs)[lipanelargs]) )
## panel(v1,v2, indx=jd1, indy=jd2, plargs=plargs)
## llastmfg <- par("mfg")
}
else {
lv0 <- as.numeric(v1)
plot(lv0,lv0, type="n", axes=FALSE, xlab="",ylab="")
uu <- par("usr") # diagonal: print variable name
text(mean(uu[1:2]),mean(uu[3:4]), lylab, cex=lcsizediag) ## no par("cex") here!
}
## usr <- par("usr")
## lat=c(mean(usr[1:2]),mean(usr[3:4]))
if (jr==lnr||jd2==nv2) lf.axis(1, v1, xaxmar, xlabmar, lxlab)
if (jc==1) lf.axis(2, v2, yaxmar, ylabmar, lylab)
if (jr==1) lf.axis(3, v1, xaxmar, xlabmar, lxlab)
if (jc==lnc||jd1==nv1) lf.axis(4, v2, yaxmar, ylabmar, lylab)
if (jr==1&jc==1&lItit)
pltitle(plargs=plargs, show=NA, outer.margin=TRUE, marpar=marpar)
} else frame()
}
}
stamp(sure=FALSE, outer.margin=TRUE)
}
}
## if (lkeeppar)
## par(mfg=llastmfg)
if (u.notfalse(assign)) plassign(list=plargs)
invisible(plargs)
} ## end plmatrix
## ====================================================================
plpanel <- #f
function(x = NULL, y = NULL, indx=NULL, indy=NULL, type="p",
frame = FALSE, title = FALSE,
plargs = NULL, ploptions = NULL, marpar = NULL,
...) ## data=plargs$pldata
{ ## !!!? i.getxy
if (length(plargs)==0) plargs <- pl.envir ## get(...)
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
pldata <- plargs$pldata
##
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
##
ploptions$stamp <- FALSE
lrefl <- lplft$reflinecoord
lshrefl <- u.notfalse(lrefl) ## i.getploption("refline"))
mbox <- i.getploption("factor.show")=="mbox" &&
max(table(x))>=i.getploption("mbox.minnobs")
lIsm <- i.getploption("smooth")
## intro, needed if formulas are used or data is given or ...
lcall <- match.call()
lxnm <- "x"
lynm <- "y"
if (is.formula(x)|is.formula(y)|
any(c("data","pcol","psize")%in%names(lcall))) {
lcall$assign <- FALSE
lcall$ploptions <- ploptions
if (is.null(lcall$data)) lcall$data <- pldata
lplargs <- do.call(pl.control, as.list(lcall[-1]), envir=parent.frame())
ploptions <- lplargs$ploptions
plargs$pldata <- pldata <- lplargs$pldata
x <- pldata[,lxnm <- attr(pldata, "xvar", exact=TRUE)[1], drop=FALSE]
y <- pldata[,lynm <- attr(pldata, "yvar", exact=TRUE), drop=FALSE]
} else {
## ---
if (length(x)==0) {
x <- pldata[,1, drop=FALSE]
lxnm <- names(pldata)[2]
}
if (length(y)==0) {
y <- pldata[,2, drop=FALSE]
lxnm <- names(pldata)[1]
}
}
if (is.data.frame(x)) x <- x[,1]
if (sum(!is.na(x))==0) {
warning(":plpanel: no finite values of variable ", lxnm,
". Nothing to plot")
return()
}
if (sum(!is.na(as.matrix(y)))==0) {
warning(":plpanel: no finite values of variable(s) ", paste(lynm, collapse=", "),
". Nothing to plot")
return()
}
## lvv <- transferAttributes(i.factor(lvv), lvv)
if (is.character(x)) x <- factor(x) ## !!! attributes!
if (is.character(y)) {
if (NCOL(y)>1) {
warning("!plpanel! multiple y cannot be of type character or factor",
"Using the first column")
y <- y[,1]
}
y <- factor(y)
}
if (length(dropNA(unique(x)))==1) x <- factor(x)
if (is.factor(x)) { lIsm <- FALSE
if (!is.factor(y) & mbox) {
plargs$pldata <- data.frame(x=x,y=y)
plmboxes.default(x, y, plargs=plargs, add=TRUE, ...)
return()
}
} else {
if (is.factor(y) & mbox) {
plargs$pldata <- data.frame(x=y, y=x)
plmboxes.default(y, x, plargs=plargs, add=TRUE, horizontal=TRUE, ...)
return()
}
}
## ---
lys <- NULL
lyp <- y
if (lIsm) {
lIyp <- attr(y, "primary", exact=TRUE)
lIys <- attr(y, "secondary", exact=TRUE)
if (length(lIyp) | length(lIys)) {
lIyp <- i.def(lIyp, 1:NCOL(y))
lIys <- i.def(lIys, setdiff(1:NCOL(y), lIyp))
}
lyp <- if (length(lIyp)) y[,lIyp, drop=FALSE] else y
lys <- if (length(lIys)) y[,lIys] else NULL
}
## ---------------------
## start plotting
if (frame) plframe(x,lyp, ploptions=ploptions, marpar=marpar, ...) ## !!!
## secondary smooths
if (lIsm & length(lys))
plsmooth(x, y=NULL, ysec=lys, band=FALSE, power=lplft$smooth.power,
xy=FALSE, plargs=plargs, ploptions=ploptions)
## refline
if (lshrefl && length(lrfl <- lplft$reflinecoord))
plrefline(lrfl, x=x, y=y, plargs=plargs, ploptions=ploptions)
## points
plpoints(x, lyp, type=type, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE, ...)
## primary smooth
if (lIsm) plsmooth(x, y=lyp, plargs=plargs, ploptions=ploptions, ...)
## title
if (u.notfalse(title)) pltitle(plargs=plargs, show=title)
} ## end plpanel
## ====================================================================
panelSmooth <- #f
function(x, y, indx, indy, plargs = NULL, ...) {
if (length(plargs)==0) plargs <- pl.envir ## get(...)
graphics::panel.smooth(x, y, pch=plargs$plfeatures$pch,
col=plargs$plfeatures$pcol,
cex=i.getploption("csize.pch")*par("cex"), ...)
}
## ==========================================================================
plcond <- #f
function(x, y=NULL, condvar = NULL, data=NULL, panel=NULL, ## panelargs = plargs,
nrow=NULL, ncol=NULL, xaxmar=NULL, yaxmar=NULL, ## xlabmar=NULL, ylabmar=NULL,
## xcondmar=NULL, ycondmar=NULL,
xlab=NULL, ylab=NULL, ## partial match!?!
oma=NULL, ## mar=NULL, csize=NULL,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: pairs with different plotting characters, marks and/or colors
## showing submatrices of the full scatterplot matrix
## possibly on seeral pages
## -------------------------------------------------------------------------
lf.condkey <- function(x, rg, ext) {
lwd <- diff(rg)
lx <- (x-rg[1])/lwd
if (ext>0)
## 0 in the interval, linear beyond until abs(result)>1
clipat(lx/ext - pmin(lx,1)*(lx>0)/ext, c(-1,1), clipped=NA)
else clipat(x, rg, clipped=NA)
}
## --------------------------------------------------------------------
lcall <- match.call()
## lIplargs <- is.null(lcall[["plargs"]])
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
lcall$.subdefault <- as.expression(substitute(x)) ##as.character(as.expression(substitute(x)))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (is.name(substitute(data)))
lcall$.subdefault <- as.expression(substitute(data))
data
}
lcall$distinguishy <- FALSE
lcall$gensequence <- FALSE
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, envir=parent.frame())
## lplft$main <- lmain
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
## -----------
pldata <- plargs$pldata
## ----------------
lnobs <- nrow(pldata)
lnint <- rep(i.getploption("plcond.nintervals"),2)
## --------------
## lmain <- plargs$main
## ltitcs <- i.getploption("title.csize")
## title: how many lines?
##- lltit <- (length(lmain)>0&&lmain!="") * sum(ltitcs[1:2])
##- if (lltit==0) {
##- if(length(lsub)>0&&as.character(lsub)!="") lltit <- ltitcs[2] ## + 0.2
##- } else lltit <- lltit ## +0.2
## --- position of tick marks and axis labels, oma
xaxmar <- ifelse(i.def(xaxmar, 1)[1]>1, 3,1)
yaxmar <- ifelse(i.def(yaxmar, 2)[1]>2, 4,2)
##- xlabmar <- i.def(xlabmar, xaxmar)
##- ylabmar <- i.def(ylabmar, yaxmar)
xcondmar <- 4-xaxmar ## i.def(xcondmar, 3)
ycondmar <- 6-yaxmar
## --- data and bookkeeping
lx <- pldata[,i.def(attr(pldata,"xvar", exact=TRUE),1)[1]]
ly <- pldata[,i.def(attr(pldata,"yvar", exact=TRUE),2)[1]]
lxlab <- attr(lx,"varlabel", exact=TRUE)
lylab <- attr(ly,"varlabel", exact=TRUE)
lpcl <- i.def(pldata[[".pcol."]], i.getploption("colors")[1])
lpcol <- rep(rgb(t(col2rgb(lpcl))), length=length(lx))
lpch <- i.def(pldata[[".pch."]], i.getploption("pch")[1])
lpsize <- i.def(pldata[[".psize."]], 1)
lcondv <- c(attr(pldata, "by"), attr(pldata, "by2"))
if (u.isnull(lcondv))
stop("!plcond! no conditioning variable(s) found")
llby <- length(lcondv)
if (llby>2)
warning(":plcond: only the first 2 conditioning variables will be used: ",
paste(lcondv[1:2], collapse=", "))
## ---
lc2vars <- llby>=2
lext <- i.getploption("plcond.extend")
## condition keys
for (li in 1:(1+lc2vars)) {
lv <- pldata[,lcondv[li]]
if (is.numeric(lv)) {
lcutp <- attr(lv, "cutpoints", exact=TRUE)
if (u.isnull(lcutp)) {
lrg <- robrange(lv)
lcutp <- seq(lrg[1],lrg[2], length=lnint[li]+1)
}
lck <- ## a column of paling weights for each conditioning interval
sapply(seq_len(length(lcutp)-1),
function(i) lf.condkey(lv, lcutp[i+0:1], lext)
)
attr(lck, "cutpoints") <- lcutp
} else { ## lv is not numeric
lvn <- as.numeric(lv)
llev <- levels(lv)
lck <- sapply(seq_along(llev), function(i) ifelse(lvn==i, 0, NA) )
attr(lck, "labels") <- llev
}
if (li==1) { ## horizontal axis
lckeyx <- lck
lbyxlab <- attr(lv,"varlabel", exact=TRUE)
} else { ## vertical
lckeyy <- lck
lbyylab <- attr(lv,"varlabel", exact=TRUE)
}
}
if (!lc2vars) { ## only one conditioning v
lckeyy <- matrix(0,1,1)
lbyylab <- NULL
}
lnintx <- ncol(lckeyx)
lninty <- ncol(lckeyy)
## ----- graphical prep
lcsize <- i.getploption("csize")
marpar <- i.getmarpar(plargs=plargs)
lmar <- rep(i.getploption("panelsep"), length=4)
if(!lc2vars) lmar[3] <- i.def(i.getploption("title.line")[2], 0.8)
## space for conditional variables' axes
loma <- i.getploption("oma")
lomadef <- rep(0,4) ## marpar$mar
lomadef[xcondmar] <- lomadef[xcondmar] + 2
lomadef[ycondmar] <- lomadef[ycondmar] + 2
loma <- replaceNA(loma, lomadef)
ploptions$mframesmax <- c(lnintx, lninty)
## ---
if (!u.true(i.getploption("keeppar"))) {
loldp <- par(c("mar","mgp","oma","mfrow"))
on.exit(par(loldp), add=TRUE, after=FALSE)
}
## ---
lpar <- plmframes(if(lc2vars) lninty, if(lc2vars) lnintx,
if(!lc2vars) lnintx, reduce=TRUE, oma=loma,
plargs=plargs) ## !!! plargs not active
## lpar$marpar$mar <- lpar$marpar$mar+c(0,0,0,1) ## !!! Flick!
plargs$marpar <- marpar <- lpar$marpar
lmgp <- lcsize*c(marpar$margin.line,0)
lbylabline <- lmgp[1]
lnumline <- lmgp[2]
## --------------------------------------------
lmfg <- par("mfg")
lnr <- lmfg[3]
lnc <- lmfg[4]
if (lc2vars) {
lnpgr <- ceiling(lninty/lnr)
lnpgc <- ceiling(lnintx/lnc)
} else {
lnpgr <- 1
lnc <- lnr*lnc
lnpgc <- ceiling(lnintx/lnc)
lnr <- 1
}
## cexpch
lcsize.pch <- i.getploption("csize.pch")
if (is.function(lcsize.pch)) lcsize.pch <- lcsize.pch(lnobs)
ploptions$csize.pch <- lcsize.pch ##!!! plargs
ploptions$axes <- FALSE ##!!! plargs
##- lipanelargs <-
##- intersect(names(as.list(args(panel))), c("indx","indy","panelargs"))
##
##- ## log
##- if (length(grep("x",log))>0) ldata[ldata[,1:nv1]<=0,1:nv1] <- NA
##- if (length(grep("y",log))>0) ldata[ldata[,lv2+1:nv2]<=0,lv2+1:nv2] <- NA
## --- specific for plcond
lsmooth <- i.getploption("smooth")
lIsmooth <- u.notfalse(lsmooth)
lsmminobs <- i.getploption("smooth.minobs")
lccolors <- i.getploption("plcond.col")
lccl <- col2rgb(lccolors)/255
lccolors <- rgb(t(cbind(lccl, (lccl[,c(1,2,1,2)]+lccl[,c(3,3,4,4)])/2 )) )
lpale <- i.getploption("plcond.pale")
lccsize <- i.getploption("plcond.csize")*par("cex.axis")
lcslab <- i.getploption("csize.lab")*par("cex.lab")
## ---
lcutpx <- attr(lckeyx, "cutpoints", exact=TRUE)
lcnumx <- length(lcutpx)>0
lcutpx <- format(lcutpx, digits=3)
llevx <- attr(lckeyx, "labels", exact=TRUE)
lcutpy <- attr(lckeyy, "cutpoints", exact=TRUE)
lcnumy <- length(lcutpy)>0
lcutpy <- format(lcutpy, digits=3)
llevy <- attr(lckeyy, "labels", exact=TRUE)
panel <- i.def(panel, i.getploption("plcond.panel"))
if (is.character(panel)) panel <- get(panel, pl.envir)
if (!is.function(panel)) {
warning(":plmatrix: 'panel' not found. Using 'plgraphics::plpanelCond'")
panel <- plgraphics::plpanelCond
}
## ------------------------------------
lcsizepl <- par("cin")/par("pin")
ladjfacx <- lcsizepl[1]*0.4
ladjfacy <- lcsizepl[2]*0.3
ljy <- 1
## --------------------------------------------------------------
## plot
for (ipgr in 1:lnpgr) {
lr <- (ipgr-1)*lnr ## start at row index lr
for (ipgc in 1:lnpgc) {
lc <- (ipgc-1)*lnc
for (jr in 1:lnr) {
if (lc2vars) ljy <- (lr+lnr+1-jr)
if (lplot <- ljy<=lninty) {
lcky <- lckeyy[,ljy]
lcoly <- lpcol
lcoly[is.na(lcky)] <- NA
lcoly[lcky<0] <- lccolors[3]
lcoly[lcky>0] <- lccolors[4]
}
for (jc in 1:lnc) {
ljx <- lc+jc
if (ljx<=lnintx & lplot) { ## points from neighboring panels : "overlap"
lckx <- lckeyx[,ljx]
lcol <- lcoly
lcol[lckx<0] <- lccolors[1]
lcol[lckx>0] <- lccolors[2]
lcol[lckx<0&lcky<0] <- lccolors[5]
lcol[lckx>0&lcky<0] <- lccolors[6]
lcol[lckx<0&lcky>0] <- lccolors[7]
lcol[lckx>0&lcky>0] <- lccolors[8]
lcol[is.na(lckx)] <- NA
## ---
plframe(lx,ly, xlab="",ylab="", showlabels=FALSE,
plargs=plargs, marpar=marpar, xy=FALSE)
if(any(!is.na(lcol))) {
panel(x=lx, y=ly, ckeyx=lckx, ckeyy=lcky,
pcol=lcol, pch=lpch, psize=lpsize, pale=lpale,
smooth=lIsmooth, smooth.minobs=lsmminobs,
plargs=plargs, ploptions=ploptions)
}
}
lmfg <- par("mfg")
## --- axes
##- if (jr==lnr & xaxmar==1 & jc==1)
if (xaxmar==1&yaxmar==2){
lIax <- lmfg[1:2]==c(lmfg[3],1)
if (lIax[1])
plaxis(1, varlabel=if (lIax[2]) lxlab else "",
ploptions=ploptions, marpar=marpar)
if (lIax[2])
plaxis(2, varlabel=if (lIax[1]) lylab else "",
ploptions=ploptions, marpar=marpar)
} else {## if (xaxmar==3&yaxmar==4) other combinations not yet programmed
lIax <- lmfg[1:2]==c(1,lmfg[4])
if (lIax[1])
plaxis(3, varlabel=if (lIax[2]) lxlab else "",
ploptions=ploptions, marpar=marpar)
if (lIax[2])
plaxis(4, varlabel=if (lIax[1]) lylab else "",
ploptions=ploptions, marpar=marpar)
}
##
if (xcondmar==3 & lmfg[1]==1) {
if (lcnumx) {
ltxt <- lcutpx[ljx]
ladjx <- ladjfacx*nchar(ltxt)
mtext(ltxt, 3, lnumline, adj=-ladjx, cex=lccsize) ## , xpd=TRUE
if (lmfg[2]==lmfg[4])
mtext(lcutpx[ljx+1], 3, lnumline, adj=1, cex=lccsize)
} else mtext(llevx[ljx], 3, lnumline, cex=lccsize)
}
if (ycondmar==4 & lmfg[2]==lmfg[4]) {
if (lcnumy) {
ltxt <- lcutpy[ljy]
ladjy <- ladjfacy*nchar(ltxt)
mtext(lcutpy[ljy], 4, lnumline, adj=-ladjy, cex=lccsize)
if (jr==1) mtext(lcutpy[ljy+1], 4, lnumline, adj=1, cex=lccsize)
} else mtext(llevy[ljy], 4, lnumline, cex=lccsize)
}
if (xcondmar==1) mtext(lbyxlab, 1, lbylabline, cex=lcslab, outer=TRUE)
if (xcondmar==3) mtext(lbyxlab, 3, lbylabline, cex=lcslab, outer=TRUE)
if (ycondmar==2) mtext(lbyylab, 2, lbylabline, cex=lcslab, outer=TRUE)
if (ycondmar==4) mtext(lbyylab, 4, lbylabline, cex=lcslab, outer=TRUE)
}
}
}
}
} ## end plcond
## ---------------------------------------------------------------------------
plpanelCond <- #f
function(x, y, ckeyx, ckeyy, pch = 1, pcol = 1, psize = 1, pale = c(0.2,0.6),
csize=0.8, smooth = NULL, smooth.minobs = NULL,
plargs = NULL, ploptions = NULL, ...)
{
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
lsmminobs <- i.getplopt(smooth.minobs)
ploptions$printnotices <- FALSE
if (all(is.na(pcol)))
pcol <- rep(i.getploption("pch")[1], length=length(x))
lcpl <- (1-abs(ckeyx))*(1-abs(ckeyy))
li <- !is.na(lcpl)
if (sum(li)==0) return()
##
lpale <- pale[1] + diff(pale)*(1-lcpl)
lii <- which(lcpl!=1)
pcol[lii] <- colorpale(pcol[lii], lpale[lii])
lpsize <- psize*ifelse(lcpl==1, 1, csize)
x[!li] <- NA
plpoints(x, y, pcol=pcol, pch=pch, psize=lpsize, plargs=plargs, xy=FALSE)
if (u.notfalse(smooth) & sum(li)>=lsmminobs)
plsmooth(x[li],y[li], weight=lcpl[li], plargs=plargs, ploptions=ploptions, ...)
}
## ====================================================================
plmbox <- #f
function(x, at=0, probs=NULL, outliers=TRUE, na.pos=NULL,
horizontal = FALSE,
width=1, wfac=NULL, minheight= NULL, adj=0.5, extquant=FALSE,
widthfac=c(max=2, med=1.3, medmin=0.3, outl=NA),
colors=c(box="lightblue2",med="blue",na="gray90"), lwd=c(med=3, range=2),
warn=options("warn") )
{
## Purpose: multi-boxplot
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 14 Dec 2013, 10:09
f.box <- function(wid, quant, col, lwmax) {
## if (is.na(col)||col==0) col="white"
if (wid>lwmax) {
if (horizontal) {
polygon(quant, at+lpos*lwmax, col="black")
polygon(quant, at+lpos*lwmax^2/wid, col=col)
} else {
polygon(at+lpos*lwmax, quant, col="black")
polygon(at+lpos*lwmax^2/wid, quant, col=col)
}
} else {
if(wid>0)
{
if (horizontal)
polygon(quant, at+lpos*wid, col=col) else
polygon(at+lpos*wid, quant, col=col)
}
}
}
## -----------------------------------
lq <- lwid <- NULL
lfac <- 0
lx <- as.numeric(x[!is.na(x)])
if (length(lx)==0) {
if (warn>=0) warning(":plmbox: no non-missing data")
return(structure(numeric(0), q=lq, width=lwid))
} else { ## ----
stopifnot(length(width)==1,length(wfac)<=1)
if (u.isnull(probs))
probs <- if (sum(!is.na(x))<20) c(0.1,0.5,1)/2 else
c(0.05,0.1,0.25,0.50,0.75,1)/2
lprobs <- if (all(probs<=0.5)) c(probs,1-probs) else c(probs)
lprobs <- sort(unique(lprobs))
colors <- as.list(colors)
box.col <- colors[["box"]]
if (length(box.col)==1)
box.col <- ifelse(0.25<=head(lprobs,-1) & lprobs[-1]<=0.75, box.col, NA)
## values for degenerate case
lxsd <- IQR(lx)
lfac <- if (u.isnull(wfac)) width*2*lxsd else wfac*length(lx)
# was mad/dnorm(0)
lmed <- median(lx)
lwmed <- width
lrg <- range(lx)
lirg <- i.def(attr(x, "innerrange", exact=TRUE), lrg)
ljrg <- any(lirg!=lrg)
lirgd <- diff(lirg)
loutl <- lx
lwoutl <- widthfac["outl"]
if (diff(lrg) > 0) { ## non-degenerate
if (u.isnull(minheight))
minheight <- if (lxsd==0) lirgd*0.01 else lxsd*0.02
lqpl <- lq <- quinterpol(lx, probs=lprobs, extend=extquant)
lirgext <- attr(x, "innerrange.ext", exact=TRUE)
if (ljrg) { ## transformed coord
lx <- plcoordtrsf(lx, lirg, lirgext)
lrg <- plcoordtrsf(lrg, lirg, lirgext)
lqpl <- plcoordtrsf(lqpl, lirg, lirgext)
}
loutl <- lx[lx<min(lq)|lx>max(lq)]
## ---
lwid <- lfac*diff(lprobs)/pmax(diff(lq), minheight)
lwmax <- widthfac["max"]*0.5 ##*lfac/ifelse(lxsd>0, lxsd, 1) !!! ???
## length of median bar
lnwid <- length(lwid)
lnw1 <- max(ceiling(lnwid/4),2)
lnw2 <- lnwid/2
li <- (floor(lnw2)-lnw1+1):(ceiling(lnw2)+lnw1)
lwmed <- max(widthfac["med"]*min(lwmax,max(nainf.exclude(lwid[li]))),
widthfac["medmin"],na.rm=TRUE)
lpos <- c(-adj,-adj,1-adj,1-adj)
if (is.na(lwoutl)) lwoutl <- 0.1*lwmax
## ---------------------------------------
for (li in 1:(length(lprobs)-1)) {
llq <- lqpl[li+0:1]
if (diff(llq)<minheight) llq <- mean(llq) + c(-0.5,0.5)*minheight
f.box(lwid[li], llq[c(1,2,2,1)], box.col[li], lwmax)
}
} ##
## median
if (horizontal) {
lines(rep(lmed,2), at+lwmed*c(-adj,1-adj), col=colors[["med"]],
lwd=lwd["med"])
lines(lrg, c(at,at), # +linepos*0.01*diff(par("usr")[1:2])*(0.5-adj),
lwd=lwd["range"])
} else {
lines(at+lwmed*c(-adj,1-adj), rep(lmed,2), col=colors[["med"]],
lwd=lwd["med"])
lines(c(at,at), # +linepos*0.01*diff(par("usr")[1:2])*(0.5-adj),
lrg, lwd=lwd["range"])
}
if (outliers&&length(loutl)) {
lat <- rep(at,length(loutl))
if (horizontal)
segments(loutl, lat-lwoutl*adj, loutl, lat+lwoutl*(1-adj)) else
segments(lat-lwoutl*adj, loutl, lat+lwoutl*(1-adj), loutl)
}
}
if (!u.isnull(na.pos)) {
lmna <- mean(is.na(x))
if (lmna) {
ldna <- diff(na.pos)
if (length(ldna)==0 || is.na(ldna) || ldna==0)
stop("!plmbox! argument 'na.pos' not suitable")
lwidna <- lfac*lmna/abs(ldna)
f.box(lwidna, na.pos[c(1,2,2,1)], colors[["na"]], lwmax)
}
}
invisible(structure(lfac/length(x), q=lq, width=lwid))
} ## end plmbox
## ====================================================================
plmboxes <- function(x, ...)
UseMethod("plmboxes")
plmboxes.formula <- #f
function(x, y=NULL, data, ...)
{
ldt <- genvarattributes(getvariables(x, data))
##- l1backback <- length(x[[3]])>1 && as.character(x[[3]][[2]])=="1"
##- if (l1backback)
##- ldt <- data.frame(transferAttributes(ldt[,1]),0,
##- transferAttributes(ldt[,2]))
ldtnm <- substitute(data)
ldtnm <- if (is.name(ldtnm)) as.character(ldtnm) else format(ldtnm)
plmboxes.default(ldt[,attr(ldt,"xvar", exact=TRUE),drop=FALSE],
ldt[,attr(ldt,"yvar", exact=TRUE),drop=FALSE], ldt,
.subdefault = ldtnm, ...) ## if (nchar(ldtnm)<30) ldtnm else ""
}
## ------------------------------------------------------------
plmboxes.default <- #f
function(x=NULL, y=NULL, data=NULL, width = 1, at = NULL,
horizontal = FALSE,
probs = NULL, outliers = TRUE, na = FALSE, backback = NULL,
refline = NULL, add = FALSE,
xlim = NULL, ylim = NULL, axes = TRUE, xlab = NULL, ylab = NULL,
labelsperp = FALSE, xmar = NULL, mar = NULL,
widthfac = NULL, minheight = NULL, colors = NULL, lwd = NULL,
.subdefault = NULL, plargs = NULL, ploptions = NULL, marpar = NULL,
...)
{
## Purpose: multibox plot
## ----------------------------------------------------------------------
## Author: Werner Stahel, Date: 14 Dec 2013, 23:38
lcall <- match.call()
if (is.null(plargs)) {
lcall[[1]] <- quote(pl.control)
lcall$x <- x ## needs evaluation
## lcall$.subdefault <- .subdefault ## as.character(substitute(x))
lcall$y <- y
lcall$data <-
if(length(data)) {
if (u.isnull(.subdefault) & is.name(substitute(data)))
lcall$.subdefault <- as.character(substitute(data))
data
}
lcall$.environment. <- parent.frame()
##
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions ## was .ploptions
if (!inherits(marpar, "i.marpar"))
marpar <- i.getmarpar(marpar, plargs=plargs)
if(length(loldp <- attr(marpar, "oldpar")))
on.exit(par(loldp), add=TRUE, after=FALSE)
lcsize <- i.getploption("csize")
## ----------------------------------------------------------------------
pldata <- plargs$pldata
if(is.null(x))
x <- pldata[,i.def(attr(pldata,"xvar", exact=TRUE),1), drop=FALSE]
## may have two columns
else if(!is.data.frame(x)) x <- as.data.frame(x)
if(is.null(y))
y <- pldata[,i.def(attr(pldata,"yvar", exact=TRUE)[1],2),drop=FALSE]
else if(!is.data.frame(y))
y <- setvarattributes(data.frame(y=y), varlabel="Y")[1] ## !!? ok ?
if (!is.numeric(y[,1]))
stop("!plmboxes.default! 'y' must be numeric")
ly <- y[,1]
##- lly <- i.def(i.def(attr(ly, "numvalues"), attr(ly, "plcoord")), ly) ## ??
lly <- i.def(attr(ly, "plvalues"), i.def(attr(ly, "numvalues"), ly)) ## ??
lhoriz <- as.logical(i.def(horizontal, FALSE, valuetrue=TRUE))
## widths
lwfac <- modarg(widthfac, c(max=2, med=1.3, medmin=0.3, outl=NA, sep=0.003))
## colors, line widths
lcol <- modarg(colors, i.getploption("mbox.colors"))
llwd <- modarg(lwd, c(med=3, range=2))
## data
## preliminary
x[,1] <- lx <- i.factor(x[,1]) # unused levels are dropped
llr <- ncol(x)>=2 ## asymmetric mboxes required for binary (second) factor
if (llr) {
x[,2] <- lx2 <- transferAttributes(i.factor(x[,2]),x[,2], except="levels")
if (length(levels(lx2))!=2) {
warning(":plmboxes: second x-variable must be binary. I ignore it.")
x <- x[,1, drop=FALSE]
llr <- FALSE
}
}
llist <- split(lly,x)
llev <- levels(lx)
lng <- length(llev)
lnn <- sapply(llist,length)
lsd <- mean(sapply(llist,mad,na.rm=TRUE),na.rm=TRUE)
width <- rep(width, length=lng)
lfac <- width*lsd/(max(lnn)*(1+llr))
if (u.isnull(minheight)) {
lscales <- sapply(llist, IQR, na.rm=TRUE)
minheight <- median(lscales)*i.getploption("mbox.minheight")
}
## labels
xlab <- i.def(xlab, attr(x[,1],"varlabel", exact=TRUE), valuefalse="")
if (length(xlab)>1) xlab <- xlab[2]
## if (xlab=="1") xlab <- ""
ylab <- i.def(ylab, attr(ly, "varlabel", exact=TRUE), valuefalse="")
## position
if (lnat <- length(at)) {
if (lnat!=lng) {
warning(":plmboxes: 'x' has wrong length")
at <- if (lnat>lng) at[1:lng] else NULL
}
}
if (u.isnull(at)) at <- 1:lng
backback <-
i.getplopt(backback) &&
length(dropNA(unique(x[,1])))==2 && NCOL(x)==1
if (backback) {
llr <- TRUE
lng <- 1
}
lpos <- if(backback) rep(mean(at),2) else at
## probabilities
if (u.isnull(probs))
probs <- if (sum(!is.na(ly))/(lng*(1+llr))<20) c(0.1,0.5,1)/2 else
c(0.05,0.1,0.25,0.50,0.75,1)/2
## box for NA's?
na <- i.def(na, NA)
na.pos <- i.def(na, c(min(lly, na.rm=TRUE)*(1-0.3)-0.3*max(lly, na.rm=TRUE)),
valuefalse=NULL)
if (length(na.pos)==1)
na.pos <- na.pos+ 0.03*diff(range(lly, na.rm=TRUE))*c(-1,1)
lusr <- par("usr")
## plot range
## lrg <- if (add) lusr[3:4] else attr(y, "plrange")
if (add) {
xlim <- lusr[1:2]
ylim <- lusr[3:4]
} else {
lxldf <- i.extendrange(
range(at, na.rm=TRUE) + ## max(diff(at)) *
(max(width[c(1,length(width))]) - 0.7*backback)*c(-1,1)*0.4) ## !!! is 0.4 ok???
## *i.getploption("plext")
xlim <-replaceNA(c(i.def(xlim, NA), NA)[1:2], lxldf)
attributes(xlim) <- attributes(lx)[c("ticksat","ticklabelsat","ticklabels")]
## show NA's of y
if (lIna <- !u.isnull(na.pos)) {
lyat <- lyat[lyat>max(na.pos)]
if (length(lyat)<3)
lyat <- pretty(ly, n=i.def(ploptions$tickintervals, 7))
attr(ly, "plrange") <- range(c(attr(ly, "plrange", exact=TRUE), na.pos))
}
ylim <- i.def(ylim, attr(ly, "plrange", exact=TRUE))
attributes(ylim) <- attributes(ly)[c("ticksat","ticklabelsat","ticklabels")]
## margin pars
lmar <- marpar$mar
lxmardef <- lmar[1+lhoriz]
## the next statement defines the maximal label length usually as 10
lmaxnchar <-
ifelse(is.numeric(labelsperp), min(max(1,labelsperp),20), 10)
lxmar <- c(i.def(xmar, NA), NA,NA)[1:3]
if (is.na(lxmar[1]))
lxmar[1] <-
ifelse(labelsperp,
2 + 0.5*min(max(nchar(llev)), lmaxnchar), lxmardef)
lmar[1+lhoriz] <- lxm1 <- max(lxmar[1], lmar[1+lhoriz], na.rm=TRUE)
lxmline <-
c(ifelse(is.na(lxmar[2]), max(lxm1-1, marpar$margin.line[1]),
lxmar[2]),
ifelse(is.na(lxmar[3]), marpar$margin.line[2], lxmar[3]) )
##
marpar$mar <- lmar
plargs$plmarpar <- marpar
loldp <- par(cex=lcsize*par("cex"), mar=lmar)
if (!i.getploption("keeppar"))
on.exit(par(loldp), add=TRUE, after=FALSE)
## ---
ploptions$axes <- FALSE
if (u.true(ploptions$grid))
ploptions$grid <-
if(lhoriz) list(TRUE, at) else list(at, TRUE)
llev <- levels(x[,1])
attr(lx, "ticklabelsat") <- attr(lx, "ticksat") <- seq_along(llev)
attr(lx, "ticklabels") <- llev
attr(lx, "varlabel") <- structure(attr(lx, "varlabel"), adj=1)
## ---------------------------------
if (lhoriz)
plframe(ly, xlim, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE)
else plframe(xlim, ly, plargs=plargs, ploptions=ploptions,
marpar=marpar, xy=FALSE)
if (axes) {
lpla <- plargs
lpla$ploptions <- ploptions
lpla$plmarpar$margin.line <- lxmline
plaxis(1+lhoriz, lx, las=2*as.logical(labelsperp),
marpar=marpar, plargs=lpla)
##- mtext(attr(lx, "varlabel"), 1+lhoriz, lxlabline,
##- cex=i.getploption("margin.csize")[1])
if(lIna && anyNA(ly))
mtext("NA", 2-lhoriz, line=lcsize, at=mean(na.pos), las=2)
##- if (backback) {
##- mtext(llev2[1], 1+lhoriz,1, at=0.75)
##- mtext(llev2[2], 1+lhoriz,1, at=1.25)
##- }
## mtext(xlab, side=1+lhoriz, line=ploptions$mar[1+lhoriz]-1)
plaxis(2-lhoriz, x=ly, marpar=marpar, plargs=plargs)
}
} # if (!add)
## ---
if (!u.isnull(refline))
if(lhoriz)
abline(v=refline, col=ploptions$refline.col,
lty=ploptions$refline.lty, lwd=ploptions$refline.lwd)
else
abline(h=refline, col=ploptions$refline.col,
lty=ploptions$refline.lty, lwd=ploptions$refline.lwd)
## ---
lusrd <- diff(par("usr")[1:2])
lsep <- lwfac["sep"]*llr*lusrd
lwoutl <- lwfac["outl"]
if (is.na(lwoutl)) {
lwoutl <- 0.05*lusrd
lwfac["outl"] <- lwoutl/lng
}
if (llr) lwfac[c("medmin","outl")] <- lwfac[c("medmin","outl")] /2
## ------------
lattr <- attributes(ly)
for (li in 1:lng) {
if (is.na(at[li])) next
lli <- llist[[li]]
if (length(lli)) {
attributes(lli) <- lattr
plmbox(lli,lpos[li]-lsep, probs=probs, outliers=outliers,
horizontal=lhoriz,
wfac=lfac[li], adj=1-0.5*(1-llr), na.pos=na.pos,
widthfac=lwfac, colors=lcol, lwd=llwd, warn=-1)
}
if (llr) { ## second half of asymmetrix mbox
llir <- llist[[li+lng]]
if (length(llir)) {
attributes(llir) <- lattr
plmbox(llir,lpos[li]+lsep,probs=probs, outliers=outliers,
horizontal=lhoriz,
wfac=lfac[li], adj=0, na.pos=na.pos,
widthfac=lwfac, colors=lcol, warn=-1)
}
}
}
pltitle(plargs=plargs)
stamp(sure=FALSE)
if (u.notfalse(assign)) plassign(list=plargs)
invisible(at) ##!!? return plargs
} ## end plmboxes
## ====================================================================
plcoordtrsf <- #f
function(x, innerrange, innerrange.ext)
{
llx <- pmax(pmin(x,innerrange[2]),innerrange[1])
lxd <- x-llx
if (any(lxd!=0, na.rm=TRUE))
x <- llx + lxd/(1+abs(lxd)/(diff(innerrange)*innerrange.ext))
x
}
## ====================================================================
plres2x <- #f
function(formula=NULL, reg=NULL, data=NULL, restrict=NULL, size = 1,
xlab = NULL, ylab= NULL, pale = 0.2,
plargs = NULL, ploptions = NULL, assign = TRUE, ...)
{
## Purpose: plot residuals vs. two x`s
## Author: ARu , Date: 11/Jun/91
## Aenderungen: MMae, 30/Jan/92, Dez.94
## --------------------------------------------------------------------------
## Arguments:
## formula z~x+y, where
## x, y coordinates of points given by two vector arguments.
## z gives orientation (by sign)
## and size (by absolute value) of symbol.
## reg regression results
## data data
## you must specify either reg or data
## restrict absolute value which truncates the size.
## The corresponding symbols are marked by stars.
## size the symbols are scaled so that "size" is the size of
## the largest symbol in cm.
## main main title, defaults to the formula
## ... additional arguments for the S-function `plot`
## the function currently only plots z for the first two terms of the
## right hand side of formula
## --------------------------------------------------------------------------
lcall <- match.call()
if (is.null(plargs)) {
lac <- as.list(lcall)[-1]
lac$x <- lac$reg
lac$xvar <- lac$formula
ladrop <- c("formula", "restrict", "size", "reg")
lcall <- c(list(quote(plregr.control)),
lac[setdiff(names(lac), ladrop)])
mode(lcall) <- "call"
plargs <- eval(lcall, parent.frame())
}
if (length(ploptions)==0) ploptions <- plargs$ploptions
plargs$plmarpar <- marpar <- i.getmarpar(plargs=plargs)
lregrft <- plargs$regrfeatures
## ------------------------------------------------------------------
lz <- lregrft$residuals
pldata <- plargs$pldata
lxvar <- attr(pldata, "xvar", exact=TRUE)
if (length(lz)==0) lz <- attr(pldata, "yvar", exact=TRUE)
##--- restrict z values
lrestr <-
if (any(attr(lz, "nouter", exact=TRUE)>0))
max(abs(attr(lz, "innerrange", exact=TRUE))) else NULL
restrict <- i.def(i.def(restrict, lrestr), NULL, valuefalse=NULL)
if(length(restrict)==0) restr <- FALSE else {
restr <- abs(lz) > restrict
lz <- pmin( pmax( lz, -restrict), restrict) }
## size
size <- i.def(size, 1)
lppin <- par("pin")
lratio <- 2*size * par("cin")[1] / lppin
llwd <- i.getploption("lwd")
lpcol <- pldata[[".pcol."]]
if (length(lpcol)) {
lgrpcol <- i.def(i.getploption("group.col"), i.getploption("col"))
if (is.factor(lpcol)) lpcol <- as.numeric(lpcol)
if (is.numeric(lpcol)) lpcol <- rep(lgrpcol, length=max(lpcol))[lpcol]
} else lpcol <- i.getploption("col")[1]
pldata$".pcol." <- colorpale(lpcol, pale=pale)
## for ...
lzj <- lz[,1]
lzj <- lzj/max(abs(lzj), na.rm = TRUE)
lpanel <-
function(xx, yy, indx, indy, pch, col, plab, lwd, zz, ...) {
lusr <- par("usr")
lfx <- lratio[1] * diff(lusr[1:2])
lfy <- lratio[2] * diff(lusr[3:4])
lsxz <- c(lfx * abs(zz))
lsyz <- c(lfy * zz)
lx <- attr(xx, "plcoord", exact=TRUE)
if (u.isnull(lx)) lx <- xx
ly <- attr(yy, "plcoord", exact=TRUE)
if (u.isnull(ly)) ly <- yy
plpoints(lx, ly, plargs=plargs, marpar=marpar, xy=FALSE)
segments(lx - lsxz, ly - lsyz, lx + lsxz, ly + lsyz,
lwd = llwd, col=col, xpd=TRUE)
##--- mark restricted observations: ---
if(any(restr)) {
points((xx - lsxz)[restr], (yy - lsyz)[restr], pch= 8, mkh = 1/40,
xpd=TRUE)
points((xx + lsxz)[restr], (yy + lsyz)[restr], pch= 8, mkh = 1/40,
xpd=TRUE)
}
}
ljx <- lxvar[1]
lx <- pldata[,ljx]
##- llrg <- attr(lx, "plrange")
##- attr(lx, "plrange") <- llrg + c(-1,1)*diff(llrg)* 2*lratio
ljy <- lxvar[2]
ly <- pldata[,ljy]
##- llrg <- attr(ly, "plrange")
##- attr(ly, "plrange") <- llrg + c(-1,1)*diff(llrg)* 2*lratio
##--
##---------------
## lplxx <- i.getploption("plsymbolext") * 2 * size
lplext <- i.getploption("plext") + 0.05*size
plframe(lx, ly, xlab=xlab[1], ylab=ylab[1], plext=lplext,
ploptions=ploptions, xy=FALSE) ## !!!? marpar
##--- draw symbols: ---
lpanel(lx, ly, zz=lzj, lwd=llwd, col=lpcol)
lmain <- lregrft$main
if (length(lmain)==0)
lmain <-
paste(attr(lzj, "varlabel", exact=TRUE), "~", lregrft$formula[2])
pltitle(lmain, outer.margin=FALSE) ## , csize=lregrft$csize.main
stamp(sure=FALSE, ploptions=ploptions)
if (u.notfalse(assign)) plassign(list=plargs)
## "plres2x done"
} ## end plres2x
## ==========================================================================
plmframes <- #f
function(mfrow=NULL, mfcol=NULL, mft=NULL, byrow=TRUE, reduce = FALSE,
oma=NULL, mar=NULL, mgp=NULL, plargs=NULL, ploptions=NULL, ...)
{
## Purpose: par(mfrow...)
## Author: Werner Stahel, 1994 / 2001
lf.mft2mf <- function(mft, din) { ## split mfg into nrowmax and ncolmax
mfrow <- max(1, ceiling(sqrt(mft*0.8*ldin[2]/ldin[1])) )
## 0.8: landscape preferred
lmcol <- ceiling(mft/mfrow)
c(ceiling(mft/lmcol), lmcol)
}
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
lmar <- i.getplopt(mar)
## requested quantities
ldin <- par("din")
lmfg0 <- if (length(mft)) lf.mft2mf(mft, ldin)
lmfg <- if (length(mfrow))
if (length(mfrow)>=2) mfrow[1:2] else c(i.def(mfrow, 0), i.def(mfcol,0))
lmfg <- if (all(lmfg<=0)) c(lmfg0,1,1)[1:2] else pmax(1,lmfg)
## nrowmax, ncolmax
lmfgmax <- i.getploption("mframesmax")
if (length(lmfgmax)==1)
lmfgmax <- if (lmfgmax==0) lmfg else lf.mft2mf(lmfgmax, ldin)
lmfgsug <- lmfg
lnpg <- ceiling(lmfg/lmfgmax)
lmfgsug <- ceiling(lmfg/lnpg)
if (reduce) lmfg <- lmfgsug
lnpmax <- max(lmfg)
## margin pars
marpar <- i.getmarpar(mar=lmar, oma=oma, plargs=plargs)
lmar <- replaceNA(rep(c(marpar$mar,NA,NA,NA,NA), length=4),
i.getploption("mar.default"))
if(reduce) lmar <- rep(lps <- i.getploption("panelsep"), length=4)
lmgp <- c(marpar$margin.line,0)
lImain <- !(length(lplft$main)==0||lplft$main=="")
lIsub <- !(length(lplft$sub)==0||lplft$sub%in%c("",":"))
ltl <- c(i.getploption("title.line", ploptions), 0.2)
## reduce if subtitle is empty !!!
lcx <- ifelse(max(lmfg)>2, 0.66, ifelse(prod(lmfg)>2, 0.83, 1))
## outer margin should not depend on number of panels.
## reverse size reduction contained in plain R
lomadef <- max(
c(lImain*(ltl[1]-ltl[2]), lIsub*ltl[2]) +
rep(c(i.getploption("title.csize"),1), length=2)/lcx )
## 0.83 may be par("cex") after
if(lomadef>0) lomadef <- lomadef+0.5/lcx
loma <- replaceNA(i.getplopt(oma),
c(0,0, lomadef, i.getploption("stamp")/lcx))
if(reduce) {
marpar$omastart <- marpar$mar - lps
loma <- loma + marpar$mar
}
loldp <-
if(byrow)
par(mfrow=lmfg, oma=loma, mar=lmar, mgp=lmgp, ...)
else par(mfcol=lmfg, oma=loma, mar=lmar, mgp=lmgp, ...)
par(new=FALSE)
invisible(
structure(list(marpar=marpar, mar=lmar, oma=loma, mfig = lmfg,
mrow = if (byrow) lmfg, mcol = if(!byrow) lmfg,
mfigsug = lmfgsug, npages = lnpg),
oldpar=loldp)
)
}
## ==========================================================================
stamp <- #f
function(sure=TRUE, outer.margin = NULL,
project=getOption("project"), step=getOption("step"),
stamp=NULL, line=NULL, ploptions=NULL, ...)
{
## Purpose: plot date and project information
## -------------------------------------------------------------------------
## Arguments:
## sure if F, the function only plots its thing if getOption("stamp")>0
## outer if T, the date is written in the outer margin
## project project title
## step title of step of data analysis
## ... arguments to mtext , e.g., line=3
## -------------------------------------------------------------------------
## Author: Werner Stahel, Date: 13 Aug 96, 09:00
stamp <- i.def(stamp, i.getploption("stamp"))
if (length(outer.margin)==0) outer.margin <- par("oma")[4]>0
t.txt <- date()
## llong <- nchar(t.txt)>23
t.txt <- paste(substring(t.txt,5,10),",",
substring(t.txt,23,24),
if(stamp>1)
paste("/", substring(t.txt,12,16),sep=""),
sep="")
if (length(project)>0 && project!="")
t.txt <- paste(t.txt, project, sep=" | ")
if (length(step)>0 && step!="")
t.txt <- paste(t.txt, step, sep=" | ")
if( sure | stamp==2 || ( stamp==1 & (
## last figure on page :
{ t.tfg <- par("mfg") ; all(t.tfg[1:2]==t.tfg[3:4]) }
|| u.true(outer.margin) ) )) {
lline <-
i.def(line,
max(( if(outer.margin) par("oma") else par("mar") )[4] - 1.2,
0.2) )
mtext(t.txt, 4, line=lline, cex = 0.6, adj = 0, outer = outer.margin, ...)
}
invisible(t.txt)
}
## ===========================================================================
legendr <- #f
function(x=0.05,y=0.95,legend, ...) {
lusr <- par("usr")
lx <- lusr[1] + x*diff(lusr[1:2])
ly <- lusr[3] + y*diff(lusr[3:4])
legend(lx,ly,legend, ...)
}
## ======================================================================
ploptions <- #f
function (x=NULL, ploptions = NULL, list=NULL, default=NULL,
assign=TRUE, ...)
{ ##
lpldef <- get("default.ploptions", pos=pl.envir)
loldo <- ploptions
if (u.isnull(loldo)) loldo <- get("usr.ploptions", pos=pl.envir)
else if (length(ploptions)==1 && is.numeric(ploptions)) {
if (ploptions==1) loldo <- get("usr.ploptions", pos=pl.envir)
else {
if (ploptions>1) loldo <- get("ploptions", pos=pl.envir)
else stop("!ploptions! invalid argument 'ploptions'")
}
}
lnewo <- loldo
##
largs <- c(list, list(...))
##
if (!u.isnull(x)) { ## asking for options
if(!is.character(x)) {
warning(":ploptions: First argument 'x' must be of mode character")
return(NULL)
}
return(if(length(x)==1) loldo[[x]] else loldo[x])
}
## --- get default values
if (length(default) && u.notfalse(default)) {
if (u.true(default)) default <- "all"
if (!is.character(default))
stop("!ploptions! Argument 'default' must be of mode character or logical")
if (default[1]=="all") largs = c(lpldef, largs)
## resets all available components
else {
if (default[1]=="unset") {
largs <- c(lpldef[names(lpldef)%nin%names(loldo)], largs)
default <- default[-1]
}
if (any(default!=""))
largs <- c(largs, lpldef[default[default%in%names(lpldef)]])
}
}
## ---
else if (is.null(largs)) return(ploptions)
## --- set options
## check
if (length(largs)) largs <- check.ploption(list=largs)
if (length(largs)) lnewo[names(largs)] <- largs
lo <- intersect(names(largs),names(loldo))
if (length(lo)) attr(lnewo, "old") <- loldo[lo]
## assign
if (assign==1) plassign("usr.ploptions", lnewo)
else if (assign>1) plassign("ploptions", lnewo)
invisible(lnewo)
}
## end of ploptions
## ---------------
plassign <- #f
function(x = NULL, value = NULL, list = NULL)
{
if (length(list)) {
x <- c(x, names(list))
value <- c(list(value),list)
for (li in seq_along(x)) assign(x[li], list[[li]], pos=pl.envir)
}
else assign(x, value, pos=pl.envir)
}
## ====================================================================
##- current <- #f
##- function (x = NULL, list = NULL, assign=TRUE, ...)
##- { ##
##- ploptions(x = x, list = list,
##- ploptions = get("ploptions", pos=pl.envir),
##- assign = 2, ...)
##- }
##- lnewc <- as.list( loldc <- current )
##- ##
##- if (!u.isnull(x)) { ## asking for options
##- if(!is.character(x)) {
##- warning(":current: First argument 'x' must be of mode character")
##- return(NULL)
##- }
##- return(if(length(x)==1) loldc[[x]] else loldc[c])
##- }
##- ## --- set components
##- largs <- c(list, list(...))
##- lnames <- c(names(largs))
##- if (assign) for (lnm in lnames) current[[lnm]] <- largs[[lnm]]
##- lnewc[lnames] <- largs
##- invisible(lnewc)
##- }
## ====================================================================
plmarginpar <- #f
function(plargs=pl.envir, csize=NULL)
{
marpar <- i.getmarpar(plargs=plargs)
ploptions <- plargs$ploptions
lcsize <- i.getplopt(csize)
loldp <- par(mar=lcsize*marpar$mar,
## oma=marpar$oma, changing oma sets a new page
mgp=c(lcsize*marpar$margin.line,0),
cex=lcsize*par("cex"))
## workaround a problem with changing margin pars
lusr <- par("usr")
try(points(1.1*lusr[1]-0.1*lusr[2],1.1*lusr[3]-0.1*lusr[4],pch=" ",
xpd=TRUE) , silent=TRUE)
invisible(loldp)
}
## ====================================================================
i.getploption <- #f
function(opt, opts=NULL)
{
## opt is character, opts list or NULL
lpldef <- get("default.ploptions", pos=pl.envir)
if (is.null(opts))
opts <- get("ploptions", envir=parent.frame()) ## list in calling fn
if (is.function(opts)) opts <- NULL
if (is.null(opts))
opts <- get("ploptions", pos=pl.envir) ## list in calling fn
## ---
lopt <- opts[[opt]]
if (is.null(lopt)||(!is.function(lopt))&&all(is.na(lopt))) ## NULL or NA
lopt <- ploptions(opt)
else {lopt <- check.ploption(opt, lopt)
if (length(lopt)) lopt <- lopt[[1]]
}
if (length(lopt)==0) lopt <- lpldef[[opt]]
lopt
}
## ---------------------------------------------------
i.getplopt <- #f
function(opt, opts = NULL) {
lpldef <- get("default.ploptions", pos=pl.envir)
if (is.null(opts))
opts <- get("ploptions", envir=parent.frame()) ## list in calling fn
lnam <- as.character(substitute(opt))
lopt <- opt
if (is.function(opts)) opts <- NULL
if (u.isnull(lopt)||(is.atomic(lopt)&&all(is.na(lopt))))
lopt <- opts[[lnam]]
if (u.isnull(lopt)||(is.atomic(lopt)&&all(is.na(lopt))))
lopt <- ploptions(lnam)
else unlist(check.ploption(lnam, lopt)) ## check
if (u.isnull(lopt)) lopt <- lpldef[[lnam]]
lopt
}
## --------------------------------------------------------------------------
i.getgroupopt <- #f
function(group, ploptions=NULL)
{ ## get point and line characteristics
if (!is.numeric(group)) group <- factor(group)
ln <- if(is.numeric(group)) max(group) else length(levels(group))
lcol <- i.getploption("col")
lgcol <- i.getploption("group.col")
lgcol <- i.def(lgcol, lcol[-1], valuefalse=rep(lcol[1],ln))
lpch <- i.getploption("pch")
lgpch <- i.getploption("group.pch")
lgpch <- i.def(lgpch, lpch[-1], valuefalse=rep(lpch[1],ln))
llty <- i.getploption("lty")
lglty <- i.getploption("group.lty")
lglty <- i.def(lglty, llty[-1], rep(valuefalse=llty[1],ln))
structure(group, group.col=lgcol, group.pch=lgpch, group.lty=lglty)
}
## -------------------------------------------------------------------------
i.getcolor <- #f
function(col, ploptions=NULL)
{ ## get color
lcolors <- i.getploption("colors")
lncol <- length(lcolors)
if (is.numeric(col)|is.logical(col)) lcolors[1+(col-1)%%lncol]
else {
if (is.character(col)) if (any(col%nin%colors())) col <- factor(col)
if (is.factor(col)) lcolors[2+(as.numeric(col)-1)%%(lncol-1)] else col
}
}
## --------------------------------------------------------------------------
i.getxy <- #f
function(x=NULL, y=NULL, plargs=NULL, ploptions=NULL, call=NULL, envir = NULL)
{
if (is.null(plargs)) plargs <- pl.envir ## get(...)
if (is.null(ploptions)) ploptions <- plargs$ploptions
pldata <- plargs$pldata
if (is.formula(x)|is.formula(y) |
any(c("data","pcol","pch","psize","group")%in%names(call))) {
call$assign <- FALSE
call$ploptions <- i.def(ploptions, plargs$ploptions)
if (u.isnull(x)|u.isnull(y)) {
call$data <- pldata ## attributes should be obtained from this dataset
if (u.isnull(x)) call$x <- pldata[,attr(pldata, "xvar", exact=TRUE)]
if (u.isnull(y)) call$y <- pldata[,attr(pldata, "yvar", exact=TRUE)]
}
call$gencoord <- FALSE ## i.getxy is called by low level pl functions
call$ploptions <- ploptions
plargs <- do.call(pl.control, as.list(call[-1]), envir=envir)
ploptions <- plargs$ploptions
pldata <- plargs$pldata
x <- pldata[,attr(pldata, "xvar", exact=TRUE)]
y <- pldata[,attr(pldata, "yvar", exact=TRUE)]
} else {
## ---
## x or y not explicit
if (u.isnull(x)) x <- pldata[,c(attr(pldata, "xvar", exact=TRUE),1)[1]]
if (lnox <- u.isnull(x))
warning(":[low level pl fn]: no x values found")
if (u.isnull(y)) y <- pldata[,c(attr(pldata, "yvar", exact=TRUE),2)[1]]
if (lnoy <- u.isnull(y))
warning(":[low level pl fn]: no y values found")
if (lnox|lnoy) return(NULL)
##- if (length(x)==0) x <- pldata[,1]
##- if (length(y)==0) y <- pldata[,2]
}
list(x=x, y=y, plargs=plargs, ploptions=ploptions)
}
## -------------------------------------------------------
i.getmarpar <- #f
function(marpar=NULL, mar=NULL, axes=NULL, axlab=axes,
title=TRUE, title.line=NULL,
plargs=pl.envir, ploptions=NULL, ...)
{ ## get graphical parameters that control plot margins
if (is.null(ploptions)) ploptions <- plargs$ploptions
lplft <- plargs$plfeatures
axes <- i.getplopt(axes, ploptions)
##
lmcs <- rep(i.getploption("margin.csize", ploptions), length=2)
lex <- i.getploption("margin.exp", ploptions) * lmcs[1]
lml <- i.getploption("margin.line", ploptions)
## ltcs <- rep(i.getploption("title.csize", ploptions), length=2)
## space for title
ltl <- c(i.getplopt(title.line, ploptions),0.2)
## title.line will be modified if sub is empty
ltl <- ltl - (length(lplft$sub)&&lplft$sub!="")*(ltl[2]-0.2)
ltm <- ifelse(u.notfalse(title), max(ltl), 0)
lIstamp <- i.getploption("stamp")
lmaxes <-
ifelse((1:4)%in%axlab, lml[1] + ifelse((1:4)%nin%axes, diff(lml), 0),
ifelse((1:4)%in%axes, lml[2], 0))
lmar <- pmax(lmaxes) + c(0,0, ltm, lIstamp*0.7) + lex
if (length(mar)) lmar <- replaceNA(mar, lmar)
structure(list(mar=lmar, title.line=ltl, margin.line=lml), class="i.marpar")
}
## -----------------------------------------------------------------------
charSize <- function(n) min(1.5/log10(n),2)
markextremes <- function(n) ceiling(sqrt(n)/2)/n
smoothpar <- function(n) c(min(1.8/n^0.2, 0.98), 1.5)
smoothxtrim <- function(n, c=2) 1.6^(log10(n)*c)/n
## ======================================================================
## checking functions
check.ploption <- #f
function(optname, value, list=NULL) {
if (is.null(list)) list <- setNames(list(value), optname)
lnl <- length(list)
loptnames <- names(list)
for (lil in seq_len(lnl)) {
lnm <- loptnames[lil]
lvalue <- list[[lnm]]
lcheck <- ploptionsCheck[[lnm]]
if (length(lcheck)) {
## if (is.list(lcheck)) {
if (!is.list(lcheck[[1]])) lcheck <- list(lcheck)
lnopt <- length(lcheck)
lmsg <- rep("", lnopt)
for (lj in seq_len(lnopt)) {
lch <- lcheck[[lj]]
lfn <- get(lch[[1]])
lmsg[lj] <- lmsgj <-
switch(paste("v",length(lch),sep=""), v0="", v1=lfn(lvalue),
v2=lfn(lvalue, lch[[2]]), v3=lfn(lvalue, lch[[2]], lch[[3]]),
v4=lfn(lvalue, lch[[2]], lch[[3]], lch[[4]]),"")
if (lmsgj=="") break
}
## }
if (all(lmsg!="")) {
warning(":check.ploption: argument '", lnm,
"' not suitable. It should\n ",
paste(lmsg, collapse=" -- or \n "),
"\n instead of (str())", immediate.=TRUE)
str(lvalue)
list[lnm] <- NULL
}
}
}
## return components that passed the test
list
}
## -----------------------------------------------------------
check.color <- #f
function(x, dummy) {
if (is.atomic(x) && is.character(x)) {
lpal <- ploptions("colors") ## palette()
lx <- try(palette(c(x,"black")), silent=TRUE)
## palette asks for at least 2 colors
palette(lpal) ## restore palette
if (inherits(lx, "try-error"))
return("consist of known color names")
else return("")
}
else {
if(is.atomic(x) && is.numeric(x)) {
if(all(x>=0 )) return("") ## & x<=length(palette())
else return("if numeric, be >=0") ## and <=length(palette())
}
else {
if (is.matrix(x)) {
if (!any(li <- apply(x, 2, function(x) x<0 | x>255))) return("")
return(
paste("be a matrix with 3 rows with numbers in [0, 255]",
if (length(x)>1) paste("\n columns ",paste(li, collapse=", "),
" out of range")) )
}
}
}
"be a (vector of) color name(s) or an rgb matrix"
}
##---------
check.numrange <- #f
function(x, range, na.ok=TRUE, length=NA) {
if (is.function(x)) return("be numeric (not a function)")
if (!is.na(length)) {
if (length > length(x))
return(paste("have length at least ",length))
}
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!(is.numeric(x)|is.logical(x))) return("be numeric")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(range))) return("")
range <- ifelse(is.na(range), c(-Inf,Inf), range)
if (!any(li <- x<range[1]|x>range[2], na.rm=TRUE)) return("")
paste("be within [",paste(range, collapse=", "),"]",
if (length(x)>1) paste("\n violated for element(s) ",
paste(which(li), collapse=", ")))
}
check.numvalues <- #f
function(x, values=NA, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!(is.numeric(x)|is.logical(x))) return("be numeric")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(values))) return("")
if (any(li <- (!is.na(x) & (x %nin% values))))
return(paste("have values in [",
paste(values[1:min(5, length(values))], collapse=", "),
if (length(values)>5) ",...", "]",
if (length(x)>1) paste("\n violated for elements ",
paste(li, collapse=", "))) )
""
}
check.char <- #f
function(x, values, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (!is.character(x)) return("be of mode character")
if ((!na.ok) && any(is.na(x))) return("not contain NAs")
if (all(is.na(values))) return("")
if (!any(li <- (!is.na(x) & (x %nin% values)))) return("")
paste("have values in [",
paste(values[1:min(5, length(values))], collapse=", "),
if (length(values)>5) ",...", "]",
if (length(x)>1) paste("\n violated for elements ",
paste(li, collapse=", ")))
}
check.logical <- #f
function(x, values, na.ok=TRUE) {
if (na.ok && (u.isnull(x) || (is.atomic(x)&&all(is.na(x)))) ) return("")
if ((is.logical(x) | (is.numeric(x))) && !all(is.na(x)) ) return("")
"be of mode logical (or interpretable as such)"
}
check.list <- #f
function(x) {
if (is.list(x)) return("")
"be a list"
}
check.listnum <- #f
function(x, values=NA, na.ok=TRUE) {
if (is.list(x)) {
lchk <- lapply(x, function(xx) check.numvalues(xx, values, na.ok) )
if (all(lchk=="")) return("")
return(paste("if a list, all components must be numeric"))
}
"be a list"
}
check.function <- #f
function(x, values, na.ok=TRUE) {
if (is.function(x)) return("")
if (na.ok && (u.isnull(x) || all(is.na(x))) ) return("")
if (is.character(x)) {
lfn <- try(get(x), silent=TRUE)
if (inherits(lfn, "try-error"))
return(paste("be a function or the name of an existing function.\n '",
lfn, "' is not available.") )
else return("")
}
"be a function or the name of an existing function."
}
## ----------------------------------------------------------------------
cnr <- function(range=NA, na.ok=TRUE, length=NA)
list("check.numrange", range=range, na.ok=na.ok, length=length)
cnv <- function(values=NA) list("check.numvalues", values=values)
cch <- function(values=NA) list("check.char", values=values)
ccl <- function() list("check.color", NULL)
clg <- function(na.ok=TRUE) list("check.logical", na.ok=na.ok)
cfn <- function() list("check.function", NULL)
cls <- function() list("check.list")
cln <- function(values=NA) list("check.listnum", values=values)
## ---------------------------------------------------------------------
c.pchvalues <- c(0:25,33:120)
c.ltyvalues <- 1:6
## ==========================================================================
c.colors <- c("black","red","blue","darkgreen", ##"deepskyblue3",
"orange","purple","deepskyblue2","green3","coral4",
"pink3", "aquamarine3", "brown2") ## "darkgoldenrod3", "burlywood",
t.ncol <- length(c.colors)
t.col <- 1:t.ncol
## visualize the colors, possibly to improve the definition
##- palette(c.colors)
##- plot(0:1, c(1,length(ly <-1:length(c.colors))), type="n")
##- for (lj in 1:length(ly)) lines(0:1, rep(lj,2), col=lj, lty=1)
##- c.colors <- c("black","red","blue","darkgreen","brown","orange","purple",
##- "olivedrab", "burlywood", "violet")
c.dateticks <- data.frame(
limit =c(30*365,3800,3.1*365,370,190, 65, 35, 10, 5, 3, 1,.33,.16,.09),
smallunit = I(c( "y","y","m","m","m","d","d","d","h","h","h","h","M","M")),
smallint = c( 1 , 1 , 3 , 1 , 1 , 10, 5 , 1 , 12, 3 , 1 , 1 , 30, 15),
bigunit = I(c( "y","y","y","m","m","m","d","d","d","h","h","h","h","M")),
bigint = c( 5 , 2 , 1 , 3 , 3 , 1 , 10, 5 , 1 ,12 , 3 , 3 , 1 , 30),
labelunit = I(c( "y","y","y","m","m","m","d","d","d","d","h","h","h","h")),
labelint = c( 5 , 5 , 1 , 6 , 3 , 1 , 10, 5 , 1 , 1 , 6, 6 , 1 , 1 )
)
## ----------------------------------------------------------------------
usr.ploptions <- default.ploptions <-
list(
keeppar = FALSE,
colors = c.colors, pale = 0.3,
linewidth = c(solid=1, dash=1.3, dot=1.7,
dashDot=1.3, dashLong=1.2, dashLongDot=1.15),
csize = 1,
ticklength = c(-0.5, 0, 0.2, -0.2),
tickintervals = c(7,4),
## basic
pch = 1:18, csize.pch=charSize, csize.plab=0.7, ## !?
psize.max = 3,
lty=c.ltyvalues, lwd=1, col=t.col, pcol=t.col, lcol=t.col,
##
innerrange = TRUE, innerrange.factor=4, innerrange.ext=0.1,
innerrange.function = "robrange",
plext=0.05, markextremes = markextremes, ## is a function...
## variables
variables.pch=1:18, variables.col=c.colors, variables.lty=c.ltyvalues,
variables.lcol=c.colors,
## censored
censored.pch = c(62, 60, 2, 23, 23, 6, 23, 23),
## >, <, Delta, q,q, nabla, q,quadrat
censored.size=1.3, censored.pale = 0.3,
## group
group.pch=TRUE, group.col=TRUE, group.lty=TRUE,
group.lcol=TRUE,
## title (mtext)
title.line=c(2,0.8), title.adj = c(0.5,0.97,0.03),
title.csize=c(1.3,1), title.csizemin=0.6, title.maxchars=80,
sub = TRUE,
##
xlab = "", ylab = "",
mframesmax = 30,
panel = "plpanel",
## frame
axes = 1:2,
mar = c(3,3,2,1)+0.2, mar.default = c(3,3,2,1)+0.2,
oma=rep(NA,4), oma.default=c(0,0,2,0)+0.2,
margin.csize = c(1.2, 1), margin.line = c(2,0.8),
margin.exp = c(1,0.8),
panelsep = 0.5,
date.origin = 1970, date.format=c("y-m-d", "h:m:s"),
## time axes
##- timerangelim =
##- list(year=c(4,20), month=c(4,6), day=c(4,10), hour=4, min=4),
date.ticks = c.dateticks,
## grid
grid = TRUE, grid.lty = 1, grid.lwd = 1, grid.col = "gray75",
zeroline = TRUE, zeroline.lty = 1, zeroline.lwd = 1,
zeroline.col = "gray50",
## refline
refline = TRUE,
refline.lty = c(4,6), refline.lwd = c(1,0.7), refline.col = "darkgreen",
## smooth
smooth = TRUE,
smooth.function = "smoothRegr", smooth.par = smoothpar, smooth.iter = 50,
smooth.minobs = 8, smooth.band = FALSE,
## smoothline
smooth.lty = 1, smooth.lwd = c(2, 0.7),
smooth.col = "blue", smooth.pale = c(0.7,-0.3),
smooth.xtrim = smoothxtrim,
## bars
bar.midpointwidth = 1, bar.lty = 1, bar.lwd = c(2,1), bar.col = "burlywood4",
## factors
factor.show = "mbox", backback = TRUE,
mbox.minnobs = 6, mbox.minheight = 0.02,
mbox.colors = c(box="lightblue",med="blue",na="gray90",refline="magenta"),
jitter = NA, jitter.minnobs = 6, jitter.factor = 0.8,
## condquant
condquant = TRUE, condprob.range = c(0,1), condquant.pale = c(0.5, 0.5),
condquant.pch = c(3,4),
## plmatrix
diaglabel.csize = 1.5,
## plcond options
plcond.panel = plpanelCond,
plcond.nintervals = 5, plcond.extend=0.5, ## condvarExtend,
plcond.col = c("darkgreen", "coral3", "blue", "magenta3"),
plcond.pale = c(0.2,0.7), plcond.csize = 0.8,
## subset
subset.rgratio = 0.9,
## plregr
functionxvalues = 51,
regr.plotselect = c( yfit=0, resfit=NA, absresfit = NA,
absresweights = NA, qq = NA,
leverage = 1, resmatrix = 1, qqmult = 1),
regr.addcomp = FALSE,
leveragelimit = c(NA, 0.99),
cookdistlines = 1:2,
stamp=1, doc=TRUE,
printnotices = TRUE, debug = FALSE )
## -----------------------------------------------------------------------
ploptionsCheck <-
list(
keeppar = clg(),
colors=ccl(), pale = cnr(c(-1,1)),
linewidth = cnr(c(0.1,5)), csize = cnr(c(0.1,5)),
ticklength = cnr(c(-2,2)),
tickintervals = cnr(c(2,20)),
## basic
pch = cnv(c.pchvalues),
csize.pch = list(cfn(),cnr(c(0.1,5))), csize.plab=cnr(c(0.1,5)),
lty=cnv(c.ltyvalues), lwd=cnr(c(0.1,5)),
col=list(cnr(c(0,t.ncol)), ccl()), lcol=list(cnr(c(0,t.ncol)), ccl()),
pcol=list(cnr(c(0,t.ncol)), ccl()),
## group
group.pch=cnv(c.pchvalues),
group.col=list(clg(),ccl()), group.lty=list(clg(),cnv(c.ltyvalues)),
group.lcol=list(clg(),ccl()),
## variables
variables.pch=cnv(c.pchvalues), variables.col=ccl(),
variables.lty=cnv(c.ltyvalues),
variables.lcol=list(cnr(c(0,t.ncol)), ccl()),
## censored
censored.pch = cnv(c.pchvalues),
censored.size=cnr(c(0.1,5)), censored.pale = cnr(c(0,1)),
## frame
panelsep=cnr(c(0,3)),
## title
title.csize=cnr(c(0.1,5)), title.csizemin=cnr(c(0.1,2)), title.adj = cnr(c(-0.2,1.2)),
title.line=cnr(c(-5,5)), title.maxchars=cnr(c(5,200)),
sub = list(clg(),cch()),
axes=list(cnr(c(1:4), na.ok=TRUE),clg()),
mar=cnr(c(0,20), na.ok=TRUE), mar.default=cnr(c(0,20), na.ok=FALSE),
oma=cnr(c(0,10), na.ok=TRUE), oma.default=cnr(c(0,10), na.ok=FALSE),
mgp=cnr(c(0,5), na.ok=FALSE, length=3),
panel=list(cfn(),cch()),
date.origin = cnr(c(1900,2050)), date.format = cch(),
stamp=list(clg(),cnr(c(-1,2))),
mframesmax = cnr(c(4,100)),
innerrange = list(clg(),cnr()), innerrange.factor=cnr(c(0.5,10)),
innerrange.ext = cnr(c(0,0.5)),
plext = cnr(c(0,0.5)), markextremes = list(cfn(), cnr(c(0,0.5))),
## plcond options
plcond.panel = cfn(),
plcond.ninterval = cnr(0,50), plcond.extend=list(cfn(), cnr(c(0,10))),
plcond.col = list(cnr(c(0,t.ncol)), ccl()),
plcond.pale = cnr(c(0,1)), plcond.csize = cnr(c(0,3)),
## plcond.mix = cnr(c(0,1)),
zeroline = list(clg(),cnr()),
zeroline.lty = cnv(c.ltyvalues), zeroline.lwd = cnr(c(0.1,5)),
zeroline.col = list(cnr(c(0,t.ncol)), ccl()),
## refline
refline = list(cls(), clg(),cnr(0,2),cfn()),
refline.lty = cnv(c.ltyvalues), refline.lwd = cnr(c(0.1,5)),
refline.col = list(cnr(c(0,t.ncol)), ccl()),
## smoothline
smooth.lty = cnv(c.ltyvalues), smooth.lwd = cnr(c(0.1,5)),
smooth.col = list(cnr(c(0,t.ncol)), ccl()), smooth.pale = cnr(c(-1,1)),
smooth = clg(),
smooth.function = cfn(), smooth.par = list(cfn(), cnr(c(0,2))),
smooth.minobs = cnr(c(3,20)), smooth.band = clg(),
## bars
bar.lty = cnv(c.ltyvalues), bar.lwd = cnr(c(0.1,5)),
bar.col = list(cnr(c(0,t.ncol)), ccl()),
bar.midpointwidth = cnr(c(0.1,5)),
## factors
factor.show = cch(c("mbox","jitter","asis","")), backback = clg(),
mbox.minnobs = cnr(c(1,Inf)), mbox.minheight = cnr(c(0,0.1)),
mbox.colors = ccl(),
jitter = clg(), jitter.minnobs = cnr(c(1,Inf)),
jitter.factor = cnr(c(0.1,1)),
## time axes
## subset
subset.rgratio = cnr(c(0.1,1)),
## condquant
condquant = clg(), condquant.pale = cnr(c(0,1)),
condquant.pch = cnv(c.pchvalues),
condprob.range = cnr(c(0,1)),
## plmatrix
diaglabel.csize = cnr(c(0.2,10)),
## plregr
functionxvalues = cnr(c(5,500)),
smooth.xtrim = list(cfn(), cnr(c(0,0.4), na.ok=FALSE)),
regr.plotselect = cnr(), regr.addcomp = clg(),
leveragelimit = cnr(c(0.05,0.99999)), cookdistlines = cnr(c(0.05, 5)),
printnotices = clg(), debug = clg()
)
## --------------------------------------------------------------------------
pl.envir <- new.env()
pl.envir$ploptions <- pl.envir$usr.ploptions <- default.ploptions
pl.envir$pl.scaleFunctions <- c("log","log10","logst","sqrt","asinp","logit","qnorm")
## ======================================================================
i.argPldata <- c("psize", "plab", "pch", "pcol",
"by", "group", "smooth.group", "smooth.weights", "smooth.weight")
i.argPlcontr <-
c("x", "y", "data", "transformed", "subset", ## "csize", "markextremes",
"vcol", "vlty", "vpch", "plscale", ## "smooth",
"main", "sub", ".subdefault", ## "mar",
"xlab", "ylab", "varlabel",
"ploptions", ".environment.")
i.argPlregr <- c("plotselect", "sequence", "addcomp", "smooth.legend")
Try the plgraphics package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.