Die perfekte Grafik mit R – base schlägt gg

Ulrike Grömping
Beuth Hochschule für Technik Berlin


28. April 2021

Warum dieser Vortrag?

Sucht man im Web, findet man (fast) nur gg:

Konsequenz: viele Grafiken mit gg-Voreinstellungen, was bzgl.

oft keine Bereicherung ist.

Rahlf (2017) hat mich mit seinen schönen Grafiken beeindruckt (mit seinem Code weniger; und die Farben – ausgewählt für Print – funktionieren auf dem Bildschirm nicht immer).

gg auf freier Wildbahn

Screenshot einer Konferenz-Präsentation

Screenshot einer Konferenz-Präsentation

gg auf freier Wildbahn

Screenshot einer Konferenz-Präsentation

Screenshot einer Konferenz-Präsentation

Ziel des Vortrags

When done right, graphs can be appealing, informative, and of considerable value to an academic article. Unfortunately, researchers generally suck at making good graphs. We surmise that this is because researchers do not completely master their graphing software, and they are either too lazy or too busy to remedy the situation. Consequently, the produced graph is often a severe distortion of the ideal Platonian graph that the researcher had in mind initially.

R kann den “ideal Platonian graph” erstellen.

Ziel des Vortrags:
Hinweise und Beispiele – vor allem für Base R – dies zu erreichen

Kleiner Beitrag dazu: R package prepplot, erstellt um die Umsetzung von Tipps aus Rahlf (2017) zu unterstützen

Grafik-Philosophien in R

Hier vor allem: Base R Grafik, kleine Exkurse zu gg Grafik

Spoiler: Es wird keine perfekte Grafik gezeigt …

Base R Grafik Cheat Sheets

wären dringend nötig, weil bei der Vielzahl der Parameter die Orientierung fehlt

Es gibt einige wenige - mit sehr unterschiedlichen Ausrichtungen.

Schwierig:

Ich habe einen Drei-Seiter erstellt, der

darstellt.

Regionen und Ränder: eine Grafik

Standard Parameter für Übergreifendes

Standard Parameter für Plot-Inhalte

können in par und vielen Plot-Funktionen verwendet werden.

Plot-Elemente

Platzierung von Annotationen

Standardparameter für Achsen und Titel (ohne cex)

Standard Parameter für Text

können in par, in text, in mtext und teils auch in Plot-Funktionen verwendet werden.

pos für Text-Positionierung kann in text verwendet werden und überschreibt dann adj.

cex betrachten wir später noch genauer.

Arrangements mit mehreren Abbildungen

Einfach: par Parameter mfrow, mfcol multiple figures by row or col

par(mfrow=c(2,3)) erzeugt ein gleichmäßiges 2x3 Layout,
das zeilenweise befüllt wird.

par(mfcol=c(2,3)) erzeugt ein gleichmäßiges 2x3 Layout,
das spaltenweise befüllt wird.

Arrangements mit mehreren Abbildungen

Spannender: layout kann flexible Aufteilungen gestalten, z.B. für gemeinsame Legenden mehrerer Plots oder regelrechte Dashboards.

mm <- rbind(c(1,1,2),
            c(1,1,3),
            c(4,5,5))
layout(mat=mm, widths=c(2,1,1), heights=c(2,2,1))

Dies kann z.B. genutzt werden, um eine gemeinsame Legende für mehrere “small multiples” Diagramme zu liefern (z.B. für diese Grafik verwendet, hier der zugehörige Code).

Regionen und Ränder: mehrere Grafiken

Randgrößen und Schriftgrößen

Umrechnung zwischen mar und mai (oma und omi analog)

Randbreite [inch] (mai) = Anzahl Zeilen (mar) * Zeichenhöhe [inch] (cin[2]) * par("cex")* par("mex")

Randbreite bei Layouts mehrerer Grafiken

cex in Funktionen

par("cex") ändern:

Nicht vergessen: Das muss nach etwaigen layouts erfolgen, denn layouts modifizieren cex und mex.

Standardparameter beim Aufruf von Highlevel-Plot-Funktionen und teils auch prepplot

Beispiele

Beispiel: Barplot mit gewaffelten Balken (nach Rahlf)

par(las=1, cex=1.2, mex=0.75, family="Lato", las=1, 
    mar=c(rep(1.1,3), 4.1), oma=c(3,1,6,1)+0.1)

# Define data

myData<-c(25296,28365,32187,36835,39788,44282,51122,60420,
          58437,62484)/1000
myLabels<-sprintf("%02d", c(2002:2011)-2000)
names(myData) <-  myLabels
n <- length(myData)
myColours<-c(rep("olivedrab", n-1), "darkred")

# Plot

bplt <- barplot(myData, plot=FALSE)
xlim <- c( bplt[1] - (bplt[2] - bplt[1])/3, 
           bplt[n] + (bplt[n] - bplt[n-1])/3 )
ylim <- range(c(0, ceiling(myData)))
prepplot(xlim, ylim, bg="grey98", 
         mgpx=c(2, 0.5, 0), yaxs="i", xaxt="n", yaxt="n")

barplot(myData, col=myColours, border=myColours, add=TRUE, 
        yaxt="n", mgp=c(1.5,0.25,0))
abline(h=0:6*10, col="grey98", lwd=2.5)
axis(4, col="grey20", lwd=0, mgp=c(2,0.25,0))
text(bplt[n], myData["11"], pos=3, round(myData["11"],1), 
     xpd = NA, col="grey20")

# Titling

mtext("Sales Development Microsoft", line=4, adj=0,
      family="Lato Black", cex=2, outer=TRUE) 
mtext("2002–2011, figures in Billion US-Dollars", 
      line=2, adj=0, cex=1.35, font=3, outer=TRUE) 
mtext("Source: money.cnn.com", side=1, line=1.8, adj=1, 
      cex=1, font=3, outer=TRUE)

Beispiel: Barplot auf Gridline-Hintergrund

par(las=1, cex=1.2, mex=0.75, family="Lato", las=1, 
    mar=c(rep(1.1,3), 4.1), oma=c(3,1,6,1) + 0.1)

#myColours_t <- maketransparent(myColours,
#                             c(rep(212, n-1), 184))

myColours_t <- maketransparent(c(rep(brewer.pal(5,"PiYG")[5], n-1),
                               myColours[n]),
                             c(rep(212, n-1), 184))

# Plot

## bplt <- barplot(myData, plot=FALSE)
## bplt, xlim and ylim from previous chunk

prepplot(xlim, ylim, bg="grey98", 
         mgpx=c(2, 0.5, 0), yaxs="i", xaxt="n", yaxt="n",
         gridy=TRUE, yticks=0:6*10, lty.grid = 1)
barplot(myData, col=myColours_t, border=myColours, add=TRUE, 
        yaxt="n", mgp=c(1.5,0.25,0))
axis(4, col="grey20", lwd=0, mgp=c(2,0.25,0))
text(bplt[n], myData["11"], pos=3, round(myData["11"],1), 
     xpd = NA, col="grey20")

# Titling

mtext("Sales Development Microsoft", line=4, adj=0,
      family="Lato Black", outer=TRUE, cex=2)
mtext("2002–2011, figures in Billion US-Dollars", 
      line=2, adj=0, cex=1.35, font=3, outer=TRUE)
mtext("Source: money.cnn.com", side=1, line=1.8, adj=1, 
      cex=1, font=3, outer=TRUE)

