cdata Transforms
Win-Vector LLC
12/26/2017
Start up and show original Keras plot.
library("ggplot2")
library("cdata")## Loading required package: wraprlibrary("seplyr")
library("keras")
library("kableExtra")
options(knitr.table.format = "html")
h <- readRDS("historyobject.rds")
plot(h)
dOrig <- readRDS("metricsframe.rds")
dOrig$epoch <- seq_len(nrow(dOrig))
d <- dOrig
d$loss <- -d$loss
d$val_loss <- -d$val_loss
cR <- d %.>%
head(.)
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") | val_loss | val_acc | loss | acc | epoch |
|---|---|---|---|---|
| -0.3769818 | 0.8722 | -0.5067290 | 0.7852000 | 1 |
| -0.2996994 | 0.8895 | -0.3002033 | 0.9040000 | 2 |
| -0.2963943 | 0.8822 | -0.2165675 | 0.9303333 | 3 |
| -0.2779052 | 0.8899 | -0.1738829 | 0.9428000 | 4 |
| -0.2842501 | 0.8861 | -0.1410933 | 0.9545333 | 5 |
| -0.3119754 | 0.8817 | -0.1135626 | 0.9656000 | 6 |
Or with a bit more color:
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
row_spec(., 0, background = "lightgreen") %.>%
column_spec(., 1:4, background = "yellow")| val_loss | val_acc | loss | acc | epoch |
|---|---|---|---|---|
| -0.3769818 | 0.8722 | -0.5067290 | 0.7852000 | 1 |
| -0.2996994 | 0.8895 | -0.3002033 | 0.9040000 | 2 |
| -0.2963943 | 0.8822 | -0.2165675 | 0.9303333 | 3 |
| -0.2779052 | 0.8899 | -0.1738829 | 0.9428000 | 4 |
| -0.2842501 | 0.8861 | -0.1410933 | 0.9545333 | 5 |
| -0.3119754 | 0.8817 | -0.1135626 | 0.9656000 | 6 |
Reproducing the first plot
First plot: reproduce the original with bulk-renaming of columns (via the new cdata::map_fieldsD() function).
First we perform the equivalent of a “shred”, “un-pivot”, or “gather”:
cT <- build_unpivot_control(
nameForNewKeyColumn= 'origColName',
nameForNewValueColumn= 'performance',
columnsToTakeFrom= c('val_loss',
'val_acc',
'loss',
'acc' ))
dT <- rowrecs_to_blocks(
d,
controlTable = cT,
columnsToCopy = "epoch")
cR <- dT %.>%
head(.)
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") | epoch | origColName | performance |
|---|---|---|
| 1 | val_loss | -0.3769818 |
| 1 | val_acc | 0.8722000 |
| 1 | loss | -0.5067290 |
| 1 | acc | 0.7852000 |
| 2 | val_loss | -0.2996994 |
| 2 | val_acc | 0.8895000 |
Then we define a value mapping table to build the new value key columns that we need.
mp <- data.frame(
origColName = qc(val_loss, val_acc,
loss, acc),
dataset = qc("validation", "validation",
"training", "training"),
measure = qc("minus binary cross entropy", "accuracy",
"minus binary cross entropy", "accuracy"),
stringsAsFactors = FALSE)
mp %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(mp), background = "lightgrey") %.>%
column_spec(., 1, background = "lightgreen") %.>%
column_spec(., 2:ncol(mp), background = "yellow")| origColName | dataset | measure |
|---|---|---|
| val_loss | validation | minus binary cross entropy |
| val_acc | validation | accuracy |
| loss | training | minus binary cross entropy |
| acc | training | accuracy |
We apply that key map and we are ready to plot:
dT <- map_fields(dT,
"origColName",
mp)
dT$measure <- factor(dT$measure,
levels = c("minus binary cross entropy",
"accuracy"))
cR <- dT %.>%
head(.)
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
column_spec(., 2, background = "lightgreen") %.>%
column_spec(., c(4,5), background = "yellow")| epoch | origColName | performance | dataset | measure |
|---|---|---|---|---|
| 1 | val_loss | -0.3769818 | validation | minus binary cross entropy |
| 1 | val_acc | 0.8722000 | validation | accuracy |
| 1 | loss | -0.5067290 | training | minus binary cross entropy |
| 1 | acc | 0.7852000 | training | accuracy |
| 2 | val_loss | -0.2996994 | validation | minus binary cross entropy |
| 2 | val_acc | 0.8895000 | validation | accuracy |
pick <- dT %.>%
filter_se(.,
qe(measure == "minus binary cross entropy",
dataset == "validation")) %.>%
.$epoch[[which.max(.$performance)]]
ggplot(data = dT,
aes(x = epoch,
y = performance,
color = dataset)) +
geom_point() +
stat_smooth(geom = "line", se = FALSE, method = "loess", alpha = 0.5) +
facet_wrap(~measure, ncol=1, scales = "free_y") +
geom_vline(xintercept = pick, alpha=0.7, color='darkgreen') +
scale_color_brewer(palette = "Dark2") +
ggtitle("model performance by epoch, dataset, and measure")
Creating an improved performance trajectory plot
Second plot: the steps to get to WVPlots::plot_Keras_fit_trajectory(). In particular show the structure of the control table (especially when applied to itself). The idea is: any in-table block-structure can be taken to any block-structure by moving through a very wide column as an intermediate (or dual form: through a very thin intermediate structure such as RDF-triples).
First let’s take a look at our data.
cR <- d %.>%
head(.) %.>%
select_se(., qc(epoch, val_loss, val_acc, loss, acc))
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
column_spec(., 2:5, background = "yellow") %.>%
row_spec(., 2:nrow(cR), background = "lightgrey") | epoch | val_loss | val_acc | loss | acc |
|---|---|---|---|---|
| 1 | -0.3769818 | 0.8722 | -0.5067290 | 0.7852000 |
| 2 | -0.2996994 | 0.8895 | -0.3002033 | 0.9040000 |
| 3 | -0.2963943 | 0.8822 | -0.2165675 | 0.9303333 |
| 4 | -0.2779052 | 0.8899 | -0.1738829 | 0.9428000 |
| 5 | -0.2842501 | 0.8861 | -0.1410933 | 0.9545333 |
| 6 | -0.3119754 | 0.8817 | -0.1135626 | 0.9656000 |
Let’s concentrate on a single row (in this case the first row).
d %.>%
head(., n=1) %.>%
select_se(., qc(epoch, val_loss, val_acc, loss, acc)) %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:1, background = "lightgrey") %.>%
column_spec(., 2:5, background = "yellow")| epoch | val_loss | val_acc | loss | acc |
|---|---|---|---|---|
| 1 | -0.3769818 | 0.8722 | -0.506729 | 0.7852 |
To create ggplot2::geom_ribbon() and ggplot2::geom_segment() we need both the training and validation loss for a given epoch to be in the same row. We also want the different performance metrics to be in different rows so we can use ggplot2::facet_wrap(). That means we want the first row of data to look like the following sub-table:
cT <- dplyr::tribble(
~measure, ~training, ~validation,
"minus binary cross entropy", "loss", "val_loss",
"accuracy", "acc", "val_acc"
)
cR <- d %.>%
head(., n=1) %.>%
rowrecs_to_blocks(
.,
controlTable = cT,
columnsToCopy = "epoch")
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
column_spec(., 2, background = "lightgreen") %.>%
column_spec(., 3:4, background = "yellow")| epoch | measure | training | validation |
|---|---|---|---|
| 1 | minus binary cross entropy | -0.506729 | -0.3769818 |
| 1 | accuracy | 0.785200 | 0.8722000 |
What allows this motion is the controlTable which is essentially a before or after diagram of the transform (depending on which direction you are going). I can not emphasize enough the benefit of looking at the data and drawing out the transform on paper before attempting any coding.
The control table is as follows:
cT %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cT), background = "lightgrey") %.>%
column_spec(., 1, background = "lightgreen") %.>%
column_spec(., 2:3, background = "yellow")| measure | training | validation |
|---|---|---|
| minus binary cross entropy | loss | val_loss |
| accuracy | acc | val_acc |
It can be applied to data, or to itself, in a forward or backward direction (depending if we use cdata::rowrecs_to_blocks() or cdata::blocks_to_rowrecs()).
cR <- cT %.>%
blocks_to_rowrecs(
.,
controlTable = cT,
keyColumns = NULL) %.>%
select_se(.,
qc(val_loss, val_acc, loss, acc))
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
column_spec(., 1:4, background = "yellow")| val_loss | val_acc | loss | acc |
|---|---|---|---|
| val_loss | val_acc | loss | acc |
We can now apply the transform to all the data, and produce the final plot.
dT <- rowrecs_to_blocks(
d,
controlTable = cT,
columnsToCopy = "epoch")
cR <- dT %.>%
head(.)
cR %.>%
knitr::kable(.) %.>%
kable_styling(., full_width = F) %.>%
kable_styling(., full_width = F) %.>%
row_spec(., 0:nrow(cR), background = "lightgrey") %.>%
column_spec(., 2, background = "lightgreen") %.>%
column_spec(., 3:4, background = "yellow")| epoch | measure | training | validation |
|---|---|---|---|
| 1 | minus binary cross entropy | -0.5067290 | -0.3769818 |
| 1 | accuracy | 0.7852000 | 0.8722000 |
| 2 | minus binary cross entropy | -0.3002033 | -0.2996994 |
| 2 | accuracy | 0.9040000 | 0.8895000 |
| 3 | minus binary cross entropy | -0.2165675 | -0.2963943 |
| 3 | accuracy | 0.9303333 | 0.8822000 |
dT$measure <- factor(dT$measure,
levels = c("minus binary cross entropy",
"accuracy"))
# note: this step requres wrapr 1.0.3 or better
dT <- dT %.>%
mutate_se(.,
qae(rmin := ifelse(validation <= training, validation, NA),
rmax := ifelse(validation <= training, training, NA),
discounted := ifelse(validation <= training,
validation - 0.1*(training-validation),
validation)))
pick <- dT %.>%
filter_se(.,
qe(measure == "minus binary cross entropy")) %.>%
.$epoch[[which.max(.$discounted)]]
ggplot(data = dT,
aes(x = epoch,
xend = epoch,
y = validation,
yend = training,
ymin = rmin,
ymax = rmax)) +
geom_segment(alpha = 0.5) +
geom_point() +
geom_point(aes(y = training), shape = 3, alpha = 0.5) +
stat_smooth(geom = "line",
se = FALSE,
color = "#d95f02",
alpha = 0.8,
method = "loess") +
stat_smooth(geom = "line",
aes(y = discounted),
se = FALSE,
color = "#d95f02",
alpha = 0.2,
method = "loess",
linetype = 2) +
geom_ribbon(alpha=0.2, fill = "#1b9e77") +
geom_vline(xintercept = pick, alpha=0.7, color='#e6ab02') +
facet_wrap(~measure, ncol=1, scales = 'free_y') +
ylab("performance") +
ggtitle("model performance by epoch, dataset, and measure")
All of the above is now wrapped in convenient function: WVPlots::plot_Keras_fit_trajectory().
Conclusion
All of the above is based on the second generation fluid data theory behind the cdata package. The first generation of the theory was about establishing and maintaining invariant that make data transform reversible and commutative. The second generation of the theory is about transforms beyond pivot/un-pivot (moving sets of values in unison).
A quick list of references: