tests/pl-test.R

In plgraphics: User Oriented Plotting Functions

require(plgraphics) ##, lib="/u/stahel/R/regdevelop/pkg/plgraphics.Rcheck")
## require(plgraphics, lib="/u/stahel/R/regdevelop/pkg/plgraphics.Rcheck")

if(!dev.interactive(orNone=TRUE)) pdf("pl-test.pdf")

plyx(Sepal.Width~Sepal.Length, data=iris)
plyx(iris[,c("Sepal.Width","Sepal.Length")]) ##!!! farben
plyx(iris$Sepal.Width~iris$Sepal.Length)
plyx(~Sepal.Length, ~Sepal.Width, data=iris)
ff <- function() plyx(~Sepal.Length, ~Sepal.Width, data=iris)
ff()

## ploptions
ploptions("linewidth")
t.plo <- ploptions(linewidth=1.5)
ploptions("linewidth")
t.plo$linewidth
pl.envir$ploptions$linewidth
default.ploptions$linewidth
t.plo <- ploptions(default="linewidth")
ploptions("linewidth")

t.plo <- ploptions(col="magenta", smooth.col="darkgreen", assign=F)
attr(t.plo, "old")
ploptions("col")
t.plo$col

par(mar=c(2,2,1,2))
ploptions(mar=rep(4,4), setpar=TRUE)
par("mar")
attr(pl.envir$ploptions, "oldpar")
t.plo <- ploptions(default="mar", setpar=TRUE)
## stopifnot(all(par("mar")==default.ploptions$mar))

par(attr(pl.envir$ploptions, "oldmarginpar"))
par("mar")

## margins
plmframes(2,1)
ploptions(default="all", setpar=TRUE)
par(mar=c(2,2,5,2))
plyx(Sepal.Width~Sepal.Length, data=iris) ## margins according to ploptions
par("mar") ## paramteres have been recovered
mtext("wrong place for text",3,1, col="red")  ## margins not appropriate for active plot
points(8,4.5, pch="X", col="red") ## with xpd=F, the point is not shown
points(8,4.5, pch="X", col="red", xpd=TRUE) ##  the point is not shown
plpoints(8,4.5, pch="O", col="blue", pch.cex=5)
par("mar")
t.plo <- plmarginpar() ## get margin parameters from pl.envir 
  ## generated by the last pl graphics call
par("mar")
mtext("here is the right place",3,1, col="blue")
t.usr <- par("usr")
points(t.usr[1],t.usr[4], pch="O", col="magenta", cex=4)

par(t.plo)  ## restores old 'margin parameters' 
par("mar")

plyx(Sepal.Width~Sepal.Length, data=iris, keeppar=TRUE)
par("mar")
mtext("this goes to the right place, too",3,1)

par(mar=c(2,2,5,2))
plot(1:10)
plpoints(8,8, col="red", csize=2) ## surprise, it works
## ------------
plyx(Sepal.Width~Sepal.Length, data=iris,
     margin.csize=c(1.3,0.7), margin.line=c(2,1.2), csize=0.8) 
## -----------------------------------------------------

plyx(Sepal.Width ~ Sepal.Length, data=iris)
## again, each step separately
t.dt <- pl.envir$pldata
pl.envir$grid <- TRUE
plframe(t.dt$Sepal.Length, t.dt$Sepal.Width)
plframe(Sepal.Width~Sepal.Length, data=iris)
plframe()
plsmooth(t.dt$Sepal.Length, t.dt$Sepal.Width)
plsmooth(smooth.col="red",smooth.lty=1)
t.plab <- plmark(t.dt$Sepal.Length, t.dt$Sepal.Width, markextremes=0.03,
                 plargs=pl.envir)
plpoints(t.dt$Sepal.Length, t.dt$Sepal.Width, plargs=pl.envir, plab=t.plab) 
plpoints(col="blue", cex=2) ## gets the coordinates from pl.envir
plpoints(Sepal.Width ~ Sepal.Length, data=iris, pch="+", cex=2, col="green") 

## ---------------------------------------------------------
plmframes(2,2)
plyx(Sepal.Width~Sepal.Length, data=iris, ploptions=t.plo)
plyx(Sepal.Width~Sepal.Length, data=iris, 
     psize=Petal.Length^3, pcol=Species, pch=Species, cex=1.5)
