Start up and show original `Keras` plot. ```{r setup} library("ggplot2") library("cdata") library("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)) # flip loss score so that larger = better 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") ``` Or with a bit more color: ```{r setup2} 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") ``` # Reproducing the first plot First plot: reproduce the original with bulk-renaming of columns (via the new [`cdata::map_fieldsD()`](https://winvector.github.io/cdata/reference/map_fieldsD.html) function). First we perform the equivalent of a "shred", "un-pivot", or "gather": ```{r firstplot} 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") ``` Then we define a value mapping table to build the new value key columns that we need. ```{r fp2} 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") ``` We apply that key map and we are ready to plot: ```{r akm} 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") # this is picking the epoch with the optimal loss # (minimum(loss) -> maximum(-loss) pick <- dT %.>% filter_se(., qe(measure == "minus binary cross entropy", dataset == "validation")) %.>% .$epoch[[which.max(.$performance)]] # pick colors so that validation curve is perceptually dominant. # training comes first manual_scale = c("#fec44f", "#993404") 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="#993404", linetype=2) + scale_color_manual(values =manual_scale) + 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()](https://winvector.github.io/WVPlots/reference/plot_Keras_fit_trajectory.html). 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. ```{r lineplot} 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") ``` Let's concentrate on a single row (in this case the first row). ```{r lineplot1} d %.>% head(., n=1) %.>% select_se(., qc(epoch, val_loss, val_acc, loss, acc)) %.>% 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") ``` 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: ```{r lineplot2} 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") ``` 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: ```{r lpcct} 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") ``` 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()`). ```{r lpc} 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") # Now move it back cR %.>% moveValuesToRowsD( ., controlTable = cT) ``` Try this with numbers. ```{r proto} onerow = d %.>% head(., n=1) onerow %.>% knitr::kable(.) %.>% kable_styling(., full_width = F) %.>% row_spec(., 0:nrow(cR), background = "lightgrey") %.>% column_spec(., 1:4, background = "yellow") r1 = moveValuesToRowsD(onerow, controlTable=cT, columnsToCopy = 'epoch') r1 %.>% knitr::kable(.) %.>% kable_styling(., full_width = F) %.>% row_spec(., 0:nrow(cT), background = "lightgrey") %.>% column_spec(., 2, background = "lightgreen") %.>% column_spec(., 3:4, background = "yellow") moveValuesToColumnsD(r1, controlTable=cT, keyColumns='epoch') %.>% knitr::kable(.) %.>% kable_styling(., full_width = F) %.>% row_spec(., 0:nrow(cR), background = "lightgrey") %.>% column_spec(., 2:5, background = "yellow") ``` We can now apply the transform to all the data, and produce the final plot. ```{r moveall} 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") %.>% column_spec(., 2, background = "lightgreen") %.>% column_spec(., 3:4, background = "yellow") 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()](https://winvector.github.io/WVPlots/reference/plot_Keras_fit_trajectory.html). # Conclusion All of the above is based on the second generation fluid data theory behind the `cdata` package. The [first generation of the theory](http://winvector.github.io/FluidData/RowsAndColumns.html) was about establishing and maintaining invariant that make data transform reversible and commutative. The [second generation of the theory](http://winvector.github.io/FluidData/ArbitraryTransform.html) is about transforms beyond pivot/un-pivot (moving sets of values in unison). A quick list of references: * [Coordinatized Data: A Fluid Data Specification](http://winvector.github.io/FluidData/RowsAndColumns.html) * [Arbitrary Data Transforms Using cdata](http://winvector.github.io/FluidData/ArbitraryTransform.html) * [Data Wrangling at Scale](http://winvector.github.io/FluidData/DataWranglingAtScale.html) * [Big Data Transforms](http://winvector.github.io/FluidData/BigDataTransforms.html) * [cdata Transforms](http://winvector.github.io/FluidData/PlotExample/PlotExample.html) (*this article*) * [Plotting Keras Performance Trajectories](http://winvector.github.io/FluidData/PlotExample/KerasPerfPlot.html) * [Plotting xgboost Performance Trajectories](http://winvector.github.io/FluidData/PlotExample/xgboostPerfPlot.html)