创建一个“TearDrop”图表

Question

试图在R中创建我们称之为“泪珠/冰淇淋锥”的图表。目标是能够比较多个因素的实际值和相对值。我画的是什么，我们希望它看起来像一个实物模型：

然而，在连接两个百分点，在规模变化的线（又名使得锥）的麻烦。这里有一些演示代码来说明我到目前为止的内容。

person = c("Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane") 
period = c("2016", "2016", "2016", "2016", "2016", "2016", "2016", "2016", "2017", "2017","2017","2017","2017","2017","2017","2017") 
metric = c("Metric1", "Metric1", "Metric1", "Metric1", "Metric2", "Metric2", "Metric2", "Metric2", "Metric1", "Metric1", "Metric1", "Metric1", "Metric2", "Metric2", "Metric2", "Metric2") 
value = round(runif(16, -0.005, 1.0049), 2) 

tmp = data.frame(person, period, metric, value)  

ggplot(data = tmp, 
      aes_string(x = "person", 
         y = value, 
         color = "person", 
         fill= "person")) + 
    geom_point(aes(size = period))+ 
    geom_line() + 
    scale_size_manual("Year", values=c(3, 6)) + 
    facet_wrap(~metric, nrow=1, labeller = label_wrap_gen()) + 
    labs(y = "Dummy Example", 
     fill="person") + 
    theme(legend.direction = "horizontal", 
     legend.position = "bottom", 
     legend.key = element_blank(), 
     legend.background = element_rect(fill = "white", colour = "gray30"), 
     plot.title=element_text(hjust=.5, size=22), 
     axis.title.x=element_blank(), 
     axis.text.x = element_text(angle =90, hjust=1)) 

如果你运行它，你可以看到，2016年和2017年的数据点是不同的，想拥有它们之间的平滑过渡。

任何帮助将不胜感激。

---- ----解决这里 是多亏了你所有我能放在一起的解决方案：

library(ggplot2) 
library(ggforce) 

person = c("Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane", "Bob", "Joe", "Sue", "Jane") 
period = c("2016", "2016", "2016", "2016", "2016", "2016", "2016", "2016", "2017", "2017","2017","2017","2017","2017","2017","2017") 
metric = c("Metric1", "Metric1", "Metric1", "Metric1", "Metric2", "Metric2", "Metric2", "Metric2", "Metric1", "Metric1", "Metric1", "Metric1", "Metric2", "Metric2", "Metric2", "Metric2") 
value = round(runif(16, -0.005, 1.0049), 2) 

tmp = data.frame(person, period, metric, value)  
tmp$x <- as.numeric(tmp$person) * .25 # to use continuous x 
tmp$r <- ifelse(as.numeric(tmp$HALF_YEAR)==1, .01, .04) #set radious based on period 

#Create single line for each person/metric by Metric 
{ 
    tmp2 <- cast(tmp, person+metric ~ period, value=value) 
    tmp2$x <- as.numeric(tmp2$person) * .25 # to use continuous x 
} 


#create dataframe for polygons to fill the cones 
{ 
    #Create Dummy section (to create dataframe) 
    { 
    tmp.c <- rep(tmp2[1, 1], 4) 
    tmp.t <- rep(tmp2[1, 2], 4) 
    tmp.x <- c(tmp2[1, 5]-.01, tmp2[1, 5]-.04, tmp2[1, 5]+.04, tmp2[1, 5]+.01) 
    tmp.y <- c(tmp2[1, 3], tmp2[1, 4], tmp2[1, 4], tmp2[1, 3]) 
    tmp.P <- data.frame(tmp.c, tmp.t, tmp.x, tmp.y) 
    } 

    for(i in seq_len(nrow(tmp2))) { 
    if(as.numeric(tmp2[i, 3]) > as.numeric(tmp2[i,4])) { 
     tmp.x <- c(tmp2[i, "x"]-.04, tmp2[i, "x"]-.01, tmp2[i, "x"]+.01, tmp2[i, "x"]+.04) 
     tmp.y <- c(min(tmp2[i, 3], tmp2[i, 4]), max(tmp2[i, 3], tmp2[i, 4]), max(tmp2[i, 3], tmp2[i, 4]), min(tmp2[i, 3], tmp2[i, 4])) 
    }else{ 
     tmp.x <- c(tmp2[i, "x"]-.01, tmp2[i, "x"]-.04, tmp2[i, "x"]+.04, tmp2[i, "x"]+.01) 
     tmp.y <- c(min(tmp2[i, 3], tmp2[i, 4]), max(tmp2[i, 3], tmp2[i, 4]), max(tmp2[i, 3], tmp2[i, 4]), min(tmp2[i, 3], tmp2[i, 4])) 
    } 

    tmp.c <- rep(tmp2[i, "person"], 4) 
    tmp.t <- rep(tmp2[i, "metric"], 4) 

    tmp.P <- rbind(tmp.P, data.frame(tmp.c, tmp.t, tmp.x, tmp.y)) 
    } 

    names(tmp.P) <- c("person", "metric", "x", "y") 

    #remove earlier dummy frame 
    tmp.P <- tail(tmp.P, -4) 
} 

