Skip to content

Instantly share code, notes, and snippets.

@timelyportfolio

timelyportfolio/Readme.md

Last active March 30, 2020 06:14
Show Gist options
  • Save timelyportfolio/8300c43ac43d772600df to your computer and use it in GitHub Desktop.
Save timelyportfolio/8300c43ac43d772600df to your computer and use it in GitHub Desktop.
Download ZIP
some examples with rbokeh inspired by ggplot2 and lattice
Raw
Readme.md

lattice

examples inspired by this book

ggplot2

examples inspired by this book

Raw
examples_ggplot2.R
# examples from ggplot2 book
# http://www.amazon.com/ggplot2-Elegant-Graphics-Data-Analysis/dp/0387981403/ref=sr_1_1?ie=UTF8&qid=1423697224&sr=8-1&keywords=ggplot2
library(rbokeh)
library(ggplot2)
data(diamonds)
bp <- figure( height = 400, width = 700 )
bp %>% ly_points(carat,price,diamonds,color=cut,size=5)
# add hover
bp %>%
ly_points(carat,price,diamonds,color=cut,size=1,hover=list(cut,clarity,color))
# make it a hexbin
bp %>%
ly_hexbin( carat, price, diamonds )
# make it a hexbin with facet by color
lapply(
levels(unique(diamonds$color))
,function(c){
figure( height = 300, width = 300, title = paste0("Color: ",c) ) %>%
ly_hexbin( carat, log(price), diamonds[which(diamonds$color==c),] )
}
) %>%
grid_plot( nrow = 3, ncol = 3, same_axes = T )
# histogram on diamonds
bp %>% ly_hist( x = carat, data = diamonds, breaks = 2 )
# density on diamonds
bp %>% ly_density( x = carat, data = diamonds )
# quantile on diamonds
bp %>% ly_quantile(price,group = "color", diamonds)
bp %>% ly_quantile(price,group = "color", diamonds, distn=qnorm)
#demo a transform
bp %>%
ly_points( cyl, mpg^2, mtcars ) %>%
# not transformed
ly_points( cyl, mpg, mtcars, color = "red" ) %>%
# axis need to come after layers specified
y_axis( log = T )
# set vs map color
bp %>%
ly_points( mpg, wt, mtcars, color = "purple")
bp %>%
ly_points( mpg, wt, data.frame(name=rownames(mtcars),mtcars), color = cyl, hover = list(name))
# boxplot
data("Oxboys", package = "nlme")
bp %>%
ly_boxplot( Occasion, height, Oxboys )
Raw
examples_lattice.R
# http://www.amazon.com/Lattice-Multivariate-Data-Visualization-Use/dp/0387759689/ref=cm_cr_pr_product_top
library(rbokeh)
library(dplyr)
library(pipeR)
bp <- figure( height = 400, width = 700 )
data(Chem97,package = "mlmRev")
##### figure 1_01 #####
bp %>%
ly_hist( gcsescore, Chem97, breaks = seq(0,8,0.5) )
# now do the facetted version
lapply(
as.character(sort(unique(Chem97$score)))
, function(s){
figure( 300, 300, title = paste0("Score: ",s) ) %>%
ly_hist(
gcsescore
,filter(Chem97, score == as.numeric(s))
,breaks = seq(0,8,0.5)
)
}
) %>%
grid_plot( nrow = 2, ncol = 3, same_axes=T )
##### figure 1_02 #####
bp %>%
ly_hist( gcsescore, Chem97, breaks = seq(0,8,0.5) )
# now do the facetted version
lapply(
as.character(sort(unique(Chem97$score)))
, function(s){
figure( 300, 300, title = paste0("Score: ",s) ) %>%
ly_density(
gcsescore
, data = filter(Chem97, score == as.numeric(s))
# get error with color mapping
, color = substr(RColorBrewer::brewer.pal(name="Dark2",n=6)[as.numeric(s)/2+1],2,7)
)
}
) %>>%
(~show(grid_plot( ., nrow = 2, ncol = 3, same_axes=T ))) %>>%
(~show(grid_plot( ., nrow = 2, ncol = 3, same_axes=T, byrow = F ))) %>>%
(~show(grid_plot( ., nrow = 3, ncol = 2, same_axes=T ))) %>>%
(grid_plot( ., nrow = 3, ncol = 2, same_axes=T, byrow = F ))
##### figure 1_03 #####
local({
bp2<- bp
lapply(
as.character(sort(unique(Chem97$score)))
, function(s){
bp2 <<- bp2 %>%
ly_density(
gcsescore
, data = filter(Chem97, score == as.numeric(s))
# get error with color mapping
, color = substr(RColorBrewer::brewer.pal(name="Dark2",n=6)[as.numeric(s)/2+1],2,7)
)
}
)
bp2
})
##### figure 2_01 #####
data(Oats, package = "MEMSS")
apply(
unique(expand.grid(
levels(Oats$Block)
, levels(Oats$Variety)
, stringsAsFactors = F )
)
, MARGIN = 1
, function(tuple){
figure( width = 400, height = 400, title = paste0(tuple) ) %>>%
ly_lines(
nitro, yield
, data =
Oats %>>%
filter( Variety == tuple[[2]] & Block == tuple[[1]] ) %>>%
group_by ( nitro ) %>>%
summarise ( yield = mean( yield ) )
, line_color = substr(
RColorBrewer::brewer.pal(n=3,name="Set1")[which(tuple[[2]]==levels(Oats$Variety))]
,2,7
)
)
}
) -> bp2
bp2 %>%
grid_plot( nrow = 6, ncol = 3, same_axes = T, byrow = F)
##### figure 2_02 #####
grid_plot(bp2[seq(1,18,6)], nrow = 1, ncol = 3, same_axes = T )
##### figure 2_06 #####
data(barley,package="lattice")
# no facet to get started
bp %>%
ly_points( yield, variety, barley, color = year, hover = list( variety, yield ) )
# now show facet
lapply(
levels( barley$site )
,function(s){
figure( height = 200, width = 700, title = s ) %>%
ly_points(
yield, variety
# for fun do without dplyr
, data = subset(barley, site == s)
, color = year
, hover = list( variety, yield )
, size = 6
)
}
) %>%
grid_plot( nrow = length(.), ncol = 1, same_axes = T )
##### figure 2_07 #####
# no facet first
bp %>%
ly_lines(
nitro, yield
,data = Oats
,color = Variety
,group = Variety
)
# now with facets
lapply(
levels(Oats$Block)
,function(b){
figure( height = 400, width = 200, title = b ) %>>%
ly_lines(
nitro, yield
,data = subset( Oats, Block == b )
,color = Variety
,group = Variety
)
}
) %>>%
grid_plot( nrow = 1, ncol = length(.), same_axes = T )
##### figure 2_08 - 2_11 #####
# bar charts not yet supported but support is in process
##### figure 3_01 #####
data(faithful)
bp %>>%
# draw the density line using parameters in example
ly_density( eruptions, faithful, bw = 0.2, n = 200, kernel = "rect" ) %>>%
# draw density with defaults
ly_density( eruptions, faithful, color = "blue" ) %>>%
#add random y to jitter for rugplot of points at bottom
ly_points(
eruptions
# note use of inline expression
, runif(n = nrow(faithful), min = 0, max = 0.025)
, faithful
, size = 5
)
##### figure 3_02 #####
# like above but a rug plot
bp %>>%
# draw the density line using parameters in example
ly_density( eruptions, faithful, bw = 0.2, n = 200, kernel = "rect" ) %>>%
# sort of a hack but hey it works
ly_multi_line(
xs = cbind(faithful$eruptions,faithful$eruptions)
# note use of inline expression
, ys = cbind(rep(0,nrow(faithful)),rep(0.025,nrow(faithful)))
)
##### figure 3_03 ########
data(gvhd10, package = "latticeExtra")
#get density data for the plot
lapply(
levels(gvhd10$Days)
,function(d){
figure( height = 200, width = 400, title = paste0("Days: ", d) ) %>>%
ly_density(
log(FSC.H)
,data = subset(gvhd10, Days == d)
)
}
) %>>%
grid_plot( nrow = 4, ncol = 2, same_axes = T )
##### figure 3_05 ########
data(Chem97, package = "mlmRev")
# no facet first for simplicity
# since first example of ly_quantile
bp %>>%
ly_quantile(
x = gcsescore
,group = score
,data = Chem97
,distn = qnorm
)
lapply(
sort(unique(Chem97$score))
,function(d){
figure( width = 300 , height = 300, title = paste0("Score: ", d) ) %>>%
ly_quantile(
x = gcsescore
,data = subset(Chem97,score == d)
,distn = qnorm
,color = substr(RColorBrewer::brewer.pal(name="Dark2",n=6)[as.numeric(d)/2+1],2,7)
)
}
) %>>%
grid_plot( nrow = 2, ncol = 3, same_axes = T )
##### figure 3_06 ########
local({
lapply(
levels(Chem97$gender)
,function(g){
bp <- figure( width = 300 , height = 300, title = paste0("Gender: ", g) )
Reduce(
function(x,y){
bp <<- ly_quantile(
bp
,x = gcsescore
,data = subset(Chem97, score == y & gender == g)
,distn = qnorm
,color = substr(RColorBrewer::brewer.pal(name="Dark2",n=6)[as.numeric(y)/2+1],2,7)
,size = 5
)
}
,sort(unique(Chem97$score))
)
return(bp)
}
)
}) %>>%
grid_plot( nrow = 1, ncol = 2, same_axes = T )
##### figure 3_08 #######
# use a less functional approach to get the data in ECDF form
data(Chem97, package = "mlmRev")
data <- data.frame()
gender <- unique(Chem97$gender)
scores <- unique(Chem97$score)
for (i in 1 : length(scores) ) {
for (j in 1 : length(gender) ) {
tempdata <- list()
#code primarily from lattice panel.ecdfplot
#note: example subset gcsescore > 0
n = sum(!is.na(Chem97[which( Chem97$gender == gender[j] & Chem97$score == scores[i] & Chem97$gcsescore > 0 ),]$gcsescore))
tempdata$x = sort(Chem97[which( Chem97$gender == gender[j] & Chem97$score == scores[i] & Chem97$gcsescore > 0 ),]$gcsescore)
tempdata$y = seq_len(n)/n
tempdata$gender = rep( gender[j], length(tempdata$x) )
tempdata$score = rep(scores[i], length(tempdata$x) )
data <- rbind( data, data.frame( tempdata ) )
}
}
colnames(data) <- c("x1", "y1", "gender", "score")
local({
lapply(
sort(unique(data$score))
,function(s){
bp <- figure( width = 300 , height = 300, title = paste0("Score: ", s) )
Reduce(
function(x,y){
print(y)
bp <<- ly_points(
bp
,x = x1
,y = y1
,data = subset(data, score == s & gender == y )
,color = gender
,size = 3
)
}
,levels(data$gender)
,init = levels(data$gender)[1]
)
return(bp)
}
)
}) %>>%
grid_plot( nrow = 2, ncol = 3, same_axes = T )
##### figure 3_09 #######
data(Chem97, package = "mlmRev")
data <- data.frame()
gender <- unique(Chem97$gender)
scores <- unique(Chem97$score)
for (i in 1 : length(scores) ) {
for (j in 1 : length(gender) ) {
tempdata <- list()
#code primarily from lattice panel.qqmath
n <- sum(!is.na( Chem97[which(Chem97$gcsescore > 0 & Chem97$score == scores[i] & Chem97$gender == gender[j] ),]$gcsescore))
tempdata$x = qunif(ppoints(n))
tempdata$y = quantile(
x = Chem97[which(Chem97$gcsescore > 0 & Chem97$score == scores[i] & Chem97$gender == gender[j] ),]$gcsescore,
ppoints(n),
names = FALSE,
type = 7,
na.rm = TRUE)
tempdata$gender = rep( gender[j], n )
tempdata$score = rep(scores[i], n )
data <- rbind( data, data.frame( tempdata ) )
}
}
colnames(data) <- c("x1", "y1", "gender", "score")
local({
lapply(
sort(unique(data$score))
,function(s){
bp <- figure( width = 200 , height = 500, title = paste0("Score: ", s) )
Reduce(
function(x,y){
print(y)
bp <<- ly_points(
bp
,x = x1
,y = y1
,data = subset(data, score == s & gender == y )
,color = gender
,size = 1
,hover = list(x1,y1)
) %>>%
x_axis( label = "Std Normal ") %>>%
y_axis( label = "GCSEScore")
}
,levels(data$gender)
,init = levels(data$gender)[1]
)
return(bp)
}
)
}) %>>%
grid_plot( nrow = 1, ncol = 6, same_axes = T )
##### figure 3_10 #######
data(Chem97, package = "mlmRev")
Chem97 %>>%
dplyr::group_by( gender, score ) %>%
do(
data.frame(
x = qnorm(ppoints(100))
,y = quantile(.$gcsescore, ppoints(100), names = F, type = 7, na.rm = F)
,score = unique(.$score)
,gender = unique(.$gender)
)
) %>>%
(reshape2::dcast(., x + score ~ gender, value.var = "y")) %>>%
(dat~
lapply(
sort(unique(dat$score))
,function(s){
figure( width = 200, height = 200, title = paste0("score: ", s) ) %>>%
ly_points(
M
,F
,data = filter( dat, score == s )
,size = 4
,hover = list(score,M,F)
) %>>%
ly_abline( a= 0, b = 1 )
}
)
) %>>%
grid_plot( nrow = 2, ncol = 3, same_axes = T )
##### figure 3_11 #######
data(Chem97, package = "mlmRev")
# non facet first since first boxplot
figure( width = 700, height = 400
# little clunky to force sort on categorical axis
, xlim = as.character(sort(unique(Chem97$score)))
) %>>%
ly_boxplot(
as.character(score)
,gcsescore
,data = Chem97
) %>>%
x_axis(label = "Average GCSE Score")
# now facet it
lapply(
levels(Chem97$gender)
,function(g){
# non facet first since first boxplot
figure( width = 500, height = 300
# little clunky to force sort on categorical axis
, xlim = as.character(sort(unique(Chem97$score)))
) %>>%
ly_boxplot(
as.character(score)
,gcsescore
,data = filter(Chem97, gender == g)
) %>>%
ly_lines(
as.character(score)
,mean_gcse
,data = filter(Chem97, gender == g) %>>%
group_by( score) %>>%
summarize( mean_gcse = mean(gcsescore) )
, color = "black"
) %>>%
x_axis(label = "Average GCSE Score")
}
) %>>%
grid_plot( nrow = 1, ncol = 2 )#, same_axes messes up sort )
##### figure 3_12 #######
data(Chem97, package = "mlmRev")
lapply(
sort(unique(Chem97$score))
,function(s){
# non facet first since first boxplot
figure( width = 200, height = 500, title = paste0("score: ", s) ) %>>%
ly_boxplot(
gender
,gcsescore
,data = filter(Chem97, score == s)
) %>>%
ly_points(
gender
,mean_gcse
,data = filter(Chem97, score == s) %>>%
group_by( gender ) %>>%
summarize( mean_gcse = mean(gcsescore) )
, color = "black"
, glyph = 9
)
}
) %>>%
grid_plot( nrow = 1, ncol = 2, same_axes = T )
##### figure 3_15 #######
data(quakes)
figure( height = 400, width = 700, ylim = as.character(seq(4,6.5,0.1)) ) %>>%
ly_points(
depth
,factor(mag)
,data = quakes
,size = 4
,color = "black"
,alpha = 1
)
##### figure 3_16 #######
# don't think the jitter is possible with a categorical scale/axis
data(quakes)
figure( height = 400, width = 700, xlim = as.character(seq(4,6.5,0.1)) ) %>>%
ly_points(
factor(mag)
,depth
,data = quakes
,size = 4
,color = "black"
,alpha = 1
)
##### figure 3_17 #######
# again, not sure jitter possible with categorical scale/axis
data(barley,package="lattice")
barley %>>%
(
data.frame(
.
,residuals = sqrt(abs(residuals(lm(yield~variety+year+site,.))))
)
) %>>%
(dat~
ly_points(
figure( width = 700, height = 400, xlim = levels(dat$site) )
,site
,residuals
,data = dat
,color = year
) %>>%
ly_points(
site
,median_residual
,color = year
,data = dat %>>% group_by( site, year ) %>>% summarize( median_residual = median(residuals) )
,glyph = 3
,size = 30
) %>>%
ly_lines(
site
,median_residual
,color = year
,data = dat %>>% group_by( site, year ) %>>% summarize( median_residual = median(residuals) )
)
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment