ggfreqScatter <- function(x, y, by=NULL, bins=50, g=10, cuts=NULL,
xtrans = function(x) x,
ytrans = function(y) y,
xbreaks = pretty(x, 10),
ybreaks = pretty(y, 10),
xminor = NULL,
yminor = NULL,
xlab=as.character(substitute(x)),
ylab=as.character(substitute(y)),
fcolors=viridis::viridis(10),
nsize=FALSE, stick=FALSE,
html=FALSE, prfreq=FALSE, ...) {
xlab <- if(! missing(xlab)) xlab
else if(label(x) != '') label(x, plot=TRUE, html=html) else xlab
ylab <- if(! missing(ylab)) ylab
else if(label(y) != '') label(y, plot=TRUE, html=html) else ylab
nx <- is.numeric(x); ny <- is.numeric(y)
xbreaks <- if(nx) xbreaks; ybreaks <- if(ny) ybreaks
bins <- rep(bins, length.out=2)
bypres <- length(by) > 0
if(! bypres) by <- rep(0, times=length(x))
i <- ! (is.na(x) | is.na(y))
x <- xtrans(x[i]); y <- ytrans(y[i])
by <- by[i]
if(nx) {
rx <- range(x)
sx <- diff(rx) / bins[1]
x <- rx[1] + sx * round((x - rx[1]) / sx)
}
if(ny) {
ry <- range(y)
sy <- diff(ry) / bins[2]
y <- ry[1] + sy * round((y - ry[1]) / sy)
}
k <- subset(as.data.frame(table(by, x, y)), Freq > 0)
if(nx) k$x <- as.numeric(as.character(k$x))
if(ny) k$y <- as.numeric(as.character(k$y))
if(prfreq) print(table(k$Freq))
if(stick) {
if(! ny) stop('stick=TRUE only works with numeric y')
Y <- k$y
f <- k$Freq
m <- max(f)
z <- 1.15 * m / sy
k$y1 <- Y - f / z / 2
k$y2 <- Y + f / z / 2
k$y3 <- ifelse(f == m, NA, Y - m / z / 2)
k$y4 <- ifelse(f == m, NA, Y - f / z / 2)
k$y5 <- ifelse(f == m, NA, Y + f / z / 2)
k$y6 <- ifelse(f == m, NA, Y + m / z / 2)
w <- ggplot(k, aes(x=x, y=y, label=Freq)) +
geom_segment(aes(x=x, y=y1, xend=x, yend=y2, color=I('black')), data=k) +
geom_segment(aes(x=x, y=y3, xend=x, yend=y4, color=I('lightgray')), data=k) +
geom_segment(aes(x=x, y=y5, xend=x, yend=y6, color=I('lightgray')), data=k) +
xlab(xlab) + ylab(ylab) +
labs(caption=paste0('Maximum frequency:', m))
if(bypres) w <- w + facet_wrap(~ by)
return(w)
}
if(g == 0) {
w <- if(nsize)
ggplot(k, aes(x=x, y=y, size=Freq ^ 0.25, label=Freq)) +
geom_point(...) +
scale_size_continuous() +
xlab(xlab) + ylab(ylab) +
guides(size = guide_legend(title='Frequency'))
else
ggplot(k, aes(x=x, y=y, label=Freq,
color=Freq ^ 0.25)) +
geom_point(...) +
scale_color_gradientn(colors=fcolors) +
guides(alpha = FALSE,
color = guide_legend(title='Frequency')) +
xlab(xlab) + ylab(ylab)
if(bypres) w <- w + facet_wrap(~ by)
return(w)
}
k$fg <- if(length(cuts)) cut2(k$Freq, cuts=cuts) else cut2(k$Freq, g=g)
ufreq <- sort(unique(k$Freq))
few <- length(ufreq) <= 15
brn <- if(few) ufreq else unique(quantile(k$Freq, seq(0, g) / g))
w <- if(nsize)
ggplot(k, aes(x=x, y=y, size=Freq ^ 0.25, label=Freq)) +
geom_point(...) +
scale_size_continuous(breaks=brn ^ 0.25, labels=round(brn)) +
xlab(xlab) + ylab(ylab) +
guides(size = guide_legend(title='Frequency'))
else
ggplot(k, aes(x=x, y=y, label=Freq,
color=if(few) Freq else as.integer(fg))) + # k$Freq
geom_point(...) +
scale_color_gradientn(colors=fcolors,
breaks=if(few) ufreq else 1 : length(levels(k$fg)),
labels=if(few) ufreq else levels(k$fg)) +
guides(alpha = 'none',
color = guide_legend(title='Frequency')) +
xlab(xlab) + ylab(ylab)
if(nx) w <- w + scale_x_continuous(breaks=xtrans(xbreaks),
labels=format(xbreaks),
minor_breaks=if(length(xminor))
xtrans(xminor))
if(ny) w <- w + scale_y_continuous(breaks=ytrans(ybreaks),
labels=format(ybreaks),
minor_breaks=if(length(yminor))
ytrans(yminor))
if(bypres) w <- w + facet_wrap(~ by)
w
}
utils::globalVariables(c('fg','y1','y2','y3','y4','y5','y6'))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.