Create custom shapes

Question

I'm a bit lost on this one, I've tried messing around with geom_polygon but successive attempts seem worse than the previous.

The image that I'm trying to recreate is this, the colours are unimportant, but the positions are:

In addition to creating this, I also need to be able to label each element with text.

At this point, I'm not expecting a solution (although that would be ideal) but pointers or similar examples would be immensely helpful.

One option that I played with was hacking scale_shape and using 1,1 as coords. But was stuck with being able to add labels.

The reason I'm doing this with ggplot, is because I'm generating scorecards on a company by company basis. This is only one plot in a 4 x 10 grid of other plots (using pushViewport)

Note: The top tier of the pyramid could also be a rectangle of similar size.

Full Disclosure: This was also posted to the ggplot2 mailing list. (I'll update if I receive a response)

Answer 1

It seems like you could use a combination of geom_path() and geom_segment() since you either know or can reasonably guesstimate the coordinate locations for each major point on your graph/chart/thingamajigger up there. Maybe something like this would work? The data.frame that was constructed contains the outline of the shape above (I opted for the rectangle at the top...I'm sure you could find an easy way to generate the points to approximate a circle if you really wanted. Then use geom_segment() to divvy up that large shape as you need.

df <- data.frame(
    x = c(-8,-4,4,8,-8, -8, -8, 8, 8, -8)
    , y = c(0,18,18,0,0, 18, 22, 22, 18, 18)
    , group = c(rep(1,5), rep(2,5)))
    
qplot(x,y, data = df, geom = "path", group = group)+
    geom_segment(aes(x = 0, y = 0, xend = 0, yend = 12 )) +
    geom_segment(aes(x = -6.75, y = 6, xend = 6.75, yend = 6)) +
    geom_segment(aes(x = -5.25, y = 12, xend = 5.25, yend = 12)) +
    geom_segment(aes(x = -2, y = 12, xend = -2, yend = 18)) + 
    geom_segment(aes(x = 2, y = 12, xend = 2, yend = 18)) + 
    geom_text(aes(x = -5, y = 2.5), label = "hi world")

---

Edit: qplot() was deprecated in ggplot2 3.4.0. Here is the same code using ggplot aes:

ggplot(data = df,aes(x, y, group = group)) +
  geom_path() +
  geom_segment(aes(x = 0, y = 0, xend = 0, yend = 12 )) +
  geom_segment(aes(x = -6.75, y = 6, xend = 6.75, yend = 6)) +
  geom_segment(aes(x = -5.25, y = 12, xend = 5.25, yend = 12)) +
  geom_segment(aes(x = -2, y = 12, xend = -2, yend = 18)) + 
  geom_segment(aes(x = 2, y = 12, xend = 2, yend = 18)) + 
  geom_text(aes(x = -5, y = 2.5), label = "hi world")

Answer 2

Here is my proposed solution. Create a series of polygon data, and use geom_polygon() to plot these. Plot the text labels with geom_text().

Create the ellipse with ellipsoidhull(), in the cluster package.

You will want to modify the plot aesthetics by removing the legend, gridlines, axis labels, etc.

library(ggplot2)
library(cluster)

mirror <- function(poly){
    m <- poly
    m$x <- -m$x
    m
}

poly_br <- data.frame(
        x=c(0, 4, 3, 0),
        y=c(0, 0, 1, 1),
        fill=rep("A", 4)
)


poly_mr <- data.frame(
        x=c(0, 3, 2, 0),
        y=c(1, 1, 2, 2),
        fill=rep("B", 4)
)

poly_tr <- data.frame(
        x=c(0.5, 2, 1, 0.5),
        y=c(2, 2, 3, 3),
        fill=rep("C", 4)
)

poly_tm <- data.frame(
        x=c(-0.5, 0.5, 0.5, -0.5),
        y=c(2, 2, 3, 3),
        fill=rep("D", 4)
        )

poly_bl <- mirror(poly_br)
poly_ml <- mirror(poly_mr)
poly_tl <- mirror(poly_tr)


get_ellipse <- function(data, fill){
    edata <- as.matrix(data)
    ehull <- ellipsoidhull(edata)
    phull <- as.data.frame(predict(ehull))
    data.frame(
            x=phull$V1, 
            y=phull$y, 
            fill=rep(fill, nrow(phull))
    )
}

ellipse <- get_ellipse(
        data.frame(
                x=c(0, 2, 0, -2),
                y=c(3, 3.5, 4, 3.5)
    ), fill="E"
)

text <- data.frame(
        x=c(2, -2, 1.5, -1.5, 1.25, -1.25, 0, 0),
        y=c(0.5, 0.5, 1.5, 1.5, 2.5, 2.5, 2.5, 3.5),
        text=c("br", "bl", "mr", "ml", "tr", "tl", "tm", "ellipse"))


poly <- rbind(poly_br, poly_bl, poly_mr, poly_ml, poly_tr, poly_tm, poly_tl, ellipse)


p <- ggplot() + 
        geom_polygon(data=poly, aes(x=x, y=y, fill=fill), colour="black") +
        geom_text(data=text, aes(x=x, y=y, label=text))
print(p)

Answer 3

With grid graphics,

 library(grid)

 ellipse <- function (x = 0, y = 0, a=1, b=1,
                      angle = pi/3, n=300) 
 {

   cc <- exp(seq(0, n) * (0+2i) * pi/n) 

   R <- matrix(c(cos(angle), sin(angle),
                 -sin(angle), cos(angle)), ncol=2, byrow=T)

   res <- cbind(x=a*Re(cc), y=b*Im(cc)) %*% R
   data.frame(x=res[,1]+x,y=res[,2]+y)
 }


 pyramidGrob <- function(labels = c("ellipse", paste("cell",1:7)),
                         slope=5,
                         width=1, height=1,
                         fills=c(rgb(0, 113, 193, max=256),
                           rgb(163, 163, 223, max=256),
                           rgb(209, 210, 240, max=256),
                           rgb(217, 217, 217, max=256)), ...,
                         draw=FALSE){

   a <- 0.4
   b <- 0.14
   ye <- 3/4 + b*sin(acos((3/4 / slope-0.5)/a))
   e <- ellipse(0.5, ye, a=a, b=b,angle=0)
   g1 <- polygonGrob(e$x, e$y, gp=gpar(fill=fills[1]))

   x1 <- c(0, 0.5, 0.5, 1/4 / slope, 0)
   y1 <- c(0, 0, 1/4, 1/4, 0)

   x2 <- c(1/4 / slope, 0.5, 0.5, 1/2 / slope, 1/4/slope)
   y2 <- y1 + 1/4

   x3 <- c(1/2 / slope, 0.5, 0.5, 3/4 / slope,  1/2/slope)
   y3 <- y2 + 1/4

   x4 <- c(0.5 - 3/4/slope, 0.5 + 3/4/slope,
           0.5 + 3/4 / slope, 0.5 - 3/4/slope,
           0.5 - 3/4/slope)

   y4 <- y3

   d <- data.frame(x = c(x1,1-x1,x2,1-x2,x3,1-x3,x4),
                   y = c(y1,y1,y2,y2,y3,y3,y4),
                   id = rep(seq(1,7), each=5))

   g2 <- with(d, polygonGrob(x, y, id,
                   gp=gpar(fill=fills[c(rep(2:4,each=2),4)])))

   x5 <- c(0.5, 0.25, 0.25, 0.25, 0.75, 0.75, 0.75, 0.5)
   y5 <- c(3/4+1/8, 1/8, 1/2 - 1/8, 1/2 + 1/8,
           1/8, 1/2 - 1/8, 1/2 + 1/8, 1/2 + 1/8)

   g3 <- textGrob(labels, x5,y5, vjust=1)
   g <- gTree(children=gList(g1,g2,g3), ...,
              vp=viewport(width=width,height=height))

   if(draw) grid.draw(g)
   invisible(g)
 }


 grid.newpage()

 ## library(gridExtra)
 source("http://gridextra.googlecode.com/svn/trunk/R/arrange.r")

 grid.arrange(pyramidGrob(height=0.4),
              pyramidGrob(),
              pyramidGrob(width=0.5),ncol=2)

Further, Grid viewports can be used to place different objects on the same page. For instance,

library(gridExtra)


grid.arrange(tableGrob(head(iris)[,1:3]),
           pyramidGrob(), qplot(1:10,1:10),
           lattice::xyplot(1:10~1:10), ncol=2, 
           main = "arrangement of Grid elements")