#Create plot 
ggplot(tmp) + 
    geom_circle(aes_string(x0='x', y0='value', r='r', fill='person', color = 'person')) + 
    geom_polygon(data=tmp.P, aes(x=x, y=y, fill=person, color = person)) + 
    facet_wrap(~metric, nrow=1, labeller = label_wrap_gen()) +  
    labs(y = "Example", fill="person") + 
    scale_fill_manual("person", values=colors) + 
    scale_color_manual("person", values=colors) + 
    coord_fixed() + 
    theme(legend.direction = "horizontal", 
     legend.position = "bottom", 
     legend.key = element_blank(), 
     legend.background = element_rect(fill = "white", colour = "gray30"), 
     plot.title=element_text(hjust=.5, size=22), 
     axis.title.x=element_blank(), 
     axis.text.x = element_text(angle =90, hjust=1)) + 
    scale_x_continuous(breaks = seq(.25,1,.25), labels = levels(tmp$person)) 

而且它的伟大工程 - Working Example

唯一的问题现在是取决于数值，图形被压扁 - 但我无法删除cord_fixed，因为那时圈子变得疯狂。

下面是数据的一个例子，它是什么样子：

value = c(0.96, 0.96, 0.97, 0.99, 0.94, 0.96, 0.96, 0.98, 0.99, 0.95, 0.96, 0.99, 0.97, 0.91, 0.95, 0.97) 

Squashed Plot

任何想法在周围的工作是什么？

Answer 1

这不是特别优雅，但你可以简单地从ggforce包和geom_segment（）geom_circle的组合（）画出来。你将不得不清理的圆直径的传说，也许调整某些缩放值的更好看锥体，但例如：

library(ggplot2) 
library(ggforce) 

tmp$x.origin <- as.numeric(tmp$person) * .25 # to use continuous x 
tmp$r <- abs(as.numeric(tmp$period) - 3) *.02 # vary radius by year 
tmp2 <- cbind(tmp[1:8,],tmp[9:16,c(4,6)]) # messy reshape... 
names(tmp2)[4:8] <- c("value.2016", "x.origin", "r.2016", "value.2017", "r.2017") 

ggplot(tmp) + geom_circle(aes(x0=x.origin, y0=value, r=r, fill=person, color = person, alpha = .3)) + 
    geom_segment(data = tmp2, aes(x = x.origin - r.2016, xend = x.origin - r.2017, y = value.2016, yend = value.2017, color = person)) + 
    geom_segment(data = tmp2, aes(x = x.origin + r.2016, xend = x.origin + r.2017, y = value.2016, yend = value.2017, color = person)) + 
    facet_wrap(~metric, nrow=1, labeller = label_wrap_gen()) + labs(y = "Dummy Example", fill="person") + coord_fixed() + theme(legend.position = "bottom") + 
    scale_x_continuous(breaks = seq(.25,1,.25), labels = levels(tmp$person)) 

Answer 2

您可能可以创建一个泪珠图表，但其中一个选项呢？

library(tidyverse) 

ggplot(tmp, aes(period, value, group=person, colour=person)) + 
    geom_line() + 
    geom_point() + 
    geom_text(data=tmp %>% group_by(person, metric) %>% arrange(period) %>% slice(1), 
      aes(label=person), position=position_nudge(x=-0.2)) + 
    facet_grid(. ~ metric) + 
    guides(colour=FALSE) 

ggplot(tmp, aes(period, value, colour=metric, group=metric)) + 
    geom_line(position=position_dodge(0.5)) + 
    geom_point(position=position_dodge(0.5)) + 
    facet_grid(. ~ person, scales="free_x")