plot.depth <- function( data, # datenframe yaxis.first=TRUE, # enthält erste Spalte Tiefendaten? yaxis.num="n", # Zahlen an/aus an="s" aus="n" xaxes.equal=TRUE, # Gleichskalierung TRUE/FALSE; für alle gültig oder separat durch c(...) xaxis.num="s", # Zahlen an/aus an="s" aus="n"; für alle gültig oder separat durch c(...) bty="L",# L, c, o ... Boxtyp: für alle gültig oder separat durch c(...) l.type="solid",# Linientyp: für alle gültig oder separat durch list(...) l.width=1, # Linienbreite: für alle gültig oder separat durch list(...) l.color="black", # Linienfarbe: für alle gültig oder separat durch c(...) plot.type="o",# Linien/Punkttyp: für alle gültig oder separat mit c(...) # möglich: o, b, c, n, h, p, l, s, S # o = Punkt + Linie durchgezogen # b = Punkt + Linie unterbrochen # c = Linie unterbrochen + ohne Punkte # h = histogramm-artige Linien # p = nur Punkte # l = Linie durchgezogen # s oder S = Stufen plot.before=NULL, # was VOR dem eigentlichen Zeichnen ausgeführt werden soll # z.B.: grid() als expression() angeben, also 'expression(grid())'; # kann auch mit list(...) verschachtelt werden; # für alle gültig oder separat durch list(...) plot.after=NULL, # was NACH dem eigentlichen Zeichnen ausgeführt werden soll # z.B.: zusätzliche Grafiken z.B.: points(), lines() als expression() angeben: # expression(lines(...)) - kann auch mit list(...) verschachtelt werden; # für alle gültig oder separat durch list(...) axis.lab=FALSE, # keine zusätzlichen labels an restliche y-Achsen axis.ticks=TRUE, # ticks zusätzlich ja axis.top=list(c(FALSE, FALSE)), # x-Achse auch top? für c(axis=TRUE, labels=TRUE) # für alle gültig oder separat verschachtelt mit list( c(T,F), c(T,T), ...) nx.minor.ticks=5,# Anz. Intervalle f. x-Teilstriche wenn Paket Hmisc installiert # für alle gültig oder separat durch c(...) ny.minor.ticks=5, # Anz. Intervalle f. y-Teilstriche wenn Paket Hmisc installiert # für alle gültig oder separat durch c(...) mar.outer=c(1,6,4,1), # Rand außen bottom, left , top, right mar.top=9, # Rand oben mar.bottom=5, # Rand unten txt.xadj=0.1, # align Text x-Richtung 0...1 links ... rechts vom plot txt.yadj=0.1, # align Text y-Richtung in Skaleneinheiten + -> nach oben; - -> nach unten locator=FALSE, # Spaltenbeschriftung explizit mit Maus setzen colnames.scale.loc=0.7,# Schriftgröße f. alle columnnames wenn locator=TRUE colnames=TRUE,# für alle gültig oder separat durch c(...) rotation=60,# Text Rotation: für alle gültig oder separat durch c(...) polygon=FALSE, # Polygonplot an/aus: für alle gültig oder separat durch c(...) polygon.color="gray",# Farbe Polygonplot: für alle gültig oder separat durch c(...) p.type=21, # Punkttyp: für alle gültig oder separat durch list(...) p.bgcolor="white", # HGrund Punkte: für alle gültig oder separat durch c(...) p.fgcolor=l.color, # VGrund Punkte: für alle gültig oder separat durch c(...) subtitle="", # Untertitel: für alle gültig oder separat durch list(...) xlabel="", # x-AchsenBeschriftung: für alle gültig oder separat durch list(...) main="",# Titel der einzelnen Plots: für alle gültig oder separat durch list(...) min.scale.level=0.2, # 0...1 wenn Daten kleiner als 0.2(=20%) vom maximalsten Wert, # dann wird mehr Platz für den Plot gemacht min.scale.rel=0.5, # 0...1 reslativer Platz/Breite der Teilgrafik zur maximal möglichen Breite # 1=maximale mögliche Breite min.scaling=FALSE, # bei TRUE nur separate Angabe mit c(FALSE, FALSE, TRUE, .. ) sinnvoll color.minscale="gray95", # Farbe minimal-skalierter Daten: # für alle gültig oder separat durch list(...) ... # restliche Optionen für interne Funktion 'lines()' ){ # ------8<---- Funktion minor.tick Anfang # aus dem Hmisc Paket zusätzlich axis=c(1,2) + '...' für axis( , ...) eingefügt: # axis=c(3,4) zeichnet auch Achsen oben; minor.tick <- function (nx = 2, ny = 2, tick.ratio = 0.5, axis=c(1,2), ...) { ax <- function(w, n, tick.ratio) { range <- par("usr")[if (w == "x") 1:2 else 3:4] tick.pos <- if (w == "x") par("xaxp") else par("yaxp") distance.between.minor <- (tick.pos[2] - tick.pos[1])/tick.pos[3]/n possible.minors <- tick.pos[1] - (0:100) * distance.between.minor low.minor <- min(possible.minors[possible.minors >= range[1]]) if (is.na(low.minor)) low.minor <- tick.pos[1] possible.minors <- tick.pos[2] + (0:100) * distance.between.minor hi.minor <- max(possible.minors[possible.minors <= range[2]]) if (is.na(hi.minor)) hi.minor <- tick.pos[2] if (.R.) axis(if (w == "x") axis[1] else axis[2], seq(low.minor, hi.minor, by = distance.between.minor), labels = FALSE, tcl = par("tcl") * tick.ratio, ...) else axis(if (w == "x") axis[1] else axis[2], seq(low.minor, hi.minor, by = distance.between.minor), labels = FALSE, tck = par("tck") * tick.ratio, ...) } if (nx > 1) ax("x", nx, tick.ratio = tick.ratio) if (ny > 1) ax("y", ny, tick.ratio = tick.ratio) invisible() } # ------8<---- Funktion minor.tick Ende # Daten überprüfen if(!is.data.frame(data)) stop(paste("\n!> Funktion \'plot.depth(data, ...)\' erwartet data.frame! \n!> Die Daten sind aber: \'",mode(data),"\'", sep="")) if(ncol(data) < 2) stop("\n!> Es sollten mindestens 2 Spalten in den Daten enthalten sein!") nc <- ncol(data) nr <- nrow(data) if(yaxis.first==TRUE){ nc.data <- nc-1 draw <- 2:nc y.depth <- data[,1] } else{ nc.data <- nc draw <- 1:nc y.depth <- (1:nr)*(-1) warning("!> Die Daten werden nach Zeilennummern gezeichnet.\n") } x.maximum <- max(apply(data[,draw],2,max, na.rm=TRUE)) x.maxima <- apply(data[,draw],2,max, na.rm=TRUE) # cat(x.maximum) zur kontrolle Ausgabe hier x.max <- apply(data[,draw],2,max, na.rm=TRUE) stopifnot(0 <= min.scale.level && min.scale.level <=1) stopifnot(0 <= min.scale.rel && min.scale.rel <=1) par(no.readonly=TRUE) -> original # Grafikparameter speichern # Maxima der einzelnen Spalten apply(data[,draw],2,max, na.rm=TRUE) -> x.widths for(i in 1:length(x.widths)){ ifelse(length(xaxes.equal)==nc.data, equal.i <- i, equal.i <- 1) ifelse(x.widths[i]/max(x.widths) <= min.scale.level, {# x.widths/max <= 0.5 min.scale.rel -> x.widths[i] # 0...min.scale.rel # Maximum für x-Achse ifelse(xaxes.equal[equal.i]==FALSE, {# FALSE: x.max[i] <- max(data[,draw[i]]) # Maximum der Spalte }, { x.max[i] <- x.maximum * min.scale.rel # Maximum aller Daten } ) # xaxes.equal },{# x.widths/max > 0.5 x.widths[i] <- x.widths[i]/max(x.widths) # 0...1 # Maximum für x-Achse ifelse(xaxes.equal[equal.i]==FALSE, {# FALSE: x.max[i] <- max(data[,draw[i]]) # Maximum der Spalte },{ x.max[i] <- x.maxima[i] # Maximum aller Daten } ) # xaxes.equal } ) # minscale.level } # cat("Proportionen:", round(x.widths,2), "\n") # Kontrollausgabe # Layout festlegen layout(matrix(1:nc.data,1 , nc.data), widths=x.widths) # eigentliches zeichnen par(mar=c(mar.bottom, 0, mar.top, 0)+0.1, xpd=FALSE) for(i in 1:length(draw)){ # Index-Schalter für verschiedene Optionen ifelse(length(plot.type)==nc.data, n.i <- i, n.i <- 1) ifelse(length(ny.minor.ticks)==nc.data, ny.i <- i, ny.i <- 1) ifelse(length(nx.minor.ticks)==nc.data, nx.i <- i, nx.i <- 1) ifelse(length(polygon)==nc.data, p.i <- i, p.i <- 1) ifelse(length(min.scaling)==nc.data, min.i <- i, min.i <- 1) ifelse(length(l.type)==nc.data, lt.i <-i, lt.i <- 1) ifelse(length(l.color)==nc.data, lc.i <-i, lc.i <-1) ifelse(length(l.width)==nc.data, lw.i <-i, lw.i <- 1) ifelse(length(p.type)==nc.data, pt.i <-i, pt.i <- 1) ifelse(length(colnames)==nc.data, col.i <- i, col.i <- 1) ifelse(length(rotation)==nc.data, r.i <- i, r.i <- 1) ifelse(length(xlabel)==nc.data, xlab.i <- i, xlab.i <- 1) ifelse(length(subtitle)==nc.data, sub.i <- i, sub.i <- 1) ifelse(length(main)==nc.data, main.i <- i, main.i <- 1) ifelse(length(plot.before)==nc.data, before.i <- i, before.i <- 1) ifelse(length(plot.after)==nc.data, after.i <- i, after.i <- 1) ifelse(length(axis.top)==nc.data, axtop.i <- i, axtop.i <- 1) ifelse(length(xaxis.num)==nc.data, xnum.i <- i, xnum.i <- 1) # Ränder x-Achse if(i==1) par(oma=mar.outer, xaxt=xaxis.num[xnum.i]) else par(xaxt=xaxis.num[xnum.i]) # Minimum ifelse( min(data[,draw[i]], na.rm=TRUE) > 0, x.min <- 0,# 0... max x.min <- min(data[,draw[i]], na.rm=TRUE) # min...max ) # if(yaxis.first==TRUE) x.min <- 0 # else x.min <- min(data[,draw[i]], na.rm=TRUE) # Grafik zeichnen plot(data[,draw[i]], y.depth, ann=FALSE,# nichts an Achse type="n",# Punkttyp yaxt=ifelse(i==1,"s",yaxis.num),# y-Achse an/aus xlim=c(x.min,x.max[i]), bty=ifelse(length(bty)==nc.data, bty[i], bty), xlab=ifelse(length(xlabel)==nc.data, xlabel[i], xlabel), panel.first = eval(plot.before[[before.i]]) ) # Achsenteilstriche falls Paket Hmisc if(require(Hmisc)) minor.tick(ny=ny.minor.ticks[ny.i], nx=nx.minor.ticks[ny.i]) else warning("!> Für kleine Achsen-Teilstriche bitte Paket \'Hmisc\' installieren") # immitierte Histogramme; Breite über Option l.width möglich if( plot.type[n.i] =="h"){ for(n in 1:nr){ x <- c(0,data[n,draw[i]]) y <- c(y.depth[n], y.depth[n]) par(lend="butt") # Linien-Ende gekappt f. "barplots" besser lines(x,y, lty=l.type[[lt.i]], lwd=l.width[[lw.i]], col=ifelse(length(l.color[[lc.i]])==nr, l.color[[lc.i]][n], l.color[[lc.i]]), ) par(lend="round") # Linien-Ende gekappt f. "barplots" besser } } # Polygonplot if (polygon[p.i]==TRUE){ # NA zu = ersetzen data.null <- data data.null[is.na(data.null)] <- 0 # Kontrolle Option: min.scaling if (min.scaling[min.i]==TRUE || min.scaling[min.i] > 0){ # default 5-fach Vergrößern if(min.scaling[min.i]==TRUE) min.scaling[min.i] <- 5 polygon( c(0, data.null[,draw[i]]*min.scaling[min.i],0) , c(y.depth[1],y.depth,y.depth[nr]), col=ifelse(length(color.minscale)==nc.data,color.minscale[[i]],color.minscale[1]) ) # Skalierung als message ausgeben message(paste("!> Spalte \'", colnames(data)[draw[i]],"\' wurde ", min.scaling[min.i], "-fach skaliert.\n", sep="") ) } # richtigen Polygonplot zeichnen polygon( c(0, data.null[,draw[i]] ,0) , c(y.depth[1], y.depth, y.depth[nr]), col=ifelse(length(polygon.color)==nc.data, polygon.color[i], polygon.color) ) # Warnung/Empfehlung, falls NA in Daten if(any(is.na(data[,draw[i]]))) warning("!> Spalte \'", colnames(data)[draw[i]], "\' enthält NA\'s.", "\n!> Empfehlung: keinen Polygonplot, da die Werte auf \'0\' gesetzt werden.", "\n!> Setze entsprechende Spalte über Option \'polygon=c(T, T, F, ...)\' explizit auf \'F\' (FALSE)", "\n!> oder zeichne immitiertes Balkendiagramm mit den beiden Optionen:", "\n!> plot.type=c(...,\"h\",...),\n!> l.width=c(..., 15, ...), ",call. = FALSE) } # Punkte Linien, was auch immer lines(data[,draw[i]], y.depth, ann=FALSE,# nichts an Achse type=ifelse(plot.type[n.i]=="h", "n",plot.type[n.i]),# Punkttyp lty=l.type[[lt.i]], lwd=l.width[[lw.i]], pch=p.type[[pt.i]], col=l.color[[lc.i]], bg=ifelse(length(p.bgcolor)==nc.data, p.bgcolor[i], p.bgcolor), panel.last = eval(plot.after[[after.i]]), ... ) # Spaltenbeschriftung if(locator==TRUE) colnames[col.i]=FALSE if(colnames[col.i]==TRUE){ min(par()$usr[1:2]) -> x.text abs(max(par()$usr[1:2])-x.text)*txt.xadj -> x.adj # % Breite x-Achse max(par()$usr[3:4]) -> y.text par(xpd=TRUE) text(x.text+x.adj, y.text+txt.yadj, labels=colnames(data)[draw[i]], adj=0, srt=rotation[r.i] ) par(xpd=FALSE) } # Titelei, Beschriftung title( sub=subtitle[[sub.i]], xlab=xlabel[[xlab.i]], main=main[[main.i]] ) # y-Achse für restliche Daten if(i > 1) axis(side=2, labels=axis.lab, tick=axis.ticks) # x-Achse top if(length(axis.top[[axtop.i]])==2){ if(axis.top[[axtop.i]][1]==TRUE){ axis(side=3, labels=axis.top[[axtop.i]][2], tick=TRUE, tcl=0.5) minor.tick(ny=0, nx=nx.minor.ticks[ny.i], axis=c(3,4), tcl=0.25) } } else warning("!> Option 'axis.top' erwartet 2 Argumente als list(...):", "\n!> 2. Argument ist für Achsen-Zahlen also z.B.: axis.top=list(c(T, F))") }# end for par(original) # Spaltennamen mit Hand setzen if(locator==TRUE){ par(xpd=TRUE) -> original message("!> Hinweis: Mit Maus jetzt Spaltentext plazieren.\n!> Klick = linke untere Ecke.") for(i in 1:length(draw)){ locator(1) -> wo # Mausposition erfassen text(wo$x, wo$y, labels=colnames(data)[draw[i]], adj=0, srt=rotation[r.i], cex=colnames.scale.loc ) } par(original) } }# end plot.depth