Включить небольшую таблицу в легенду в графике R

Question

Я строю точечный график продаж для компаний, сгруппированных по странам. Итак, мой код dotchart(sales, labels=company, groups=country, data=mydata). Я также создал таблицу средних значений продаж по странам. Есть ли способ включить эту таблицу в качестве легенды внутри точечного графика?

Четыре часа спустя ... Я просто наткнулся на действительно аккуратный способ добавления табличной информации к графикам с помощью команды addtable2plot в пакете plotrix. Следуя примеру ЧЛ:

res <- matrix(nc=3, nr=4)
for (i in 1:4) res[i,] <- tapply(iris[,i], iris[,5], mean)
colnames(res) <- levels(iris[,5])
rownames(res) <- colnames(iris)[1:4]

library(plotrix)
dotchart(res, auto.key=list(position="top", column=3), xlab="Mean"); addtable2plot(3,15, res, cex=.8)

Answer 1

Вот мой дубль grid (и набор данных Iris):

library(lattice)
library(grid)
library(gridExtra)
res <- matrix(nc=3, nr=4)
for (i in 1:4) res[i,] <- tapply(iris[,i], iris[,5], mean)
colnames(res) <- levels(iris[,5])
rownames(res) <- colnames(iris)[1:4]
dp <- dotplot(res, auto.key=list(position="top", column=3), xlab="Mean")

pdf("1.pdf", width=10, height=5)
grid.newpage() 
pushViewport(viewport(layout=grid.layout(1, 2, widths=unit(c(5,4), "inches"))))

pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) 
print(dp, newpage=FALSE) 
popViewport(1)

pushViewport(viewport(layout.pos.col=2, layout.pos.row=1, clip="on"))
grid.draw(tableGrob(head(iris), gp=gpar(fontsize=6, lwd=.5)))
popViewport()
dev.off()

Другое решение с ggplot2 доступно только на странице github Хэдли Уикхэма, Смешивание графиков ggplot2 с другими графическими выводами . Наконец, страница справки для gridExtra::grid.arrange() содержит дополнительный пример.

Чтобы показать таблицу внутри графика, мы можем изменить код следующим образом:

grid.newpage() 
pushViewport(viewport(layout=grid.layout(1, 1, widths=unit(c(5,4), "inches"))))

pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) 
print(dp, newpage=FALSE) 
popViewport(1)

pushViewport(viewport(x=0.5, y=0.3, clip="off"))
grid.draw(tableGrob(head(iris), padding.v=unit(1, "mm"), padding.h=unit(1, "mm"), 
          gp=gpar(fontsize=6, lwd=.5)))
popViewport()

что дает

(Цвет фона ячеек можно изменить с помощью theme= при вызове tableGrob().)

Answer 2

Возможно, вариант заключается в преобразовании легенды в таблицу:

library(dplyr)
library(stringr)
library(ggplot2)
windowsFonts(CourierNew=windowsFont("Courier New")) # ONLY FOR WINDOWS

#1. GET THE SUMMARY STATS FROM YOUR TABLE
data<-iris %>% group_by(Species) %>% 
  summarise(Sepal.Len = paste(format(round(median(Sepal.Length),2),nsmall=2) ), 
            P.len = tryCatch(paste(format(round(median(Petal.Length),2),nsmall=2) ),error = function(e) {"NA" ; "NA"} )  ,
            counts=n() )


data<-as.data.frame(data)
data
#      Species Sepal.Len P.len counts
# 1     setosa      5.00  1.50     50
# 2 versicolor      5.90  4.35     50
# 3  virginica      6.50  5.55     50

# 2. CREATE THE TITLE OF THE LEGEND BASED ON YOUR STATS
  make.title.legend <- function(data) {
  list<-list()
  x<-1
  nchar1<-max(nchar(as.character(data[,x])) )
  nchar2<-nchar(colnames(data)[x])
  maxdif<-max(c(nchar2,nchar1))-min(c(nchar2,nchar1))
  first <-  paste0(colnames(data)[x], sep=paste(replicate(maxdif, " "), collapse = "")) 
  list[[first]] <-first
  for (i in 1:(ncol(data)-1)) {
    x<-i+1
    nchar1<-max(nchar(as.character(data[,x])) )
    nchar2<-nchar(colnames(data)[x])
    maxdif<-if(nchar2>nchar1){0} else {nchar1-nchar2}#
    first <-  paste0(colnames(data)[x], sep=paste(replicate(maxdif, " "), collapse = "")) 
    list[[first]] <-first
    title<-str_c(list, collapse = " ")
  }
  return(title)
}

