Train a neural network model to classify images of clothing.

[Link]("keras")

Installing package into ‘/usr/local/lib/R/site-library’

(as ‘lib’ is unspecified)

also installing the dependencies ‘RcppTOML’, ‘here’, ‘png’, ‘config’, ‘tfautograph’, ‘reticulate’, ‘tensorflow’, ‘tfrun

library(keras)

[Link](c("ggplot2", "cowplot", "tidyr"))

Installing packages into ‘/usr/local/lib/R/site-library’

(as ‘lib’ is unspecified)

fashion_mnist <- dataset_fashion_mnist()

str(fashion_mnist)

List of 2
$ train:List of 2
..$ x: int [1:60000, 1:28, 1:28] 0 0 0 0 0 0 0 0 0 0 ...
..$ y: int [1:60000(1d)] 9 0 0 3 0 2 7 2 5 5 ...
$ test :List of 2
..$ x: int [1:10000, 1:28, 1:28] 0 0 0 0 0 0 0 0 0 0 ...
..$ y: int [1:10000(1d)] 9 2 1 1 6 1 4 6 5 7 ...

c(train_images, train_labels) %<-% fashion_mnist$train

c(test_images, test_labels) %<-% fashion_mnist$test

str(train_images)

int [1:60000, 1:28, 1:28] 0 0 0 0 0 0 0 0 0 0 ...

str(train_labels)

int [1:60000(1d)] 9 0 0 3 0 2 7 2 5 5 ...

class_names <- c('T-shirt/top', 'Trouser', 'Pullover', 'Dress', 'Coat',

'Sandal', 'Shirt', 'Sneaker', 'Bag', 'Ankle boot')
num_classes <- length(class_names)

dim(train_images)

60000 · 28 · 28

range(train_images)

0 · 255

dim(train_labels)

60000

train_labels %>% unique() %>% sort()

0·1·2·3·4·5·6·7·8·9

dim(test_images)

10000 · 28 · 28

dim(test_labels)
10000

library(tidyr)
library(ggplot2)

plot_fashionmnist_image <- function(image){

image <- [Link](image)
colnames(image) <- seq_len(ncol(image))
image$y <- seq_len(nrow(image))
image <- gather(image, "x", "value", -y)
image$x <- [Link](image$x)

ggplot(image, aes(x = x, y = y, fill = value)) +

geom_tile() +
scale_fill_gradient(low = "white", high = "black", [Link] = NA) +
scale_y_reverse() +
theme_minimal() +
theme([Link] = element_blank(),
[Link] = element_blank(),
[Link] = element_blank(),
[Link] = 1)
}

plot_fashionmnist_image(train_images[1,,])

train_images <- train_images/255

test_images <- test_images/255

train_images <- array_reshape(train_images, c(nrow(train_images), 28, 28, 1))

test_images <- array_reshape(test_images, c(nrow(test_images), 28, 28, 1))

range(train_images)
range(test_images)

0·1
0·1

par(mfcol=c(5,5))
par(mar=c(0, 0, 1.5, 0), xaxs='i', yaxs='i')
for (i in 1:25) {
img <- train_images[i, , , ]
img <- t(apply(img, 2, rev))
image(1:28, 1:28, img, col = gray((0:255)/255), xaxt = 'n', yaxt = 'n',
main = paste(class_names[train_labels[i] + 1]))
}
dim(train_images)
dim(test_images)

60000 · 28 · 28 · 1
10000 · 28 · 28 · 1

library(tensorflow)

[Link]("keras")
[Link]("keras3") # or remotes::install_github("rstudio/keras")

library(keras3)

Removing package from ‘/usr/local/lib/R/site-library’

(as ‘lib’ is unspecified)

Installing package into ‘/usr/local/lib/R/site-library’

(as ‘lib’ is unspecified)

Registered S3 methods overwritten by 'keras3':

method from
[Link].keras_training_history keras
plot.keras_training_history keras
print.keras_training_history keras
r_to_py.R6ClassGenerator keras

Attaching package: ‘keras3’

The following objects are masked from ‘package:tensorflow’:

set_random_seed, shape

The following objects are masked from ‘package:keras’:

%<-active%, %py_class%, activation_elu, activation_exponential,

