In stp4/stp25plot: meine plots
knitr::opts_chunk$set(echo = TRUE)
require(stp25tools)
require(stp25plot) # meine Funktionen
require(stp25stat2)
require(magrittr)
lattice::trellis.par.set(bw_theme)
require(lattice) # Lattice-Plots
require(RColorBrewer) # Farben
require(latticeExtra)
require(effects) # Effekte
require(gridExtra) # Plots agregieren
require(ggplot2)
require(cowplot)
set.seed(2)
n <- 20 * 3 * 2
DF <- data.frame(
n = runif(n, min = 1, max = 5),
e = runif(n, min = 1, max = 5),
o = runif(n, min = 1, max = 5),
g = runif(n, min = 1, max = 5),
a = cut(runif(n, min = 1, max = 5), 3, 1:3),
treatment = gl(3, n / 3, labels = c("UG1", "UG2", "KG"))[sample.int(n)],
sex = gl(2, n / 2, labels = c("male", "female"))
)
DF <-
Label(
DF,
sex="Geschlecht",
n = "Neuroticism",
e = "Extraversion",
o = "Openness",
g = "Conscientiousness",
a ="Agreeableness"
)
Funktionen
- Theme for lattice-plots set_lattice(), reset_lattice() und lattice::trellis.par.set(bw_theme(farbe()))
- auto_plot Einzelne lattice plots analog wie die Funktion Tabelle()
- Boxplot bwplot2()
- plot.bland_altman()
- Hilfsfunktionen wrap_sentence(), stp25plot:::plot.efflist()
Likertplot
set.seed(1)
n <- 100
lvs <- c("--", "-", "o", "+", "++")
DF2 <- data.frame(
Magazines = gl(length(lvs), 1, n, lvs),
Comic.books = gl(length(lvs), 2, n, lvs),
Fiction = gl(length(lvs), 3, n, lvs),
Newspapers = gl(length(lvs), 5, n, lvs)
)
DF2$Comic.books[sample.int(n / 2)] <- lvs[length(lvs)]
DF2$Newspapers[sample.int(n / 2)] <- lvs[1]
DF2$Magazines[sample.int(n / 2)] <- lvs[2]
DF2 <- transform(DF2, Geschlecht = cut(rnorm(n), 2, c("m", "f")))
#Res1 <- Tbll_likert( ~ ., DF2[, -5])
Res2 <- Tbll_likert(. ~ Geschlecht, DF2)
likertplot(Item ~ . | Geschlecht,
data = Res2,
between=list(x=0), columns=5)
# col = likert_col(attr(data, "plot")$nlevels, middle = ReferenceZero)
DF2 |> likert_plot(Magazines, Comic.books, Fiction, Newspapers,
relevel = letters[1:5],
auto.key = list(columns=5, between=.15, space="top"),
# between=list(x=0),
horizontal=FALSE,
ReferenceZero = 1.5)
Signifikanz-Plot
Der Fliegen-Schiss-Plot mein absoluter lieblings Plot!!
require(stpvers)
#require(lmerTest)
require(emmeans)
#dummy
dat<- data.frame(
nmp=factor(c(
'nmp01', 'nmp02', 'nmp03', 'nmp04', 'nmp05', 'nmp05', 'nmp05', 'nmp05',
'nmp06', 'nmp06', 'nmp06', 'nmp12', 'nmp12', 'nmp12', 'nmp12', 'nmp12',
'nmp13', 'nmp13', 'nmp13', 'nmp13', 'nmp14', 'nmp14', 'nmp14', 'nmp14',
'nmp14', 'nmp15', 'nmp15', 'nmp15', 'nmp15', 'nmp15', 'nmp16', 'nmp16',
'nmp16', 'nmp16', 'nmp17', 'nmp17', 'nmp17', 'nmp17', 'nmp17', 'nmp18',
'nmp18', 'nmp18', 'nmp18', 'nmp18', 'nmp19', 'nmp20', 'nmp20', 'nmp20',
'nmp20', 'nmp20', 'nmp21', 'nmp21', 'nmp21', 'nmp21', 'nmp21', 'nmp22',
'nmp22', 'nmp22', 'nmp22', 'nmp23', 'nmp23', 'nmp23', 'nmp23', 'nmp23',
'nmp24', 'nmp24', 'nmp24', 'nmp24', 'nmp24', 'nmp26', 'nmp26', 'nmp26',
'nmp26', 'nmp27', 'nmp27', 'nmp27', 'nmp28', 'nmp28', 'nmp28', 'nmp28',
'nmp28', 'nmp29', 'nmp29', 'nmp29', 'nmp29', 'nmp29', 'nmp30', 'nmp30',
'nmp30', 'nmp31', 'nmp31', 'nmp31', 'nmp31', 'nmp36', 'nmp36', 'nmp36', 'nmp36')),
time= c(NA, NA, NA, NA, 1, 4, 6, 7.9, 1, 4, 8.1, 1, 4, 6, 12, 19, 1, 4,
6, 10.3, 1, 4, 6, 12, 24, 1, 4, 6, 12, 23.4, 1, 4, 6, 10.9, 1, 4,
6, 12, 19.6, 1, 4, 6, 12, 20.3, NA, 1, 4, 6, 12, 21.6, 1, 4, 6,
12, 21, 1, 4, 6, 10.5, 1, 4, 6, 12, 20.5, 1, 4, 6, 12, 21.5, 4,
6, 12, 22.2, 1, 4, 5, 1, 4, 6, 12, 27.8, 1, 4, 6, 12, 18.1, 1,
4, 9.1, 1, 4, 6, 20.3, 1, 4, 6, 11.4),
t.cell=c(NA, NA, NA, NA, 24.4, 35.5, 32.8, 33, 19.6, 21.1, 19.1, 22.9,
22.6, 20.3, 22.4, 20.7, 30.9, 32.1, 36.5, 41.8, 18.8, 16.4,
17.5, 18.4, 16.5, 31.6, 28.5, 30, 26.1, 23.6, 14.4, 24.8, 24.8,
19.8, 21.8, 23.8, 24.8, 23.1, 17.7, 26.6, 25.1, 27.5, 25, 16.9,
NA, 38.7, 44, 47.3, 42.9, 39.8, 11.7, 20.8, 26.7, 22, 15.2, 17.4,
28, 30.5, 27.1, 6.21, 12.6, 12, 12.1, 9.2, 5.34, 6.69, 8.93, 8.63,
4.15, 5.93, 6.47, 3.31, 6.95, 8.39, 9.31, 12.7, 2.99, 3.34, 4.35,
3.45, 1.28, 10.1, 8.78, 9.25, 12.4, 11.6, 7.7, 12.6, 13, 2.18, 2.44,
2.78, 5.31, 10.6, 12, 15.6, 15.9))
dat<- transform(dat,
time2=cut(time, c(0, 2, 4, 9, 18, Inf), paste0(c(1, 4, 6, 12, 24), "h")),
DC4= t.cell+ time/1.3)
dat<- na.omit(dat)
#prism.plots(Sepal.Length ~ Species, data = iris, centerfunc=mean)
#plotSigBars(Sepal.Length ~ Species, data = iris, type="tukey")
#dat1 <- Long(dat, DC4 ~ nmp + time2, value = "DC4")
#fit2 <- lmer(DC4 ~ time2 + (1 | nmp), data = dat1)
fit1 <- lm(DC4 ~ time2, data = dat)
em1 <- emmeans(fit1, list(pairwise ~ time2), adjust = "tukey")
#em2 <- emmeans(fit2, list(pairwise ~ time2))
prism.plots(
DC4 ~ time2,
data = dat,
#fun = mean,
ylim = c(-8, 60)
)
plotSigBars(fit1)
boxplot( DC4 ~ time2,
data = dat,
ylim = c(-15, 70))
plotSigBars(fit1, stars=FALSE)
#plotSigBars(em1, stars=FALSE)
#stripplot( DC4 ~ time2, data = dat, jitter.data=TRUE,pch=20, col="gray50")
stripplot(
DC4 ~ time2,
data = dat, ylim=c(-10,70),
ylab = "Difference (Absolute Value) [mm]", jitter.data=TRUE,
panel = function(x, y, ...) {
# panel.conf.int(x, y, ...)
panel.stripplot(x,y, pch=19, col="gray50",...)
#panel.points(x,y, pch=19,...)
#panel.mean(x,y, ...)
panel.median(x,y, ...)
panel.sig.bars(fit1, include.stars = FALSE, offset = .4)
}
)
#require(latticeExtra)
#require(effects)
fit1 <- lm(DC4 ~ time2, data = dat)
p2<- plot(effect("time2", fit1), ylim=c(0,60))
p2 + latticeExtra::layer( panel.sig.bars(fit1, include.stars = FALSE) )
require(emmeans)
plot_differenz <-
function (x, ...)
{
cis <- as.data.frame(confint(x))
x <- as.data.frame(x)
xx <-
cbind(
diff = cis$estimate,
lwr = cis$lower.CL,
upr = cis$upper.CL,
p.value = x$p.value
)
row.names(xx) <- cis$contrast
psig <- ifelse( x$p.value<.1, "black", "gray50")
stats:::plot.TukeyHSD(list(x = as.matrix(xx)), col=psig, ...)
xx
}
op=par(mar=c(4.2, 5, 3.8, 2))
fit1 |>
emmeans("time2") |>
pairs() |>
plot_differenz(las = 1, xlim =c(15, -25))
par(op)
Sparkplot
Stolen from http://www.motioninsocial.com/tufte/#sparklines
set.seed(1)
DF_sprk <- data.frame(
Laborwert = gl(7, 8,
labels = c(
"Albumin", "Amylase", "Lipase",
"AST", "ALT","Bilirubin","C-Peptid")),
Treat = gl(2, 4, labels = c("Control", "Treat")),
Time = gl(4, 1, labels = c("t0", "t1", "t2", "t4")),
x = rnorm(7 * 8)
)
DF_sprk <- transform(DF_sprk,
x = scale(x + as.numeric(Treat)*2 + as.numeric(Time) / 2))
DF_sprk1 <- Summarise(DF_sprk, x ~ Laborwert + Time, fun=mean )
names(DF_sprk1)[4]<- "x"
#DF_sprk<- DF_sprk[-3]
#head(DF_sprk)
#: "p", "l", "h", "b", "o", "s", "S", "r", "a", "g"
p1 <- sparkplot(x ~ Time | Laborwert, DF_sprk1, between=1.5
#,char.arrows= c(down= '-', updown='', up= "+" )
)
col<- c("purple", "darkgreen")
p2<- sparkplot(
x ~ Time | Laborwert,
DF_sprk,
groups = Treat,
between=1.5,
include.labels = FALSE,
left.padding=-5, right.padding=3,
col = col ,
key = list(
corner = c(1, 1.1),
lines = list(col = col, lwd = 2),
cex = .75,
columns = 2,
text = list(levels(DF_sprk$Treat))
)
#, char.arrows= c(down= '-', updown='', up= "+" )
)
p3 <- sparkplot(
x ~ Time | Laborwert,
DF_sprk,
groups = Treat,
type="barchart",
between=1.5,
include.labels = FALSE,
left.padding=-5, right.padding=3,
col = col
#, char.arrows= c(down= '-', updown='', up= "+" )
)
#windows(8,4)
#require(cowplot)
plot_grid(p1, p2, p3,
nrow=1,
rel_widths = c(.7, .5, .5)
)
Auto-Plot auto_plot()
Die Funktion klebt lattice- plots zu einer matrix zusammen.
Verwendung: auto_plot(formula, data) oder data |> auto_plot(var_x, var_y, var_z) Die Funktion kann dabei Formel wie z.B.
$a+b+c\sim g$
$a[box]+b[bar]+c[dot]\sim g$
$log(a) +b +c \sim g$
$y \sim a+b+c$
https://www.zahlen-kern.de/editor/
DF |> auto_plot(
n,
e[box],
o[hist],
g,
a,
treatment,
by = ~ sex,
par.settings = bw_theme()
)
auto_plot(treatment ~ n + e + sex, DF)
enviro <- lattice::environmental
enviro2 <- transform(
enviro,
smell = cut(
enviro$ozone,
breaks = c(0, 30, 50, Inf),
labels = c("ok", "hm", "yuck"),
ordered = TRUE
),
is.windy = factor(wind > 10, c(TRUE, FALSE), labels = c("windy", "calm")
)
) |> Label(
ozone=" Average ozone concentration (of hourly measurements)",
radiation = "Solar radiation (from 08:00 to 12:00)",
temperature = "Maximum daily temperature",
wind = "Average wind speed (at 07:00 and 10:00)",
smell = "Smell of ozone"
)
head(enviro2)
auto_plot(
enviro2,
ozone[hist],
radiation,
smell,
temperature,
by = ~ is.windy,
col.bar= farbe("Blues")[3],
ylab= c("ppb", "langleys", "%", "F"),
include.percent=TRUE,
wrap.main=30
# levels.logical = c(TRUE, FALSE),
# labels.logical = c("ja", "nein")
)
dat2 <- get_data(
"
comp_0 comp_1 comp_2 comp_3 comp_4 comp_5 comp_6 comp_7 comp_8 gender
TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE TRUE TRUE TRUE FALSE FALSE TRUE FALSE FALSE Male
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male
FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE Male
FALSE FALSE TRUE FALSE TRUE FALSE TRUE FALSE FALSE Male
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE FALSE FALSE TRUE TRUE FALSE FALSE FALSE TRUE Female
FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE Female
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Female
FALSE FALSE FALSE FALSE FALSE FALSE TRUE TRUE FALSE Male
TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE TRUE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male
TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male
TRUE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE Male
FALSE FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE Male
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Female
FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE TRUE Male
FALSE TRUE FALSE TRUE FALSE FALSE FALSE FALSE TRUE Female
FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male
FALSE TRUE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male
TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Female
FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE Female
"
) |> Label(
comp_0 = "A+" ,
comp_1 = "Heart Failure" ,
comp_2 = "Rhythm Abnormality" ,
comp_3 = "Valve Dysfunction" ,
comp_4 = "Bleeding with OAC" ,
comp_5 = "ACS" ,
comp_6 = "Neurological Event",
comp_7 = "Neoplastic Disease",
comp_8 = "Others",
gender = "Gender"
)
Mehrfachantworten mit multi_barplot().
# dat2[1:5] |>
# multi_barplot()
#
# dat2 |>
# multi_barplot(. ~ gender,
# reorder = TRUE,
# last = c("Others" ))
#
# dat2[1:5] |>
# auto_plot()
#
# dat2 |>
# auto_plot(. ~ gender)
# dat2 |> auto_plot(comp_1, comp_2, comp_3 ,
# include.percent=TRUE,
# include.reorder=TRUE,
# main ="Complicationen",
# xlab= "Prozent")
set_lattice()
~Initialisieren der Lattice - Optionen mit set_lattice().
Im Hintergrund werden die latticeExtra::ggplot2like.opts()
aufgerufen und die default Werte in opar und oopt gespeichert um sie mit reset_lattice() zurück seten zu können.~
reset_lattice()
lattice::trellis.par.set(bw_theme(farbe()))
p1<-barchart(xtabs(~treatment + sex + a, DF),
auto.key=list(space="top", columns=3,
cex=.7, between=.7 ),
par.settings= standard_theme())
p2<-barchart(xtabs(~ treatment + sex + a, DF),
auto.key=list(space="top", columns=3,
cex=.7, between=.7 ),
par.settings=bw_theme())
p3<-barchart(xtabs(~ treatment + sex + a, DF),
auto.key=list(space="top", columns=3,
cex=.7, between=.7 ),
par.settings=ggplot_theme())
grid.arrange(p1, p2, p3, ncol=3)
Einbetten von set_lattice() über update()
obj <-
xyplot(
Sepal.Length + Sepal.Width ~ Petal.Length + Petal.Width,
iris, type = c("p", "r"),
jitter.x = TRUE, jitter.y = TRUE, factor = 5,
auto.key = list(
cex.title = 1.2,
title = "Expected Tau",
text = c("30 ms", "80 ms", "130 ms", "180 ms"),
space = "top" # lines = TRUE, rectangles = TRUE
))
obj <- update(obj,
legend = list(
right =
list(fun = "draw.colorkey",
args = list(list(at = 0:100)))))
p1 <- update(obj, par.settings = custom.theme( ))
p2 <- update(obj, par.settings = ggplot_theme())
p3 <- update(obj, par.settings = bw_theme(), axis = axis.grid)
grid.arrange(p1, p2, p3, ncol = 3)
strip Sonderzeichen + Größe
x1<-rnorm(100); x2<-gl(2, 50, labels = c("Control", "Treat"))
y<-(1.5-as.numeric(x2))*x1+rnorm(100)
#windows(7,4)
p1<- xyplot(y~x1|x2,
xlab = expression(hat(mu)[0]),
type=(c("p", "r")),
# - auch mit fontsize=20
ylab=list(label="Percent of Respondents", cex=2),
par.strip.text=list(lines=2.5, col=6),
strip=strip.custom(factor.levels=
expression(
sqrt(G^{1}), sqrt(italic(R)^{1}))))
print(p1)
bwplot2
Lattice bwplot mit groups. Ist eine erweiterung von lattice::bwplot. Die Funktion arbeitet mit panel.superpose.
p1 <- bwplot2(
yield ~ site,
data = barley, groups = year, main="bwplot2()", par.settings = bw_theme(),
auto.key = list(points = FALSE, rectangles = TRUE, space = "right")
)
p2 <-
bwplot(
yield ~ site,
barley,groups = year, main="panel.superpose", par.settings = bw_theme(),
auto.key = list(points = FALSE, rectangles = TRUE, space = "right"),
box.width = 1 / 4,
panel = function(x, y, groups, subscripts, ...) {
xx <-
as.numeric(x) + scale(as.numeric(groups), scale = FALSE)/(nlevels(groups)+1)
panel.superpose(
xx, y, ...,
panel.groups = panel.bwplot,
groups = groups,
subscripts = subscripts
)
}
)
grid.arrange(p1, p2)
bwplot(yield ~ site, data = barley, groups=year,
pch = "|", box.width = 1/3,
auto.key = list(points = FALSE, rectangles = TRUE, space = "right"),
panel = panel.superpose,
panel.groups = function(x, y, ..., group.number) {
panel.bwplot(x + (group.number-1.5)/3, y, ...)
mean.values <- tapply(y, x, mean)
panel.points(x + (group.number-1.5)/3, mean.values[x], pch=17)
}
)
bwplot(
yield ~ site,
barley, groups = year, main="panel.superpose", par.settings = bw_theme(),
auto.key = list( points = FALSE, rectangles = TRUE, space = "right"),
box.width = 1 / 4,
panel = function(x, y, groups, subscripts, ...) {
xx <-
as.numeric(x) + scale(as.numeric(groups), scale = FALSE) /
(nlevels(groups)+1)
panel.superpose(
xx, y, ..., panel.groups = panel.mean,
groups = groups, subscripts = subscripts
)
panel.grid(h = -1, v = 0)
# panel.stripplot(x, y, ..., jitter.data = TRUE,
# groups = groups, subscripts = subscripts)
# panel.superpose(x, y, ..., panel.groups = panel.average,
# groups = groups, subscripts = subscripts)
# panel.points(x, y, ..., panel.groups = panel.average,
# groups = groups, subscripts = subscripts)
}
)
Forest
forest_plot() Tabelle und Vertikaler-Plot gestohlen von survminer::ggforest()
ggplot_forest() Vertikaler-Plot ohne Tabelle aber dafuer sind Gruppen moeglich - stolen from https://github.com/NightingaleHealth/ggforestplot
model1 <- lm(mpg ~ wt, data = mtcars)
model2 <- lm(mpg ~ wt + cyl, data = mtcars)
prepare_forest(model1, model2)
require(survival)
colon<- Label(colon, sex="Geschlecht")
fit1 <- lm(status ~ sex + rx + adhere,
data = colon)
forest_plot(fit1)
fit2 <- glm(status ~ sex + rx + adhere,
data = colon, family = binomial())
forest_plot(fit2)
fit3 <- coxph(Surv(time, status) ~ sex + rx + adhere,
data = colon)
forest_plot(fit3, colon)
set.seed(1)
n <- 10 * 2 * 3 *100
dat <- data.frame(
y = rnorm(n),
sex = gl(2, n / 2, labels = c("male", "female")) ,
rx = gl(3, n / 3, labels = c("Obs", "Tev", "Tev+5FU"))[sample.int(n)],
age = 1:n,
bmi = rnorm(n )
)
dat <- transform(dat,
y = y +
as.numeric(sex) / 2 +
as.numeric(rx)
)
fit1 <- lm(y ~ sex + rx + age + bmi, dat)
tab<-forest_plot(fit1, plot=FALSE)
tab
ggplot_forest(tab)
ggplot_table(
data.frame(
var = c("Intercept", "Sex", "Sex", "Alter"),
level = c(NA, "male", "female", NA),
N = c(NA, 25, 47, 25+47),
estimate = c(-.77, NA, .51 , .4),
conf.low = c(-1.53, NA, -.17, .2),
conf.high = c(-0.1, NA, 1.2, .6),
p.value = c(0.046, NA, 0.1407, 0.0021)
)
)
Balken mít Errorbars
mycol <- c("#0433FF",
"#00F801",
"#FF2600",
"#918E00",
"#FE9300")
data <- data.frame(
name = c("0h", "1h", "24h"),
value = c(1.4, 2.6, 2) / 100,
sd1 = c(1.2, 2.8, 1.9) / 100,
sd2 = c(2, 0.75, 2.4) / 100
)
# Most basic error bar
ggplot(data) +
geom_bar(
aes(x = name, y = value),
stat = "identity",
fill = "#64B2FC",
alpha = 0.7
) +
geom_errorbar(
aes(x = name,
ymin = sd1,
ymax = sd2),
width = 0.2,
colour = "gray40",
alpha = 0.9,
size = 1
) + scale_y_continuous(labels = scales::percent) +
labs(title = "Non-viable cells",
# subtitle = "(1973-74)",
# caption = "Data from the 1974 Motor Trend US magazine.",
# tag = "B",
x = "Time [h]",
y = "",) +
theme_classic()
Balken mit Zahlen
set.seed(2)
DF_balk <-
data.frame(
value = runif(2 * 5, min = 20, max = 80),
sex = factor(rep(c("male", "female"), times = 5)),
variable = factor(rep(
c(
n = "Neurotizismus",
e = "Extraversion",
o = "Offenheit",
g = "Gewissenhaftigkeit",
a = "Vertraeglichkeit"
),
times = 2
))
)
barchart(
reorder(variable, value) ~ value,
subset(DF_balk, sex == "male"),
box.ratio = 2,
xlim = c(-5, 100),
origin = 0,
#' par.settings=colorset,
panel = function(...) {
panel.barchart(...)
panel.barchart.text(..., digits = 1, suffix = " %")
}
)
Tortendiagramme
# Create test data.
data <- data.frame(
category=c("Granulocytes", "CD3+", "CD56+", "CD19+", "Monocytes"),
count=c(80,10,5,3,2)
)
# Compute percentages
data$fraction <- data$count / sum(data$count)
# Compute the cumulative percentages (top of each rectangle)
data$ymax <- cumsum(data$fraction)
# Compute the bottom of each rectangle
data$ymin <- c(0, head(data$ymax, n=-1))
# Compute label position
data$labelPosition <- (data$ymax + data$ymin) / 2
# Compute a good label
#data$label <- paste0(data$category, "\n value: ", data$count)
# Make the plot
ggplot(data,
aes(ymax=ymax, ymin=ymin, xmax=4, xmin=2,
fill=category)) +
geom_rect() +
# geom_text( x=2,
# aes(y=labelPosition,
# label=label,
# color=1), size=6) + # x here controls label position (inner / outer)
scale_fill_manual(
values =
c("#918E00","#00F801","#FF2600","#0433FF","#FE9300")) +
coord_polar(theta="y") +
xlim(c(-1, 4)) +
theme_void() +
theme(legend.position = "top") +
labs(title = "Leukocyte composition 1h NMP") +
theme(legend.title = element_blank(),# element_text(size=12, color = "salmon", face="bold"),
legend.justification=c(0,1),
legend.position=c(0.4, 0.7),
legend.background = element_blank(),
legend.key = element_blank()
)
# Geht nicht problemlos in Markdown
print(torte(~treatment+sex, DF, init.angle=45, main="lattice"))
gtorte(~treatment+sex, DF, init.angle=45, main="ggplot")
# Geht nicht problemlos in Markdown
tab <- as.data.frame(xtabs( ~ treatment + sex, DF))
# par(new = TRUE)
stp25plot::piechart(~Freq|sex,
tab, groups= treatment,
auto.key=list(columns=3))
MetComp_BAP
Tukey Mean Difference oder auch Bland Altman Metode
DF2<- data.frame(
A=c(1, 5,10,20,50,40,50,60,70,80, 90,100,
150,200,250,300,350,400,450,500,550,
600,650,700,750,800,850,900, 950,1000),
B=c(8,16,30,14,39,54,40,68,72,62,122, 80,
181,259,275,380,320,434,479,587,626,
648,738,766,793,851,871,957,1001,980),
group= sample(gl(2, 15, labels = c("Control", "Treat")))
)
require(stp25metcomp)
x<- MetComp_BAP(~A+B, DF2)
plot(x)
x
cowplot
gridExtra::grid.arrange( )
Zusammen mixen von unterschiedlichen Grafik-Typen.
The cowplot package is a simple add-on to ggplot.
https://wilkelab.org/cowplot/articles/index.html
library(ggplot2)
library(grid)
library(gridExtra)
library(cowplot)
theme_set(theme_half_open())
set.seed(0815) # Create example data
data <-
data.frame(x = 1:21,
# Create example data
y = rnorm(21),
group = rep(letters[1:3], 7))
p1 <-
ggplot(data, aes(x, y, color = group)) + # Create ggplot2 plot
geom_point(size = 5) +
geom_line() # Draw default ggplot2 plot
p2 <- ggplot(data, aes(x, group , color = group)) + geom_boxplot()
title <-
ggdraw() +
draw_label("Arrange Plots", fontface = 'bold')
p1 <- p1 +
guides(colour = guide_legend(
title = "legend title",
override.aes =
list(
size = 5,
fill = NA,
linetype = 0
)
)) +
theme(legend.position = c(.2, .5))
legend <- get_legend(p1)
p1 <- p1 +
theme(legend.position = "none")
p2 <- p2 +
theme(legend.position = "none")
p2 <-
plot_grid(p2,
legend,
ncol = 1,
rel_heights = c(1, .5))
plot_grid(
title,
NULL,
p1,
p2,
nrow = 2,
rel_widths = c(1, .6),
rel_heights = c(0.2, 1)
)
#require(ggplot2)
#require(cowplot)
#require(lattice)
p1<- ggplot(iris, aes(Sepal.Length, fill = Species)) +
geom_density(alpha = 0.5) +
scale_y_continuous(expand = expansion(mult = c(0, 0.05))) +
theme_minimal_hgrid(10)
p2<- densityplot(~Sepal.Length|Species , iris)
plot_grid(p1, p2, rel_widths = c(1, 1.5)
, labels = c('A', 'B'))
Mixing different plotting frameworks
# require(ggplot2)
# require(cowplot)
# require(lattice)
require(gridGraphics)
p1 <- function() {
par(
mar = c(3, 3, 1, 1),
mgp = c(2, 1, 0)
)
boxplot(mpg ~ cyl, xlab = "cyl", ylab = "mpg", data = mtcars)
}
ggdraw(p1) +
theme(plot.background = element_rect(fill = "cornsilk"))
ggformula
Quelle https://rpruim.github.io/Statistical-Rethinking/Examples/ggformula.html
gf_point() for scatter plots
gf_line() for line plots (connecting dots in a scatter plot)
gf_density() or gf_dens() or gf_histogram() or gf_freqpoly() to display distributions of a quantitative variable
gf_boxplot() or gf_violin() for comparing distributions side-by-side
gf_counts() for bar-graph style depictions of counts.
gf_bar() for more general bar-graph style graphics
#require(ggplot2)
require(ggformula)
#require(lattice)
theme_set(theme_bw())
mtcars2 <- within(mtcars, {
vs <- factor(vs, labels = c("V-shaped", "Straight"))
am <- factor(am, labels = c("Automatic", "Manual"))
cyl <- factor(cyl)
gear <- factor(gear)
})
#' ggplot
p1 <-
ggplot(mtcars2) +
geom_point(aes(x = wt, y = mpg, colour = gear)) +
labs(
title = "Fuel economy declines as weight increases",
subtitle = "(1973-74)",
caption = "Data from the 1974 Motor Trend US magazine.",
tag = "ggplot",
x = "Weight (1000 lbs)",
y = "Fuel economy (mpg)",
colour = "Gears"
)
#' ggformula
p2 <-
gf_point(mpg ~ wt , data = mtcars2, color = ~ gear) +
labs(
title = "Fuel economy declines as weight increases",
subtitle = "(1973-74)",
caption = "Data from the 1974 Motor Trend US magazine.",
tag = "gf_point",
x = "Weight (1000 lbs)",
y = "Fuel economy (mpg)",
colour = "Gears"
)
#' lattice
p3 <-
xyplot(
mpg ~ wt,
mtcars2,
groups = gear,
par.settings = bw_theme(farbe(), cex.main = .8, cex.add = .8),
grid=TRUE,
main = "Fuel economy declines as weight increases\n(1973-74)",
sub = "Data from the 1974 Motor Trend US magazine.",
xlab = "Weight (1000 lbs)",
ylab = "Fuel economy (mpg)",
auto.key = list(space = "right", title = "Gears")
)
cowplot::plot_grid(p1, p2, p3, ncol=2)
Effectplot
require(ggplot2)
mtcars2 <- within(mtcars, {
vs <- factor(vs, labels = c("V", "S"))
am <- factor(am, labels = c("automatic", "manual"))
cyl <- (cyl)
cyl_ord <- ordered(cyl)
gear <- ordered(gear)
carb <- ordered(carb)
})
mtcars2$mpg[mtcars2$cyl_ord==6] <- mtcars2$mpg[mtcars2$cyl_ord==6] *.5
mtcars2 <- mtcars2 |>
Label(
mpg = "Miles/(US) gallon",
cyl_ord = "Number of cylinders",
disp = "Displacement (cu.in.)",
hp = "Gross horsepower",
drat = "Rear axle ratio",
wt = "Weight (1000 lbs)",
qsec = "1/4 mile time",
vs = "Engine (0 = V-shaped, 1 = straight)",
am = "Transmission (0 = automatic, 1 = manual)",
gear = "Number of forward gears",
carb = "Number of carburetors"
)
fit <- lm(mpg ~ hp * wt + am +cyl , data = mtcars2)
fit2 <- lm(mpg ~ hp * wt + am +cyl_ord , data = mtcars2)
Meine Version vs plot.efflist
plot( effects::allEffects(fit2) )
plot2( effects::allEffects(fit2) )
e2 <- effects::allEffects(fit2)
p1 <- plot2(e2,
axes = list(
x = list(
hp = list(lab = "Gross horsepower"),
wt = list(lab = "Weight (1000 lbs"),
am = list(lab = "Transmission (0 = automatic, 1 = manual)"),
cyl_ord = list(lab = "Number of cylinders"),
cex = .75
),
y = list(lab = "Miles/(US) gallon")
)
)
p2<-plot2(e2,
labels = stp25tools::get_label(mtcars2),
plot=FALSE)
cowplot::plot_grid(plotlist =p2,
labels = c('A', 'B', 'C'),
# scale = c(1, .9, .8),
rel_heights = c(3,4))
Konfidenz-Band mit geom_ribbon()
ef1 <-
as.data.frame(
effects::effect(term = "hp", fit,
xlevels = list(
hp = seq(50, 350, by =10))))
p1 <- ggplot(ef1, aes(hp, fit)) +
geom_line() +
geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.3) +
labs(y = 'Miles/(US) gallon',
x = 'Gross horsepower',
title = 'Main-Effect-Plot') +
theme_classic()
Interaction mit geom_line()
ef2 <- as.data.frame(effects::effect("hp:wt", fit))
ef2$Weight <- factor(ef2$wt)
p2 <- ggplot(ef2, aes(hp, fit, col = Weight)) +
geom_line() +
labs(y = 'Miles/(US) gallon',
x = 'Gross horsepower',
title = 'Interaction-Plot') +
theme_classic()
Fehlerbalken mit **
#ef3<- as.data.frame(effects::effect("am", fit))
ef4 <- as.data.frame(effects::effect("cyl_ord", fit2))
p3 <- ggplot(ef4, aes(cyl_ord, fit, group=1 )) +
geom_point()+
geom_line()+
geom_errorbar(
aes(x = cyl_ord,
ymin = lower,
ymax = upper),
width = 0.2,
colour = "gray40",
alpha = 0.9,
linewidth = .75
) + labs(y = 'Miles/(US) gallon',
x = 'Number of cylinders',
title = 'Cylinder Ordinal (nicht linear)') +
theme_classic()
ef4 <- as.data.frame(effects::effect("cyl", fit))
p4 <- ggplot(ef4, aes(cyl, fit, group=1 )) +
geom_point()+
geom_line()+
geom_errorbar(
aes(x = cyl,
ymin = lower,
ymax = upper),
width = 0.2,
colour = "gray40",
alpha = 0.9,
linewidth = .75
) + labs(y = 'Miles/(US) gallon',
x = 'Number of cylinders ',
title = 'Cylinder Metrisch (linear)') +
ylim(c(8,23))+
# xlim(c(4, 8))+
annotate("text", x = 6, y=9, label = stp25stat2::APA(fit)) +
theme_classic()
library(patchwork)
p1 + p2 + p3 + p4 +
plot_layout(ncol=2)
ggeffects
require(ggeffects)
require(ggeffects)
ggeffect()
# computes marginal effects by internally calling effects::Effect()
ggemmeans()
# uses emmeans::emmeans()
ggpredict()
# uses predict()
ggpredict(fit, term = "hp") |> plot() +
ggeffect(fit, term = "hp") |> plot( add.data = TRUE) +
ggemmeans(fit,term = "hp") |> plot(log.y = TRUE)
## S3 method for class 'ggeffects'
plot(
x,
ci = TRUE,
ci.style = c("ribbon", "errorbar", "dash", "dot"),
facets,
add.data = FALSE,
limit.range = FALSE,
residuals = FALSE,
residuals.line = FALSE,
collapse.group = FALSE,
colors = "Set1",
alpha = 0.15,
dodge = 0.25,
use.theme = TRUE,
dot.alpha = 0.35,
jitter = 0.2,
log.y = FALSE,
case = NULL,
show.legend = TRUE,
show.title = TRUE,
show.x.title = TRUE,
show.y.title = TRUE,
dot.size = NULL,
line.size = NULL,
connect.lines = FALSE,
grid,
one.plot = TRUE,
rawdata,
...
)
Quelle: https://strengejacke.github.io/ggeffects/
Die lib ggeffects() berechnet die Marginalen Effecte bei Interactionen anderst als effect(), daher aufpassen!!
ef1 <-
as.data.frame(effects::effect(term = "hp", fit,
xlevels = list(hp = c(
50, 85, 120, 155, 195, 230, 265, 335
))))
effects::effect(term = "hp",
fit,
xlevels =
list(hp =
c(50, 85, 120, 155, 195, 230, 265, 335)))
ggpredict(fit, term = "hp")
ggeffect(fit,term = "hp")
ggemmeans(fit,term = "hp")
mydf <- ggpredict(fit, terms = "hp")
p2 <- ggplot(mydf, aes(x, predicted)) +
geom_line() +
geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1) +
theme_classic()
mydf <- ggpredict(fit, terms = c("hp", "wt"))
p3 <- ggplot(mydf, aes(x = x, y = predicted, colour = group)) +
geom_line()
p4 <- ggplot(mydf,
aes(x = x, y = predicted)) +
geom_line() +
facet_wrap( ~ group)
library(patchwork)
p1 + p2 + p3 + p4 + plot(mydf) +
plot_layout(ncol=2)
require(ggeffects)
mod <- lm(prestige ~ type*(education + income) + women, Prestige)
mydf<-ggpredict(mod, terms =c( "education", "type"))
mydf
# ggplot(mydf, aes(x, predicted)) +
# geom_line() +
# geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1)
p1 <-plot(mydf)
p1
p1 +
facet_wrap(~group) +
theme(legend.position = "none")
#plot(allEffects(mod))
ggplot(mydf, aes(x = x, y = predicted, group =group)) +
geom_line() +
geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1) +
facet_wrap(~group)
theme_set(theme_ggeffects())
p1<-ggpredict(fit, "am") |>
plot(
connect.lines = TRUE,
ci=FALSE,
dot.size = 5)+ geom_errorbar(
aes_string(ymin = "conf.low",
ymax = "conf.high"),
width = 0.099#,
#size = line.size
) +
theme_classic()
p1
Effectplot mit emmeans
require(emmeans)
head(pigs)
pigs.lm1 <- lm(log(conc) ~ source + factor(percent), data = pigs)
ref_grid(pigs.lm1)
pigs.lm2 <- lm(log(conc) ~ source + percent, data = pigs)
ref_grid(pigs.lm2)
emmeans default
plot(emmeans(pigs.lm1,
~ percent | source))
emmeans ruecktransformiert
plot(emmeans(pigs.lm1,
~ percent | source),
xlab= "plasma leucine [mcg/ml]" ,
type = "response")
emmip(pigs.lm1,
source ~ percent)
plot(emmeans(pigs.lm2,
~ percent | source,
at = list(percent = c(10, 15, 20))
)
)
emmip(
ref_grid(pigs.lm2, cov.reduce = FALSE),
source ~ percent)
emmip(ref_grid(pigs.lm2,
at= list(percent = c(10, 15, 20))),
source ~ percent,
ylab= "plasma leucine [mcg/ml]" ,
type = "response"
)
Klassiker mit Effect()
predictorEffect()
Von mir lang ignorierte Variante von Effect mit Formeln!
mod <- lm(prestige ~ type*(education + income) + women, Prestige)
plot(predictorEffect("income", mod), main="", rug=FALSE)
plot(predictorEffects(mod, ~ education + women), main="", rug=FALSE)
plot(predictorEffects(mod, ~ women+ education),
axes= list(x=list( women=list(lab="Anteil Frauen"),
education=list(lab="Bildung"))), main="", rug=FALSE)
Modifizier plot.efflist
#require(stpvers)
A = rnorm(100)
B = rnorm(100, 53, 10)
C = factor(rep(c("This", "That"), 50))
A <- A + log(B / 50) + as.numeric(C)
#log(B)
Logit <- function(x)
car::logit(x, adjust = 0)
invLogit <- function(x)
exp(x) / (1 + exp(x))
prop <- function(odds)
odds / c(1 + odds)
odds <- function(p)
p / (1 - p)
allEffects
ef <- allEffects(lm(A ~ B + C))
plot(ef,
axes = list(
x = list(
B = list(
transform = list(trans = log, inverse = exp),
ticks = list(at = c(30, 50, 70)),
lab = "Age, log-scale"),
C = list(lab = "Treatment")
),
y = list(lim= c(.0, 2.5),
lab = "Vitamins"
# transform = list(link = Logit, inverse = invLogit),
# transform=list(trans=log, inverse=exp),
# type="rescale",
# ticks = list(at = c(.05, .25, .50, .75)),
#
)),
main = "")
lattice::trellis.par.set(bw_theme(farbe()))
plot(Effect(c("source", "percent"),
pigs.lm2,
transformation=list(link=log, inverse=exp)),
multiline=TRUE,
key.args = list(space="right" ),
main="",
ylab="plasma leucine [mcg/ml]")
pigs.lm3 <- lm(log(conc) ~ source * percent, data = pigs)
plot(
allEffects(pigs.lm3),
main = "",
multiline = TRUE,
key.args = list(
space = "right", columns = 1,
border = FALSE,
fontfamily = "serif",
cex.title = .80, cex = 0.75
)
)
emmip(
ref_grid(pigs.lm3, cov.reduce = TRUE),
source ~ percent)
emmip(
ref_grid(pigs.lm3, cov.reduce = FALSE),
source ~ percent)
raw_data <-
data.frame(
subject_id = rep(1:6, 4),
time = as.factor(rep(c("t0", "t1"), each = 12)),
group = rep(rep(c("Control", "Treat"), each = 6), 2),
value = c(2:7, 6:11, 3:8, 7:12)
)
head(raw_data)
stripplot(
value ~ time | group,
groups = subject_id,
data = raw_data,
panel = function(x, y, ...) {
panel.stripplot(x, y,
type = "b",
col="blue",
lty = 2, ...)
panel.average(x, y, fun = mean, lwd = 2, col = "gray80", ...) # plot line connecting means
mm<-mean(y)
panel.abline(h=mm, v=1.5, col="gray80")
panel.text(x=1.5,y=mm, APA(wilcox.test(y~x)) )
}
)
transformation
require(effects)
John Fox URL http://www.jstatsoft.org/v32/i01/
set.seed(2)
ctl <- c(4.17, 5.58, 5.18, 6.11, 4.50, 4.61, 5.17, 4.53, 5.33, 5.14)
trt <- c(4.81, 4.17, 4.41, 3.59, 5.87, 3.83, 6.03, 4.89, 4.32, 4.69)
edu <- cut(c(ctl, trt),3)
ctl2<- ctl + rnorm(10,0,.5)
trt2 <-trt + rnorm(10,1.2,.5)
group <- gl(2, 10, 40, labels = c("Ctl_gt", "Trt"))
serum <-round(rnorm(length(group)),2)
time <- factor(rep(1:2, each=20))
DF<- data.frame(id= factor(c(1:20, 1:20)),
time,
y = round(c(ctl, trt, ctl2, trt2) + serum + as.numeric(group),2),
y1 = round(c(ctl, trt, ctl2, trt2)*10,2),
y2 = round(c(ctl, trt, ctl2, trt2)+2,2),
group,
edu= factor(c(edu,edu), labels=Cs(low, med, high)),
serum )
fit <- lm(y ~ group * time * serum, DF)
plot(effects::allEffects(fit))
Tbll_desc( ~ log(prestige) + income + type + education,
data = Prestige)
mod <- lm(log(prestige) ~ income:type + education, data = Prestige)
# does not work: effect("income:type", mod, transformation=list(link=log, inverse=exp))
plot(Effect(c("income", "type"), mod,
transformation=list(link=log, inverse=exp)),
main="", ylab="prestige")
GOF-Plots
require(car)
car::residualPlots(fit)
car::marginalModelPlots(fit)
car::avPlots(fit)
library(visreg)
Patrick Breheny and Woodrow Burchett
URL: https://cran.r-project.org/web/packages/visreg/vignettes/quick-start.html
Limitation: plot kann nicht einfach in cowplot::plot_grid integriert werdrn.
par(mfrow=c(1,3))
visreg::visreg(fit)
library(stats) termplot
par(mfrow=c(1,3))
stats::termplot(fit,
se = TRUE,
resid = TRUE,
plot=TRUE, ask=FALSE)
library(rockchalk)
Paul E. Johnson
URL https://github.com/pauljohn32/rockchalk
Hier gibt es keine Updates mehr???
rockchalk::plotSlopes(fit,
plotx = "group",
interval = "confidence")
rockchalk::plotSlopes(fit,
plotx = "group",
modx = "time",
interval = "confidence")
raw_data <-
data.frame(
subject_id = rep(1:6, 4),
time = as.factor(rep(c("t0", "t1"), each = 12)),
group = rep(rep(c("Control", "Treat"), each = 6), 2),
value = c(2:7, 6:11, 3:8, 7:12)
)
head(raw_data)
stripplot(
value ~ time | group,
groups = subject_id,
data = raw_data,
panel = function(x, y, ...) {
panel.stripplot(x,
y,
type = "b",
col = "blue",
lty = 2,
...)
panel.average(x,
y,
fun = mean,
lwd = 2,
col = "gray80",
...) # plot line connecting means
mm <- mean(y)
panel.abline(h = mm, v = 1.5, col = "gray80")
panel.text(x = 1.5, y = mm, APA(wilcox.test(y ~ x)))
}
)
Altman and Bland (Tukey Mean-Difference Plot)
set.seed(0815)
Giavarina <- data.frame(
A=c(1,5,10,20,50,
40,50,60,70,80,
90,100,150,200,250,
300,350,400,450,500,
550,600,650,700,750,
800,850,900,950,1000),
B=c(8,16,30,14,39,
54,40,68,72,62,
122,80,181,259,275,
380,320,434,479,587,
626,648,738,766,793,
851,871,957,1001,980),
group= sample(gl(2, 15, labels = c("Control", "Treat")))
)
Giavarina <- transform(Giavarina, C = round( A + rnorm(30,0,20)),
D = round( A + rnorm(30,0,10) + A/10 ),
E = round( A + rnorm(30,5,10) + (100-A/10) ))
# A - Goldstandart
x <- MetComp_BAP(~A+B, Giavarina)
#> Warning: Warning in bland.altman.stats:Mehr als 2 Methoden.
# x |> Output("BA-Analyse der Messwertreihe")
plot(x)
lattice::tmd( A ~ B, Giavarina)
Survival Analysis
Add number-at-risk annotations to a plot
require("survival")
s <- Surv(colon$time / 365, colon$status)
## Need to increase margins a bit
par(mar = c(10, 6, 2, 1),mfrow = c(1,2))
## no stratification
fit1 <- survfit(s ~ 1)
plot(fit1)
addNrisk(fit1)
## with stratification
at <- c(0, 2, 4)
lty <- 1:3
xlim <- c(0, 6)
fit2 <- survfit(s ~ rx, data = colon)
plot(fit2,
xlab = 'Time (years)',
ylab = 'Survival',
xaxt = "n",
xlim=xlim,
lty = lty)
addNrisk(fit2, at)
axis(1, at = at, gap.axis = 1 / 4)
legend(
'bottomleft',
legend = names(fit2$strata),
lty = lty,
bty = 'n'
)
Hmisc::minor.tick(nx = 4, tick.ratio = 1 / 2)
ECDF-Plot
ecdfplot {latticeExtra}
# data(Chem97, package = "mlmRev")
#
# ecdfplot(~gcsescore | factor(score), data = Chem97,
# groups = gender,
# auto.key = list(columns = 2),
# subset = gcsescore > 0,
# xlab = "Average GCSE Score")
data(singer, package = "lattice")
ecdfplot(~height | voice.part, data = singer)
data(singer, package = "lattice")
Interessante Grafik Beispiele
Lattice xyplot mit Pfeilen und verlaufende Farben.
dat <- stp25tools::get_data("
variable value change leverage
happiness 4.62 -0.42 0.01
motivation 3.6 -0.41 0.05
training 3.4 -0.33 0.14
performance 3.2 0.30 0.82
lmx 2.96 0.21 0.33
communication 2.9 -0.11 0.43
autonomy 2.7 0.11 0.22
insecurity 2.5 0.12 0.21
stress 1.6 0.14 0.12")
#Create a function to generate a continuous color palette
rbPal <- colorRampPalette(c('gray','blue'))
xyplot(
reorder(variable, value) ~ value ,
xlab = "", ylab = "",
data = dat,
xlim = c(0.85, 5.15),# drop.unused.levels = FALSE,
scales = list(x = list(
at = 1:5,
labels = c( "low", "moderate", "considerable", "hig","very high")
)),
panel = function(x, y, ...) {
col <- rbPal(8)[as.numeric(cut(dat$leverage,breaks = 8))]
panel.dotplot(
x = x, y = y,
col = col,
cex = 1.1 + 1 * dat$leverage,
pch = 19
)
panel.arrows(
x0 = x, y0 = y,
x1 = x + x * dat$change, y1 = y,
col=col, lwd = 2,
angle = 30, code = 2, length = 0.1
)
}
)
# siehe panel.segplot
panel.arrows2 <- function(x0, y0 , x1, y1,
col, alpha, lty, lwd, ...) {
panel.dotplot(
x = x0, y = y0,
col = col,
cex = 1.5,
pch = "|"
)
panel.arrows(
x0, y0, x1, y1,
col = col ,
alpha = alpha,
lty = lty,
lwd = lwd,
...
)
}
dat$change <- dat$value + dat$change * dat$value
dat$centers <- (dat$value + dat$change) / 2
#require(latticeExtra)
segplot(
reorder(variable, value) ~ value + change,
level = leverage,
data = dat,
draw.bands = FALSE,
centers = centers,
segments.fun = panel.arrows2,
lwd = 2,
angle = 30,
code = 2,
length = 0.1,
colorkey = TRUE,
col.regions = rbPal# hcl.colors #terrain.colors
)
Spine Plots and Spinograms
require("colorspace")
ttnc <- margin.table(Titanic, c(1, 4))
spineplot(ttnc, col = sequential_hcl(2, palette = "Purples 3"))
# require(latticeExtra)
segplot(factor(1:10) ~ rnorm(10) + rnorm(10), level = runif(10))
data(USCancerRates)
segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male,
data = subset(USCancerRates, state == "Washington"))
segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male,
data = subset(USCancerRates, state == "Washington"),
draw.bands = FALSE,
centers = rate.male)
segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male,
data = subset(USCancerRates, state == "Washington"),
level = rate.female,
col.regions = terrain.colors)
segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male,
data = subset(USCancerRates, state == "Washington"),
draw.bands = FALSE,
centers = rate.male,
segments.fun = panel.arrows,
ends = "both",
angle = 90,
length = 1,
unit = "mm")
segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male,
data = subset(USCancerRates, state == "Washington"),
draw.bands = FALSE, centers = rate.male)
Misc
Speichern von Grafiken als PDF scheitert wen Unicode verwendet wird abhilfe bietet CairoPDF.
require(Cairo)
CairoPDF( paste0(Abb()[3],"-cell-count.pdf"), width = 7, height = 0.66*8 +.4)
plot_grid(p_all, p_cit, p_trns, p_dbd)
invisible(dev.off())
Links
https://ggobi.github.io/ggally/index.html
http://www.sthda.com/english/articles/24-ggpubr-publication-ready-plots/78-perfect-scatter-plots-with-correlation-and-marginal-histograms/
ggpubr
http://www.sthda.com/english/articles/24-ggpubr-publication-ready-plots/78-perfect-scatter-plots-with-correlation-and-marginal-histograms/
stp4/stp25plot documentation built on April 3, 2024, 7:11 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.
knitr::opts_chunk$set(echo = TRUE) require(stp25tools) require(stp25plot) # meine Funktionen require(stp25stat2) require(magrittr) lattice::trellis.par.set(bw_theme) require(lattice) # Lattice-Plots require(RColorBrewer) # Farben require(latticeExtra) require(effects) # Effekte require(gridExtra) # Plots agregieren require(ggplot2) require(cowplot) set.seed(2) n <- 20 * 3 * 2 DF <- data.frame( n = runif(n, min = 1, max = 5), e = runif(n, min = 1, max = 5), o = runif(n, min = 1, max = 5), g = runif(n, min = 1, max = 5), a = cut(runif(n, min = 1, max = 5), 3, 1:3), treatment = gl(3, n / 3, labels = c("UG1", "UG2", "KG"))[sample.int(n)], sex = gl(2, n / 2, labels = c("male", "female")) ) DF <- Label( DF, sex="Geschlecht", n = "Neuroticism", e = "Extraversion", o = "Openness", g = "Conscientiousness", a ="Agreeableness" )
Funktionen
- Theme for lattice-plots set_lattice(), reset_lattice() und lattice::trellis.par.set(bw_theme(farbe()))
- auto_plot Einzelne lattice plots analog wie die Funktion Tabelle()
- Boxplot bwplot2()
- plot.bland_altman()
- Hilfsfunktionen wrap_sentence(), stp25plot:::plot.efflist()
Likertplot
set.seed(1) n <- 100 lvs <- c("--", "-", "o", "+", "++") DF2 <- data.frame( Magazines = gl(length(lvs), 1, n, lvs), Comic.books = gl(length(lvs), 2, n, lvs), Fiction = gl(length(lvs), 3, n, lvs), Newspapers = gl(length(lvs), 5, n, lvs) ) DF2$Comic.books[sample.int(n / 2)] <- lvs[length(lvs)] DF2$Newspapers[sample.int(n / 2)] <- lvs[1] DF2$Magazines[sample.int(n / 2)] <- lvs[2] DF2 <- transform(DF2, Geschlecht = cut(rnorm(n), 2, c("m", "f")))
#Res1 <- Tbll_likert( ~ ., DF2[, -5]) Res2 <- Tbll_likert(. ~ Geschlecht, DF2) likertplot(Item ~ . | Geschlecht, data = Res2, between=list(x=0), columns=5) # col = likert_col(attr(data, "plot")$nlevels, middle = ReferenceZero)
DF2 |> likert_plot(Magazines, Comic.books, Fiction, Newspapers, relevel = letters[1:5], auto.key = list(columns=5, between=.15, space="top"), # between=list(x=0), horizontal=FALSE, ReferenceZero = 1.5)
Signifikanz-Plot
Der Fliegen-Schiss-Plot mein absoluter lieblings Plot!!
require(stpvers) #require(lmerTest) require(emmeans) #dummy dat<- data.frame( nmp=factor(c( 'nmp01', 'nmp02', 'nmp03', 'nmp04', 'nmp05', 'nmp05', 'nmp05', 'nmp05', 'nmp06', 'nmp06', 'nmp06', 'nmp12', 'nmp12', 'nmp12', 'nmp12', 'nmp12', 'nmp13', 'nmp13', 'nmp13', 'nmp13', 'nmp14', 'nmp14', 'nmp14', 'nmp14', 'nmp14', 'nmp15', 'nmp15', 'nmp15', 'nmp15', 'nmp15', 'nmp16', 'nmp16', 'nmp16', 'nmp16', 'nmp17', 'nmp17', 'nmp17', 'nmp17', 'nmp17', 'nmp18', 'nmp18', 'nmp18', 'nmp18', 'nmp18', 'nmp19', 'nmp20', 'nmp20', 'nmp20', 'nmp20', 'nmp20', 'nmp21', 'nmp21', 'nmp21', 'nmp21', 'nmp21', 'nmp22', 'nmp22', 'nmp22', 'nmp22', 'nmp23', 'nmp23', 'nmp23', 'nmp23', 'nmp23', 'nmp24', 'nmp24', 'nmp24', 'nmp24', 'nmp24', 'nmp26', 'nmp26', 'nmp26', 'nmp26', 'nmp27', 'nmp27', 'nmp27', 'nmp28', 'nmp28', 'nmp28', 'nmp28', 'nmp28', 'nmp29', 'nmp29', 'nmp29', 'nmp29', 'nmp29', 'nmp30', 'nmp30', 'nmp30', 'nmp31', 'nmp31', 'nmp31', 'nmp31', 'nmp36', 'nmp36', 'nmp36', 'nmp36')), time= c(NA, NA, NA, NA, 1, 4, 6, 7.9, 1, 4, 8.1, 1, 4, 6, 12, 19, 1, 4, 6, 10.3, 1, 4, 6, 12, 24, 1, 4, 6, 12, 23.4, 1, 4, 6, 10.9, 1, 4, 6, 12, 19.6, 1, 4, 6, 12, 20.3, NA, 1, 4, 6, 12, 21.6, 1, 4, 6, 12, 21, 1, 4, 6, 10.5, 1, 4, 6, 12, 20.5, 1, 4, 6, 12, 21.5, 4, 6, 12, 22.2, 1, 4, 5, 1, 4, 6, 12, 27.8, 1, 4, 6, 12, 18.1, 1, 4, 9.1, 1, 4, 6, 20.3, 1, 4, 6, 11.4), t.cell=c(NA, NA, NA, NA, 24.4, 35.5, 32.8, 33, 19.6, 21.1, 19.1, 22.9, 22.6, 20.3, 22.4, 20.7, 30.9, 32.1, 36.5, 41.8, 18.8, 16.4, 17.5, 18.4, 16.5, 31.6, 28.5, 30, 26.1, 23.6, 14.4, 24.8, 24.8, 19.8, 21.8, 23.8, 24.8, 23.1, 17.7, 26.6, 25.1, 27.5, 25, 16.9, NA, 38.7, 44, 47.3, 42.9, 39.8, 11.7, 20.8, 26.7, 22, 15.2, 17.4, 28, 30.5, 27.1, 6.21, 12.6, 12, 12.1, 9.2, 5.34, 6.69, 8.93, 8.63, 4.15, 5.93, 6.47, 3.31, 6.95, 8.39, 9.31, 12.7, 2.99, 3.34, 4.35, 3.45, 1.28, 10.1, 8.78, 9.25, 12.4, 11.6, 7.7, 12.6, 13, 2.18, 2.44, 2.78, 5.31, 10.6, 12, 15.6, 15.9)) dat<- transform(dat, time2=cut(time, c(0, 2, 4, 9, 18, Inf), paste0(c(1, 4, 6, 12, 24), "h")), DC4= t.cell+ time/1.3) dat<- na.omit(dat) #prism.plots(Sepal.Length ~ Species, data = iris, centerfunc=mean) #plotSigBars(Sepal.Length ~ Species, data = iris, type="tukey")
#dat1 <- Long(dat, DC4 ~ nmp + time2, value = "DC4") #fit2 <- lmer(DC4 ~ time2 + (1 | nmp), data = dat1) fit1 <- lm(DC4 ~ time2, data = dat) em1 <- emmeans(fit1, list(pairwise ~ time2), adjust = "tukey") #em2 <- emmeans(fit2, list(pairwise ~ time2)) prism.plots( DC4 ~ time2, data = dat, #fun = mean, ylim = c(-8, 60) ) plotSigBars(fit1)
boxplot( DC4 ~ time2, data = dat, ylim = c(-15, 70)) plotSigBars(fit1, stars=FALSE) #plotSigBars(em1, stars=FALSE)
#stripplot( DC4 ~ time2, data = dat, jitter.data=TRUE,pch=20, col="gray50") stripplot( DC4 ~ time2, data = dat, ylim=c(-10,70), ylab = "Difference (Absolute Value) [mm]", jitter.data=TRUE, panel = function(x, y, ...) { # panel.conf.int(x, y, ...) panel.stripplot(x,y, pch=19, col="gray50",...) #panel.points(x,y, pch=19,...) #panel.mean(x,y, ...) panel.median(x,y, ...) panel.sig.bars(fit1, include.stars = FALSE, offset = .4) } )
#require(latticeExtra) #require(effects) fit1 <- lm(DC4 ~ time2, data = dat) p2<- plot(effect("time2", fit1), ylim=c(0,60)) p2 + latticeExtra::layer( panel.sig.bars(fit1, include.stars = FALSE) )
require(emmeans) plot_differenz <- function (x, ...) { cis <- as.data.frame(confint(x)) x <- as.data.frame(x) xx <- cbind( diff = cis$estimate, lwr = cis$lower.CL, upr = cis$upper.CL, p.value = x$p.value ) row.names(xx) <- cis$contrast psig <- ifelse( x$p.value<.1, "black", "gray50") stats:::plot.TukeyHSD(list(x = as.matrix(xx)), col=psig, ...) xx } op=par(mar=c(4.2, 5, 3.8, 2)) fit1 |> emmeans("time2") |> pairs() |> plot_differenz(las = 1, xlim =c(15, -25)) par(op)
Sparkplot
Stolen from http://www.motioninsocial.com/tufte/#sparklines
set.seed(1) DF_sprk <- data.frame( Laborwert = gl(7, 8, labels = c( "Albumin", "Amylase", "Lipase", "AST", "ALT","Bilirubin","C-Peptid")), Treat = gl(2, 4, labels = c("Control", "Treat")), Time = gl(4, 1, labels = c("t0", "t1", "t2", "t4")), x = rnorm(7 * 8) ) DF_sprk <- transform(DF_sprk, x = scale(x + as.numeric(Treat)*2 + as.numeric(Time) / 2)) DF_sprk1 <- Summarise(DF_sprk, x ~ Laborwert + Time, fun=mean ) names(DF_sprk1)[4]<- "x" #DF_sprk<- DF_sprk[-3]
#head(DF_sprk) #: "p", "l", "h", "b", "o", "s", "S", "r", "a", "g" p1 <- sparkplot(x ~ Time | Laborwert, DF_sprk1, between=1.5 #,char.arrows= c(down= '-', updown='', up= "+" ) ) col<- c("purple", "darkgreen") p2<- sparkplot( x ~ Time | Laborwert, DF_sprk, groups = Treat, between=1.5, include.labels = FALSE, left.padding=-5, right.padding=3, col = col , key = list( corner = c(1, 1.1), lines = list(col = col, lwd = 2), cex = .75, columns = 2, text = list(levels(DF_sprk$Treat)) ) #, char.arrows= c(down= '-', updown='', up= "+" ) ) p3 <- sparkplot( x ~ Time | Laborwert, DF_sprk, groups = Treat, type="barchart", between=1.5, include.labels = FALSE, left.padding=-5, right.padding=3, col = col #, char.arrows= c(down= '-', updown='', up= "+" ) ) #windows(8,4) #require(cowplot) plot_grid(p1, p2, p3, nrow=1, rel_widths = c(.7, .5, .5) )
Auto-Plot auto_plot()
Die Funktion klebt lattice- plots zu einer matrix zusammen.
Verwendung: auto_plot(formula, data) oder data |> auto_plot(var_x, var_y, var_z) Die Funktion kann dabei Formel wie z.B. $a+b+c\sim g$
$a[box]+b[bar]+c[dot]\sim g$
$log(a) +b +c \sim g$
$y \sim a+b+c$
https://www.zahlen-kern.de/editor/
DF |> auto_plot( n, e[box], o[hist], g, a, treatment, by = ~ sex, par.settings = bw_theme() )
auto_plot(treatment ~ n + e + sex, DF)
enviro <- lattice::environmental enviro2 <- transform( enviro, smell = cut( enviro$ozone, breaks = c(0, 30, 50, Inf), labels = c("ok", "hm", "yuck"), ordered = TRUE ), is.windy = factor(wind > 10, c(TRUE, FALSE), labels = c("windy", "calm") ) ) |> Label( ozone=" Average ozone concentration (of hourly measurements)", radiation = "Solar radiation (from 08:00 to 12:00)", temperature = "Maximum daily temperature", wind = "Average wind speed (at 07:00 and 10:00)", smell = "Smell of ozone" ) head(enviro2)
auto_plot( enviro2, ozone[hist], radiation, smell, temperature, by = ~ is.windy, col.bar= farbe("Blues")[3], ylab= c("ppb", "langleys", "%", "F"), include.percent=TRUE, wrap.main=30 # levels.logical = c(TRUE, FALSE), # labels.logical = c("ja", "nein") )
dat2 <- get_data( " comp_0 comp_1 comp_2 comp_3 comp_4 comp_5 comp_6 comp_7 comp_8 gender TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE TRUE TRUE TRUE FALSE FALSE TRUE FALSE FALSE Male FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE Male FALSE FALSE TRUE FALSE TRUE FALSE TRUE FALSE FALSE Male FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE FALSE FALSE TRUE TRUE FALSE FALSE FALSE TRUE Female FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE Female FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Female FALSE FALSE FALSE FALSE FALSE FALSE TRUE TRUE FALSE Male TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE TRUE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Male TRUE FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE Male FALSE FALSE TRUE TRUE FALSE FALSE FALSE FALSE FALSE Male FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE FALSE FALSE FALSE TRUE FALSE FALSE FALSE FALSE Female FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE FALSE FALSE FALSE FALSE TRUE FALSE TRUE Male FALSE TRUE FALSE TRUE FALSE FALSE FALSE FALSE TRUE Female FALSE FALSE TRUE FALSE FALSE FALSE FALSE FALSE FALSE Male FALSE TRUE TRUE FALSE FALSE TRUE FALSE FALSE FALSE Male TRUE FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE Female FALSE FALSE FALSE FALSE FALSE FALSE FALSE FALSE TRUE Female " ) |> Label( comp_0 = "A+" , comp_1 = "Heart Failure" , comp_2 = "Rhythm Abnormality" , comp_3 = "Valve Dysfunction" , comp_4 = "Bleeding with OAC" , comp_5 = "ACS" , comp_6 = "Neurological Event", comp_7 = "Neoplastic Disease", comp_8 = "Others", gender = "Gender" )
Mehrfachantworten mit multi_barplot().
# dat2[1:5] |> # multi_barplot() # # dat2 |> # multi_barplot(. ~ gender, # reorder = TRUE, # last = c("Others" )) # # dat2[1:5] |> # auto_plot() # # dat2 |> # auto_plot(. ~ gender) # dat2 |> auto_plot(comp_1, comp_2, comp_3 , # include.percent=TRUE, # include.reorder=TRUE, # main ="Complicationen", # xlab= "Prozent")
set_lattice()
~Initialisieren der Lattice - Optionen mit set_lattice(). Im Hintergrund werden die latticeExtra::ggplot2like.opts() aufgerufen und die default Werte in opar und oopt gespeichert um sie mit reset_lattice() zurück seten zu können.~
reset_lattice() lattice::trellis.par.set(bw_theme(farbe())) p1<-barchart(xtabs(~treatment + sex + a, DF), auto.key=list(space="top", columns=3, cex=.7, between=.7 ), par.settings= standard_theme()) p2<-barchart(xtabs(~ treatment + sex + a, DF), auto.key=list(space="top", columns=3, cex=.7, between=.7 ), par.settings=bw_theme()) p3<-barchart(xtabs(~ treatment + sex + a, DF), auto.key=list(space="top", columns=3, cex=.7, between=.7 ), par.settings=ggplot_theme()) grid.arrange(p1, p2, p3, ncol=3)
Einbetten von set_lattice() über update()
obj <- xyplot( Sepal.Length + Sepal.Width ~ Petal.Length + Petal.Width, iris, type = c("p", "r"), jitter.x = TRUE, jitter.y = TRUE, factor = 5, auto.key = list( cex.title = 1.2, title = "Expected Tau", text = c("30 ms", "80 ms", "130 ms", "180 ms"), space = "top" # lines = TRUE, rectangles = TRUE )) obj <- update(obj, legend = list( right = list(fun = "draw.colorkey", args = list(list(at = 0:100))))) p1 <- update(obj, par.settings = custom.theme( )) p2 <- update(obj, par.settings = ggplot_theme()) p3 <- update(obj, par.settings = bw_theme(), axis = axis.grid) grid.arrange(p1, p2, p3, ncol = 3)
strip Sonderzeichen + Größe
x1<-rnorm(100); x2<-gl(2, 50, labels = c("Control", "Treat")) y<-(1.5-as.numeric(x2))*x1+rnorm(100) #windows(7,4) p1<- xyplot(y~x1|x2, xlab = expression(hat(mu)[0]), type=(c("p", "r")), # - auch mit fontsize=20 ylab=list(label="Percent of Respondents", cex=2), par.strip.text=list(lines=2.5, col=6), strip=strip.custom(factor.levels= expression( sqrt(G^{1}), sqrt(italic(R)^{1})))) print(p1)
bwplot2
Lattice bwplot mit groups. Ist eine erweiterung von lattice::bwplot. Die Funktion arbeitet mit panel.superpose.
p1 <- bwplot2( yield ~ site, data = barley, groups = year, main="bwplot2()", par.settings = bw_theme(), auto.key = list(points = FALSE, rectangles = TRUE, space = "right") ) p2 <- bwplot( yield ~ site, barley,groups = year, main="panel.superpose", par.settings = bw_theme(), auto.key = list(points = FALSE, rectangles = TRUE, space = "right"), box.width = 1 / 4, panel = function(x, y, groups, subscripts, ...) { xx <- as.numeric(x) + scale(as.numeric(groups), scale = FALSE)/(nlevels(groups)+1) panel.superpose( xx, y, ..., panel.groups = panel.bwplot, groups = groups, subscripts = subscripts ) } ) grid.arrange(p1, p2)
bwplot(yield ~ site, data = barley, groups=year, pch = "|", box.width = 1/3, auto.key = list(points = FALSE, rectangles = TRUE, space = "right"), panel = panel.superpose, panel.groups = function(x, y, ..., group.number) { panel.bwplot(x + (group.number-1.5)/3, y, ...) mean.values <- tapply(y, x, mean) panel.points(x + (group.number-1.5)/3, mean.values[x], pch=17) } )
bwplot( yield ~ site, barley, groups = year, main="panel.superpose", par.settings = bw_theme(), auto.key = list( points = FALSE, rectangles = TRUE, space = "right"), box.width = 1 / 4, panel = function(x, y, groups, subscripts, ...) { xx <- as.numeric(x) + scale(as.numeric(groups), scale = FALSE) / (nlevels(groups)+1) panel.superpose( xx, y, ..., panel.groups = panel.mean, groups = groups, subscripts = subscripts ) panel.grid(h = -1, v = 0) # panel.stripplot(x, y, ..., jitter.data = TRUE, # groups = groups, subscripts = subscripts) # panel.superpose(x, y, ..., panel.groups = panel.average, # groups = groups, subscripts = subscripts) # panel.points(x, y, ..., panel.groups = panel.average, # groups = groups, subscripts = subscripts) } )
Forest
forest_plot() Tabelle und Vertikaler-Plot gestohlen von survminer::ggforest()
ggplot_forest() Vertikaler-Plot ohne Tabelle aber dafuer sind Gruppen moeglich - stolen from https://github.com/NightingaleHealth/ggforestplot
model1 <- lm(mpg ~ wt, data = mtcars) model2 <- lm(mpg ~ wt + cyl, data = mtcars) prepare_forest(model1, model2)
require(survival) colon<- Label(colon, sex="Geschlecht")
fit1 <- lm(status ~ sex + rx + adhere, data = colon) forest_plot(fit1)
fit2 <- glm(status ~ sex + rx + adhere, data = colon, family = binomial()) forest_plot(fit2)
fit3 <- coxph(Surv(time, status) ~ sex + rx + adhere, data = colon) forest_plot(fit3, colon)
set.seed(1) n <- 10 * 2 * 3 *100 dat <- data.frame( y = rnorm(n), sex = gl(2, n / 2, labels = c("male", "female")) , rx = gl(3, n / 3, labels = c("Obs", "Tev", "Tev+5FU"))[sample.int(n)], age = 1:n, bmi = rnorm(n ) ) dat <- transform(dat, y = y + as.numeric(sex) / 2 + as.numeric(rx) )
fit1 <- lm(y ~ sex + rx + age + bmi, dat) tab<-forest_plot(fit1, plot=FALSE) tab
ggplot_forest(tab)
ggplot_table( data.frame( var = c("Intercept", "Sex", "Sex", "Alter"), level = c(NA, "male", "female", NA), N = c(NA, 25, 47, 25+47), estimate = c(-.77, NA, .51 , .4), conf.low = c(-1.53, NA, -.17, .2), conf.high = c(-0.1, NA, 1.2, .6), p.value = c(0.046, NA, 0.1407, 0.0021) ) )
Balken mít Errorbars
mycol <- c("#0433FF", "#00F801", "#FF2600", "#918E00", "#FE9300") data <- data.frame( name = c("0h", "1h", "24h"), value = c(1.4, 2.6, 2) / 100, sd1 = c(1.2, 2.8, 1.9) / 100, sd2 = c(2, 0.75, 2.4) / 100 ) # Most basic error bar ggplot(data) + geom_bar( aes(x = name, y = value), stat = "identity", fill = "#64B2FC", alpha = 0.7 ) + geom_errorbar( aes(x = name, ymin = sd1, ymax = sd2), width = 0.2, colour = "gray40", alpha = 0.9, size = 1 ) + scale_y_continuous(labels = scales::percent) + labs(title = "Non-viable cells", # subtitle = "(1973-74)", # caption = "Data from the 1974 Motor Trend US magazine.", # tag = "B", x = "Time [h]", y = "",) + theme_classic()
Balken mit Zahlen
set.seed(2) DF_balk <- data.frame( value = runif(2 * 5, min = 20, max = 80), sex = factor(rep(c("male", "female"), times = 5)), variable = factor(rep( c( n = "Neurotizismus", e = "Extraversion", o = "Offenheit", g = "Gewissenhaftigkeit", a = "Vertraeglichkeit" ), times = 2 )) ) barchart( reorder(variable, value) ~ value, subset(DF_balk, sex == "male"), box.ratio = 2, xlim = c(-5, 100), origin = 0, #' par.settings=colorset, panel = function(...) { panel.barchart(...) panel.barchart.text(..., digits = 1, suffix = " %") } )
Tortendiagramme
# Create test data. data <- data.frame( category=c("Granulocytes", "CD3+", "CD56+", "CD19+", "Monocytes"), count=c(80,10,5,3,2) ) # Compute percentages data$fraction <- data$count / sum(data$count) # Compute the cumulative percentages (top of each rectangle) data$ymax <- cumsum(data$fraction) # Compute the bottom of each rectangle data$ymin <- c(0, head(data$ymax, n=-1)) # Compute label position data$labelPosition <- (data$ymax + data$ymin) / 2 # Compute a good label #data$label <- paste0(data$category, "\n value: ", data$count) # Make the plot ggplot(data, aes(ymax=ymax, ymin=ymin, xmax=4, xmin=2, fill=category)) + geom_rect() + # geom_text( x=2, # aes(y=labelPosition, # label=label, # color=1), size=6) + # x here controls label position (inner / outer) scale_fill_manual( values = c("#918E00","#00F801","#FF2600","#0433FF","#FE9300")) + coord_polar(theta="y") + xlim(c(-1, 4)) + theme_void() + theme(legend.position = "top") + labs(title = "Leukocyte composition 1h NMP") + theme(legend.title = element_blank(),# element_text(size=12, color = "salmon", face="bold"), legend.justification=c(0,1), legend.position=c(0.4, 0.7), legend.background = element_blank(), legend.key = element_blank() )
# Geht nicht problemlos in Markdown print(torte(~treatment+sex, DF, init.angle=45, main="lattice"))
gtorte(~treatment+sex, DF, init.angle=45, main="ggplot")
# Geht nicht problemlos in Markdown tab <- as.data.frame(xtabs( ~ treatment + sex, DF)) # par(new = TRUE) stp25plot::piechart(~Freq|sex, tab, groups= treatment, auto.key=list(columns=3))
MetComp_BAP
Tukey Mean Difference oder auch Bland Altman Metode
DF2<- data.frame( A=c(1, 5,10,20,50,40,50,60,70,80, 90,100, 150,200,250,300,350,400,450,500,550, 600,650,700,750,800,850,900, 950,1000), B=c(8,16,30,14,39,54,40,68,72,62,122, 80, 181,259,275,380,320,434,479,587,626, 648,738,766,793,851,871,957,1001,980), group= sample(gl(2, 15, labels = c("Control", "Treat"))) )
require(stp25metcomp) x<- MetComp_BAP(~A+B, DF2) plot(x) x
cowplot
gridExtra::grid.arrange( )
Zusammen mixen von unterschiedlichen Grafik-Typen.
The cowplot package is a simple add-on to ggplot. https://wilkelab.org/cowplot/articles/index.html
library(ggplot2) library(grid) library(gridExtra) library(cowplot) theme_set(theme_half_open()) set.seed(0815) # Create example data data <- data.frame(x = 1:21, # Create example data y = rnorm(21), group = rep(letters[1:3], 7)) p1 <- ggplot(data, aes(x, y, color = group)) + # Create ggplot2 plot geom_point(size = 5) + geom_line() # Draw default ggplot2 plot p2 <- ggplot(data, aes(x, group , color = group)) + geom_boxplot() title <- ggdraw() + draw_label("Arrange Plots", fontface = 'bold') p1 <- p1 + guides(colour = guide_legend( title = "legend title", override.aes = list( size = 5, fill = NA, linetype = 0 ) )) + theme(legend.position = c(.2, .5)) legend <- get_legend(p1) p1 <- p1 + theme(legend.position = "none") p2 <- p2 + theme(legend.position = "none") p2 <- plot_grid(p2, legend, ncol = 1, rel_heights = c(1, .5)) plot_grid( title, NULL, p1, p2, nrow = 2, rel_widths = c(1, .6), rel_heights = c(0.2, 1) )
#require(ggplot2) #require(cowplot) #require(lattice) p1<- ggplot(iris, aes(Sepal.Length, fill = Species)) + geom_density(alpha = 0.5) + scale_y_continuous(expand = expansion(mult = c(0, 0.05))) + theme_minimal_hgrid(10) p2<- densityplot(~Sepal.Length|Species , iris) plot_grid(p1, p2, rel_widths = c(1, 1.5) , labels = c('A', 'B'))
Mixing different plotting frameworks
# require(ggplot2) # require(cowplot) # require(lattice) require(gridGraphics) p1 <- function() { par( mar = c(3, 3, 1, 1), mgp = c(2, 1, 0) ) boxplot(mpg ~ cyl, xlab = "cyl", ylab = "mpg", data = mtcars) } ggdraw(p1) + theme(plot.background = element_rect(fill = "cornsilk"))
ggformula
Quelle https://rpruim.github.io/Statistical-Rethinking/Examples/ggformula.html
gf_point() for scatter plots
gf_line() for line plots (connecting dots in a scatter plot)
gf_density() or gf_dens() or gf_histogram() or gf_freqpoly() to display distributions of a quantitative variable
gf_boxplot() or gf_violin() for comparing distributions side-by-side
gf_counts() for bar-graph style depictions of counts.
gf_bar() for more general bar-graph style graphics
#require(ggplot2) require(ggformula) #require(lattice) theme_set(theme_bw()) mtcars2 <- within(mtcars, { vs <- factor(vs, labels = c("V-shaped", "Straight")) am <- factor(am, labels = c("Automatic", "Manual")) cyl <- factor(cyl) gear <- factor(gear) }) #' ggplot p1 <- ggplot(mtcars2) + geom_point(aes(x = wt, y = mpg, colour = gear)) + labs( title = "Fuel economy declines as weight increases", subtitle = "(1973-74)", caption = "Data from the 1974 Motor Trend US magazine.", tag = "ggplot", x = "Weight (1000 lbs)", y = "Fuel economy (mpg)", colour = "Gears" ) #' ggformula p2 <- gf_point(mpg ~ wt , data = mtcars2, color = ~ gear) + labs( title = "Fuel economy declines as weight increases", subtitle = "(1973-74)", caption = "Data from the 1974 Motor Trend US magazine.", tag = "gf_point", x = "Weight (1000 lbs)", y = "Fuel economy (mpg)", colour = "Gears" ) #' lattice p3 <- xyplot( mpg ~ wt, mtcars2, groups = gear, par.settings = bw_theme(farbe(), cex.main = .8, cex.add = .8), grid=TRUE, main = "Fuel economy declines as weight increases\n(1973-74)", sub = "Data from the 1974 Motor Trend US magazine.", xlab = "Weight (1000 lbs)", ylab = "Fuel economy (mpg)", auto.key = list(space = "right", title = "Gears") ) cowplot::plot_grid(p1, p2, p3, ncol=2)
Effectplot
require(ggplot2) mtcars2 <- within(mtcars, { vs <- factor(vs, labels = c("V", "S")) am <- factor(am, labels = c("automatic", "manual")) cyl <- (cyl) cyl_ord <- ordered(cyl) gear <- ordered(gear) carb <- ordered(carb) }) mtcars2$mpg[mtcars2$cyl_ord==6] <- mtcars2$mpg[mtcars2$cyl_ord==6] *.5 mtcars2 <- mtcars2 |> Label( mpg = "Miles/(US) gallon", cyl_ord = "Number of cylinders", disp = "Displacement (cu.in.)", hp = "Gross horsepower", drat = "Rear axle ratio", wt = "Weight (1000 lbs)", qsec = "1/4 mile time", vs = "Engine (0 = V-shaped, 1 = straight)", am = "Transmission (0 = automatic, 1 = manual)", gear = "Number of forward gears", carb = "Number of carburetors" ) fit <- lm(mpg ~ hp * wt + am +cyl , data = mtcars2) fit2 <- lm(mpg ~ hp * wt + am +cyl_ord , data = mtcars2)
Meine Version vs plot.efflist
plot( effects::allEffects(fit2) )
plot2( effects::allEffects(fit2) )
e2 <- effects::allEffects(fit2) p1 <- plot2(e2, axes = list( x = list( hp = list(lab = "Gross horsepower"), wt = list(lab = "Weight (1000 lbs"), am = list(lab = "Transmission (0 = automatic, 1 = manual)"), cyl_ord = list(lab = "Number of cylinders"), cex = .75 ), y = list(lab = "Miles/(US) gallon") ) )
p2<-plot2(e2, labels = stp25tools::get_label(mtcars2), plot=FALSE) cowplot::plot_grid(plotlist =p2, labels = c('A', 'B', 'C'), # scale = c(1, .9, .8), rel_heights = c(3,4))
Konfidenz-Band mit geom_ribbon()
ef1 <- as.data.frame( effects::effect(term = "hp", fit, xlevels = list( hp = seq(50, 350, by =10)))) p1 <- ggplot(ef1, aes(hp, fit)) + geom_line() + geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.3) + labs(y = 'Miles/(US) gallon', x = 'Gross horsepower', title = 'Main-Effect-Plot') + theme_classic()
Interaction mit geom_line()
ef2 <- as.data.frame(effects::effect("hp:wt", fit)) ef2$Weight <- factor(ef2$wt) p2 <- ggplot(ef2, aes(hp, fit, col = Weight)) + geom_line() + labs(y = 'Miles/(US) gallon', x = 'Gross horsepower', title = 'Interaction-Plot') + theme_classic()
Fehlerbalken mit **
#ef3<- as.data.frame(effects::effect("am", fit)) ef4 <- as.data.frame(effects::effect("cyl_ord", fit2)) p3 <- ggplot(ef4, aes(cyl_ord, fit, group=1 )) + geom_point()+ geom_line()+ geom_errorbar( aes(x = cyl_ord, ymin = lower, ymax = upper), width = 0.2, colour = "gray40", alpha = 0.9, linewidth = .75 ) + labs(y = 'Miles/(US) gallon', x = 'Number of cylinders', title = 'Cylinder Ordinal (nicht linear)') + theme_classic() ef4 <- as.data.frame(effects::effect("cyl", fit)) p4 <- ggplot(ef4, aes(cyl, fit, group=1 )) + geom_point()+ geom_line()+ geom_errorbar( aes(x = cyl, ymin = lower, ymax = upper), width = 0.2, colour = "gray40", alpha = 0.9, linewidth = .75 ) + labs(y = 'Miles/(US) gallon', x = 'Number of cylinders ', title = 'Cylinder Metrisch (linear)') + ylim(c(8,23))+ # xlim(c(4, 8))+ annotate("text", x = 6, y=9, label = stp25stat2::APA(fit)) + theme_classic()
library(patchwork) p1 + p2 + p3 + p4 + plot_layout(ncol=2)
ggeffects
require(ggeffects)
require(ggeffects) ggeffect() # computes marginal effects by internally calling effects::Effect() ggemmeans() # uses emmeans::emmeans() ggpredict() # uses predict() ggpredict(fit, term = "hp") |> plot() + ggeffect(fit, term = "hp") |> plot( add.data = TRUE) + ggemmeans(fit,term = "hp") |> plot(log.y = TRUE)
## S3 method for class 'ggeffects'
plot(
x,
ci = TRUE,
ci.style = c("ribbon", "errorbar", "dash", "dot"),
facets,
add.data = FALSE,
limit.range = FALSE,
residuals = FALSE,
residuals.line = FALSE,
collapse.group = FALSE,
colors = "Set1",
alpha = 0.15,
dodge = 0.25,
use.theme = TRUE,
dot.alpha = 0.35,
jitter = 0.2,
log.y = FALSE,
case = NULL,
show.legend = TRUE,
show.title = TRUE,
show.x.title = TRUE,
show.y.title = TRUE,
dot.size = NULL,
line.size = NULL,
connect.lines = FALSE,
grid,
one.plot = TRUE,
rawdata,
...
)
Quelle: https://strengejacke.github.io/ggeffects/
Die lib ggeffects() berechnet die Marginalen Effecte bei Interactionen anderst als effect(), daher aufpassen!!
ef1 <- as.data.frame(effects::effect(term = "hp", fit, xlevels = list(hp = c( 50, 85, 120, 155, 195, 230, 265, 335 )))) effects::effect(term = "hp", fit, xlevels = list(hp = c(50, 85, 120, 155, 195, 230, 265, 335))) ggpredict(fit, term = "hp") ggeffect(fit,term = "hp") ggemmeans(fit,term = "hp")
mydf <- ggpredict(fit, terms = "hp") p2 <- ggplot(mydf, aes(x, predicted)) + geom_line() + geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1) + theme_classic() mydf <- ggpredict(fit, terms = c("hp", "wt")) p3 <- ggplot(mydf, aes(x = x, y = predicted, colour = group)) + geom_line() p4 <- ggplot(mydf, aes(x = x, y = predicted)) + geom_line() + facet_wrap( ~ group)
library(patchwork) p1 + p2 + p3 + p4 + plot(mydf) + plot_layout(ncol=2)
require(ggeffects) mod <- lm(prestige ~ type*(education + income) + women, Prestige) mydf<-ggpredict(mod, terms =c( "education", "type")) mydf # ggplot(mydf, aes(x, predicted)) + # geom_line() + # geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1) p1 <-plot(mydf) p1 p1 + facet_wrap(~group) + theme(legend.position = "none") #plot(allEffects(mod)) ggplot(mydf, aes(x = x, y = predicted, group =group)) + geom_line() + geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .1) + facet_wrap(~group)
theme_set(theme_ggeffects()) p1<-ggpredict(fit, "am") |> plot( connect.lines = TRUE, ci=FALSE, dot.size = 5)+ geom_errorbar( aes_string(ymin = "conf.low", ymax = "conf.high"), width = 0.099#, #size = line.size ) + theme_classic() p1
Effectplot mit emmeans
require(emmeans) head(pigs) pigs.lm1 <- lm(log(conc) ~ source + factor(percent), data = pigs) ref_grid(pigs.lm1) pigs.lm2 <- lm(log(conc) ~ source + percent, data = pigs) ref_grid(pigs.lm2)
emmeans default
plot(emmeans(pigs.lm1, ~ percent | source))
emmeans ruecktransformiert
plot(emmeans(pigs.lm1, ~ percent | source), xlab= "plasma leucine [mcg/ml]" , type = "response")
emmip(pigs.lm1, source ~ percent)
plot(emmeans(pigs.lm2, ~ percent | source, at = list(percent = c(10, 15, 20)) ) )
emmip( ref_grid(pigs.lm2, cov.reduce = FALSE), source ~ percent)
emmip(ref_grid(pigs.lm2, at= list(percent = c(10, 15, 20))), source ~ percent, ylab= "plasma leucine [mcg/ml]" , type = "response" )
Klassiker mit Effect()
predictorEffect()
Von mir lang ignorierte Variante von Effect mit Formeln!
mod <- lm(prestige ~ type*(education + income) + women, Prestige) plot(predictorEffect("income", mod), main="", rug=FALSE) plot(predictorEffects(mod, ~ education + women), main="", rug=FALSE) plot(predictorEffects(mod, ~ women+ education), axes= list(x=list( women=list(lab="Anteil Frauen"), education=list(lab="Bildung"))), main="", rug=FALSE)
Modifizier plot.efflist
#require(stpvers) A = rnorm(100) B = rnorm(100, 53, 10) C = factor(rep(c("This", "That"), 50)) A <- A + log(B / 50) + as.numeric(C) #log(B) Logit <- function(x) car::logit(x, adjust = 0) invLogit <- function(x) exp(x) / (1 + exp(x)) prop <- function(odds) odds / c(1 + odds) odds <- function(p) p / (1 - p)
allEffects
ef <- allEffects(lm(A ~ B + C)) plot(ef, axes = list( x = list( B = list( transform = list(trans = log, inverse = exp), ticks = list(at = c(30, 50, 70)), lab = "Age, log-scale"), C = list(lab = "Treatment") ), y = list(lim= c(.0, 2.5), lab = "Vitamins" # transform = list(link = Logit, inverse = invLogit), # transform=list(trans=log, inverse=exp), # type="rescale", # ticks = list(at = c(.05, .25, .50, .75)), # )), main = "")
lattice::trellis.par.set(bw_theme(farbe())) plot(Effect(c("source", "percent"), pigs.lm2, transformation=list(link=log, inverse=exp)), multiline=TRUE, key.args = list(space="right" ), main="", ylab="plasma leucine [mcg/ml]")
pigs.lm3 <- lm(log(conc) ~ source * percent, data = pigs) plot( allEffects(pigs.lm3), main = "", multiline = TRUE, key.args = list( space = "right", columns = 1, border = FALSE, fontfamily = "serif", cex.title = .80, cex = 0.75 ) ) emmip( ref_grid(pigs.lm3, cov.reduce = TRUE), source ~ percent) emmip( ref_grid(pigs.lm3, cov.reduce = FALSE), source ~ percent)
raw_data <- data.frame( subject_id = rep(1:6, 4), time = as.factor(rep(c("t0", "t1"), each = 12)), group = rep(rep(c("Control", "Treat"), each = 6), 2), value = c(2:7, 6:11, 3:8, 7:12) ) head(raw_data) stripplot( value ~ time | group, groups = subject_id, data = raw_data, panel = function(x, y, ...) { panel.stripplot(x, y, type = "b", col="blue", lty = 2, ...) panel.average(x, y, fun = mean, lwd = 2, col = "gray80", ...) # plot line connecting means mm<-mean(y) panel.abline(h=mm, v=1.5, col="gray80") panel.text(x=1.5,y=mm, APA(wilcox.test(y~x)) ) } )
transformation
require(effects) John Fox URL http://www.jstatsoft.org/v32/i01/
set.seed(2) ctl <- c(4.17, 5.58, 5.18, 6.11, 4.50, 4.61, 5.17, 4.53, 5.33, 5.14) trt <- c(4.81, 4.17, 4.41, 3.59, 5.87, 3.83, 6.03, 4.89, 4.32, 4.69) edu <- cut(c(ctl, trt),3) ctl2<- ctl + rnorm(10,0,.5) trt2 <-trt + rnorm(10,1.2,.5) group <- gl(2, 10, 40, labels = c("Ctl_gt", "Trt")) serum <-round(rnorm(length(group)),2) time <- factor(rep(1:2, each=20)) DF<- data.frame(id= factor(c(1:20, 1:20)), time, y = round(c(ctl, trt, ctl2, trt2) + serum + as.numeric(group),2), y1 = round(c(ctl, trt, ctl2, trt2)*10,2), y2 = round(c(ctl, trt, ctl2, trt2)+2,2), group, edu= factor(c(edu,edu), labels=Cs(low, med, high)), serum )
fit <- lm(y ~ group * time * serum, DF)
plot(effects::allEffects(fit))
Tbll_desc( ~ log(prestige) + income + type + education, data = Prestige) mod <- lm(log(prestige) ~ income:type + education, data = Prestige) # does not work: effect("income:type", mod, transformation=list(link=log, inverse=exp)) plot(Effect(c("income", "type"), mod, transformation=list(link=log, inverse=exp)), main="", ylab="prestige")
GOF-Plots
require(car) car::residualPlots(fit)
car::marginalModelPlots(fit)
car::avPlots(fit)
library(visreg)
Patrick Breheny and Woodrow Burchett URL: https://cran.r-project.org/web/packages/visreg/vignettes/quick-start.html
Limitation: plot kann nicht einfach in cowplot::plot_grid integriert werdrn.
par(mfrow=c(1,3)) visreg::visreg(fit)
library(stats) termplot
par(mfrow=c(1,3)) stats::termplot(fit, se = TRUE, resid = TRUE, plot=TRUE, ask=FALSE)
library(rockchalk) Paul E. Johnson URL https://github.com/pauljohn32/rockchalk
Hier gibt es keine Updates mehr???
rockchalk::plotSlopes(fit,
plotx = "group",
interval = "confidence")
rockchalk::plotSlopes(fit,
plotx = "group",
modx = "time",
interval = "confidence")
raw_data <- data.frame( subject_id = rep(1:6, 4), time = as.factor(rep(c("t0", "t1"), each = 12)), group = rep(rep(c("Control", "Treat"), each = 6), 2), value = c(2:7, 6:11, 3:8, 7:12) ) head(raw_data) stripplot( value ~ time | group, groups = subject_id, data = raw_data, panel = function(x, y, ...) { panel.stripplot(x, y, type = "b", col = "blue", lty = 2, ...) panel.average(x, y, fun = mean, lwd = 2, col = "gray80", ...) # plot line connecting means mm <- mean(y) panel.abline(h = mm, v = 1.5, col = "gray80") panel.text(x = 1.5, y = mm, APA(wilcox.test(y ~ x))) } )
Altman and Bland (Tukey Mean-Difference Plot)
set.seed(0815) Giavarina <- data.frame( A=c(1,5,10,20,50, 40,50,60,70,80, 90,100,150,200,250, 300,350,400,450,500, 550,600,650,700,750, 800,850,900,950,1000), B=c(8,16,30,14,39, 54,40,68,72,62, 122,80,181,259,275, 380,320,434,479,587, 626,648,738,766,793, 851,871,957,1001,980), group= sample(gl(2, 15, labels = c("Control", "Treat"))) ) Giavarina <- transform(Giavarina, C = round( A + rnorm(30,0,20)), D = round( A + rnorm(30,0,10) + A/10 ), E = round( A + rnorm(30,5,10) + (100-A/10) ))
# A - Goldstandart x <- MetComp_BAP(~A+B, Giavarina) #> Warning: Warning in bland.altman.stats:Mehr als 2 Methoden. # x |> Output("BA-Analyse der Messwertreihe") plot(x)
lattice::tmd( A ~ B, Giavarina)
Survival Analysis
Add number-at-risk annotations to a plot
require("survival") s <- Surv(colon$time / 365, colon$status) ## Need to increase margins a bit par(mar = c(10, 6, 2, 1),mfrow = c(1,2)) ## no stratification fit1 <- survfit(s ~ 1) plot(fit1) addNrisk(fit1) ## with stratification at <- c(0, 2, 4) lty <- 1:3 xlim <- c(0, 6) fit2 <- survfit(s ~ rx, data = colon) plot(fit2, xlab = 'Time (years)', ylab = 'Survival', xaxt = "n", xlim=xlim, lty = lty) addNrisk(fit2, at) axis(1, at = at, gap.axis = 1 / 4) legend( 'bottomleft', legend = names(fit2$strata), lty = lty, bty = 'n' ) Hmisc::minor.tick(nx = 4, tick.ratio = 1 / 2)
ECDF-Plot
ecdfplot {latticeExtra}
# data(Chem97, package = "mlmRev") # # ecdfplot(~gcsescore | factor(score), data = Chem97, # groups = gender, # auto.key = list(columns = 2), # subset = gcsescore > 0, # xlab = "Average GCSE Score") data(singer, package = "lattice") ecdfplot(~height | voice.part, data = singer)
data(singer, package = "lattice")
Interessante Grafik Beispiele
Lattice xyplot mit Pfeilen und verlaufende Farben.
dat <- stp25tools::get_data(" variable value change leverage happiness 4.62 -0.42 0.01 motivation 3.6 -0.41 0.05 training 3.4 -0.33 0.14 performance 3.2 0.30 0.82 lmx 2.96 0.21 0.33 communication 2.9 -0.11 0.43 autonomy 2.7 0.11 0.22 insecurity 2.5 0.12 0.21 stress 1.6 0.14 0.12") #Create a function to generate a continuous color palette rbPal <- colorRampPalette(c('gray','blue')) xyplot( reorder(variable, value) ~ value , xlab = "", ylab = "", data = dat, xlim = c(0.85, 5.15),# drop.unused.levels = FALSE, scales = list(x = list( at = 1:5, labels = c( "low", "moderate", "considerable", "hig","very high") )), panel = function(x, y, ...) { col <- rbPal(8)[as.numeric(cut(dat$leverage,breaks = 8))] panel.dotplot( x = x, y = y, col = col, cex = 1.1 + 1 * dat$leverage, pch = 19 ) panel.arrows( x0 = x, y0 = y, x1 = x + x * dat$change, y1 = y, col=col, lwd = 2, angle = 30, code = 2, length = 0.1 ) } )
# siehe panel.segplot panel.arrows2 <- function(x0, y0 , x1, y1, col, alpha, lty, lwd, ...) { panel.dotplot( x = x0, y = y0, col = col, cex = 1.5, pch = "|" ) panel.arrows( x0, y0, x1, y1, col = col , alpha = alpha, lty = lty, lwd = lwd, ... ) } dat$change <- dat$value + dat$change * dat$value dat$centers <- (dat$value + dat$change) / 2 #require(latticeExtra) segplot( reorder(variable, value) ~ value + change, level = leverage, data = dat, draw.bands = FALSE, centers = centers, segments.fun = panel.arrows2, lwd = 2, angle = 30, code = 2, length = 0.1, colorkey = TRUE, col.regions = rbPal# hcl.colors #terrain.colors )
Spine Plots and Spinograms
require("colorspace") ttnc <- margin.table(Titanic, c(1, 4)) spineplot(ttnc, col = sequential_hcl(2, palette = "Purples 3"))
# require(latticeExtra) segplot(factor(1:10) ~ rnorm(10) + rnorm(10), level = runif(10)) data(USCancerRates) segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male, data = subset(USCancerRates, state == "Washington")) segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male, data = subset(USCancerRates, state == "Washington"), draw.bands = FALSE, centers = rate.male) segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male, data = subset(USCancerRates, state == "Washington"), level = rate.female, col.regions = terrain.colors) segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male, data = subset(USCancerRates, state == "Washington"), draw.bands = FALSE, centers = rate.male, segments.fun = panel.arrows, ends = "both", angle = 90, length = 1, unit = "mm") segplot(reorder(factor(county), rate.male) ~ LCL95.male + UCL95.male, data = subset(USCancerRates, state == "Washington"), draw.bands = FALSE, centers = rate.male)
Misc
Speichern von Grafiken als PDF scheitert wen Unicode verwendet wird abhilfe bietet CairoPDF.
require(Cairo) CairoPDF( paste0(Abb()[3],"-cell-count.pdf"), width = 7, height = 0.66*8 +.4) plot_grid(p_all, p_cit, p_trns, p_dbd) invisible(dev.off())
Links
https://ggobi.github.io/ggally/index.html
http://www.sthda.com/english/articles/24-ggpubr-publication-ready-plots/78-perfect-scatter-plots-with-correlation-and-marginal-histograms/
ggpubr
http://www.sthda.com/english/articles/24-ggpubr-publication-ready-plots/78-perfect-scatter-plots-with-correlation-and-marginal-histograms/
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.