Я написал функцию для построения плотности скрипок, сравнивая значения двух отдельных фреймов данных. Один представлен в верхней половине скрипки, другой в нижней половине. Я достиг этого, просто записав плотности нижней половины -y (см. Строку 36).
https://imgur.com/bt3BnIy
Поскольку плотности могут быть только положительными, я бы хотел использовать положительные тикина оси плотности. Какой самый простой способ сохранить галочки там, где они есть, но пометить их abs ()?
РЕДАКТИРОВАТЬ: просто, чтобы сделать это кристально ясно, что я пытаюсь получить;)
https://imgur.com/a/14Xd4S5
require(ggplot2)
require(dplyr)
interpolate <- function(x.left, x.right, y.left, y.right, x.fill){
y.fill <- (y.right - y.left) / (x.right - x.left) * (x.fill - x.left) + y.left
return(y.fill)
}
add.quantiles.to.density <- function(plotline, quantiles){
for (i in 1:length(quantiles)){
x.fill <- as.numeric(quantiles)[i]
pre <- plotline %>% filter(x <= x.fill)
post <- plotline %>% filter(x >= x.fill)
x.1 <- pre[nrow(pre), "x"]
x.2 <- post[1, "x"]
y.1 <- pre[nrow(pre), "y"]
y.2 <- post[1, "y"]
y.fill <- interpolate(x.1, x.2, y.1, y.2, x.fill)
plotline <- rbind(pre, c(x.fill, y.fill, as.numeric(as.character(pre[nrow(pre), "quant"]))), c(x.fill, y.fill, as.numeric(as.character(post[1, "quant"]))), post)
}
return(plotline)
}
plot.violin.density.comparison <- function(colname, upper, lower, quantiles){
upper.col <- select(upper, c(colname))
lower.col <- select(lower, c(colname))
colnames(upper.col)<- "values"
colnames(lower.col)<- "values"
density.data.u <- density(upper.col$values,
bw = min(abs(max(upper.col$values)-min(upper.col$values)),
abs(max(lower.col$values)-min(lower.col$values))) / 128)
density.data.l <- density(lower.col$values,
bw = min(abs(max(upper.col$values)-min(upper.col$values)),
abs(max(lower.col$values)-min(lower.col$values))) / 128)
plotline.u <- data.frame(x = density.data.u$x, y = density.data.u$y)
plotline.l <- data.frame(x = density.data.l$x, y = -density.data.l$y)
quantiles.u <- quantile(upper.col$values, quantiles)
quantiles.l <- quantile(lower.col$values, quantiles)
plotline.u$quant <- factor(findInterval(plotline.u$x, quantiles.u))
plotline.l$quant <- as.factor(as.numeric(factor(findInterval(plotline.l$x, quantiles.l))) + length(quantiles) + 1)
plotline.u <- add.quantiles.to.density(plotline.u, quantiles.u)
plotline.l <- add.quantiles.to.density(plotline.l, quantiles.l)
plotline <- rbind(plotline.l, plotline.u)
ggplot(plotline, aes(x, y)) +
geom_ribbon(aes(ymin = 0, ymax = y, fill = quant)) +
scale_fill_manual(values = c("white", "#FFC090", "#FF6030", "#FF3000", "#FF0030", "#FF3060", "#FF90C0", "white",
"white", "#C090FF", "#6030FF", "#3000FF", "#0030FF", "#3060FF", "#90C0FF", "white"),
guide = "none") +
scale_x_continuous(name = paste("value of", colname),
limits = c( min(plotline$x), max(plotline$x))) +
scale_y_continuous(name = paste("density of ", colname, "\'s values", sep=""),
limits = c(-max(abs(plotline$y)), max(abs(plotline$y)))) +
geom_segment(aes(x = mean(upper.col$values),
xend = mean(upper.col$values),
y = 0,
yend = plotline.u[which.min(abs(plotline.u$x-mean(upper.col$values))), "y"])) +
geom_segment(aes(x = mean(lower.col$values),
xend = mean(lower.col$values),
y = 0,
yend = plotline.l[which.min(abs(plotline.l$x-mean(lower.col$values))), "y"]))
}
colname <- "blah"
upper <- data.frame(x = c(1:1024), y = runif(1024, min = -1, max = 1), blah = runif(1024, min = -0.5, max = 0.5))
lower <- data.frame(x = c(1:2048), y = runif(2048, min = -3, max = 3), blah = runif(2048, min = -0.3, max = 0.6))
quantiles <- c(0.01, 0.05, 0.25, 0.5, 0.75, 0.95, 0.99)
plot.violin.density.comparison(colname, upper, lower, quantiles)