activation_gelu, activation_hard_sigmoid, activation_linear,
activation_relu, activation_selu, activation_sigmoid,
activation_softmax, activation_softplus, activation_softsign,
activation_tanh, adapt, application_densenet121,
application_densenet169, application_densenet201,
application_efficientnet_b0, application_efficientnet_b1,
application_efficientnet_b2, application_efficientnet_b3,
application_efficientnet_b4, application_efficientnet_b5,
application_efficientnet_b6, application_efficientnet_b7,
application_inception_resnet_v2, application_inception_v3,
application_mobilenet, application_mobilenet_v2,
application_mobilenet_v3_large, application_mobilenet_v3_small,
application_nasnetlarge, application_nasnetmobile,
application_resnet101, application_resnet101_v2,
application_resnet152, application_resnet152_v2,
 application_resnet50, application_resnet50_v2, application_vgg16,
application_vgg19, application_xception, bidirectional,
callback_backup_and_restore, callback_csv_logger,
callback_early_stopping, callback_lambda,
callback_learning_rate_scheduler, callback_model_checkpoint,
callback_reduce_lr_on_plateau, callback_remote_monitor,
callback_tensorboard, clone_model, constraint_maxnorm,
constraint_minmaxnorm, constraint_nonneg, constraint_unitnorm,
count_params, custom_metric, dataset_boston_housing,
dataset_cifar10, dataset_cifar100, dataset_fashion_mnist,
dataset_imdb, dataset_imdb_word_index, dataset_mnist,
dataset_reuters, dataset_reuters_word_index, freeze_weights,
from_config, get_config, get_file, get_layer, get_vocabulary,
get_weights, image_array_save, image_dataset_from_directory,
image_load, image_to_array, imagenet_decode_predictions,
imagenet_preprocess_input, initializer_constant,
initializer_glorot_normal, initializer_glorot_uniform,
initializer he normal initializer he uniform

x_train <- train_images %>%

array_reshape(c(60000, 28, 28, 1))
x_test <- test_images %>%
array_reshape(c(10000, 28, 28, 1))

dim(train_images)
dim(x_train)

60000 · 28 · 28 · 1
60000 · 28 · 28 · 1

model <- keras_model_sequential()

model %>%
layer_flatten(input_shape = c(28, 28)) %>%
layer_dense(units = 128, activation = 'relu') %>%
layer_dense(units = 10, activation = 'softmax')

model %>% compile( optimizer = 'adam',

loss = 'sparse_categorical_crossentropy',
metrics = c('accuracy')
)

model <- keras_model_sequential()

model %>%
layer_conv_2d(filters = 32, kernel_size = c(3,3), padding = 'same',
activation = 'relu', input_shape = c(28, 28, 1)) %>%
layer_max_pooling_2d(pool_size = c(2, 2), strides = 2) %>%
layer_conv_2d(filters = 64, kernel_size = c(3,3), padding = 'same',
activation = 'relu') %>%
layer_max_pooling_2d(pool_size = c(2, 2), stride = 2) %>%
layer_flatten() %>%
layer_dense(units = 128, activation = 'relu') %>%
layer_dense(units = 10, activation = 'softmax')

summary(model)

Model: "sequential"
┏━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━┳━━━━━━━━━━━━━━━━━━━━━━━━━━┳━━━━━━━━━━━━━━━┓
┃ Layer (type) ┃ Output Shape ┃ Param # ┃
┡━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━╇━━━━━━━━━━━━━━━━━━━━━━━━━━╇━━━━━━━━━━━━━━━┩
│ flatten (Flatten) │ (None, 784) │ 0 │
├───────────────────────────────────┼──────────────────────────┼───────────────┤
│ dense (Dense) │ (None, 128) │ 100,480 │
├───────────────────────────────────┼──────────────────────────┼───────────────┤
│ dense_1 (Dense) │ (None, 10) │ 1,290 │
└───────────────────────────────────┴──────────────────────────┴───────────────┘
Total params: 101,770 (397.54 KB)
Trainable params: 101,770 (397.54 KB)
Non-trainable params: 0 (0.00 B)

model %>% compile(

loss = 'sparse_categorical_crossentropy',
optimizer = 'adam',
 metrics = c('accuracy')
)

