There is a way to do this that's not that too complicated, but rather ugly. Or something that is over the top cumbersome (I didn't realize how far I was digging until I was done...)
Before I go too far... I noticed that there is a ton of white space and that you have gaps set to zero. You can add the parameter offsetgroup and get rid of a lot more whitespace. Check it out:
plot_ly(data = df,
x = ~type, y = ~value, name = ~age, offsetgroup = ~type, # <- I'm new!
color = ~type, type = "box", showlegend = F) %>%
layout(yaxis = list(title = "Diversity"),
boxmode = "group", boxgap = 0, boxgroupgap = 0)
With the not-too-complicated-but-kind-of-ugly method
The line is the box outline, the median line, the lines from Q1 to the lower fence, from Q3 to the upper fence, and the whiskers.
I assigned the plot to the object plt for this code. When I checked the object, it didn't have the data element, so I built the plot next.
plt <- plotly_build(plt)
Then I added colors with lapply.
# this looks ugly!
lapply(1:12,
function(i){
nm = plt$x$data[[i]]$name
cr = ifelse(nm == "o",
"#66FF66", "black")
plt$x$data[[i]]$line$color <<- cr # change graph by age
}
)
plt
With the ridiculous-amount-of-code-for-a-few-lines-but-looks-better method
I guess it isn't a few lines. It's 48 lines.
For this method, you need to build the plot like I did in the before (plotly_build), so that the data element is in the plt object.
Then you have to determine the first and third quantile, the IQR, the max and min values between the quantiles and 1.5 * IQR for each type and age grouping so that you have the y values for the lines.
I wrote a function to get the upper and lower fences.
fen <- function(vals){
iq = 1.5 * IQR(vals)
q3 = quantile(vals, 3/4) # top of the box
uf = q3 + iq # top of the fence
vt = max(vals[vals > q3 & vals < uf]) # max value in range
q1 = quantile(vals, 1/4) # btm of the box
bf = q1 - iq # btm of the fence
vb = min(vals[vals < q1 & vals > bf]) # min value in range
sz = function(no){
if(length(no) > 1) {no = no[[1]]}
return(no)
}
vt = sz(vt)
vb = sz(vb)
return(list(vt, vb))
}
Then I used this function and the data to determine the remaining values needed to draw the lines.
df1 <- df %>%
# have to reverse the order or it won't line up
mutate(age = factor(age, levels = c("o", "y"), ordered = T)) %>%
group_by(type, age) %>%
summarise(ufen = fen(value)[[1]], # top of the fence
q3 = quantile(value, 3/4), # top of the box
q1 = quantile(value, 1/4), # btm of the box
dfen = fen(value)[[2]]) # btm of the fence
To plot these new lines, I used shapes which is equivalent to ggplot2 annotations. (annotations in Plotly is primarily for text.)
There are several steps to drawing these lines. First I've started with some things that are essentially the same in every line. After that is a vector that helps place the lines on the x-axis.
# line shape basics; the same for every line
tellMe <- function(shade){
list(type = "line",
line = list(color = shade),
xref = "paper",
yref = "y")
}
# setup for placing lines on the x-axis; these are % of space
xers = c(rep(.0825, 4), rep(.083 * 3, 4), rep(.083 * 5, 4))
Now four lapply statements: the upper fences, the lower fences, the upper whiskers, and the lower whiskers.
lns <- lapply(1:12,
function(i) { # upper fence lines
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn, x1 = xn,
y0 = df1[i, ]$q3[[1]], # it's named; this makes it val only
y1 = df1[i, ]$ufen, more)
})
mlns <- lapply(1:12,
function(i) { # lower fence lines
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn, x1 = xn,
y0 = df1[i, ]$q1[[1]], # it's named; this makes it val only
y1 = df1[i, ]$dfen, more)
})
# default whisker width is 1/2 the width of the box
# current boxes of 1/4 of the space by type
# with domain [0, 1], the box width is 1/12 * .5, so
# the whisker width is
ww = 1/12 * .5 *.5
# already have the center, so half on each side...
ww = ww * .5
wwlns <- lapply(1:12,
function(i) { # upper fence whisker
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn - ww, x1 = xn + ww,
y0 = df1[i, ]$ufen, y1 = df1[i, ]$ufen,
more)
})
wwm <- lapply(1:12,
function(i) { # lower fence whisker
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn - ww, x1 = xn + ww,
y0 = df1[i, ]$dfen, y1 = df1[i, ]$dfen,
more)
})
Now you have to concatenate the lists and add them to the plot.
# combine shapes
shp <- append(lns, mlns)
shp <- append(shp, wwlns)
shp <- append(shp, wwm)
plt %>% layout(shapes = shp)
There are OBVIOUSLY better color choices out there.