plyx(Sepal.Width~Sepal.Length, data=iris, smooth=2, smooth.group=Species)
plyx(Sepal.Width~Sepal.Length, data=iris, smooth=TRUE, group=Species)
plmframes()
plyx(jitter(Sepal.Width) ~ jitter(Sepal.Length), data=iris, axp=7, plab=T)
plmframes(2,3, mar=c(NA, 0.5), oma=c(2,2,2,2)+2)
plyx(Petal.Length+Petal.Width~Sepal.Length+Sepal.Width, group=Species,
     data=iris, mf=FALSE)
plmframes(2,2)
plyx(Petal.Length ~ Sepal.Length+Sepal.Width, data=iris, smooth=TRUE,
     smooth.group=iris$Species, refline=lm, refline.lwd=2)
plyx(Sepal.Width~Sepal.Length, data=iris[1:50,], smooth=F, markextremes=0.1)
plyx(Sepal.Width~Sepal.Length, data=iris,
     refline=function(x,y) { mtext("anything goes",3,-1); c(9,-1)})
attr(iris$Sepal.Length, "ticksat") <- 
  structure(seq(4, 8, 0.5), small=seq(4,8,0.1))
iris$"(pcol)" <- as.numeric(iris$Species)
plyx(Sepal.Width~Sepal.Length, data=iris)

t.plargs <- pl.control(~Species+Petal.Length, ~Sepal.Width+Sepal.Length,
                       data=iris, smooth.group=Species, group=Species)
t.plargs$ploptions$group.col <- c("magenta","orange","cyan")
plpanel(iris$Petal.Length, iris$Petal.Width, plargs=t.plargs, frame=TRUE)

t.plo <- ploptions(col="blue")
plyx(Sepal.Width~Sepal.Length, data=iris, ploptions=t.plo)
plyx(Sepal.Width~Sepal.Length, data=iris)

ploptions(gridlines.col="lightblue")
t.plo <- ploptions(list=list(smooth.lty=4, smooth.lwd=5), assign=FALSE)
plyx(Sepal.Width~Sepal.Length, data=iris, ploptions=t.plo, gridlines=TRUE)

plyx(y=EuStockMarkets[1:40,], type="b") ## ??? 2 blaue linien
plyx(structure(1:40, varlabel="time"), EuStockMarkets[1:40,], type="b")

ff <- function(formula, data, smooth=T, pcol=1)
  plyx(formula, data=data, smooth=smooth, pcol=pcol)
ff(Sepal.Width~Sepal.Length, data=iris, pcol=I("gray"), smooth=T)

## plmatrix
plmatrix(iris, pch=as.numeric(Species))
plmatrix(~Sepal.Length+Sepal.Width, ~Petal.Length+Petal.Width, data=iris,
         smooth=TRUE, pch=as.numeric(iris[,"Species"]))
plmatrix(~Sepal.Length+Sepal.Width, ~Petal.Length+Petal.Width, data=iris,
         panel=points)

plmatrix(Petal.Width+Petal.Length~Sepal.Width+Sepal.Length+Species, data=iris, 
     margin.csize=c(1.3,0.9), margin.line=c(2,1.2), csize=1.2) 

## plmboxes
plmboxes(Sepal.Width~Species, data=iris, labelsvert=1, main="iris")
plmboxes(Sepal.Length~Species, data=iris,
  widthfac=c(med=2), colors=c(med="red"), horizontal=TRUE)

## attributes of variables
data(d.blast)
dd <- genvarattributes(d.blast)
str(attributes(dd$tremor))
ddd <- setvarattributes(dd, list( tremor=list(ticksat=seq(0,24,2),
  ticklabelsat = seq(0,24,10)) ) )
str(attr(ddd$tremor, "ticklabels"))

plyx(tremor~distance, data=ddd, subset=location=="loc3")

dd <- d.blast[d.blast$location=="loc6",]
## outliers and type="l" or "b"
dd$distance[2:5] <- c(150, 130, 110, 125)
dd$tremor[c(2,4)] <- 6
plyx(tremor~distance, data=dd, innerrange.factor=2, type="b")
## ------------------------------------------------------------
## gendate
rr <- gendate(year=2010, month=c("Jan","Apr"), day=c(3,30),
            hour=25, min=c(0,70), sec=c(0,300))
stopifnot(all(
  format(rr) == c("(10-01-04 01:00:00)", "(10-05-01 02:15:00)")
  ))
td <- data.frame(datum=as.Date(c("2010-05-20","1968-05-01")),
                 tag=c(1.5, 3), min=c(30,70))
rr <- gendate(date=datum, day=tag, hour=6, data=td, min=min)
stopifnot(all(
  format(rr) == c("(10-05-20 06:30:00)", "(68-05-01 07:10:00)")
  ))