history<- model %>% fit(x_train, train_labels, epochs = 5,verbose = 2)

history_df <- [Link](history)

str(history_df)

'[Link]': 10 obs. of 4 variables:

$ epoch : int 1 2 3 4 5 1 2 3 4 5
$ value : num 0.922 0.926 0.927 0.929 0.932 ...
$ metric: Factor w/ 2 levels "accuracy","loss": 1 1 1 1 1 2 2 2 2 2
$ data : Factor w/ 2 levels "training","validation": 1 1 1 1 1 1 1 1 1 1

hist<-as_tibble(history_df)
hist

A tibble: 10 × 4
epoch value metric data

<int> <dbl> <fct> <fct>

1 0.9222834 accuracy training

2 0.9257666 accuracy training

3 0.9269834 accuracy training

4 0.9289666 accuracy training

5 0.9315833 accuracy training

1 0.2065779 loss training

2 0.1996884 loss training

3 0.1934710 loss training

4 0.1887941 loss training

5 0.1843376 loss training

score <- model %>% evaluate(x_train, train_labels)

cat('Train Loss & Accuracy:', score,'acc', "\n")

Train Loss & Accuracy:

Error in cat("Train Loss & Accuracy:", score, "acc", "\n"): argument 2 (type 'list') cannot be handled by 'cat'
Traceback:

1. .handleSimpleError(function (cnd)
. {
. watcher$capture_plot_and_output()
. cnd <- sanitize_call(cnd)
. watcher$push(cnd)
. switch(on_error, continue = invokeRestart("eval_continue"),
. stop = invokeRestart("eval_stop"), error = invokeRestart("eval_error",
. cnd))
. }, "argument 2 (type 'list') cannot be handled by 'cat'", base::quote(cat("Train Loss & Accuracy:",
. score, "acc", "\n")))

plot(history)
score <- model %>% evaluate(x_test, test_labels)
cat('Test Loss & Accuracy:', score,'acc', "\n")

Test Loss & Accuracy:

Error in cat("Test Loss & Accuracy:", score, "acc", "\n"): argument 2 (type 'list') cannot be handled by 'cat'
Traceback:

1. .handleSimpleError(function (cnd)
. {
. watcher$capture_plot_and_output()
. cnd <- sanitize_call(cnd)
. watcher$push(cnd)
. switch(on_error, continue = invokeRestart("eval_continue"),
. stop = invokeRestart("eval_stop"), error = invokeRestart("eval_error",
. cnd))
. }, "argument 2 (type 'list') cannot be handled by 'cat'", base::quote(cat("Test Loss & Accuracy:",
. score, "acc", "\n")))

predictions <- model %>% predict(x_test)

predictions[1, ]

3.24519647265653e-11 · 5.68119240540454e-09 · 1.64125946167104e-09 · 1.56476783976954e-14 · 5.32035882017112e-09 ·

1.15231059680809e-05 · 5.07938302529709e-10 · 0.0019032247364521 · 3.10466539629739e-12 · 0.998085260391235

[Link](predictions[1, ])

10

options([Link]=10, [Link]=10)
par(mfcol=c(5,5))
par(mar=c(0, 0, 1.5, 0), xaxs='i', yaxs='i')
for (i in 1:25) {
img <- test_images[i, , ]
img <- t(apply(img, 2, rev))
predicted_label <- [Link](predictions[i, ]) - 1
true_label <- test_labels[i]
if (predicted_label == true_label) { color <- 'blue' }
else
{ color <- 'red' }
image(1:28, 1:28, img, col = gray((0:255)/255), xaxt = 'n', yaxt = 'n',
main = paste0(class_names[predicted_label + 1], " (",class_names[true_label + 1], ")"),[Link] = color)}

Error in test_images[i, , ]: incorrect number of dimensions

Traceback:
scores <- model %>% evaluate(test_images, test_labels)

# Output metrics
cat('Test loss:', scores[[1]], '\n')
cat('Test accuracy:', scores[[2]], '\n')

Test loss: 0.8826

Test accuracy: 0.3441189

pred_images <- test_images[1:32 , , , , drop = FALSE]

pred_labels <- test_labels[1:32]

