3层使用ggplot2从已汇总的计数中堆积直方图

问题描述 投票：1回答：1

我想帮助着色从data.frame中的汇总数据生成的ggplot2直方图。

我正在使用的数据集是（USArrests）数据集中的[R]构建。

我正在努力调整由arun给予this question的解决方案。

期望的结果是根据c的相对贡献（“突击”，“强奸”，“谋杀”）制作“犯罪”的直方图并为每个条形颜色。

代码：

attach(USArrests)

#Create vector SUM arrests per state
Crime <- with(USArrests, Murder+ Rape+ Assault)

#bind Vector Crime to dataframe USArrets and name it USArrests.transform
USArrests.transform <- cbind (USArrests, Crime)

#See if package is installed, and do if not
if (!require("ggplot2")) {
  install.packages("ggplot2")
  library(ggplot2)
}

ggplot (data = USArrests.transform, aes(x= Crime)) + geom_histogram()
# get crime histogram plot and name it crime.plot
crime.plot <- ggplot (data = USArrests.transform, aes(x= Crime)) + geom_histogram()
# get data of crime plot: cols = count, xmin and xmax
crime.data <- ggplot_build(crime.plot)$data[[1]][c("count", "x", "xmin", "xmax")]
# add a id colum for ddply
crime.data$id <- seq(nrow(crime.data))

#See if package is installed, and do if not
if (!require("plyr")) {
  install.packages("plyr")
  library(plyr)
}

#Split data frame, apply function en return results in a data frame: ddply
crime.data.transform <- ddply(crime.data, .(id), function(x) {
  tranche <- USArrests.transform[USArrests.transform$Crime >= x$xmin & USArrests.transform$Crime <= x$xmax, ]
  if(nrow(tranche) == 0) return(c(x$x, 0, 0))
  crime.plot <- c(x=x$x, colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["Crime"] * x$count)
})

#See if package is installed, and do if not
if (!require("reshape2")) {
  install.packages("reshape2")
  library(reshape2)
}

crime.data.transform <- melt(crime.data.transform, id.var="id")
ggplot(data = crime.data.transform, aes(x=id, y=value)) + geom_bar(aes(fill=variable), stat="identity", group=1)

[错误]：上面给出了以下错误：

Error in list_to_dataframe(res, attr(.data, "split_labels"), .id, id_as_factor) : 
  Results do not have equal lengths

随后重塑后的部分错误。

关于我做错了什么以及如何在上面的例子中解决它的任何建议？

r ggplot2 dplyr plyr lapply
1个回答
0
投票

