Можете ли вы легко нанести ковры / оси сверху / справа в ggplot2?

Question

Следующий пример не имеет внутреннего значения ... он просто предназначен для демонстрации конкретного размещения надписей, ковриков и т. Д. И является представителем [отредактировано] (a) значительно более крупного проекта, над которым я работаю Я не могу подробно обсуждать, (б) который требует использования ggplot, и (в) нужны визуальные особенности графики, аналогичные отраженным на графике ниже.

Возможно ли воссоздать следующее, используя ggplot2 напрямую или с некоторой манипуляцией с сеткой?

x <- rnorm(20)
y <- rnorm(20)

plot(x, y, axes=F, xlab="", ylab="")

axis(side = 1, at = round(mean(x), 2))
axis(side = 2, at = round(mean(y), 2))

axis(side = 3, at = round( range(x), 2 ))
axis(side = 4, at = round( range(y), 2 ))

rug(x, side=3)
rug(y, side=4)

---

Пожалуйста, смотрите решения (Chase's, модифицированные и основанные на коде Хэдли Geom), опубликованные ниже

Answer 1

Я повторю вопрос Гэвина, но, ради всего прочего, это должно вас довольно близко:

qplot(x,y) + 
    geom_segment(data = data.frame(x), aes(x = x, y = max(x) - .05, xend = x, yend = max(x))) +         #x-rug
    geom_segment(data = data.frame(x), aes(x = min(x), y = max(x), xend = max(x), yend = max(x))) +     #x-rug
    geom_segment(data = data.frame(y), aes(x = max(x) + .05, y = y, xend = max(x), yend = y)) +         #y-rug
    geom_segment(data = data.frame(y), aes(x = max(x) + .05, y = min(y), xend = max(x) + .05, yend = max(y) )) + #y-rug
    scale_x_continuous(breaks = NA) +   
    scale_y_continuous(breaks = NA) +
    xlab(NULL) +
    ylab(NULL) +
    geom_text(aes(label = round(mean(x),2), x = mean(x), y = min(y) - .2), size = 4) +
    geom_text(aes(label = round(mean(y),2), x = min(x) - .2, y = mean(y)), size = 4) + 
    geom_text(aes(label = round(max(x),2), x = max(x) + .2, y = max(y) + .2), size = 4)
    #...add other text labels to your heart's desire.

Если вам не нужно ставить коврики сверху и справа, вы можете воспользоваться geom_rug(). Я не знаю простого способа «отодвинуть» оси x или y от их предопределенных мест. Что-то вроде этого может быть легче переварить / работать с:

df <- data.frame(x,y)
qplot(x,y, data = df, geom = c("point", "rug")) # + ...any additional geom's here

Answer 2

Принятые решения

---

Ответ Чейза (изменен)

Ответ Чейза имел несколько X и Y, неуместных, в результате чего верхняя / правая оси неожиданно всплыли ... Вотобновленная версия:

xxx <- function(x, y) {

 p <- qplot(x,y) + 
    geom_segment(data     = data.frame(x), 
                 aes(x    = x, 
                     y    = max(y) + .05, 
                     xend = x, 
                     yend = max(y) + .1  )) +     #top-ticks

    geom_segment(data     = data.frame(x), 
                 aes(x    = min(x), 
                     y    = max(y) + .1, 
                     xend = max(x), 
                     yend = max(y) + .1  )) +     #top-axis

    geom_segment(data     = data.frame(y), 
                 aes(x    = max(x) + .1, 
                     y    = y, 
                     xend = max(x) + .05, 
                     yend = y)) +                #right-ticks

    geom_segment(data     = data.frame(y), 
                 aes(x    = max(x) + .1, 
                     y    = min(y), 
                     xend = max(x) + .1, 
                     yend = max(y)     )) +      #right-axis

    scale_x_continuous(breaks = NA) +   
    scale_y_continuous(breaks = NA) +
    xlab(NULL) +
    ylab(NULL) +
    geom_text(aes(label = round(mean(x), 2), 
                  x     = mean(x), 
                  y     = min(y) - .2), 
              size = 4) +

    geom_text(aes(label = round(mean(y), 2), 
                  x     = min(x) - .2, 
                  y     = mean(y)), 
              size = 4) + 

    geom_text(aes(label = round(max(y), 2), 
                  x     = max(x) + .5, 
                  y     = max(y) + .0),        
              size = 4) +                   #right-max

    geom_text(aes(label = round(min(y), 2), 
                  x     = max(x) + .5, 
                  y     = min(y) - .0),         
              size = 4) +                    #right-min

    geom_text(aes(label = round(max(x), 2), 
                  x     = max(x) + .0, 
                  y     = max(y) + .2),        
              size = 4) +                   #top-max

    geom_text(aes(label = round(min(x), 2), 
                  x     = min(x) + .0, 
                  y     = max(y) + .2),         
              size = 4)                     #top-min

}

x <- rnorm(20)
y <- rnorm(20)

(xxx(x, y))

---

Решение, основанное на коде Хэдли

См .: https://github.com/hadley/ggplot2/wiki/Creating-a-new-geom

Начиная с geom-rug.r Хэдли, по сутиЯ изменил только расположение ковров, изменив эти две (частичные) строки:

С

         y0 = unit(0, "npc"), y1 = unit(0.03, "npc"),

до

         y0 = unit(1.02, "npc"), y1 = unit(1.05, "npc"),

и с

         x0 = unit(0, "npc"), x1 = unit(0.03, "npc"),

до

         x0 = unit(1.02, "npc"), x1 = unit(1.05, "npc"),

---

 library(ggplot2)

 GeomRugAlt <- proto(Geom, {
   draw <- function(., data, scales, coordinates, ...) {  
     rugs <- list()
     data <- coordinates$transform(data, scales)    
     if (!is.null(data$x)) {
       rugs$x <- with(data, segmentsGrob(
         x0 = unit(x, "native"), x1 = unit(x, "native"), 
         y0 = unit(1.02, "npc"), y1 = unit(1.05, "npc"),
         gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
       ))
     }  

     if (!is.null(data$y)) {
       rugs$y <- with(data, segmentsGrob(
         y0 = unit(y, "native"), y1 = unit(y, "native"), 
         x0 = unit(1.02, "npc"), x1 = unit(1.05), "npc"),
         gp = gpar(col = alpha(colour, alpha), lty = linetype, lwd = size * .pt)
       ))
     }  

     gTree(children = do.call("gList", rugs))
   }

   objname <- "rug_alt"

   desc <- "Marginal rug plots"

   default_stat <- function(.) StatIdentity
   default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = 1)
   guide_geom <- function(.) "path"

   examples <- function(.) {
     p <- ggplot(mtcars, aes(x=wt, y=mpg))
     p + geom_point()
     p + geom_point() + geom_rug_alt()
     p + geom_point() + geom_rug_alt(position='jitter')
   }


 })

 geom_rug_alt <- GeomRugAlt$build_accessor()

 x <- rnorm(20)
 y <- rnorm(20)

 p <- qplot(x,y)
 p
 p + geom_rug() + geom_rug_alt()