ajout d'étiquettes d'axe "flottantes" dans le tracé facet_wrap

Question

J'ai le même problème que cet utilisateur j'ai un 'irréguliers' facettes de l'intrigue, dans laquelle la ligne du bas a moins de panneaux que les autres lignes, et je voudrais avoir de l'axe des x tiques sur le bas de chaque colonne.

La solution proposée à ce problème était de mettre en scales="free_x". (En ggplot 0.9.2.1; je crois que le comportement je suis à la recherche était par défaut dans les versions antérieures.) C'est une mauvaise solution dans mon cas: mes étiquettes de l'axe sera assez longue, afin de mettre sous chaque ligne d'occuper trop de place. Les résultats sont quelque chose comme ceci:

 x <- gl(3, 1, 15, labels=paste("this is a very long axis label ", letters[1:5]))
 y <- rnorm(length(x))
 l <- gl(5, 3, 15)
 d <- data.frame(x=x, y=y, l=l)
 ggplot(d, aes(x=x, y=y)) + geom_point() + facet_wrap(~l, scales="free_x") + 
   theme(axis.text.x=element_text(angle=90, hjust=1))

Dans un commentaire ici, Andrie suggère qu'il peut être fait manuellement en grid mais je n'ai aucune idée de comment commencer.

Answer 1

Si je me souviens bien, il y avait des questions sur comment ajouter toutes les étiquettes de la même ligne dans la dernière colonne et la manière de lever ces dernières étiquettes jusqu'à la ligne suivante. Voici donc la fonction pour les deux cas:

Edit: puisque c'est comme un substitut pour print.ggplot (voir getAnywhere(print.ggplot)) j'ai ajouté quelques lignes afin de préserver la fonctionnalité.

Edit 2: j'ai amélioré un peu plus: pas besoin de spécifier nrow et ncol plus de, parcelles avec tous les panneaux peuvent être imprimés trop.

library(grid)
# pos - where to add new labels
# newpage, vp - see ?print.ggplot
facetAdjust <- function(x, pos = c("up", "down"), 
                        newpage = is.null(vp), vp = NULL)
{
  # part of print.ggplot
  ggplot2:::set_last_plot(x)
  if(newpage)
    grid.newpage()
  pos <- match.arg(pos)
  p <- ggplot_build(x)
  gtable <- ggplot_gtable(p)
  # finding dimensions
  dims <- apply(p$panel$layout[2:3], 2, max)
  nrow <- dims[1]
  ncol <- dims[2]
  # number of panels in the plot
  panels <- sum(grepl("panel", names(gtable$grobs)))
  space <- ncol * nrow
  # missing panels
  n <- space - panels
  # checking whether modifications are needed
  if(panels != space){
    # indices of panels to fix
    idx <- (space - ncol - n + 1):(space - ncol)
    # copying x-axis of the last existing panel to the chosen panels 
    # in the row above
    gtable$grobs[paste0("axis_b",idx)] <- list(gtable$grobs[[paste0("axis_b",panels)]])
    if(pos == "down"){
      # if pos == down then shifting labels down to the same level as 
      # the x-axis of last panel
      rows <- grep(paste0("axis_b\\-[", idx[1], "-", idx[n], "]"), 
                   gtable$layout$name)
      lastAxis <- grep(paste0("axis_b\\-", panels), gtable$layout$name)
      gtable$layout[rows, c("t","b")] <- gtable$layout[lastAxis, c("t")]
    }
  }
  # again part of print.ggplot, plotting adjusted version
  if(is.null(vp)){
    grid.draw(gtable)
  }
  else{
    if (is.character(vp)) 
      seekViewport(vp)
    else pushViewport(vp)
    grid.draw(gtable)
    upViewport()
  }
  invisible(p)
}

Et voici à quoi il ressemble

d <- ggplot(diamonds, aes(carat, price, fill = ..density..)) +
  xlim(0, 2) + stat_binhex(na.rm = TRUE) + theme(aspect.ratio = 1) + 
  facet_wrap(~ color)
facetAdjust(d)

facetAdjust(d, "down")

Edit 3:

C'est une solution alternative, celle ci-dessus est très bien.

Il y a quelques problèmes lorsque l'on veut utiliser ggsave avec facetAdjust. Un complot de la classe de l' ggplot est nécessaire parce que les deux parties dans le code source de l' ggsave: print(plot) et default_name(plot) dans le cas où l'on n'a pas de fournir un nom de fichier manuellement (selon ?ggsave il semble qu'il n'est pas censé travailler, tout de même). Par conséquent, étant donné un nom de fichier, il y a une solution (peut-être avec des effets secondaires dans certains cas):

D'abord, considérons la fonction séparée qui réalise le principal effet de flottement de l'axe. Normalement, il serait de retour d'un gtable objet, cependant nous utilisons class(gtable) <- c("facetAdjust", "gtable", "ggplot"). De cette manière, il est permis d'utiliser ggsave et print(plot) fonctionne selon les besoins (voir ci-dessous pour print.facetAdjust)

facetAdjust <- function(x, pos = c("up", "down"))
{
  pos <- match.arg(pos)
  p <- ggplot_build(x)
  gtable <- ggplot_gtable(p); dev.off()
  dims <- apply(p$panel$layout[2:3], 2, max)
  nrow <- dims[1]
  ncol <- dims[2]
  panels <- sum(grepl("panel", names(gtable$grobs)))
  space <- ncol * nrow
  n <- space - panels
  if(panels != space){
    idx <- (space - ncol - n + 1):(space - ncol)
    gtable$grobs[paste0("axis_b",idx)] <- list(gtable$grobs[[paste0("axis_b",panels)]])
    if(pos == "down"){
      rows <- grep(paste0("axis_b\\-[", idx[1], "-", idx[n], "]"), 
                   gtable$layout$name)
      lastAxis <- grep(paste0("axis_b\\-", panels), gtable$layout$name)
      gtable$layout[rows, c("t","b")] <- gtable$layout[lastAxis, c("t")]
    }
  }
  class(gtable) <- c("facetAdjust", "gtable", "ggplot"); gtable
}

La fonction d'impression qui ne diffère que par quelques lignes d' ggplot2:::print.ggplot:

print.facetAdjust <- function(x, newpage = is.null(vp), vp = NULL) {
  if(newpage)
    grid.newpage()
  if(is.null(vp)){
    grid.draw(x)
  } else {
    if (is.character(vp)) 
      seekViewport(vp)
    else pushViewport(vp)
    grid.draw(x)
    upViewport()
  }
  invisible(x)
}

Exemple:

d <- ggplot(diamonds, aes(carat, price, fill = ..density..)) +
  xlim(0, 2) + stat_binhex(na.rm = TRUE) + theme(aspect.ratio = 1) + 
  facet_wrap(~ color)
p <- facetAdjust(d) # No output
print(p) # The same output as with the old version of facetAdjust()
ggsave("name.pdf", p) # Works, a filename is necessary