colourlovers
colourlovers copied to clipboard
andrewheiss
pattern aesthetic for ggplot2 geom_bar?
I'm opening issue with no pressure on you!
If I were to write such a code I'd need to:
- look how geom_bar fill works (would the pattern aes make sense for other geom's?)
- understand how to crop images
- also find out how to have a legend.
I've thought of an ugly solution which wouldn't be an aes: using ImageMagick I could make holes in the picture for each colour and overlay the picture on the pattern, and repeat this for each fill.
Hum, this would be quite ugly.
library("colourlovers")
library("ggplot2")
# plot for testing idea
qplot(factor(cyl), data=mtcars, geom="bar", fill=factor(cyl)) +
scale_fill_manual(values = c("red", "blue", "darkgreen"))
ggsave(file = "test.png", height = 10, width = 10, units = "cm")
i <- 1
for(col in c("red", "blue", "darkgreen")){
# make colour transparent
shell(paste0("convert test.png -fuzz 10% -transparent ",col," test.png"))
# download a popular pattern
jpeg("pattern1.jpg", height = 480, width = 480)
plot(clpatterns('top')[[i]])
dev.off()
shell("convert -size 393x393 pattern1.jpg -resize 1181x1181 pattern1.jpg")
# create the overlayed picture
shell("composite test.png pattern1.jpg test.png")
i <- i+1
}
Plus using the loop there is a risk to modify the patterns that were already applied.
That's actually a pretty awesomely terrible graph. I think theme still hope for this, that specific example aside.
Yeah I've given it more thought and I still long for it actually. That'd be so cool.
I'd be better to use the raster returned by the API. I'll go and have a look at the ggplot2 repo which will make me smarter!
So I'm going to stop now but I explored an idea.
### packages
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
# get pattern
p <- clpattern('1047011', fmt='json')
picture <- content(GET(p$imageUrl))
# picture is a 4 dimensional array
img <- as.raster(picture)
# rectangle example
d=data.frame(x1=c(1,3,1,5,4), x2=c(2,4,3,6,6), y1=c(1,1,4,1,3), y2=c(2,2,5,3,5), t=c('a','a','a','b','b'), r=c(1,2,3,4,5))
# data.frame with hex info for each point,
# x and y resized for filling the biggest rectangle
maxX <- max(d$x2 - d$x1)
maxY <- max(d$y2 - d$y1)
maxx <- max(maxX, maxY)
img2 <- tbl_df(as.data.frame(as.matrix(img)))
names(img2) <- 1:ncol(img2)
row.names(img2) <- nrow(img2):1
img2 <- img2 %>%
mutate(y = row.names(img2)) %>%
gather(x, value, 1:ncol(img)) %>%
mutate(x = as.numeric(x),
y = as.numeric(y)) %>%
mutate(x = (x/max(x)) * maxx,
y = (y/max(y)) * maxx)
# basic plot
p <- ggplot() +
scale_x_continuous(name="x") +
scale_y_continuous(name="y") +
geom_rect(data=d, mapping=aes(xmin=x1, xmax=x2, ymin=y1, ymax=y2, fill=t), color="black", alpha=0.5) +
geom_text(data=d, aes(x=x1+(x2-x1)/2, y=y1+(y2-y1)/2, label=r), size=4) +
theme(legend.position = "none")
ggsave(p, file = "basic.png")
# now add the pattern filling to each rectangle
for (i in 1:nrow(d)){
# only keep part of the data.frame/pattern
xmax <- d[i, "x2"] - d[i, "x1"]
ymax <- d[i, "y2"] - d[i, "y1"]
dataPlot <- filter(img2,
x <= xmax,
y <= ymax) %>%
# and shift the coordinates
mutate(x = x + d[i, "x1"],
y = y + d[i, "y1"])
p <- p +
geom_point(data=dataPlot, aes(x, y, col = value))
}
ggsave(p, file = "lion.png")
This is encouraging but:
- With geom_point I have a color scale problem for now (well I didn't try too hard to change it!)
- It means that for anything I want to fill with the pattern, I need to be able to filter part of the pattern.
- For now it's a loop but I should transform the initial pattern data.frame into a data.frame with values for any x and y on the graphic.
- I don't know how this solution would lead to having a legend.
- The choice of the rescaling of the pattern is quite important for having a nice pattern. Moreover, I may need to repeat the pattern.
We'll see if it leads me anywhere some day... Maybe I should ask for help on Twitter? Or would you ask?
Anyway, it's nice to learn more about ggplot2!
Maybe I should make this an issue for the Ropensci unconf but I doubt that wanting to put cute animals on ggplot2 is relevant. :smile:
Better try, thanks to Jim Hester.
### packages
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
library("colourlovers")
# get pattern
p <- clpattern('1047011', fmt='json')
picture <- content(GET(p$imageUrl))
# picture is a 4 dimensional array
img <- as.raster(picture)
# rectangle example
d=data.frame(x1=c(1,3,1,5,4), x2=c(2,4,3,6,6), y1=c(1,1,4,1,3), y2=c(2,2,5,3,5), t=c('a','a','a','b','b'), r=c(1,2,3,4,5))
# data.frame with hex info for each point,
# x and y resized for filling the biggest rectangle
maxX <- max(d$x2 - d$x1)
maxY <- max(d$y2 - d$y1)
maxx <- max(maxX, maxY)
img2 <- tbl_df(as.data.frame(as.matrix(img)))
names(img2) <- 1:ncol(img2)
row.names(img2) <- nrow(img2):1
img2 <- img2 %>%
mutate(y = row.names(img2)) %>%
gather(x, value, 1:ncol(img)) %>%
mutate(x = as.numeric(x),
y = as.numeric(y)) %>%
mutate(x = (x/max(x)) * maxx,
y = (y/max(y)) * maxx)
# basic plot
p <- ggplot() +
scale_x_continuous(name="x") +
scale_y_continuous(name="y") +
geom_rect(data=d, mapping=aes(xmin=x1, xmax=x2, ymin=y1, ymax=y2, fill=t), color="black", alpha=0.5) +
geom_text(data=d, aes(x=x1+(x2-x1)/2, y=y1+(y2-y1)/2, label=r), size=4) +
theme(legend.position = "none")
ggsave(p, file = "basic.png")
# now add the pattern filling to each rectangle
for (i in 1:nrow(d)){
# only keep part of the data.frame/pattern
xmax <- d[i, "x2"] - d[i, "x1"]
ymax <- d[i, "y2"] - d[i, "y1"]
dataPlot <- filter(img2,
x <= xmax,
y <= ymax)
dataPlot <- dataPlot %>%
# and shift the coordinates
mutate(x = x + d[i, "x1"],
y = y + d[i, "y1"])
p <- p + geom_raster(data = dataPlot, aes(x, y), fill = dataPlot$value)
}
ggsave(p, file = "lion.png")
I may have an idea for doing a legend. I could extract the first colour of the pattern (first in the list, it might not be the most important one in the pattern?) and use it as fill before adding the pattern. That'd be easy and would do the job.
I still don't know how to better resize/crop.
New progress! Better resizing/cropping I think.
### packages
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
library("colourlovers")
# get pattern
p <- clpattern('1047011', fmt='json')
picture <- content(GET(p$imageUrl))
# picture is a 4 dimensional array
img <- as.raster(picture)
# rectangle example
d=data.frame(x1=c(1,3,1,5,4), x2=c(2,4,3,6,6), y1=c(1,1,4,1,3), y2=c(2,2,5,3,5), t=c('a','a','a','b','b'), r=c(1,2,3,4,5))
# find the smallest distance between x/y
maxX <- min(d$x2 - d$x1)
maxY <- min(d$y2 - d$y1)
maxx <- min(maxX, maxY)
# basic plot
p <- ggplot() +
scale_x_continuous(name="x") +
scale_y_continuous(name="y") +
geom_rect(data=d, mapping=aes(xmin=x1, xmax=x2, ymin=y1, ymax=y2, fill=t), color="black", alpha=0.5) +
geom_text(data=d, aes(x=x1+(x2-x1)/2, y=y1+(y2-y1)/2, label=r), size=4) +
theme(legend.position = "none")
ggsave(p, file = "basic.png")
# now add the pattern filling to each rectangle
for (i in 1:nrow(d)){
# we have to repeat the data.frame/pattern
xmax <- d[i, "x2"] - d[i, "x1"]
ymax <- d[i, "y2"] - d[i, "y1"]
sizex <- ceiling(xmax/maxx)
sizey <- ceiling(ymax/maxx)
size <- max(sizex, sizey)
img2 <- apply(img,MARGIN=1,function(x) rep(x,size))
img2 <- apply(img2,MARGIN=1,function(x) rep(x,size))
# from matrix to data.frame
img2 <- tbl_df(as.data.frame(as.matrix(img2)))
names(img2) <- 1:ncol(img2)
row.names(img2) <- nrow(img2):1
dataPlot <- img2 %>%
mutate(y = row.names(img2)) %>%
gather(x, value, 1:ncol(img2)) %>%
mutate(x = as.numeric(x)/nrow(img2)*size,
y = as.numeric(y)/nrow(img2)*size)
# only keep the points that are in the rectangle
dataPlot <- dataPlot %>%
filter(x <= xmax, y <= ymax)
dataPlot <- dataPlot %>%
# and shift the coordinates
mutate(x = x + d[i, "x1"],
y = y + d[i, "y1"])
p <- p + geom_point(data = dataPlot, aes(x, y), col = dataPlot$value)
}
ggsave(p, file = "lion.png")
Ooh, fun. Want to put together a vignette? On Mar 18, 2016 3:09 PM, "Maëlle Salmon" [email protected] wrote:
New progress! Better resizing/cropping I think.
packages
library("dplyr") library("tidyr") library("httr") library("grid") library("ggplot2") library("colourlovers")# get patternp <- clpattern('1047011', fmt='json')picture <- content(GET(p$imageUrl))# picture is a 4 dimensional arrayimg <- as.raster(picture)
rectangle exampled=data.frame(x1=c(1,3,1,5,4), x2=c(2,4,3,6,6), y1=c(1,1,4,1,3), y2=c(2,2,5,3,5), t=c('a','a','a','b','b'), r=c(1,2,3,4,5))
find the smallest distance between x/ymaxX <- min(d$x2 - d$x1)maxY <- min(d$y2 - d$y1)maxx <- min(maxX, maxY)
basic plotp <- ggplot() +
scale_x_continuous(name="x") + scale_y_continuous(name="y") + geom_rect(data=d, mapping=aes(xmin=x1, xmax=x2, ymin=y1, ymax=y2, fill=t), color="black", alpha=0.5) + geom_text(data=d, aes(x=x1+(x2-x1)/2, y=y1+(y2-y1)/2, label=r), size=4) + theme(legend.position = "none") ggsave(p, file = "basic.png")# now add the pattern filling to each rectanglefor (i in 1:nrow(d)){
we have to repeat the data.frame/pattern
xmax <- d[i, "x2"] - d[i, "x1"] ymax <- d[i, "y2"] - d[i, "y1"]
sizex <- ceiling(xmax/maxx) sizey <- ceiling(ymax/maxx)
size <- max(sizex, sizey)
img2 <- apply(img,MARGIN=1,function(x) rep(x,size)) img2 <- apply(img2,MARGIN=1,function(x) rep(x,size))
from matrix to data.frame
img2 <- tbl_df(as.data.frame(as.matrix(img2))) names(img2) <- 1:ncol(img2) row.names(img2) <- nrow(img2):1 dataPlot <- img2 %>% mutate(y = row.names(img2)) %>% gather(x, value, 1:ncol(img2)) %>% mutate(x = as.numeric(x)/nrow(img2)_size, y = as.numeric(y)/nrow(img2)_size)
only keep the points that are in the rectangle
dataPlot <- dataPlot %>% filter(x <= xmax, y <= ymax) dataPlot <- dataPlot %>% # and shift the coordinates mutate(x = x + d[i, "x1"], y = y + d[i, "y1"])
p <- p + geom_point(data = dataPlot, aes(x, y), col = dataPlot$value) } ggsave(p, file = "lion.png")
[image: basic] https://cloud.githubusercontent.com/assets/8360597/13880158/47c72c8e-ed1b-11e5-9b30-25788458c0d9.png [image: lion] https://cloud.githubusercontent.com/assets/8360597/13880157/47c6c3ca-ed1b-11e5-857e-7852a1abc854.png
— You are receiving this because you commented. Reply to this email directly or view it on GitHub https://github.com/leeper/colourlovers/issues/4#issuecomment-198376051
I'm having way too much fun with this actually. When I've something substantial for a geom_bar I'll write something up and stop polluting your issues board, hehe.
For what else could it be good to have pattern fills? I guess only rectangles and geom_bar?
Background images? On Mar 18, 2016 3:46 PM, "Maëlle Salmon" [email protected] wrote:
I'm having way too much fun with this actually. When I've something substantial for a geom_bar I'll write something up and stop polluting your issues board, hehe.
For what else could it be good to have pattern fills? I guess only rectangles and geom_bar?
— You are receiving this because you commented. Reply to this email directly or view it on GitHub https://github.com/leeper/colourlovers/issues/4#issuecomment-198392654
Ah yes you're right. So
- background image (challenge = find the x and y range of the pattern unit, then easy to repeat it -- it would need to be made first before adding any geom) + geom surface
- filling rectangles (same challenge, actually it's the whole problem for all applications)
- geom_bar with possibly fill depending on a factor, legend made with a classical colour fill with a colour from the corresponding pattern.
I won't be very fast but eventually I want to write the code and explanations. It makes my heart happy to see the small lions in my RStudio Viewer!
First geom_bar try. Strange borders + I have to do something about the x/y ratio.
########
# geom_bar
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
library("colourlovers")
# Generate data
c <- ggplot(mtcars, aes(factor(cyl)))
# By default, uses stat="bin", which gives the count in each category
c <- c + geom_bar(width=.5)
# get pattern
p <- clpattern('5171987', fmt='json')
picture <- content(GET(p$imageUrl))
# picture is a 4 dimensional array
img <- as.raster(picture)
index <- 0
for (i in levels(as.factor(mtcars$cyl))){
index <- index + 1
# we have to repeat the data.frame/pattern
xmax <- 1
ymax <- sum(mtcars$cyl==i)
size <- ymax
img2 <- apply(img,MARGIN=2,function(x) rep(x,size))
# from matrix to data.frame
img2 <- tbl_df(as.data.frame(as.matrix(img2)))
names(img2) <- seq(index - 0.25, to = index + 0.25, length = ncol(img2))
dataPlot <- img2 %>%
mutate(y = seq(from = 0, to = ymax, length = nrow(img2))) %>%
gather(x, value, 1:ncol(img2)) %>%
mutate(x = as.numeric(x))
c <- c + geom_point(data = dataPlot, aes(x, y), col = dataPlot$value)
}
ggsave(c+ coord_fixed(ratio = 1/4), file = "geombar.png", width = 10, height = 10)
I really have to fight the x/y ratio thing.
This is an example with the 5 most popular patterns.
### packages
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
library("colourlovers")
# get pattern
p <- clpatterns(set = "top", fmt='json')[1:5]
dataPatterns <- tbl_df(data.frame(id = do.call("c", lapply(p, "[[", 1)),
numVotes = do.call("c", lapply(p, "[[", 5)),
imageURL = do.call("c", lapply(p, "[[", 13)))) %>%
mutate(id = factor(id, levels = id[order(numVotes, decreasing = TRUE)], ordered = TRUE))
firstCol <- NULL
for (i in 1:nrow(dataPatterns)){
firstCol <- c(firstCol, p[[i]][10]$colors[[2]])
}
dataPatterns <- dataPatterns %>%
mutate(firstCol = paste0("#",firstCol),
numVotes = numVotes / 1000)
# boring -- I used the second colour because the first was too similar across patterns
boring <- ggplot(dataPatterns) +
geom_bar(aes(x = id, y = numVotes, fill = id),
stat = "identity", width = .5) +
scale_fill_manual(values = dataPatterns$firstCol) +
ylab("Number of loves (kilo-love)") +
xlab("Pattern ID")
ggsave(boring, file = "boring.png", width = 10, height = 10)
# Now make it beautiful!
for (i in 1:nrow(dataPatterns)){
# get pattern
picture <- content(GET(as.character(dataPatterns$imageURL[i])))
# picture is a 4 dimensional array
img <- as.raster(picture)
# we have to repeat the data.frame/pattern
xmax <- 1
ymax <- dataPatterns$numVotes[i]
size <- ymax
img2 <- apply(img,MARGIN=2,function(x) rep(x,size))
# from matrix to data.frame
img2 <- tbl_df(as.data.frame(as.matrix(img2)))
names(img2) <- seq(i - 0.25, to = i + 0.25, length = ncol(img2))
dataPlot <- img2 %>%
mutate(y = seq(from = 0, to = ymax, length = nrow(img2))) %>%
gather(x, value, 1:ncol(img2)) %>%
mutate(x = as.numeric(x))
boring <- boring + geom_point(data = dataPlot, aes(x, y), col = dataPlot$value)
}
ggsave(boring + coord_fixed(ratio = 1/4),
file = "cool.png", width = 10, height = 10)
I've made good progress now. I use coord_fixed and get the range of the x and y axis from ggplot_build().
### packages
library("dplyr")
library("tidyr")
library("httr")
library("grid")
library("ggplot2")
library("colourlovers")
# get pattern
p <- clpatterns(keywords = "dog")[1:5]
dataPatterns <- tbl_df(data.frame(id = do.call("c", lapply(p, "[[", 1)),
numVotes = as.numeric(do.call("c", lapply(p, "[[", 5))),
imageURL = do.call("c", lapply(p, "[[", 13)))) %>%
mutate(id = factor(id, levels = id[order(numVotes, decreasing = TRUE)], ordered = TRUE))
firstCol <- NULL
for (i in 1:nrow(dataPatterns)){
firstCol <- c(firstCol, p[[i]][10]$colors[[4]])
}
dataPatterns <- dataPatterns %>%
mutate(firstCol = paste0("#",firstCol))
# boring -- I used the third colour because the first was too similar across patterns
boring <- ggplot(dataPatterns) +
geom_bar(aes(x = id, y = numVotes, fill = id),
stat = "identity", width = .5) +
scale_fill_manual(values = dataPatterns$firstCol) +
ylab("Number of votes") +
xlab("Pattern ID")
plotInfo <- ggplot_build(boring)
extentX <- diff(plotInfo$panel$ranges[[1]]$x.major_source)[1]
extentY <- diff(plotInfo$panel$ranges[[1]]$y.major_source)[1]
boring <- boring + coord_fixed(ratio = extentX/extentY)
ggsave(boring, file = "boring.png", width = 10, height = 10)
# Now make it beautiful!
for (i in 1:nrow(dataPatterns)){
# get pattern
picture <- content(GET(as.character(dataPatterns$imageURL[i])))
# picture is a 4 dimensional array
img <- as.raster(picture)
# we have to repeat the data.frame/pattern
xmax <- 1
ymax <- dataPatterns$numVotes[i]
size <- ceiling(ymax*2/extentY)
img2 <- apply(img,MARGIN=2,function(x) rep(x,size))
# from matrix to data.frame
img2 <- tbl_df(as.data.frame(as.matrix(img2)))
names(img2) <- seq(i - 0.25, to = i + 0.25, length = ncol(img2))
dataPlot <- img2 %>%
mutate(y = seq(from = size/2*extentY, to = 0, length = nrow(img2)))%>%
gather(x, value, 1:ncol(img2)) %>%
filter(y <= ymax) %>%
mutate(x = as.numeric(x))
boring <- boring + geom_point(data = dataPlot, aes(x, y), col = dataPlot$value)
}
ggsave(boring,
file = "cool.png", width = 10, height = 10)
draft of a future vignette? https://github.com/masalmon/colourlovers_patterns
I'll first write it and then fork this repo etc. -- that is, if you want to add the vignette, obviously.
Nice try, but its still far away from nice pattern that work on black and white print outs. See http://www.andypope.info/charts/patternfills.htm
What about a simple pattern with lines? Like slanted lines, cross lines, etc?
ah sorry just saw I had already posted this link! See also https://coolbutuseless.github.io/2020/04/01/introducing-ggpattern-pattern-fills-for-ggplot/
IMO both ggtextures and ggpattern are not ideal solutions as they can't simply be integrated into ggplot. One place where this seamless integration becomes essential is when using stat_summary
some_plot + stat_summary(fun = "mean", geom = "bar", aes(pattern = some_pattern, pattern_color = some_color))
Currently, there's no way to add a pattern in this manner. Both ggtextures and ggpattern are overkill non-solutions to the simple need to add simple patterns to bars, a feature that doesn't currently exist in ggplot...