dwukierunkowy Wykres gęstości połączony z jednokierunkowym wykresem gęstości z wybranymi regionami w r
# data
set.seed (123)
xvar <- c(rnorm (1000, 50, 30), rnorm (1000, 40, 10), rnorm (1000, 70, 10))
yvar <- xvar + rnorm (length (xvar), 0, 20)
myd <- data.frame (xvar, yvar)
# density plot for xvar
upperp = 80 # upper cutoff
lowerp = 30 # lower cutoff
x <- myd$xvar
plot(density(x))
dens <- density(x)
x11 <- min(which(dens$x <= lowerp))
x12 <- max(which(dens$x <= lowerp))
x21 <- min(which(dens$x > upperp))
x22 <- max(which(dens$x > upperp))
with(dens, polygon(x = c(x[c(x11, x11:x12, x12)]),
y = c(0, y[x11:x12], 0), col = "green"))
with(dens, polygon(x = c(x[c(x21, x21:x22, x22)]),
y = c(0, y[x21:x22], 0), col = "red"))
abline(v = c(mean(x)), lwd = 2, lty = 2, col = "red")
# density plot with yvar
upperp = 70 # upper cutoff
lowerp = 30 # lower cutoff
x <- myd$yvar
plot(density(x))
dens <- density(x)
x11 <- min(which(dens$x <= lowerp))
x12 <- max(which(dens$x <= lowerp))
x21 <- min(which(dens$x > upperp))
x22 <- max(which(dens$x > upperp))
with(dens, polygon(x = c(x[c(x11, x11:x12, x12)]),
y = c(0, y[x11:x12], 0), col = "green"))
with(dens, polygon(x = c(x[c(x21, x21:x22, x22)]),
y = c(0, y[x21:x22], 0), col = "red"))
abline(v = c(mean(x)), lwd = 2, lty = 2, col = "red")
Muszę wykreślić dwukierunkowy Wykres gęstości, nie jestem pewien, czy jest lepszy sposób niż następujący:
ggplot(myd,aes(x=xvar,y=yvar))+
stat_density2d(aes(fill=..level..), geom="polygon") +
scale_fill_gradient(low="blue", high="green") + theme_bw()
Chcę połączyć wszystkie trzy typy w jeden (nie wiedziałem, czy mogę stworzyć dwukierunkowy wykres w ggplot), nie ma preforrence na to, czy rozwiązanie być działki są w ggplot lub bazy lub mieszane. Mam nadzieję, że jest to wykonalny projekt, biorąc pod uwagę solidność R. osobiście wolę ggplot2.
Uwaga: dolne cieniowanie na tym wykresie nie jest właściwe, czerwony powinien być zawsze dolny i zielony górny na wykresach xvar i yvar, co odpowiada zacienionemu regionowi na wykresie gęstości XY.
Edit: ostateczne oczekiwanie na wykresie (dzięki Sethowi i Jonowi za bardzo bliską odpowiedź)
(1) usuwanie etykiet spacji i osi itp., aby uczynić go zwartym
(2) wyrównania siatek tak, że środkowe wykresy i siatki powinny być wyrównane z wykresami bocznymi, a etykiety i rozmiar Wykresów wyglądają tak samo.
3 answers
Oto przykład łączenia wielu wykresów z wyrównaniem:
library(ggplot2)
library(grid)
set.seed (123)
xvar <- c(rnorm (100, 50, 30), rnorm (100, 40, 10), rnorm (100, 70, 10))
yvar <- xvar + rnorm (length (xvar), 0, 20)
myd <- data.frame (xvar, yvar)
p1 <- ggplot(myd,aes(x=xvar,y=yvar))+
stat_density2d(aes(fill=..level..), geom="polygon") +
coord_cartesian(c(0, 150), c(0, 150)) +
opts(legend.position = "none")
p2 <- ggplot(myd, aes(x = xvar)) + stat_density() +
coord_cartesian(c(0, 150))
p3 <- ggplot(myd, aes(x = yvar)) + stat_density() +
coord_flip(c(0, 150))
gt <- ggplot_gtable(ggplot_build(p1))
gt2 <- ggplot_gtable(ggplot_build(p2))
gt3 <- ggplot_gtable(ggplot_build(p3))
gt1 <- ggplot2:::gtable_add_cols(gt, unit(0.3, "null"), pos = -1)
gt1 <- ggplot2:::gtable_add_rows(gt1, unit(0.3, "null"), pos = 0)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt2$grobs[[which(gt2$layout$name == "panel")]],
1, 4, 1, 4)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt2$grobs[[which(gt2$layout$name == "axis-l")]],
1, 3, 1, 3, clip = "off")
gt1 <- ggplot2:::gtable_add_grob(gt1, gt3$grobs[[which(gt3$layout$name == "panel")]],
4, 6, 4, 6)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt3$grobs[[which(gt3$layout$name == "axis-b")]],
5, 6, 5, 6, clip = "off")
grid.newpage()
grid.draw(gt1)
Zauważ, że działa to z gglot2 0.9.1, a w przyszłym wydaniu możesz to zrobić łatwiej.
i wreszcie
Możesz to zrobić przez:
library(ggplot2)
library(grid)
set.seed (123)
xvar <- c(rnorm (100, 50, 30), rnorm (100, 40, 10), rnorm (100, 70, 10))
yvar <- xvar + rnorm (length (xvar), 0, 20)
myd <- data.frame (xvar, yvar)
p1 <- ggplot(myd,aes(x=xvar,y=yvar))+
stat_density2d(aes(fill=..level..), geom="polygon") +
geom_polygon(aes(x, y),
data.frame(x = c(-Inf, -Inf, 30, 30), y = c(-Inf, 30, 30, -Inf)),
alpha = 0.5, colour = NA, fill = "red") +
geom_polygon(aes(x, y),
data.frame(x = c(Inf, Inf, 80, 80), y = c(Inf, 80, 80, Inf)),
alpha = 0.5, colour = NA, fill = "green") +
coord_cartesian(c(0, 120), c(0, 120)) +
opts(legend.position = "none")
xd <- data.frame(density(myd$xvar)[c("x", "y")])
p2 <- ggplot(xd, aes(x, y)) +
geom_area(data = subset(xd, x < 30), fill = "red") +
geom_area(data = subset(xd, x > 80), fill = "green") +
geom_line() +
coord_cartesian(c(0, 120))
yd <- data.frame(density(myd$yvar)[c("x", "y")])
p3 <- ggplot(yd, aes(x, y)) +
geom_area(data = subset(yd, x < 30), fill = "red") +
geom_area(data = subset(yd, x > 80), fill = "green") +
geom_line() +
coord_flip(c(0, 120))
gt <- ggplot_gtable(ggplot_build(p1))
gt2 <- ggplot_gtable(ggplot_build(p2))
gt3 <- ggplot_gtable(ggplot_build(p3))
gt1 <- ggplot2:::gtable_add_cols(gt, unit(0.3, "null"), pos = -1)
gt1 <- ggplot2:::gtable_add_rows(gt1, unit(0.3, "null"), pos = 0)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt2$grobs[[which(gt2$layout$name == "panel")]],
1, 4, 1, 4)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt2$grobs[[which(gt2$layout$name == "axis-l")]],
1, 3, 1, 3, clip = "off")
gt1 <- ggplot2:::gtable_add_grob(gt1, gt3$grobs[[which(gt3$layout$name == "panel")]],
4, 6, 4, 6)
gt1 <- ggplot2:::gtable_add_grob(gt1, gt3$grobs[[which(gt3$layout$name == "axis-b")]],
5, 6, 5, 6, clip = "off")
grid.newpage()
grid.draw(gt1)
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2012-07-21 11:45:16
Jak w przykładzie, który podlinkowałem powyżej potrzebujesz pakietu gridExtra. To jest g, które dałeś.
g=ggplot(myd,aes(x=xvar,y=yvar))+ stat_density2d(aes(fill=..level..), geom="polygon") + scale_fill_gradient(low="blue", high="green") + theme_bw()
Użyj geom_rect, aby narysować dwa regiony
gbig=g+geom_rect(data=myd,
aes( NULL,
NULL,
xmin=0,
xmax=lowerp,
ymin=-10,
ymax=20),
fill='red',
alpha=.0051,
inherit.aes=F)+
geom_rect(aes( NULL,
NULL,
xmin=upperp,
xmax=100,
ymin=upperp,
ymax=130),
fill='green',
alpha=.0051,
inherit.aes=F)+
opts(legend.position = "none")
Jest to prosty histogram ggplot; brakuje w nim kolorowych regionów, ale są dość łatwe
dens_top <- ggplot()+geom_density(aes(x)) dens_right <- ggplot()+geom_density(aes(x))+coord_flip()
Zrób pusty wykres, aby wypełnić róg
empty <- ggplot()+geom_point(aes(1,1), colour="white")+
opts(axis.ticks=theme_blank(),
panel.background=theme_blank(),
axis.text.x=theme_blank(),
axis.text.y=theme_blank(),
axis.title.x=theme_blank(),
axis.title.y=theme_blank())
Następnie użyj siatki.funkcja Array:
library(gridExtra) grid.arrange(dens_top, empty , gbig, dens_right, ncol=2, nrow=2, widths=c(4, 1), heights=c(1, 4))
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2012-07-18 20:04:44
Opierając się na odpowiedzi Setha (Dziękuję Ci Seth, i zasługujesz na wszystkie kredyty), poprawiłem niektóre kwestie podniesione przez pytającego. Ponieważ komentarze są zbyt krótkie, aby odpowiedzieć na wszystkie pytania, postanowiłem użyć tego jako odpowiedzi. kilka problemów nadal istnieje, potrzebujesz pomocy :
# data
set.seed (123)
xvar <- c(rnorm (1000, 50, 30), rnorm (1000, 40, 10), rnorm (1000, 70, 10))
yvar <- xvar + rnorm (length (xvar), 0, 20)
myd <- data.frame (xvar, yvar)
require(ggplot2)
# density plot for xvar
upperp = 80 # upper cutoff
lowerp = 30
Figura Środkowa
g=ggplot(myd,aes(x=xvar,y=yvar))+
stat_density2d(aes(fill=..level..), geom="polygon") +
scale_fill_gradient(low="blue", high="green") +
scale_x_continuous(limits = c(0, 110)) +
scale_y_continuous(limits = c(0, 110)) + theme_bw()
Geom_rect dwa regiony
gbig=g+ geom_rect(data=myd, aes( NULL, NULL, xmin=0,
xmax=lowerp,ymin=0, ymax=20), fill='red', alpha=.0051,inherit.aes=F)+
geom_rect(aes(NULL, NULL, xmin=upperp, xmax=110,
ymin=upperp, ymax=110), fill='green',
alpha=.0051,
inherit.aes=F)+
opts(legend.position = "none",
plot.margin = unit(rep(0, 4), "lines"))
Górny histogram z zacienionym regionem
x.dens <- density(myd$xvar)
df.dens <- data.frame(x = x.dens$x, y = x.dens$y)
dens_top <- ggplot()+geom_density(aes(myd$xvar, y = ..density..))
+ scale_x_continuous(limits = c(0, 110)) +
geom_area(data = subset(df.dens, x <= lowerp), aes(x=x,y=y), fill = 'red')
+ geom_area(data = subset(df.dens, x >= upperp), aes(x=x,y=y), fill = 'green')
+ opts (axis.text.x=theme_blank(), axis.title.x=theme_blank(),
plot.margin = unit(rep(0, 4), "lines")) + xlab ("") + ylab ("") + theme_bw()
Prawy histogram z zacienionym regionem
y.dens <- density(myd$yvar)
df.dens.y <- data.frame(x = y.dens$x, y = y.dens$y)
dens_right <- ggplot()+geom_density(aes(myd$yvar, y = ..density..))
+ scale_x_continuous(limits = c(0, 110)) +
geom_area(data = subset(df.dens.y, x <= lowerp), aes(x=x,y=y),
fill = 'red')
+ geom_area(data = subset(df.dens.y, x >= upperp), aes(x=x,y=y),
fill = 'green')
+ coord_flip() +
opts (axis.text.x=theme_blank(), axis.title.x=theme_blank(),
plot.margin = unit(rep(0, 4), "lines")) + xlab ("") + ylab ("")
+ theme_bw()
Make an empty wykres do wypełnienia w rogu
empty <- ggplot()+geom_point(aes(1,1), colour="white")+
scale_x_continuous(breaks = NA) + scale_y_continuous(breaks = NA) +
opts(axis.ticks=theme_blank(),
panel.background=theme_blank(),
axis.text.x=theme_blank(),
axis.text.y=theme_blank(),
axis.title.x=theme_blank(),
axis.title.y=theme_blank())
Następnie użyj siatki.funkcja array:
library(gridExtra)
grid.arrange(dens_top, empty , gbig, dens_right, ncol=2,nrow=2,
widths=c(2, 1), heights=c(1, 2))
PS: (1) Czy ktoś może pomóc idealnie wyrównać wykresy ? (2) Czy ktoś może pomóc usunąć dodatkową przestrzeń między wykresami, próbowałem dostosować marginesy - ale jest przestrzeń między wykresem gęstości X i y i wykresem centralnym.
Warning: date(): Invalid date.timezone value 'Europe/Kyiv', we selected the timezone 'UTC' for now. in /var/www/agent_stack/data/www/doraprojects.net/template/agent.layouts/content.php on line 54
2012-07-19 02:08:31