preds_probs <- model %>%

predict(x = pred_images)

head(preds_probs)

A matrix: 6 × 10 of type dbl

3.245196e- 5.681192e- 1.641259e- 1.564768e- 5.320359e- 1.152311e- 5.079383e- 1.903225e- 3.104665e- 9.980853e-
11 09 09 14 09 05 10 03 12 01

7.081746e- 2.623711e- 9.995106e- 9.174715e- 3.919673e- 7.934851e- 2.653010e- 4.491029e- 1.738623e- 8.065196e-
05 13 01 13 04 12 05 22 12 14

5.550625e- 9.999999e- 2.070105e- 1.090525e- 2.982734e- 8.962635e- 5.027970e- 5.967017e- 1.837745e- 3.876291e-
12 01 16 14 18 25 16 30 15 27

1.957514e- 9.999999e- 7.471305e- 6.720483e- 3.570542e- 6.133036e- 1.306317e- 1.481444e- 4.069728e- 1.201304e-
10 01 12 09 13 23 11 22 14 20

1.219935e- 1.206785e- 4.220506e- 2.247167e- 2.610841e- 1.261450e- 9.851050e- 3.855647e- 7.270683e- 1.000305e-
02 08 04 03 05 07 01 11 08 07

1.124646e- 9.999999e- 9.364376e- 1.915236e- 1.990840e- 6.595905e- 1.174106e- 9.756622e- 5.269735e- 9.262436e-
10 01 13 12 15 20 11 23 14 23

apply(preds_probs, 1, [Link]) - 1

9·2·1·1·6·1·4·6·5·7·4·5·5·3·4·1·2·2·8·0·2·5·7·5·1·6·6·0·9·3·8·8

predictions <- model %>% predict(test_images)

predictions[1, ]

4.31267972089699e-06 · 4.05745770315491e-10 · 2.44669786297891e-06 · 6.54370724273434e-10 · 4.39972320728788e-12 ·

7.05943079992721e-07 · 2.41228015340766e-08 · 8.30950739327818e-06 · 6.46263598191865e-10 · 0.99998414516449

[Link](predictions[1, ])

10

class_pred <- model %>% predict(test_images) %>% k_argmax()

class_pred[1:20]

[Link]([9 2 1 1 6 1 4 6 5 7 4 5 7 3 4 1 2 4 8 0], shape=(20), dtype=int64)

test_labels[1]

img <- test_images[1, , , drop = FALSE]

dim(img)

Error in test_images[1, , , drop = FALSE]: incorrect number of dimensions

Traceback:
preds_classes <- model %>%
predict(x = pred_images)

preds_classes

A matrix: 32 × 10 of type dbl

3.245196e- 5.681192e- 1.641259e- 1.564768e- 5.320359e- 1.152311e- 5.079383e- 1.903225e- 3.104665e- 9.980853e-
11 09 09 14 09 05 10 03 12 01

7.081746e- 2.623711e- 9.995106e- 9.174715e- 3.919673e- 7.934851e- 2.653010e- 4.491029e- 1.738623e- 8.065196e-
05 13 01 13 04 12 05 22 12 14

5.550625e- 9.999999e- 2.070105e- 1.090525e- 2.982734e- 8.962635e- 5.027970e- 5.967017e- 1.837745e- 3.876291e-
12 01 16 14 18 25 16 30 15 27

1.957514e- 9.999999e- 7.471305e- 6.720483e- 3.570542e- 6.133036e- 1.306317e- 1.481444e- 4.069728e- 1.201304e-
10 01 12 09 13 23 11 22 14 20

1.219935e- 1.206785e- 4.220506e- 2.247167e- 2.610841e- 1.261450e- 9.851050e- 3.855647e- 7.270683e- 1.000305e-
02 08 04 03 05 07 01 11 08 07

1.124646e- 9.999999e- 9.364376e- 1.915236e- 1.990840e- 6.595905e- 1.174106e- 9.756622e- 5.269735e- 9.262436e-
10 01 13 12 15 20 11 23 14 23

1.641601e- 2.181746e- 6.102529e- 7.807710e- 9.998813e- 2.219171e- 5.762967e- 9.446674e- 1.338171e- 3.064601e-
11 09 05 09 01 15 05 14 10 17