很抱歉，我觉得要做一些代码优化。大部分代码都不是你的，但即使在arun的代码中，我也找到了一些优化空间。让我们看看我改变了什么：

  1. 我删除了你的attach语句，因为它不需要，如果你使用多个数据集，那么使用attach是不好的做法 - 主要是因为你没有跟踪你的数据结构
  2. 如果您创建一个序列并且步骤为1，则只使用:而不是seq。我解释了here why
  3. 代码中的错误：在return(c(x$x, 0, 0))中有一个零到一点。
  4. 此外，你不需要在x$x函数内部使用ddply。因此，它应该只是return(c(0,0,0))，在下一行它需要是c(colSums(tranche)[c("Murder", "Assault", "Rape")]。否则R也将绘制所有x值。
  5. 哎呀！你实际上这里不需要plyr。这个ddply函数只是你的crime.data-data.frame行的一个简单循环。这是你可以使用lapply循环实现的

在这里我可能需要解释一下：plyr-package试图克服apply-family-functions的缺点。除了lapply，他们的行为是相当不可预测的。尤其是sapply可能会从vector返回matrix到list-objects。只有lapply是可靠的 - 它总是给你一个list结果：

USArrests_sum <- cbind (USArrests, arrests=with(USArrests, Murder+ Rape+ Assault))

#See if package is installed, and do if not
if (!require("ggplot2")) {
  install.packages("ggplot2")
  library(ggplot2)
}

# get crime histogram plot and name it crime.plot
crime.plot <- ggplot (data = USArrests_sum, aes(x= arrests)) + geom_histogram()
crime_df <- ggplot_build(crime.plot)$data[[1]][c("count", "x", "xmin", "xmax")] # get data of crime plot: cols = count, xmin and xmax
crime_df$id = 1:nrow(crime_df) #add a id colum for ddply

#Split data frame, apply function en return results in a data frame: ddply
tranche_list<-lapply(1:nrow(crime_df), function(j) {
  myrows<-(USArrests_sum$arrests >= crime_df$xmin[j] & USArrests_sum$arrests <= crime_df$xmax[j])
  tranche <- USArrests_sum[myrows,]
  if(nrow(tranche) == 0) return(c('Murder'=0,'Assault'=0,'Rape'=0))
  crime.plot <- c(colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["arrests"] * crime_df$count[j])
})

另一种方法是使用dplyr来转换您的数据，也许其他人就是这样。我更喜欢做base R。

在下一步中你使用reshape2，后继者是tidyr。但实际上数据结构非常简单。如果您愿意，可以使用base R：

stack_df2<-data.frame(value=as.numeric(unlist(tranche_list)),
                      variable=names(unlist(tranche_list)),
                      id=rep(1:nrow(crime_df),each=3))

ggplot(data = stack_df2, aes(x=id, y=value)) + geom_bar(aes(fill=variable), stat="identity", group=1)

Appendix

我将多个函数与ddply解决方案进行了比较：

plyr_fun<-function(){
  ddply(crime_df, .(id), function(x) {
    tranche <- USArrests_sum[USArrests_sum$arrests >= x$xmin & USArrests_sum$arrests <= x$xmax, ]
    if(nrow(tranche) == 0) return(c(0, 0,0))
    crime.plot <- c(colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["arrests"] * x$count)
  })
}

apply_fun2<-function(){
  res_mat<-t(apply(crime_df, 1, function(x) {
    tranche <- USArrests_sum[USArrests_sum$arrests >= x['xmin'] & USArrests_sum$arrests <= x['xmax'], ]
    if(nrow(tranche) == 0) return(c(0, 0,0))
    crime.plot <- c(colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["arrests"] * x['count'])
  }))
  colnames(res_mat)=c("Murder", "Assault", "Rape")
}

lapply_fun3<-function(){
  tranche_list<-lapply(1:nrow(crime_df), function(j) {
    myrows<-(USArrests_sum$arrests >= crime_df$xmin[j] & USArrests_sum$arrests <= crime_df$xmax[j])
    tranche <- USArrests_sum[myrows,]
    if(nrow(tranche) == 0) return(c(0, 0,0))
    crime.plot <- c(colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["arrests"] * crime_df$count[j])
  })
  do.call(rbind,tranche_list)
}

lapply_fun<-function(){
  tranche_list<-lapply(1:nrow(crime_df), function(j) {
    myrows<-(USArrests_sum$arrests >= crime_df$xmin[j] & USArrests_sum$arrests <= crime_df$xmax[j])
    tranche <- USArrests_sum[myrows,]
    if(nrow(tranche) == 0) return(c('Murder'=0,'Assault'=0,'Rape'=0))
    crime.plot <- c(colSums(tranche)[c("Murder", "Assault", "Rape")]/colSums(tranche)["arrests"] * crime_df$count[j])
  })
}

microbenchmark::microbenchmark(apply_fun2(),lapply_fun3(),lapply_fun(),plyr_fun(),times=1000L)
Unit: milliseconds
          expr    min      lq      mean   median       uq      max neval
  apply_fun2() 5.2307 5.73340  7.169920  6.17165  7.27340  31.5333  1000
 lapply_fun3() 5.3633 5.98930  7.487173  6.40780  7.50115  37.1350  1000
  lapply_fun() 5.4470 5.99295  7.762575  6.43975  7.73060  82.2069  1000
    plyr_fun() 8.8593 9.83850 12.186933 10.54180 12.75880 192.6898  1000

实际上apply函数甚至比lapply解决方案更快。但可读性非常糟糕。通常data.table函数比apply家族快，而dplyr函数运行相对较慢，但具有良好的可读性，适用于代码翻译。

只是为了好玩 - tidyr与我的基础R解决方案的另一个基准：

tidyr_fun<-function(){
  crime_tranche<-do.call(rbind,tranche_list)
  stack_df <- gather(data.frame(crime_tranche,id=1:nrow(crime_df)), key=variable,value=value,-id)
}

base_fun<-function(){
  stack_df2<-data.frame(value=as.numeric(unlist(tranche_list)),
                        variable=names(unlist(tranche_list)),
                        id=rep(1:nrow(crime_df),each=3))
}

microbenchmark::microbenchmark(tidyr_fun(),base_fun())
Unit: microseconds
expr    min      lq     mean  median     uq    max neval
tidyr_fun() 1588.4 1869.45 2516.253 2302.35 2777.9 7671.3   100
base_fun()  286.7  367.40  530.104  454.85  612.8 3675.8   100

# In case you want to verify that the data is the same. identical(stack_df2$id[order(stack_df2$id,stack_df2$variable)],stack_df$id[order(stack_df$id,stack_df$variable)])
identical(stack_df2$value[order(stack_df2$id,stack_df2$variable)],stack_df$value[order(stack_df$id,stack_df$variable)])
identical(as.character(stack_df2$variable[order(stack_df2$id,stack_df2$variable)]),stack_df$variable[order(stack_df$id,stack_df$variable)])
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.