title<-make.title.legend(data)
title
#[1] "Species    Sepal.Len P.len counts"

# 3. CONCATENATE STAT COLUMNS IN A NEW JUSTIFIED COLUMN WITH ALL STATS
make.legend.withstats <- function(data,namecol) {
  nchar1<-nchar(as.character(data[,1])) 
  nchar2<-nchar(colnames(data)[1])
  maxlen<-max(c(nchar1,nchar2))
  data[,1]<-sprintf(paste0("%-",maxlen,"s"), data[,1])    
  data[,ncol(data)+1]<-paste(data[,1],data[,2],sep=" ")
  ncharmin2<-min(nchar(data[,2]))
  y<- ncharmin2-1
  nchara1<-nchar(data[,ncol(data)] ) # 7
  init1<-min(nchara1)
  y2<-init1-1
  minchar<-min(nchar(data[,2]))
  maxchar<-max(c(nchar(colnames(data)[2]),(nchar(data[,2]))))
  dif<-maxchar-minchar
  if (dif>0){ 
    for (i3 in minchar:(maxchar-1)) { 
      y2<-y2+1
      y<-y+1
      str_sub(data[nchar(data[,ncol(data)]) == y2, ][,ncol(data)], y2-y, y2-y)<- "  "
    } 
  }
  nd<-ncol(data)-2
  if(ncol(data)>3){ 
    for (i in 2:nd) {  
      x3<-i
      data[,ncol(data)+1]<-paste(data[,ncol(data)],data[,x3+1],sep=" ")  
      minchar<-min(nchar(data[,x3+1]))
      maxchar<-max(c(nchar(colnames(data)[x3+1]),(nchar(data[,x3+1]))))
      ncharmin2<-min(nchar(data[,x3+1]))
      y<- ncharmin2-1
      nchara1<-nchar(data[,ncol(data)] ) 
      init1<-min(nchara1)
      y2<-init1-1
      dif<-maxchar-minchar
      if (dif>0){ 
        for (i2 in minchar:(maxchar-1)) { 
          y2<-y2+1
          y<-y+1
          str_sub(data[nchar(data[,ncol(data)]) == y2, ][,ncol(data)], y2-y, y2-y)<- "  "
        }
      }
    }
  }
    data<-  as.data.frame(data[,c(1,ncol(data))])
    names(data)[2]<-paste(namecol)
    data[,1]<-gsub("\\s+$", "", data[,1]) 
    data
}   
newlabel<-make.legend.withstats(data,title)
newlabel

#     Species Species    Sepal.Len P.len counts
# 1     setosa     setosa     5.00      1.50  50
# 2 versicolor     versicolor 5.90      4.35  50
# 3  virginica     virginica  6.50      5.55  50

# 4. MERGE ORIGINAL DATAFRAME WITH DATAFRAME WITH STATS
newirislabel=merge(iris, newlabel, all.x = TRUE)
head(newirislabel)
#  Species Sepal.Length Sepal.Width Petal.Length Petal.Width Species    Sepal.Len P.len counts
#1  setosa          5.1         3.5          1.4         0.2     setosa     5.00      1.50  50

# 5. GRAPH
g1 <- ggplot(newirislabel, aes(Sepal.Length,  Petal.Length, colour=as.factor(newirislabel[,ncol(newirislabel)] ) ) )   
g2 <- g1+ guides(color = guide_legend(keywidth = 1, keyheight = 1)) # for histogram use guides(fill =
g3 <- g2+ geom_point() + labs(color=paste0("   ",title) )+ theme(legend.position=c(0.75,0.15), legend.direction="vertical"
)+ theme(legend.title=element_text(family="CourierNew",size=rel(1), face = "italic"), 
         legend.text=element_text(family="CourierNew",size=rel(1))) + labs(x = "Sepal len", y = " Petal len ")
g3