9.100473e- 1.975855e- 6.332509e- 1.900513e- 2.351546e- 4.953081e- 9.975833e- 3.605980e- 1.825058e- 1.785367e-
09 10 05 06 03 13 01 11 10 13

8.582561e- 1.657118e- 3.919179e- 1.812453e- 2.730706e- 9.999986e- 7.669777e- 4.250066e- 3.409753e- 6.626610e-
07 15 10 19 09 01 11 07 10 14

3.797787e- 1.005927e- 3.960207e- 1.781848e- 4.197960e- 1.177201e- 2.937344e- 9.999853e- 6.722638e- 2.859714e-
10 14 10 18 13 05 11 01 10 06

3.097404e- 3.361190e- 3.947598e- 7.647903e- 9.577128e- 8.438374e- 2.807334e- 2.868102e- 1.287936e- 7.075577e-
06 08 02 11 01 11 03 10 10 07

5.126124e- 8.141735e- 1.653506e- 8.097435e- 3.699514e- 9.999984e- 7.947841e- 1.103290e- 4.795469e- 7.181047e-
12 13 11 15 07 01 09 06 14 08

1.947671e- 1.812473e- 3.362632e- 3.403310e- 6.201826e- 9.851114e- 3.554242e- 1.243767e- 1.364444e- 5.064840e-
08 09 10 13 10 01 07 03 02 12

1.923720e- 1.127536e- 4.528798e- 9.988303e- 4.538405e- 1.800546e- 1.774506e- 1.689370e- 1.188893e- 4.631493e-
05 03 06 01 06 07 06 08 05 08

1.862695e- 2.748206e- 2.748010e- 1.503402e- 7.184048e- 5.029130e- 6.514141e- 1.198963e- 1.002933e- 9.682179e-
06 05 01 04 01 14 03 10 04 08

1.431510e- 9.999996e- 3.158825e- 4.056385e- 1.287640e- 2.352411e- 1.494183e- 2.111094e- 3.546925e- 7.293140e-
08 01 10 07 08 17 09 17 10 15

6.139032e- 3.593169e- 9.957889e- 3.394531e- 6.546053e- 1.249036e- 3.494586e- 1.783136e- 2.912117e- 4.997220e-
05 08 01 07 04 10 03 12 09 08

4.244176e- 1.328335e- 7.834128e- 1.077112e- 1.983005e- 1.784236e- 1.816284e- 4.571959e- 1.588417e- 7.732755e-
05 06 01 06 01 11 02 09 06 05

5.699032e- 1.337713e- 1.184032e- 8.814687e- 1.693892e- 1.345573e- 6.601865e- 4.199495e- 9.999979e- 1.310115e-
09 12 08 09 08 06 07 09 01 11

7.205077e- 9.455926e- 1.190111e- 4.363810e- 1.581982e- 8.702642e- 2.739356e- 8.468111e- 1.499278e- 8.567878e-
01 08 03 03 06 07 01 17 07 08

2.454505e- 4.457782e-
preds_classes[1] 9.923526e- 4.914188e- 6.425013e- 9.573382e- 4.542725e- 2.421903e- 4.543741e- 7.125972e-
03 09 01 09 04 10 03 09 07 06
Error: object 3.511381e-
4.421780e- 'preds_classes' not found
1.097588e- 3.300466e- 6.800636e- 9.998923e- 8.447063e- 1.076666e- 4.174629e- 1.397562e-
Traceback:
12 11 10 16 11 01 11 04 10 08

2.390146e- 1.210242e- 3.264888e- 1.348515e- 5.416631e- 1.349981e- 1.837456e- 9.998624e- 7.603222e- 1.743659e-
12 11 11 14 11 04 09 01 07 06
class_names[preds_classes[1] + 1]
3.824093e- 2.438442e- 1.605840e- 1.792940e- 1.985672e- 9.935328e- 1.503136e- 2.300219e- 5.695142e- 6.236533e-
'T-shirt/top'10 09 11 12 08 01 07 04 07 03