Beispiel: Schöner Scatterplot für wenige Datenpunkte (nach Rahlf)

par(mar=c(4,4,0.5,2),omi=c(0.5,0.5,1,0),family="Lato",las=1)
    #,cex=1.25, mex=0.8) #would mess up label positions even more
library(RColorBrewer)

# Import data and prepare chart

mydata<-read.csv(file="myData/BetterLifeIndex_Data_2011V6.csv",head=F,
    sep=";",dec=",",skip=6)
mydata<-mydata[2:36,]
attach(mydata)

myX<-as.numeric(V16)
myY<-as.numeric(V15)
myX_des<-"Self-reported Health (Scale from 0 to 100)"
myY_des<-"Life Expectancy"

# Define chart and other elements

plot(type="n",xlab=myX_des,ylab=myY_des,myX, myY,xlim=c(30,90),ylim=c(72,83),axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

myC1 <- brewer.pal(5,"PiYG")[5]
myC2 <- brewer.pal(5,"PiYG")[4]
myC3 <- brewer.pal(5,"PiYG")[1]
myC4 <- brewer.pal(5,"PiYG")[2]

myP1 <- subset(mydata[c("V2","V16","V15")],
             myX > mean(myX) & myY > mean(myY))
myP2 <- subset(mydata[c("V2","V16","V15")],
             myX < mean(myX) & myY > mean(myY))
myP3 <- subset(mydata[c("V2","V16","V15")],
             myX < mean(myX) & myY < mean(myY))
myP4 <- subset(mydata[c("V2","V16","V15")],
             myX > mean(myX) & myY < mean(myY))

myN1 <- nrow(myP1)
myN2 <- nrow(myP2)
myN3 <- nrow(myP3)
myN4 <- nrow(myP4)

symbols(myP1[,2:3], bg=myC1, circles=rep(1,myN1), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP2[,2:3], bg=myC2, circles=rep(1,myN2), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP3[,2:3], bg=myC3, circles=rep(1,myN3), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP4[,2:3], bg=myC4, circles=rep(1,myN4), inches=0.3, add=T, xpd=T, fg="white")

text(myP2[,2:3], as.matrix(myP2$V2), cex=0.9, pos=1, offset=1.75)
text(myP4[,2:3], as.matrix(myP4$V2), cex=0.9, pos=1, offset=1.75)

abline(v=mean(myX,na.rm=T), col="black", lty=3)
abline(h=mean(myY,na.rm=T), col="black", lty=3)

text(min(V16),mean(V15)+0.005*mean(V15),"high",family="Lato Black",adj=0)
text(min(V16),mean(V15)-0.005*mean(V15),"low",family="Lato Black",adj=0)
text(mean(V16)-0.001*mean(V16),72,"high",family="Lato Black",pos=4)
text(mean(V16)+0.001*mean(V16),72,"low",family="Lato Black",pos=2)

# Titling

mtext("Life Expectancy and Self-reported Health (OECD)",3,adj=0,line=2.5,cex=2.0,family="Lato Black")
mtext("Self-reported Health (scale from 0-100)",3,adj=0,line=0,cex=1.0,font=3)
mtext("Source: oecdbetterlifeindex.org",1,line=4,adj=1,cex=0.95,font=3)

Beispiel: Schöner Scatterplot,
ist transparent besser?

par(mar=c(4,4,0.5,2),omi=c(0.5,0.5,1,0),family="Lato",las=1)
    #,cex=1.25, mex=0.8) #would mess up label positions even more

### data are already defined

# Define chart and other elements

plot(type="n",xlab=myX_des,ylab=myY_des,myX, myY,xlim=c(30,90),ylim=c(72,83),axes=F)
axis(1,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)
axis(2,col=par("bg"),col.ticks="grey81",lwd.ticks=0.5,tck=-0.025)

myC1 <- maketransparent(brewer.pal(5,"PiYG")[5], 212)
myC2 <- maketransparent(brewer.pal(5,"PiYG")[4], 212)
myC3 <- maketransparent(brewer.pal(5,"PiYG")[1], 184)
myC4 <- maketransparent(brewer.pal(5,"PiYG")[2], 212)

symbols(myP1[,2:3], bg=myC1, circles=rep(1,myN1), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP2[,2:3], bg=myC2, circles=rep(1,myN2), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP3[,2:3], bg=myC3, circles=rep(1,myN3), inches=0.3, add=T, xpd=T, fg="white")
symbols(myP4[,2:3], bg=myC4, circles=rep(1,myN4), inches=0.3, add=T, xpd=T, fg="white")

text(myP2[,2:3], as.matrix(myP2$V2), cex=0.9, pos=1, offset=1.75)
text(myP4[,2:3], as.matrix(myP4$V2), cex=0.9, pos=1, offset=1.75)

abline(v=mean(myX,na.rm=T), col="black", lty=3)
abline(h=mean(myY,na.rm=T), col="black", lty=3)

text(min(V16),mean(V15)+0.005*mean(V15),"high",family="Lato Black",adj=0)
text(min(V16),mean(V15)-0.005*mean(V15),"low",family="Lato Black",adj=0)
text(mean(V16)-0.001*mean(V16),72,"high",family="Lato Black",pos=4)
text(mean(V16)+0.001*mean(V16),72,"low",family="Lato Black",pos=2)

# Titling

mtext("Life Expectancy and Self-reported Health (OECD)",3,adj=0,line=2.5,cex=2.0,family="Lato Black")
mtext("Self-reported Health (scale from 0-100)",3,adj=0,line=0,cex=1.0,font=3)
mtext("Source: oecdbetterlifeindex.org",1,line=4,adj=1,cex=0.95,font=3)

Beispiel: Schöner Scatterplot,
Variante aus meinem book review

## Plot with bg color instead of point color
## and smaller symbols
par(mar=c(5,4,0.5,2), oma=c(0,0,4,0), las=1, family="Lato", 
    cex=1.5, mex=0.8, bg="grey98")
library(RColorBrewer)

# Data were previously imported

# Define chart and other elements
myBGpoint <- "grey40"
myBGchart <- "grey40"

# prepare chart
prepplot( xlab=myX_des, ylab=myY_des, 
     xlim=c(30,90),ylim=c(72,83), cex.lab=1.2, 
     mgpx=c(2.5,0.75,0), mgpy=c(2.75,0.75,0))

## add tick marks
axis(1, col=myBGchart, col.ticks=myBGchart, col.axis=par("col"), lwd.ticks=0.5, tck=-0.025, cex=1.2, labels=FALSE)
axis(2, col=myBGchart, col.ticks=myBGchart, col.axis=par("col"), lwd.ticks=0.5, tck=-0.025, cex=1.2, labels=FALSE)

## color quadrants (neutral for mixed cases)
myC1 <- brewer.pal(9,"PiYG")[8]  ## or [5]
myC2 <- "grey98"#brewer.pal(5,"PiYG")[4]
myC3 <- brewer.pal(9,"PiYG")[2]   ## or [1]
myC4 <- "grey98"#brewer.pal(5,"PiYG")[2]

## drei <- relevant columns, subset quadrants
drei <- mydata[,c(2,15,16)] ## or 16,15? old data
myP1 <- subset(drei, myX > mean(myX) & myY > mean(myY))
myP2 <- subset(drei, myX < mean(myX) & myY > mean(myY))
myP3 <- subset(drei, myX < mean(myX) & myY < mean(myY))
myP4 <- subset(drei, myX > mean(myX) & myY < mean(myY))

myN1 <- nrow(myP1)
myN2 <- nrow(myP2)
myN3 <- nrow(myP3)
myN4 <- nrow(myP4)

lims <- par()$usr
rect(mean(myX), mean(myY), lims[2], lims[4], col=myC1, border=NA, xpd=NA) ## upper right
rect(lims[1], mean(myY), mean(myX), lims[4], col=myC2, border=NA, xpd=NA) ## upper left
rect(lims[1], lims[3], mean(myX), mean(myY), col=myC3, border=NA, xpd=NA) ## lower left
rect(mean(myX), lims[3], lims[2], mean(myY), col=myC4, border=NA, xpd=NA) ## lower right
abline(v=mean(myX,na.rm=T), col=myBGchart, lwd=3)
abline(h=mean(myY,na.rm=T), col=myBGchart, lwd=3)
box(lwd=10, col=myBGchart, which="plot")

symbols(myP1[,3:2], bg=myBGpoint, circles=rep(1,myN1), inches=0.15, add=TRUE, xpd=TRUE, fg=myC1)
symbols(myP2[,3:2], bg=myBGpoint, circles=rep(1,myN2), inches=0.15, add=TRUE, xpd=TRUE, fg=myC2)
symbols(myP3[,3:2], bg=myBGpoint, circles=rep(1,myN3), inches=0.15, add=T, xpd=T, fg=myC3)
symbols(myP4[,3:2], bg=myBGpoint, circles=rep(1,myN4), inches=0.15, add=TRUE, xpd=TRUE, fg=myC4)

## label points from mixed quadrants
## tune Finland by hand
myPos2 <- ifelse(myP2[,3] < 40, 4, 2)
myPos4 <- ifelse(myP4[,3] < mean(myX)+(90-mean(myX))/2, 4, 2)
lower <- as.numeric(myP2[,1]=="Finland")
text(myP2[,3], myP2[,2]-0.2*lower, as.matrix(myP2[,1]), cex=1.2, pos=myPos2, offset=0.85)
text(myP4[,3:2], as.matrix(myP4[,1]), cex=1.2, pos=myPos4, offset=0.85)

## label quadrant separators

text(30,mean(myY)+0.0035*mean(myY), "high", pos=4, offset=-0.75, col="grey25", font=3)
text(30,mean(myY)-0.0035*mean(myY),"low",pos=4, offset=-0.75, col="grey25", font=3)

text(mean(myX)-0.001*mean(myX), 72, "high", pos=4, col="grey25", font=3)
text(mean(myX)+0.001*mean(myX), 72, "low", pos=2, col="grey25", font=3)

# Titling

mtext("Life Expectancy and Self-reported Health (OECD)", side=3, adj=0, line=2.5, cex=2.0, family="Lato Black")
mtext("Edition 2011", adj=0, line=1, cex=1.2, font=3)  
mtext("Source: oecdbetterlifeindex.org", side=1, line=3.8, adj=1.065, cex=1.2, font=3)

Beispiel: Vergleichendes Balkendiagramm ordinaler Fragen (nach Rahlf)

par(oma=c(3,0,2.5,0),mar=c(0,10,1.5,4), 
    family="Lato",las=1, xaxs="i", font.main=1,
    cex=0.9)  

# Import data and prepare chart
## OECD
## textfile readable with read.fwf for 2009
## 11 features on reading attitudes in columns 117 to 127
## country codes in columns 4 to 6

## runs for a long time
#mypisa <- read.fwf(file="myData/INT_STQ09_DEC11.txt", 
#         widths = c(3,3,110,rep(1,11),1825),
#         col.names = c("CNT", "COUNTRY", "Muell1", 
#          paste0("ST24Q0",1:9), paste0("ST24Q",10:11), "Muell2"))
#mypisa <- mypisa[,-(c(3,15))]
#pisana <- mypisa[mypisa$CNT %in% c("USA","MEX","CAN"),]
#save(pisana, file="pisana.rda")
load("pisana.rda")
         
items28 <- pisana[,substr(names(pisana),1,5) == 'ST24Q']
source("scripts/inc_names_item28.r")

for(i in 1:ncol(items28)) 
{
items28[,i]=factor(items28[,i],levels=1:4,ordered=T)
}
source("scripts/functions/lickert.r")
library(reshape)
lik=likert(items28, grouping=pisana$CNT)
x <- print(lik); y <- x[,-2]
colours <- c("palevioletred4","lightpink","cornsilk1","cornsilk4")
k <- length(y[,1])/length(unique(y[,1]))
par(mfcol = c(k+1, 1), las=1)
par(cex=0.8, mex=1.25)

for (i in 1:k)
{
z<-y[c(i,i+k,i+2*k),]
prozcan_l <- format(round(z[1,2]+z[1,3],0),nsmall=0)
prozmex_l <- format(round(z[2,2]+z[2,3],0),nsmall=0)
prozusa_l <- format(round(z[3,2]+z[3,3],0),nsmall=0)
prozcan_r <- format(round(z[1,4]+z[1,5],0),nsmall=0)
prozmex_r <- format(round(z[2,4]+z[2,5],0),nsmall=0)
prozusa_r <- format(round(z[3,4]+z[3,5],0),nsmall=0)
b1 <- paste("Canada","-",prozcan_l,"%",sep=" ")
b2 <- paste("Mexico","-",prozmex_l,"%",sep=" ")
b3 <- paste("USA","-",prozusa_l,"%",sep=" ")

# Create chart

barplot(t(z[,2:5]), names.arg =c(b1,b2,b3),
        col=colours, 
        horiz=TRUE,axes=FALSE, cex.names = 0.95)
text(105.5,1.0-0.25,paste(prozcan_r,"%",sep=" "), xpd=TRUE, cex=0.95)
text(105.5,2.2-0.25,paste(prozmex_r,"%",sep=" "), xpd=TRUE, cex=0.95)
text(105.5,3.4-0.25,paste(prozusa_r,"%",sep=" "), xpd=TRUE, cex=0.95)
title(main=names(items28)[i], adj=0)
}

## grep coordinates for legend
usr <- par("usr")


# legend and axis
# x margins have to be like above
par(mar=c(0.5,10,1,4))
# empty plot
plot(0, 0, type="n", axes=FALSE, 
     xlim=usr[1:2], ylim=c(0,1),
         xlab="", ylab="")
axis(3, at=c(0, 25, 50, 75, 100), 
     mgp=c(0, -1, 0.8), lwd=1, tcl=0.2)

plotrix::color.legend(0, 0.18, 100, 0.5, c("Strongly disagree","Disagree","Agree","Strongly agree"), rect.col= colours, cex=0.9, align="rb")

text(-3.5, 0.34, "Legend - 50 %", adj=1, xpd=NA, cex=0.95)
text(105.5,0.34, "50 %", xpd=NA, cex=0.95)

# Titling

mtext("Reading attitude",3,line=1.4,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("How much do you disagree or agree with these statements about reading?",3,line=0.2,adj=0,cex=1.2,outer=T)
mtext("Source: PISA 2009 Assessment Framework - Key Competencies in Reading, Mathematics, and Science",1,line=1.2,adj=1.0,cex=0.9,outer=T)
mtext("Source and Copyright: OECD 2009",1,line=2,adj=1.0,cex=0.75,outer=T)

Beispiel: Vergleichendes Balkendiagramm ordinaler Fragen (nach Rahlf, ohne Randlinien, Farben wirken ganz anders!)

par(oma=c(3,0,2.5,0),mar=c(0,10,1.5,4), 
    family="Lato",las=1, xaxs="i", font.main=1,
    cex=0.9)  

# Import data and prepare chart
## OECD
## textfile readable with read.fwf for 2009
## 11 features on reading attitudes in columns 117 to 127
## country codes in columns 4 to 6

## runs for a long time
#mypisa <- read.fwf(file="myData/INT_STQ09_DEC11.txt", 
#         widths = c(3,3,110,rep(1,11),1825),
#         col.names = c("CNT", "COUNTRY", "Muell1", 
#          paste0("ST24Q0",1:9), paste0("ST24Q",10:11), "Muell2"))
#mypisa <- mypisa[,-(c(3,15))]
#pisana <- mypisa[mypisa$CNT %in% c("USA","MEX","CAN"),]
#save(pisana, file="pisana.rda")
load("pisana.rda")
         
items28 <- pisana[,substr(names(pisana),1,5) == 'ST24Q']
source("scripts/inc_names_item28.r")

for(i in 1:ncol(items28)) 
{
items28[,i]=factor(items28[,i],levels=1:4,ordered=T)
}
source("scripts/functions/lickert.r")
library(reshape)
lik=likert(items28, grouping=pisana$CNT)
x <- print(lik); y <- x[,-2]
colours <- c("palevioletred4","lightpink","cornsilk1","cornsilk4")
k <- length(y[,1])/length(unique(y[,1]))
par(mfcol = c(k+1, 1), las=1)
par(cex=0.8, mex=1.25)

for (i in 1:k)
{
z<-y[c(i,i+k,i+2*k),]
prozcan_l <- format(round(z[1,2]+z[1,3],0),nsmall=0)
prozmex_l <- format(round(z[2,2]+z[2,3],0),nsmall=0)
prozusa_l <- format(round(z[3,2]+z[3,3],0),nsmall=0)
prozcan_r <- format(round(z[1,4]+z[1,5],0),nsmall=0)
prozmex_r <- format(round(z[2,4]+z[2,5],0),nsmall=0)
prozusa_r <- format(round(z[3,4]+z[3,5],0),nsmall=0)
b1 <- paste("Canada","-",prozcan_l,"%",sep=" ")
b2 <- paste("Mexico","-",prozmex_l,"%",sep=" ")
b3 <- paste("USA","-",prozusa_l,"%",sep=" ")

# Create chart

barplot(t(z[,2:5]), names.arg =c(b1,b2,b3),
        col=colours, border=colors,
        horiz=TRUE,axes=FALSE, cex.names = 0.95)
text(105.5,1.0-0.25,paste(prozcan_r,"%",sep=" "), xpd=TRUE, cex=0.95)
text(105.5,2.2-0.25,paste(prozmex_r,"%",sep=" "), xpd=TRUE, cex=0.95)
text(105.5,3.4-0.25,paste(prozusa_r,"%",sep=" "), xpd=TRUE, cex=0.95)
title(main=names(items28)[i], adj=0)
}

## grep coordinates for legend
usr <- par("usr")


# legend and axis
# x margins have to be like above
par(mar=c(0.5,10,1,4))
# empty plot
plot(0, 0, type="n", axes=FALSE, 
     xlim=usr[1:2], ylim=c(0,1),
         xlab="", ylab="")
axis(3, at=c(0, 25, 50, 75, 100), 
     mgp=c(0, -1, 0.8), lwd=1, tcl=0.2)

plotrix::color.legend(0, 0.19, 100, 0.49, c("Strongly disagree","Disagree","Agree","Strongly agree"), rect.col= colours, cex=0.9, align="rb")
plotrix::gradient.rect(0, 0.18, 100, 0.5, col= colours, border = par("bg"))

text(-3.5, 0.34, "Legend - 50 %", adj=1, xpd=NA, cex=0.95)
text(105.5,0.34, "50 %", xpd=NA, cex=0.95)

# Titling

mtext("Reading attitude",3,line=1.4,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("How much do you disagree or agree with these statements about reading?",3,line=0.2,adj=0,cex=1.2,outer=T)
mtext("Source: PISA 2009 Assessment Framework - Key Competencies in Reading, Mathematics, and Science",1,line=1.2,adj=1.0,cex=0.9,outer=T)
mtext("Source and Copyright: OECD 2009",1,line=2,adj=1.0,cex=0.75,outer=T)

Beispiel: Vergleichendes Balkendiagramm ordinaler Fragen (Variante)

par(oma=c(3,0,2.5,0),mar=c(0,10,1.5,4), 
    family="Lato",las=1, xaxs="i", font.main=1,
    cex=0.9)  

## data were partly prepared before
## revert scale

items28 <- pisana[,substr(names(pisana),1,5) == 'ST24Q']
source("scripts/inc_names_item28.r")

for(i in 1:ncol(items28)) 
{
items28[,i]=factor(items28[,i],levels=4:1,ordered=T)
}
source("scripts/functions/lickert.r")

library(reshape)
lik=likert(items28, grouping=pisana$CNT)
x <- print(lik); y <- x[,-2]

colours <- c(hks51dark, hks51light, "#E6B8BF", "#990F26")  ## colors 1 and 4 from pals::stepped(24)
k <- length(y[,1])/length(unique(y[,1]))

par(mfcol = c(k+1, 1), las=1)
par(cex=0.8, mex=1.25)  
## keep margin like with cex=0.9 from before

proz_l <- format(round(y[,2]+y[,3],0), nsmall=0)
proz_r <- format(round(y[,4]+y[,5],0), nsmall=0)
## k times canada, k times mexico, k times usa

## prepare labels also for ggplot use
bs <- afs <- vector(mode="list", length=k)
names(bs) <- names(afs) <- names(items28)


for (i in 1:k)
{
  pick <- c(i,i+k,i+2*k)
  bs[[i]] <- b <- paste(c("Canada", "Mexico", "USA"), 
             "-", proz_l[pick], "%")
  afs[[i]] <- paste(proz_r[pick], "%")
  # Create chart
  barplot(t(y[pick, 2:5]), names.arg = b,
          col=colours, border=colors,
          horiz=TRUE, axes=FALSE, 
          cex.names = 0.95)
  text(105.5, c(1.0-0.25, 2.25 - 0.25, 3.4-0.25),  
       afs[[i]], xpd=NA, cex=0.95)
  title(main=names(items28)[i], adj=0, cex.main=1.2)
}

## grep coordinates for legend
usr <- par("usr")

# legend and axis
# x margins have to be like above
par(mar=c(0.5,10,1,4))
# empty plot
plot(0, 0, type="n", axes=FALSE, 
     xlim=usr[1:2], ylim=c(0,1),
         xlab="", ylab="")
axis(3, at=c(0, 25, 50, 75, 100), 
     mgp=c(0, -1, 0.8), lwd=1, tcl=0.2)

plotrix::color.legend(0, 0.19, 100, 0.49, rev(c("Strongly disagree","Disagree","Agree","Strongly agree")), rect.col= colours, cex=0.9, align="rb")
plotrix::gradient.rect(0, 0.17, 100, 0.51, col= colours, border = par("bg"))

text(-3.5, 0.34, "Legend - 50 %", adj=1, xpd=NA, cex=0.95)
text(105.5,0.34, "50 %", xpd=NA, cex=0.95)

# Titling
mtext("Reading attitude",3,line=1.4,adj=0,cex=1.5,family="Lato Black",outer=T)
mtext("How much do you agree or disagree with these statements about reading?",3,line=0.2,adj=0,cex=1.2,outer=T)
mtext("Source: PISA 2009 Assessment Framework - Key Competencies in Reading, Mathematics, and Science",1,line=1.2,adj=1.0,cex=0.9,outer=T)
mtext("Source and Copyright: OECD 2009",1,line=2,adj=1.0,cex=0.75,outer=T)

Beispiel: Vergleichendes Balkendiagramm gg

Quick and dirty geht geom_bar mit weniger Vorarbeiten als bei Rahlf, allerdings viel langsamer.

Auf Basis der Vorarbeiten geht es mit geom_col. Die Beschriftung an den Enden der Balken habe ich (noch) nicht hinbekommen, die Achse habe ich mir gespart (die braucht es m.E. auch nicht unbedingt). Mit Details (z.B. Abständen oben und unten, Schriftgröße der Label links) bin ich noch nicht zufrieden.

require(ggplot2)
namen <- unique(x$Item) 

  ## graph for obtaining the legend
  hilf <- data.frame(
    CNT=rep(c("CAN","MEX","USA"), each=4),
    value=factor(rep(4:1, 3), levels=1:4, labels = c("Strongly Agree", "Agree", "Disagree", "Strongly Disagree")), 
    V=c(t(x[x[,2]==namen[1],-c(1,2)])))
  hilf <- ggplot(data=hilf, 
        mapping=aes(y=CNT, x=V)) + 
  geom_col(mapping=aes(fill=value),
           position=position_fill(), 
           orientation = "y") + 
  ggtitle(namen[1]) + 
  theme_minimal() + 
  theme(legend.position = "bottom", 
        legend.title = element_text(family="Lato"),
        legend.text = element_text(family="Lato", size=9), legend.direction = "horizontal", 
        legend.key.width = unit(3, "picas"), legend.key.height = unit(1.5, "picas"),
        axis.title = element_blank(), 
        axis.text.x = element_blank(), 
        text = element_text(size=3, family="Lato")) +
  scale_fill_manual("Legende", 
        values = c("Strongly Agree" = colours[1], 
                   "Agree" = colours[2], 
                   "Disagree" = colours[3],
                   "Strongly Disagree"=colours[4])) 

  ## creating the grob list
graphlist <- vector(mode="list", length = 11)
names(graphlist) <- namen
for (nam in namen){
  namdat <- data.frame(
    CNT=rep(bs[[nam]], each=4), ##c("CAN","MEX","USA")
    value=factor(rep(4:1, 3), levels=1:4), 
    V=c(t(x[x[,2]==nam,-c(1,2)])))
  graphlist[[nam]] <- ggplot(data=namdat , 
        mapping=aes(y=CNT, x=V)) + 
  geom_col(mapping=aes(fill=value),
           position=position_fill(), 
           orientation = "y") + 
  ggtitle(nam) + 
  theme_minimal() + 
  theme(legend.position = "none", 
        axis.title = element_blank(), 
        axis.text.x = element_blank(), 
        text = element_text(size=9, family="Lato")) +
  scale_fill_manual("Legende", 
        values = c("1" = colours[4], 
                   "2" = colours[3], 
                   "3" = colours[2],
                   "4" = colours[1]))   

}
require(gridExtra)
## extend groblist with further elements
grobl <- c(toptitle = list(
                  grid::textGrob("Reading attitude" ,x=0, just="left",
                                 gp=grid::gpar(fontsize=18, fontfamily="Lato Black"))), 
           subtitle = list(grid::textGrob("How much do you agree or disagree with these statements about reading?", 
                               x=0, just="left", gp=grid::gpar(fontsize=12, fontfamily="Lato"))),
           graphlist,
           legend = list(cowplot::get_legend(hilf)),
           footer1 = list(grid::textGrob(
             "Source: PISA 2009 Assessment Framework - Key Competencies in Reading, Mathematics, and Science", 
             x=1, just="right", gp=grid::gpar(fontsize=10, fontfamily="Lato"))),
           footer2 = list(grid::textGrob("Source and Copyright: OECD 2009", x=1,
                    just="right", gp=grid::gpar(fontsize=7, fontfamily="Lato"))))

## arrange grobs (like mfrow or mfcol, with additional heights) and print
print(grid.arrange(grobs=grobl, 
                   nrow=16,ncol=1, heights=c(1,0.5,rep(2,11), 1, 0.5, 0.3)))

Beispiel: Beschriftete Kurve
(Fig. 8.1 aus W&G)

Die Abbildung ist inhaltlich klar, aber nicht “schön”.
Dringendste Verschönerung: Die Funktionslinie zuletzt (oder erneut) zeichnen.

Beispiel: Beschriftete Kurve
Variante 1

Max.BF10 = function(p) -1/(exp(1) * p * log(p))

# Plot this function for p in .001 to .1
xlow <- 0.001
xhigh <- 0.1
p1 <- 0.0373
p2 <- 0.00752
p3 <- 0.001968

par(mar = c(4, 5, 2, 2) + 0.1, cex.lab = 1.2, cex.axis = 1.2, las = 1, bg=hks51lightest, family="Lato", cex=1.2, mex=1/1.2)
prepplot::prepplot(c(0,0.1), c(0, 50),
         mgpx=c(2.5,0.1,1.5), mgpy=c(3,0.1,1.5), border="grey50",
         lwd = 2, xlab = "Two-sided p value", 
    ylab = expression("Maximum Bayes factor for H"[1]), xaxs="i", yaxs="i", bg="white")

lines(c(0, p1), c(3, 3), lwd = 2, col = "grey50")
lines(c(0, p2), c(10, 10), lwd = 2, col = "grey50")
lines(c(0, p3), c(30, 30), lwd = 2, col = "grey50")
lines(c(p1, p1), c(0, 3), lwd = 2, col = "grey50")
lines(c(p2, p2), c(0, 10), lwd = 2, col = "grey50")
lines(c(p3, p3), c(0, 30), lwd = 2, col = "grey50")
curve(Max.BF10(x), from=0.0008, to=0.1, n=1001, add=TRUE, lwd=2)

cexsize <- 1.2
text(p3, 30, expression(max((BF[10])) == 30 %<->% italic(p) %~~% 0.002), cex = cexsize, 
    pos = 4)
text(p2, 10, expression(max((BF[10])) == 10 %<->% italic(p) %~~% 0.008), cex = cexsize, 
    pos = 4)
text(p1 , 3, expression(max((BF[10])) == 3 %<->% italic(p) %~~% 0.037), cex = cexsize, 
    adj=c(0,0))

Beispiel: Beschriftete Kurve
Variante 2

Unterschiede:

Max.BF10 = function(p) -1/(exp(1) * p * log(p))

# Plot this function for p in .001 to .1
xlow <- 0.001
xhigh <- 0.1
p1 <- 0.0373
p2 <- 0.00752
p3 <- 0.001968

par(mar = c(4, 5, 2, 2) + 0.1, cex.lab = 1.2, cex.axis = 1.2, lwd=2, bg=hks51lightest, family="Lato", cex=1.2, mex=1/1.2)
prepplot::prepplot(c(0,0.1), c(0, 50), gridx=TRUE, stripesy=TRUE,
         mgpx=c(2.5,0.1,1.5), mgpy=c(3,0.1,1.5), border="grey50",
         lwd = 2, xlab = "Two-sided p value", 
    ylab = expression("Maximum Bayes factor for H"[1]), xaxs="i", yaxs="i", col.stripes = hks51lightest, bg=maketransparent(hks51light, 96))

lines(c(0, p1), c(3, 3), lwd = 2, col = "grey50")
lines(c(0, p2), c(10, 10), lwd = 2, col = "grey50")
lines(c(0, p3), c(30, 30), lwd = 2, col = "grey50")
lines(c(p1, p1), c(0, 3), lwd = 2, col = "grey50")
lines(c(p2, p2), c(0, 10), lwd = 2, col = "grey50")
lines(c(p3, p3), c(0, 30), lwd = 2, col = "grey50")
curve(Max.BF10(x), from=0.0008, to=0.1, n=1001, add=TRUE, lwd=2)

cexsize <- 1.2
text(p3, 30, expression(max((BF[10])) == 30 %<->% italic(p) %~~% 0.002), cex = cexsize, 
    adj = c(-0.04,-0.04))
text(p2, 10, expression(max((BF[10])) == 10 %<->% italic(p) %~~% 0.008), cex = cexsize, 
    adj = c(-0.02,-0.04))
text(p1 , 3, expression(max((BF[10])) == 3 %<->% italic(p) %~~% 0.037), cex = cexsize, 
    adj=c(0,0))

Beispiel: Histogramm (Figure 4.3 aus W&G)

Beispiel: Histogramm: Variante 1

## data created before
par(mar = c(6, 3, 4, 2) + 0.1, mgp = c(4, 2.75, 2.5), cex.lab = 1.2, cex.axis = 1.2, 
    cex.main=1.5, lwd=2)

h <- hist(good.choices, plot=FALSE)

prepplot::prepplot(c(0.3,0.8), c(0, ceiling(max(h$density))), yaxt="n", ylab="", xlab="Prop. Choices from Good Decks", main="Density of Studies", border="white", mgpx=c(4.5,2.75,2.5), yaxs="i", bg="white", axes=FALSE)
lines(h, freq=FALSE, border="grey20", col="grey80")
axis(1, at=4:7/10, lwd=2)
text(0.75, 0, "density", pos=1, xpd=NA, cex=1.2)
notneeded <- lapply(seq_along(h$density), function(x) text(h$mids[x], 0,  
    labels=round(h$density[x], 2), cex = 1.2, pos=1, xpd=NA))

rug(jitter(good.choices), ticksize=0.02, lwd=1)

Beispiel: Histogramm, Variante 2

## data created before
par(mar = c(6, 3, 4, 2) + 0.1, mgp = c(2.5, 1, 0), cex.lab = 1.2, cex.axis = 1.2, 
    cex.main=1.5, lwd=2)

h <- hist(good.choices, plot=FALSE)

prepplot::prepplot(c(0.35,0.75), c(0, ceiling(max(h$density))),  ylab="Density", xlab="Prop. Choices from Good Decks", main="Density of Studies", border="white", mgpx=c(2.5,0.5,0), mgpy=c(1.75,0.5,0), bg="white", gridy=TRUE, gridyminor = 4)
lines(h, freq=FALSE, border="grey20", col=maketransparent("grey80", alpha=212))

rug(jitter(good.choices), ticksize=0.02, lwd=1)

Beispiel: Histogramm, Variante 3

## data created before
par(mar = c(6, 3, 4, 2) + 0.1, mgp = c(2.5, 1, 0), cex.lab = 1.2, cex.axis = 1.2, 
    cex.main=1.5, lwd=2)

h <- hist(good.choices, plot=FALSE)

prepplot::prepplot(c(0.35,0.75), c(0, ceiling(max(h$density))),  ylab="Density", xlab="Prop. Choices from Good Decks", main="Density of Studies", border="grey98", mgpx=c(2.5,0.75,0), mgpy=c(1.75,0.2,0), bg="grey98", yaxs="i")
lines(h, freq=FALSE, border="grey80", col=maketransparent("grey80", alpha=212))
abline(h=0:7, col="grey98")

rug(jitter(good.choices), ticksize=-0.02, lwd=1, yaxs="i", mgp=c(2.5,0.5,0.15))

Beispiel: Zwei Informationen in Kombination (Figure 5.4 W&G)

Beispiel: Zwei Informationen in Kombination, verbessert

## Funktionen und Daten bei voriger Grafik

## UG 
## use layout with thin top panel for margin text, 
## medium middle panel for plot without horizontal axis 
## and largest bottom panel for plot with horizontal axis

layout(matrix(c(3,1,2), nrow=3), height=c(1.5,4,5))

## changed margin and added oma
## dropped different cex variants for one cex=1.2

par(cex=1.2, cex.lab=1.2)

x = c(1.5, 2.5, 3.5)

## Middle panel
par(mar = c(0.5, 6, 1.5, 2) + 0.1)
prepplot::prepplot(1:4, ylim=c(300, 700), 
                   xlab=" ", ylab="Time [ms]", 
                   mgpx=c(0,0,0), mgpy=c(3.5,0.5,0), xaxt="n", 
                   stripesx = 1:4, cex.sub=1.2)

points(x, MRT, lwd = 2, pch = 19)
plot.errbars = plotsegraph(x, MRT, MRT.se, 0.05, color = "black")  #0.1 = wiskwidth

lines(c(1.5, 2.5, 3.5), MRT, lwd = 2, type = "c")
## Beschriftung
text(1:3 + 0.5, MRT + MRT.se, MRT, pos=3)

#par("fin") - sum(par("mai")[c(1,3)])

## Bottom panel

par(mar = c(3.99, 6, 0.5, 2) + 0.1, mgp=c(2, 0.5, 0))
prepplot::prepplot(1:4, ylim=c(0, 0.4), xlab=" ", ylab="Proportion", 
                   mgpx=c(2,0,0), mgpy=c(3.5,0.5,0), xaxt="n",
                   stripesx = 1:4, cex.sub=1.2)
## the following statements use par("mgp")
axis(1, at = x, labels = c("Speed", "Neutral", "Accuracy"), lwd=0)
title(xlab="Cue")   
x = c(1.5, 2.5, 3.5)
lines(c(1.5, 2.5, 3.5), Er, lwd = 2, type = "c")
points(x, Er, lwd = 2, pch = 19)
plot.errbars = plotsegraph(x, Er, Er.se, 0.05, color = "black")  #0.05 = wiskwidth

## Beschriftung
text(1:3 + 0.5, Er + Er.se, Er, pos=3)

#par("fin") - sum(par("mai")[c(1,3)])

## top panel
par(mar=c(0,0,0,0))
prepplot::prepplot(0:1, 0:1, axes=FALSE, bg=par("bg"))
mtext(side=3, "Behavioral Data", cex = 1.5, line=-2, adj=0, font=2)
mtext(side=3, "Mean Response Time and Mean Proportion of Errors", cex = 1.5, line=-3.5, adj=0)

Beispiel: Grafik mit Tooltips

Beispiel: Grafik mit Tooltips mit SVGAnnotation

Das package ist nicht auf CRAN, lässt sich aber herunterladen von einer veralteten Bioconductor Seite.

Das Package behauptet von sich, ein Proof of Concept zu sein; die Arbeit daran wurde eingestellt.

Die Tooltips funktionieren nur standalone (vermutlich meine Unfähigkeit, das Ergebnis geeignet einzubinden), und außerdem überlappen die Kreise leicht, was sie aufgrund der Koordinaten eigentlich nicht tun sollten.

## dat was created before

par(mar=rep(0.1,4))  ## package would fail for rep(0,4)

## determine required space
xrange <- range(c(dat$x-dat$radius, dat$x+dat$radius))
yrange <- range(c(dat$y-dat$radius, dat$y+dat$radius))

doc = svgPlot({
   par(mar=rep(0.1,4), mgp=c(0,0,0))
   plot(dat$x, dat$y, pch=10, col=par("bg"), axes=FALSE, 
        xlab="", ylab="", xlim=xrange, ylim=yrange, asp=1)
   packCircles(dat, "Education", sizetype="area", pal=grey.colors(47),
            groupcol="Fertility", groupsort=TRUE, main="",
            labcol="labs", add=TRUE)
   })
 addToolTips(doc, dat$tips)
 ## created the xml file - figured out without help from the documentation
 ## did that outside of Rmd file, does not work from within
 # sink(file="BeispielSVGAnnotationCircles.svg")
 #  print(doc)
 #  sink(file=NULL)

Beispiel: Grafik mit Tooltips mit ggiraph

Dies ist ein echter Vorteil für die gg-Welt!

library(ggplot2)
library(ggiraph)

## dat was created before

 myggcircles <- ggplot(data=dat) + coord_fixed() +
   ggforce::geom_circle(mapping=aes(x0=x, y0=y, r=radius, color=Fertility, fill=Fertility)) +
   theme_minimal() +
   theme(panel.grid = element_blank(), axis.title = element_blank(),
         axis.text = element_blank(), legend.position="none") +
   scale_color_gradient(low="grey30", high="grey90") +
   scale_fill_gradient(low="grey30", high="grey90") +
   geom_point_interactive(mapping=aes(x=x, y=y, color=Fertility, size=3, tooltip=tips))
 ## size ensures that point can be hovered more easily
 girafe(code=print(myggcircles), width_svg = 7.5, height_svg = 7.5, 
        options = list(opts_sizing(rescale = FALSE)))

Beispiel: spiral.heatmap

Die polygon Funktion erlaubt die Darstellung geschlossener Flächen. Die Funktion spiral.heatmap macht sich das zunutze, um Saisonalität in Zeitreihen zu visualisieren. Ein small multiples Arrangement mit spiral heatmaps findet sich hier.

Funktion spiral.heatmap (ohne Prüfung von Eingaben etc.; demnächst in Jim Lemon’s plotrix) 
##   ## initialize plot 
##   par(mar=c(1,1,1,1)) 
##   symbols(0, 0, xlab="", ylab="", 
##           circles=1,  
##           inches=FALSE, asp=1, bg=bg.col, fg=bg.col,  
##           xlim=xlim, ylim=ylim,  
##           xaxt="n",yaxt="n",bty="n") 
##   if (store) ausdat <- data.frame(period=dat$period,  
##                                   season=dat$season, 
##                                   fromx=NA, fromy=NA,  
##                                   midx=NA, midy=NA,  
##                                   tox=NA, toy=NA) 
##   for (i in 1:nrow(dat)){ 
##     zeile <- dat[i,]  
##     arc <- seq(zeile$anglefrom, zeile$angleto,  
##                length.out = narc) 
##     from <- radstart + slopecircrect 
##     to <- from + thickpolys 
##     if (store) { 
##       ausdat[i,]$fromx <- (from[1]+to[1])/2*cos(arc[1]) 
##       ausdat[i,]$fromy <- (from[1]+to[1])/2*sin(arc[1]) 
##       midpos <- narc%/%2 
##       ausdat[i,]$midx <- (from[midpos]+to[midpos])/2*cos(arc[midpos]) 
##       ausdat[i,]$midy <- (from[midpos]+to[midpos])/2*sin(arc[midpos]) 
##       ausdat[i,]$tox <- (from[narc]+to[narc])/2*cos(arc[narc]) 
##       ausdat[i,]$toy <- (from[narc]+to[narc])/2*sin(arc[narc]) 
##     } 
##     radstart <- radstart + max(slopecircrect) 
##     if (!is.na(zeile$facx))  
##       polygon(c(from*cos(arc), rev(to)*cos(rev(arc))),  
##             c(from*sin(arc), rev(to)*sin(rev(arc))), 
##             col=palette[as.numeric(zeile$facx)],  
##             border = palette[as.numeric(zeile$facx)]) 
##     else polygon(c(from*cos(arc), rev(to)*cos(rev(arc))),  
##                  c(from*sin(arc), rev(to)*sin(rev(arc))), 
##                  col=na.col,  
##                  border = na.col) 
##   }     
##  
##   aus <- list(period.range = range(period), 
##               rad.range = c(radmin, max(to))) 
##    
## if (is.null(labels)) { 
##   ## prepare default labels 
##   labels <- as.character(dat[1:s,]$season) 
##   ## must be in degrees, like label.pos from call 
##   label.pos <- 180*dat[1:s,]$angle/pi 
## } 
## ## add labels 
##   if (!is.null(labels)){ 
##     stopifnot(length(labels)==length(label.pos)) 
##     stopifnot(is.character(labels) ||  
##                 is.numeric(labels) ||  
##                 is.expression(labels)) 
##   if (length(labels)>0){ 
##       ## bring label.pos to radians 
##       label.pos <- label.pos/180*pi 
##     for (i in 1:length(labels)){ 
##       lp <- label.pos[i] 
##       lab <- labels[i] 
##       ## is 1.05 a suitable position for labels? 
##       lx <- 1.05*cos(lp) 
##       ly <- 1.05*sin(lp) 
##       ## y adjustment 
##       if (lp < pi) a2 <- 0 else a2 <- 1 
##       ## text rotation and x adjustment dependent on lp 
##       if (lp < pi/2 || lp > 3*pi/2) 
##         text(lx, ly, adj=c(0, a2), 
##              lab, xpd=NA,  
##              srt=180*lp/pi, col=label.col,  
##              cex=label.cex, ...) 
##       else 
##         text(lx, ly, 
##              adj=c(1, a2), 
##              lab, xpd=NA,  
##              srt=180*lp/pi+180, col=label.col,  
##              cex=label.cex, ...) 
##     } 
##     } 
##     } 
##   if (legend) { 
##     ## logic: assume square region + legend 
##     ## for legend on the right, use ylim[2]+offset 
##     ## for legend at the bottom, use xlim[2]+offset 
##     if (bin.type=="q") legend.pos <- "r" 
##     if (legend.pos == "r"){ 
##       xl <- ylim[2]+(xlim[2]-ylim[2])/4 
##       xr <- ylim[2]+(xlim[2]-ylim[2])/2 
##       yb <- -1; yt <- 1 
##     } else 
##     { 
##       yb <- xlim[1]+(ylim[1]-xlim[1])/4 
##       yt <- xlim[1]+(ylim[1]-xlim[1])/2 
##       xl <- -1; xr <- 1 
##     }  
##     if (bin.type=="q"){ 
##        color.legend(xl,yb,xr,yt,levels(dat$facx),palette, 
##                  align="rb", gradient="y", cex=legend.cex,  
##                  col=legend.col, ...) 
##       text((xlim[2]+ylim[2])/2, 1,  
##            legend.title, pos=3,  
##            cex=legend.cex, col=legend.col) 
##     } 
##     else{ 
##       if (legend.pos=="r"){ 
##         color.legend(xl,yb,xr,yt,"",palette, 
##                    align="rb", gradient="y", cex=legend.cex,  
##                    col=legend.col, ...) 
##         text((xl+xr)/2, -1, legend.labels[1],pos=1,xpd=NA, cex=legend.cex, col=legend.col) 
##         text((xl+xr)/2, 1, legend.labels[2],pos=3,xpd=NA, cex=legend.cex, col=legend.col) 
##         text((xl+xr)/2, min(1.1, ylim[2]),  
##            legend.title, pos=3,  
##            cex=legend.cex, col=legend.col) 
##       } 
##       else{ 
##         color.legend(xl,yb,xr,yt,"",palette, 
##                      align="rb", gradient="x", cex=legend.cex,  
##                      col=legend.col, ...) 
##         text(-1,(yb+yt)/2,legend.labels[1],pos=2,xpd=NA, cex=legend.cex, col=legend.col) 
##         text(1,(yb+yt)/2,legend.labels[2],pos=4,xpd=NA, cex=legend.cex, col=legend.col) 
##         text(0, yt, legend.title, pos=1,xpd=NA, cex=legend.cex, col=legend.col) 
##       } 
##     } 
##   } 
##   ## finalize returned object 
##   hilf <- dat$angle[1:s]*180/pi 
##   names(hilf) <- as.character(dat$season[1:s]) 
##   aus$angles <- hilf[sort(as.numeric(dat[1:s,]$season), index.return=TRUE)$ix] 
##   hilf <- palette; names(hilf) <- levels(dat$facx) 
##   aus$heatcolors <- hilf 
##   if (is.numeric(x)) aus$xrange <- range(x, na.rm=TRUE) 
##   if (store) aus$points.xy <- ausdat 
##   invisible(aus)



Erstellung des Arrangements (ohne Datenvorbereitung)



## png("BerlinCovidReporting.png", width=1200, height=1200, type="cairo", 
##     pointsize = 24) 
## ### color and font settings 
## par(bg=grey(0.2), fg="white", col.main="white", font=2) 
## mypal <- pals::brewer.oranges(50) 
## ### layout 
## mat <- matrix(1:12, ncol=4, byrow=TRUE) 
## mat <- rbind(mat, 13)    ## for legend 
## mat <- rbind(14,mat,15)  ## for title and subtitle 
## layout(mat, heights=c(0.5,3,3,3,1,0.5)) 
##  
## ## create individual district spiral heatmaps 
## for (nam in Kreise){ 
##  
## ## extract current district 
## Faelle <- FaelleBerlin[FaelleBerlin$Landkreis==nam,] 
## ## fill interim missing dates with zeroes 
## datum <- as.Date(Faelle$Datum) 
## datum <- seq(min(datum), max(datum), 1) 
## Level0 <- levels(FaelleBerlin$Anzfac)[1] 
## FaelleVollst <- data.frame(Datum=datum, Anzahl=0,  
##                            Anzfac=factor(Level0,  
##                                 levels=levels(FaelleBerlin$Anzfac))) 
## for (i in 1:nrow(Faelle)) { 
##   FaelleVollst[which(FaelleVollst$Datum==Faelle[i,]$Datum),]$Anzahl <-  
##   Faelle[i,]$Anzahl 
##   FaelleVollst[which(FaelleVollst$Datum==Faelle[i,]$Datum),]$Anzfac <-  
##     Faelle[i,]$Anzfac 
## } 
## ## create weeks as periods 
## jahr <- as.POSIXlt(datum)$year+1900 
## woche <- (jahr-2020)*53+lubridate::isoweek(as.POSIXlt(datum)) 
## woche[woche==106] <- 53 
## ## create weekdays 
## Wochentag <- factor(weekdays(datum),  
##                      levels=c("Montag","Dienstag","Mittwoch", 
##                               "Donnerstag","Freitag","Samstag","Sonntag")) 
## #levels(Wochentag) <- c("Mo", "Di", "Mi", "Do", "Fr", "Sa", "So") 
## levels(Wochentag) <- c("Mo", "Tu", "We", "Th", "Fr", "Sa", "Su") 
## ## create spiral heatmap 
## myts<-timespiral::spiral.heatmap(woche,  
##            Wochentag, FaelleVollst$Anzfac,  
##            eye.rad = 0.3, clockwise=TRUE, 
##            palette=mypal, xlim=c(-1.2,1.2), 
##            ylim=c(-1.2,1.2), 
##            legend=FALSE) 
## text(0,-1.4, Kreisnam[nam], xpd=NA) 
## } 
## ## create legend and titles 
## par(mar=c(1,4,2,6)) 
## pals::pal.bands( mypal) 
## text(0,0.5, "0", pos=2) 
## text(50,0.5, round(max(FaelleBerlin$AnzPerMio),1), pos=4, xpd=NA) 
## par(mar=c(0,0,2,0)) 
## plot.new() 
## ## for title 
## title(main="History of daily Covid 19 cases per million reported by Berlin districts (status: April 3, 2021)",  
##       adj=0, cex.main=1.5) 
## mtext("arranged in spiral heatmaps to show day of week patterns in reporting days.", 
##       line=-1, cex=0.8, at=0, adj=0) 
## mtext("Each revolution represents a week, starting with the earliest week, spiralling outward in clockwise direction.", 
##       line=-2.2, cex=0.8, at=0, adj=0) 
## plot.new() 
## ## for sub titles 
## mtext("Source: RKI raw data downloaded April 4th, Statista population sizes end of 2019", font=1,  
##       cex=0.8, at=1, adj=1) 
## dev.off()








Wichtige weitere Themen





Fazit


Quick and Dirty sind base und gg Grafiken hässlich und schlecht beschriftet (auf unterschiedliche Art und Weise).


Für Publikations-Grafiken sollte das (letztlich) geändert werden.


Das geht mit Base R häufig einfacher (mag an mir liegen).


Für Base Grafiken:



Für gg Grafiken:





Collection of further cheat sheets


Gerard, David (2019). Base R Graphics Cheat Sheet. Not really a cheat sheet, 11 pages. Accessed March 3rd 2021.


Holtz, Jan (2018). Base R graph parameters: a cheatsheet. Blog post in the R graphics gallery. Accessed March 3rd 2021.


Robbins, Joyce (2016). R Base Graphics Cheatsheet, accessed April 12th 2021.


Ross, Zev (2014). Beautiful plotting in R: A ggplot2 cheatsheet. gg only, not really a cheat sheet but rather an explanation by example, long html. Accessed March 3rd 2021.


RStudio (2018). Data Visualization with ggplot2 : : CHEAT SHEET. gg only. On the more complicated side. Accessed March 3rd 2021.


Sanchez, Gaston (without year). Visual cheat sheet for some plot parameters in R. Very nice! Accessed March 3rd 2021.


Xeonkai (2016). R graphical cheat sheet (DRAFT). Unfinished cheat sheet on cheatography, accessed March 3rd 2021.