gendate(day=tag, hour=4, data=td, min=min) 
gendate(day=tag, data=td, min=min, sec=8) 
## -----------------------------------------------
plscale
prettyscale
rr <- plscale(c(0.01,1,2,5,10), "log")
## inverse function
aa <- c(0.1,10,50,100)
stopifnot(all( abs(attr(asinp, "inverse")(asinp(aa)) - aa)<1e-13) )
## =========================================
#require(regr)
## attach("../div/pl-data.rda")
showd(dd)
data(d.blast)
rr <-  lm(logst(tremor)~location*log10(distance)+log10(charge), data=d.blast)
rr <- r.blast <-
  lm(logst(tremor)~location+log10(distance)+log10(charge), data=d.blast)
plregr(rr,mf=c(3,3))
plregr(rr, addcomp=TRUE)
plregr(rr, xvar=FALSE, plotselect=c(yfit=TRUE, resfit=FALSE))
plregr(rr, transformed=TRUE, reflinesband=TRUE, sequence=TRUE)

plresx(rr, transformed=TRUE, regr.addcomp=TRUE)
plyx(d.blast$charge, naresid(structure(rr$na.action, class="exclude"), rr$resid))

dd <- d.blast[as.numeric(d.blast$location)<=3,]
dd[1,"distance"] <- 200
rr <- lm(log10(tremor)~log10(distance)+log10(charge)+location, data=dd)
plres2x(~ log10(distance) + log10(charge), reg=rr, transformed=F,
        pcol=location) ## ???

## utilities
showd(dd)
sumNA(dd)
tit(dd) <- "blasting"
plmatrix(dd, main="test plmatrix")
## --------------------------------------
plcond(Sepal.Width~Sepal.Length, data=iris, condvar=~Petal.Length+Petal.Width)
## --------------------------------------
## functions generating elements
t.fc <- fitcomp(rr,se=TRUE)
t.fc$comp[1:10,]
t.fct <- fitcomp(rr, se=TRUE, transformed=TRUE)

rr <- lm(log10(tremor)~location+log10(distance)+log10(charge), data=d.blast)
r.smooth <- gensmooth( fitted(rr), residuals(rr))
showd(r.smooth$y)
plot(fitted(rr), resid(rr), main="Tukey-Anscombe Plot")
abline(h=0)
lines(r.smooth$x,r.smooth$y, col="red")
## grouped data
t.plargs <- list(pldata=data.frame(d.blast$location), names="(smoothGroup)")
## residuals against regressor, without  plresx:
t.res <- naresid(structure(r.blast$na.action, class="exclude"), residuals(r.blast))
r.smx <- gensmooth( d.blast$dist, t.res, plargs=t.plargs)
plot(d.blast$dist, t.res, main="Residuals against Regressor")
abline(h=0)
plsmoothline(r.smx, d.blast$dist, t.res, plargs=t.plargs)

## --------------------------------------------------------
## multivariate regression
data(d.fossileSamples)
rr <-
  lm(cbind(sAngle,lLength,rWidth)~SST+Salinity+lChlorophyll+Region,
                data=d.fossileSamples)
plregr(rr)
data(d.fossileSamples)
r.foss <-
  lm(cbind(sAngle,lLength,rWidth)~SST+Salinity+lChlorophyll+Region+N,
  data=d.fossileSamples)
plregr(r.foss, plotselect=c(resfit=3, resmatrix=1, qqmult=1))

## ================================================
## glm
data(d.babysurvival)
t.d <- d.babysurvival
t.d$Age[2] <- NA
rr <- glm(Survival~Weight+Age+Apgar1,data=t.d,family=binomial)
plregr(rr, xvar=~Weight, cex.plab=0.7, ylim=c(-5,5))
plregr(rr, xvar= ~Age+Apgar1)
plregr(rr, condquant=FALSE)

## polr
if(requireNamespace("MASS")) {
data(housing, package="MASS")
rr <- MASS::polr(Sat ~ Infl + Type + Cont, weights = Freq, data = housing)
t.res <- residuals.regrpolr(rr)
showd(attr(t.res, "condquant"))
plregr(rr)
plregr(rr, factor.show="jitter")
}

## survreg
if(requireNamespace("survival")) {
data(cancer, package="survival")
cancer$gender <- factor(c("m","f")[cancer$sex])
r.sr <- survival::survreg(
  survival::Surv(time, status) ~ age + gender + ph.karno, data=cancer) 
plregr(r.sr, group=gender, pcol=gender, xvar=~age)
r.cox <- survival::coxph(
  survival::Surv(time, status) ~ age + gender + ph.karno, data=cancer) 
plregr(r.cox, group=gender, pcol=gender, xvar=~age)
}