3.030556e- 9.999999e- 1.134850e- 1.116937e- 2.261311e- 1.277215e- 1.556846e- 4.695740e- 7.236515e- 4.075952e-
10
library(ggplot2) 01 13 11 15 23 13 26 14 25
library(cowplot)
5.072941e- 1.233404e- 3.540206e- 2.509521e- 2.104406e- 2.969404e- 4.352238e- 3.503519e- 4.773534e- 2.391874e-
05 05 01 04 01 10 01 08 07 07
# Function to plot bar plot of probabilities across each class
plot_preds_bar <- function(probs,
9.678350e- 3.584358e- 2.088948e-label){
6.505897e- 2.265255e- 6.641810e- 7.525674e- 5.451436e- 8.308778e- 4.216189e-
06 08 02 06 01 10 01 09 07 07
plot_data <- [Link](class = [Link](0:9), probability = probs, pred_label = FALSE, label = FALSE)
7.170529e- 1.866322e- 1.758587e- 2.729275e- 1.906289e- 5.376355e- 2.369715e- 3.371867e- 2.621163e- 2.651781e-
plot_data$pred_label[[Link](probs)] <- TRUE
01 02 05 02 06 11 01 16 09 10
 plot_data$label[label + 1] <- TRUE
4.747311e- 3.364326e- 4.755867e- 6.939696e- 9.702948e- 3.615157e- 7.215792e- 2.246223e- 9.375513e- 9.775342e-
plot_data$legend <- "not predicted - correct"
13 09 13 15 13 06 13 02 13 01
plot_data$legend[plot_data$pred_label & plot_data$label] <- "predicted - correct"
plot_data$legend[plot_data$pred_label
1.532881e- & !plot_data$label]
5.424214e- 6.003133e- 8.346134e- 2.373854e- <- "predicted
6.987405e- - incorrect"
1.275640e- 4.498858e- 1.090026e- 2.228880e-
03 03 03 & !plot_data$pred_label]
plot_data$legend[plot_data$label 01 02 <- "actual
06 - incorrect"
01 06 03 05

4.807737e- 4.191807e- 4.175571e- 5.320999e- 8.099199e- 1.212280e- 3.442437e- 6.129789e- 9.999999e- 3.157727e-
ggplot(plot_data, aes(x = class, y = probability, fill = legend)) +
19 23 25 23 17 18 22 14 01 23
geom_bar(stat = "identity") +
scale_fill_manual(values
1.524141e- = c("predicted
5.868164e- 1.119861e- - correct"
1.716203e- = "blue",
4.322956e- 2.084113e- 8.497471e- 2.194180e- 9.999999e- 1.133308e-
10 09 "predicted 09
12 - incorrect"08= "red", 10 11 15 01 15
"actual - incorrect" = "blue",
"not predicted - correct" = "grey"),
guide = "none") +
theme_classic()
}
# Function to plot raw image and bar plot of probabilities across each class
plot_preds <- function(image, probs, label, class_names){

pred_label <- [Link](probs) - 1

correct_label <- label == pred_label
title_colour <- if(correct_label){"blue"}else{"red"}

# create title string

title <- ggdraw() +
draw_label(
paste0(class_names[pred_label + 1], " ", format(max(probs) * 100, digits = 3),
"% ", " (", class_names[label + 1], ")"),
fontface = 'bold',
x = 0,
hjust = 0,
color = title_colour) +
theme([Link] = margin(0, 0, 0, 7))

# Generate the two plots

p1 <- plot_fashionmnist_image(image)
p2 <- plot_preds_bar(probs, label)

# Create row of plots

plot_row <- plot_grid(p1, p2)

# Bring together title and row of images

plot_grid(title, plot_row, ncol = 1, rel_heights = c(0.1, 1))
}

options([Link] = 10, [Link] = 5)

i <- 1
plot_preds(pred_images[i,,,], preds_probs[i,], pred_labels[i], class_names)

i <- 5
plot_preds(pred_images[i,,,], preds_probs[i,], pred_labels[i], class_names)
options([Link] = 14, [Link] = 8)
j <- 16
plot_list <- [Link](vector(length = j))
for(i in 1:j){
plot_list[[i]]<- plot_preds(pred_images[i,,,], preds_probs[i,],
pred_labels[i], class_names)
}
plot_grid(plotlist = plot_list, ncol = 4)