Polygon methods
param.df <- data.frame(
mean=c(0, 0, 2),
sd=c(1, 2, 1))
density.df.list <- list()
for(param.i in 1:nrow(param.df)){
one.param <- param.df[param.i,]
observation <- seq(-4, 4, by=0.1)
density.df.list[[param.i]] <- data.frame(
param.i,
param.fac=factor(param.i),
one.param,
observation,
density=dnorm(observation, one.param$mean, one.param$sd),
row.names=NULL)
}
density.df <- do.call(rbind, density.df.list)
if(require(ggplot2)){
gg <- ggplot()+
geom_line(aes(
observation, density, color=param.fac),
data=density.df)
directlabels::direct.label(gg, "top.polygons")
}
#> Loading required package: ggplot2
if(require(ggplot2)){
density.df$mean.lab <- paste0("mean=", density.df$mean)
gg <- ggplot()+
geom_line(aes(
observation, density, color=param.fac),
data=density.df)+
directlabels::geom_dl(aes(
observation, density,
color=param.fac,
label.group=param.fac,
label=mean.lab),
method="top.polygons",
data=density.df)
gg
}
if(require(ggplot2)){
gg <- ggplot()+
geom_line(aes(
observation, density, color=mean.lab, group=param.fac),
data=density.df)
directlabels::direct.label(gg, "top.polygons")
}
if(require(ggplot2)){
data(BodyWeight, package="nlme")
gg <- ggplot()+
geom_line(aes(
Time, weight, color=Rat),
data=BodyWeight)+
facet_grid(. ~ Diet)
gg
}
if(require(ggplot2)){
directlabels::direct.label(gg, "right.polygons")
}
if(require(ggplot2)){
gg.wider <- gg+xlim(-10, 70)
directlabels::direct.label(gg.wider, "right.polygons")
}
if(require(ggplot2)){
directlabels::direct.label(gg.wider, "left.polygons")
}
SO post about stats
https://github.com/tdhock/directlabels/issues/24
if(require(ggplot2)){
set.seed(124234345)
# Generate data
df.2 <- data.frame(
"n_gram" = c("word1"),
"year" = rep(100:199),
"match_count" = runif(100 ,min = 1000 , max = 2000))
df.2 <- rbind(df.2, data.frame(
"n_gram" = c("word2"),
"year" = rep(100:199),
"match_count" = runif(100 ,min = 1000 , max = 2000)) )
# use stat smooth with geom_dl to get matching direct labels.
span <- 0.3
ggplot(df.2, aes(year, match_count, group=n_gram, color=n_gram)) +
geom_line(alpha = I(7/10), color="grey") +
stat_smooth(size=2, span=span, se=F) +
directlabels::geom_dl(aes(
label=n_gram),
## method should be passed to geom_dl but ggplot2 (mistakenly?)
## passes it to stat_smooth, which rightly raises a warning about
## an unknown smoothing function.
method = "last.qp",
stat="smooth", span=span) +
xlim(c(100,220))+
guides(colour="none")
}
#> Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
#> ℹ Please use `linewidth` instead.
#> This warning is displayed once every 8 hours.
#> Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
#> generated.
#> `geom_smooth()` using method = 'loess' and formula = 'y ~ x'
#> `geom_smooth()` using formula = 'y ~ x'
#> Warning: Computation failed in `stat_smooth()`
#> Caused by error in `get()`:
#> ! object 'last.qp' of mode 'function' was not found
serialize issue
https://github.com/tdhock/directlabels/issues/6
if(require(ggplot2) && require(dplyr) && require(ggthemes)){
## create data
aaa <- structure(
list(x = c(28, 27, 26, 25, 24, 23, 22, 21, 20, 19,
18, 17, 28, 27, 26, 25, 24, 23, 22, 21, 20, 19, 18, 17),
count = c(2344L,
4088L, 3247L, 2808L, 2046L, 1669L, 1315L, 951L, 610L, 543L, 469L,
370L, 937L, 1116L, 550L, 379L, 282L, 204L, 174L, 160L, 136L,
132L, 128L, 122L),
term = c("aaa", "aaa", "aaa", "aaa", "aaa",
"aaa", "aaa", "aaa", "aaa", "aaa", "aaa", "aaa", "bbb", "bbb",
"bbb", "bbb", "bbb", "bbb", "bbb", "bbb", "bbb", "bbb", "bbb",
"bbb")),
class = c("tbl_df", "tbl", "data.frame"),
row.names = c(NA,
-24L),
.Names = c("x", "count", "term"))
## have a look
print(aaa)
## initial plot
p2 <- aaa %>% ggplot(aes(x = x, y = count, group = term, colour = term)) + geom_line()
## have a look
print(p2)
## works
print(directlabels::direct.label(p2))
## plot with theme
p2 <- aaa %>% ggplot(aes(x = x, y = count, group = term, colour = term)) + geom_line() + theme_fivethirtyeight()
## have a look
print(p2)
## used to fail but should be OK as of 19 June 2020.
print(directlabels::direct.label(p2))
}
#> Loading required package: dplyr
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
#> Loading required package: ggthemes
#> # A tibble: 24 × 3
#> x count term
#> <dbl> <int> <chr>
#> 1 28 2344 aaa
#> 2 27 4088 aaa
#> 3 26 3247 aaa
#> 4 25 2808 aaa
#> 5 24 2046 aaa
#> 6 23 1669 aaa
#> 7 22 1315 aaa
#> 8 21 951 aaa
#> 9 20 610 aaa
#> 10 19 543 aaa
#> # ℹ 14 more rows
changepoint cost minima
This is a test for polygon.method with only one unaligned point per
group as input, in particular the new bottom.polygons method.
data(LOPART100, package="directlabels")
abbrev.vec <- c(
data="data and models",
cost="cost of last change")
yfac <- function(l){
factor(abbrev.vec[[l]], abbrev.vec)
}
COST <- function(dt){
data.frame(y.var=yfac("cost"), dt)
}
DATA <- function(dt){
data.frame(y.var=yfac("data"), dt)
}
sig.color <- "grey50"
tau <- 99
up.to.t <- 100
change.dt <- data.frame(tau, change=tau+0.5)
t.dt <- data.frame(up.to.t)
my.hjust <- function(x)ifelse(x < nrow(LOPART100$signal)/2, 0, 1)
min.dt <- do.call(rbind, by(
LOPART100$cost,
LOPART100$cost$Algorithm,
function(df)df[which.min(df$cost_candidates),]))
cost.range <- range(LOPART100$cost$cost_candidates)
cost.h <- cost.range[2]-cost.range[1]
blank.dt <- data.frame(
position=1, cost=cost.range[1]-cost.h/4)
label.colors <- c(
"1"="#ff7d7d",
"0"="#f6c48f")
if(require(ggplot2)){
gg <- ggplot()+
geom_blank(aes(
position, cost),
data=COST(blank.dt))+
geom_vline(aes(
xintercept=up.to.t),
color=sig.color,
data=t.dt)+
geom_text(aes(
up.to.t, 13,
hjust=my.hjust(up.to.t),
label=sprintf(
"$t=%s$", up.to.t)),
color=sig.color,
data=DATA(t.dt))+
geom_rect(aes(
xmin=start, xmax=end,
fill=paste(changes),
ymin=-Inf, ymax=Inf),
alpha=0.5,
data=LOPART100$labels)+
scale_fill_manual("label", values=label.colors)+
theme_bw()+
theme(panel.spacing=grid::unit(0, "lines"))+
facet_grid(y.var ~ ., scales="free")+
geom_text(aes(
change, 1,
hjust=my.hjust(change),
label=sprintf(
"$\\tau = %d$", tau)),
vjust=0,
data=DATA(change.dt))+
geom_vline(aes(
xintercept=change),
data=change.dt)+
geom_segment(aes(
start-0.5, mean,
size=Algorithm,
color=Algorithm,
xend=end+0.5, yend=mean),
data=DATA(LOPART100$segments))+
geom_point(aes(
position, signal),
color=sig.color,
shape=1,
data=DATA(LOPART100$signal))+
scale_size_manual(values=c(
OPART=1.5,
LOPART=0.5),
drop=FALSE)+
scale_shape_manual(values=c(
OPART=1,
LOPART=2),
drop=FALSE)+
scale_color_manual(values=c(
OPART="deepskyblue",
LOPART="black"),
drop=FALSE)+
ylab("")+
scale_x_continuous(
"position $t,\\tau$",
breaks=seq(0, 100, by=10))+
geom_point(aes(
change, cost_candidates,
color=Algorithm, shape=Algorithm),
data=COST(LOPART100$cost))+
geom_point(aes(
change, cost_candidates,
color=Algorithm),
data=COST(min.dt))
print(gg)
label.cost <- function(df){
gg+
directlabels::geom_dl(aes(
change, cost_candidates,
color=Algorithm,
label.group=Algorithm,
label=sprintf("$\\tau^*_{%d} = %d$", up.to.t, tau)),
method="bottom.polygons",
data=COST(df))
}
print(label.cost(LOPART100$cost))
## to make sure it works when there is only one point to label.
print(label.cost(min.dt))
}
LOPART ROC curve
This is a test for polygon.method with only one unaligned point per
group as input, in particular with right.polygons.
data(LOPART.ROC, package="directlabels")
algo.colors <- c(
OPART="#0077CC",
LOPART="black",
SegAnnot="#22CC22")
if(require(ggplot2)){
ggplot()+
theme_bw()+
scale_color_manual(values=algo.colors)+
scale_size_manual(values=c(
LOPART=1.5,
OPART=1))+
directlabels::geom_dl(aes(
FPR, TPR,
color=model.name,
label=paste0(model.name, ifelse(is.na(auc), "", sprintf(
" AUC=%.3f", auc
)))),
method=list(
cex=0.8,
directlabels::polygon.method(
"right",
offset.cm=0.5,
padding.cm=0.05)),
data=LOPART.ROC$points)+
geom_path(aes(
FPR, TPR,
color=model.name,
size=model.name,
group=paste(model.name, test.fold)),
data=LOPART.ROC$roc)+
geom_point(aes(
FPR, TPR,
color=model.name),
size=3,
shape=21,
fill="white",
data=LOPART.ROC$points)+
theme(
panel.spacing=grid::unit(0, "lines"),
legend.position="none"
)+
facet_grid(test.fold ~ Penalty + Parameters, labeller=label_both)+
coord_equal()+
scale_x_continuous(
"False Positive Rate (test set labels)",
breaks=c(0, 0.5, 1),
labels=c("0", "0.5", "1"))+
scale_y_continuous(
"True Positive Rate (test set labels)",
breaks=c(0, 0.5, 1),
labels=c("0", "0.5", "1"))
}
white or black text on colored background
The weighted method for rgb to grayscale conversion is used for the
default text.color in polygon.method, and explained here
https://www.tutorialspoint.com/dip/grayscale_to_rgb_conversion.htm
if(require(RColorBrewer) && require(ggplot2)){
m <- RColorBrewer::brewer.pal.info
brewer.dt.list <- list()
for(brewer.row in 1:nrow(m)){
brewer.name <- rownames(m)[[brewer.row]]
brewer.info <- m[brewer.name, ]
col.vec <- RColorBrewer::brewer.pal(brewer.info[, "maxcolors"], brewer.name)
rgb.mat <- col2rgb(col.vec)
hsv.mat <- rgb2hsv(rgb.mat)
brewer.dt.list[[brewer.name]] <- data.frame(
brewer.name,
brewer.fac=factor(brewer.name, rownames(m)),
brewer.row,
category=factor(brewer.info[, "category"], c("seq", "qual", "div")),
column=seq_along(col.vec),
color=col.vec,
t(rgb.mat),
t(hsv.mat))
}
brewer.dt <- do.call(rbind, brewer.dt.list)
ggplot()+
theme_bw()+
theme(panel.spacing=grid::unit(0, "lines"))+
facet_grid(category ~ ., scales="free", space="free")+
geom_tile(aes(
factor(column), brewer.fac, fill=color),
data=brewer.dt)+
geom_text(aes(
factor(column), brewer.fac, label=brewer.fac, color=ifelse(
((0.3 * red) + (0.59 * green) + (0.11 * blue))/255 < 0.5, "white", "black")),
data=brewer.dt)+
scale_fill_identity()+
scale_color_identity()
}
#> Loading required package: RColorBrewer
odd qp labels for timings figure
In the image below the strange thing in the labels is that the end of
the pointer of nc::capture_melt_single is inside of the pointer for
cdata::unpivot_to_blocks – this is ok, but we could probably avoid
this by switching the order. we should be able to detect/avoid this
using a linear inequality constraint: bottom of label box must be
greater than next target down, etc. But if targets are too close
together this could lead to no feasible solution.
data(odd_timings, package="directlabels")
odd4 <- subset(odd_timings, captures==4)
if(require(ggplot2)){
gg <- ggplot()+
geom_line(aes(
N.col, median.seconds, color=fun),
data=odd4)+
scale_x_log10(limits=c(10, 1e6))+
scale_y_log10()
directlabels::direct.label(gg, "right.polygons")
}
TODO edit polygon.method so that the right panel labels do not cross
– can this be added as a constraint in the qp, or do we just need to
re-order?
two dlgrobs
This example has two geom_dl with the same method, but the grobs
need different names to render correctly
https://github.com/tdhock/directlabels/issues/30
data(odd_timings, package="directlabels")
zero <- subset(odd_timings, captures==0)
on.right <- with(zero, N.col==max(N.col))
funs.right <- unique(zero[on.right, "fun"])
is.right <- zero$fun %in% funs.right
timings.right <- zero[is.right,]
timings.left <- zero[!is.right,]
if(require(ggplot2)){
gg <- ggplot()+
geom_line(aes(
N.col, median.seconds, color=fun),
data=zero)+
directlabels::geom_dl(aes(
N.col, median.seconds, color=fun, label=fun),
method="right.polygons",
data=timings.left)+
directlabels::geom_dl(aes(
N.col, median.seconds, color=fun, label=fun),
method="right.polygons",
data=timings.right)+
scale_x_log10(limits=c(10, 1e6))+
scale_y_log10()
gg
}
