Question

尝试在R中创建我们称之为“泪珠/冰淇淋圆锥”的图表。目标是能够比较多个因子的实际值和相对值。我画了一个模仿我们想要它的样子：

Concept Image

然而，无法将两个点（也就是制作锥体）与尺寸不同的线连接起来。这是一些演示代码，用于说明我到目前为止所拥有的内容。

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

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

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")

Answer 2

它并不是特别优雅，但您可以使用ggforce包中的geom_circle（）和geom_segment（）来组合它。您必须清理圆形直径的图例，并可能调整一些缩放值以获得更好看的圆锥体，但例如：

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))

创建“TearDrop”图表

2 个答案: