add: custom metrics support and metric.subspace,
wip: new binary response datasets, add: nn$evaluate, add: simulation_binary
This commit is contained in:
parent
ffd02744a8
commit
a673b50c7a
|
|
@ -7,6 +7,7 @@ export(dist.grassmann)
|
|||
export(dist.mave)
|
||||
export(dist.subspace)
|
||||
export(get.script)
|
||||
export(metric.subspace)
|
||||
export(nnsdr)
|
||||
export(parse.args)
|
||||
export(reinitialize_weights)
|
||||
|
|
|
|||
|
|
@ -255,6 +255,54 @@ dataset <- function(name = "M1", n = NULL, p = 20, sd = 0.5, ...) {
|
|||
XB <- X %*% B
|
||||
Y <- 10 * sin(pi * XB[, 1] * XB[, 2]) + 20 * (XB[, 3] - 0.5)^2 + 5 * XB[, 4] + rnorm(n, sd = sd)
|
||||
Y <- as.matrix(Y)
|
||||
} else if (name == "B1") {
|
||||
if (missing(n)) { n <- 400 }
|
||||
|
||||
B <- diag(1, p, 1)
|
||||
X <- matrix(runif(n * p, -2, 2), n, p)
|
||||
Y <- (X %*% B + rnorm(n, 0, sd)) > 0
|
||||
} else if (name == "B2") {
|
||||
if (missing(n)) { n <- 400 }
|
||||
|
||||
B <- diag(1, p, 2)
|
||||
Y <- as.matrix(sample(as.logical(0:1), n, replace = TRUE))
|
||||
X <- matrix(rnorm(n * p, sd = sd), n, p)
|
||||
x1 <- sample(c(-1, 1), n, replace = TRUE)
|
||||
x2 <- x1 * c(-1, 1)[Y + 1]
|
||||
X[, 1] <- X[, 1] + x1
|
||||
X[, 2] <- X[, 2] + x2
|
||||
} else if (name == "B3") {
|
||||
if (missing(n)) { n <- 1600 }
|
||||
if (missing(sd)) { sd <- 0.1 }
|
||||
|
||||
B <- diag(1, p, 3)
|
||||
Y <- sample(as.logical(0:1), n, replace = TRUE)
|
||||
x <- seq(0, 6 * pi, length.out = n)
|
||||
X <- matrix(rnorm(n * p, sd = sd), n, p)
|
||||
X[, 1] <- X[, 1] + 0.5 * sin(x + pi * Y)
|
||||
X[, 2] <- X[, 2] + 0.5 * cos(x + pi * Y)
|
||||
X[, 3] <- X[, 3] + (x - 3 * pi) / (3 * pi)
|
||||
} else if (name == "B4") {
|
||||
# Let
|
||||
# X ~ N_p(0, I_p)
|
||||
# then,
|
||||
# Y | X ~ Binom(sin(atan2(Z_1, Z_2) + Z_3)^2)
|
||||
# or in other words
|
||||
# E(Y | X) = sin(atan2(Z_1, Z_2) + Z_3)^2
|
||||
|
||||
if (missing(n)) { n <- 1600 }
|
||||
|
||||
B <- diag(1, p, 3)
|
||||
X <- matrix(rnorm(n * p, sd = sd), n, p)
|
||||
|
||||
# Angle and Height for each X with respect to the spiral manifold
|
||||
XB <- X %*% B
|
||||
phi <- atan2(XB[, 1], XB[, 2])
|
||||
h <- XB[, 3]
|
||||
|
||||
prob <- sin(phi + h)^2
|
||||
Y <- apply(cbind(prob, 1 - prob), 1, sample, x = as.logical(0:1),
|
||||
size = 1, replace = FALSE)
|
||||
} else {
|
||||
stop("Got unknown dataset name.")
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,58 @@
|
|||
#' @export
|
||||
metric.subspace <- function(B_true,
|
||||
X = NULL, Y = NULL,
|
||||
type = c("Refinement", "OPG"),
|
||||
name = "metric.subspace",
|
||||
normalize = FALSE
|
||||
) {
|
||||
type <- match.arg(type)
|
||||
|
||||
if (!is.matrix(B_true))
|
||||
B_true <- as.matrix(B_true)
|
||||
P_true <- B_true %*% solve(crossprod(B_true), t(B_true))
|
||||
P_true <- tf$constant(P_true, dtype = 'float32')
|
||||
|
||||
if (normalize) {
|
||||
rankSum <- 2 * ncol(B_true)
|
||||
c <- 1 / sqrt(min(rankSum, 2 * nrow(B_true) - rankSum))
|
||||
} else {
|
||||
c <- sqrt(2)
|
||||
}
|
||||
c <- tf$constant(c, dtype = 'float32')
|
||||
|
||||
if (type == "Refinement") {
|
||||
structure(function(model) {
|
||||
B <- model$get_layer('reduction')$weights
|
||||
function(y_true, y_pred) {
|
||||
P <- tf$linalg$matmul(B, B, transpose_b = TRUE)
|
||||
diff <- P_true - P
|
||||
c * tf$sqrt(tf$reduce_sum(tf$math$multiply(diff, diff)))
|
||||
}
|
||||
},
|
||||
class = c("nnsdr.metric", "Refinement"),
|
||||
name = name
|
||||
)
|
||||
} else {
|
||||
X <- tf$cast(X, dtype = 'float32')
|
||||
begin <- tf$cast(c(0, nrow(B_true) - ncol(B_true) - 1), dtype = 'int32')
|
||||
size <- tf$cast(c(nrow(B_true), ncol(B_true)), dtype = 'int32')
|
||||
structure(function(model) {
|
||||
function(y_true, y_pred) {
|
||||
with(tf$GradientTape() %as% tape, {
|
||||
tape$watch(X)
|
||||
out <- model(X)
|
||||
})
|
||||
G <- tape$gradient(out, X)
|
||||
B <- tf$linalg$eigh(tf$linalg$matmul(G, G, transpose_a = TRUE))
|
||||
B <- tf$linalg$qr(tf$slice(B[[2]], begin, size))$q
|
||||
|
||||
P <- tf$linalg$matmul(B, B, transpose_b = TRUE)
|
||||
diff <- P_true - P
|
||||
c * tf$sqrt(tf$reduce_sum(tf$math$multiply(diff, diff)))
|
||||
}
|
||||
},
|
||||
class = c("nnsdr.metric", "OPG"),
|
||||
name = name
|
||||
)
|
||||
}
|
||||
}
|
||||
|
|
@ -72,7 +72,7 @@ build.MLP <- function(input_shapes, d, name, add_reduction,
|
|||
|
||||
if (!is.null(metrics)) {
|
||||
metrics <- as.list(metrics)
|
||||
for (i in seq_along(metrics)) {
|
||||
for (i in rev(seq_along(metrics))) {
|
||||
metric <- metrics[[i]]
|
||||
if (all(c("nnsdr.metric", name) %in% class(metric))) {
|
||||
metric_fn <- reticulate::py_func(metric(mlp))
|
||||
|
|
@ -275,6 +275,30 @@ nnsdr <- setRefClass('nnsdr',
|
|||
as.array(output)
|
||||
}
|
||||
},
|
||||
evaluate = function(inputs, output) {
|
||||
if (is.list(inputs)) {
|
||||
inputs <- Map(tf$cast, as.list(inputs), dtype = 'float32')
|
||||
} else {
|
||||
inputs <- list(tf$cast(inputs, dtype = 'float32'))
|
||||
}
|
||||
eval.opg <- .self$nn.opg$evaluate(inputs, output,
|
||||
return_dict = TRUE, verbose = 0L)
|
||||
|
||||
if (is.null(.self$history.ref))
|
||||
return(data.frame(eval.opg, row.names = "OPG"))
|
||||
|
||||
eval.ref <- .self$nn.ref$evaluate(inputs, output,
|
||||
return_dict = TRUE, verbose = 0L)
|
||||
|
||||
# Convert to data.frame
|
||||
eval.opg <- data.frame(eval.opg, row.names = "OPG")
|
||||
eval.ref <- data.frame(eval.ref, row.names = "Refinement")
|
||||
# Augment mutualy exclusive columns
|
||||
eval.opg[setdiff(names(eval.ref), names(eval.opg))] <- NA
|
||||
eval.ref[setdiff(names(eval.opg), names(eval.ref))] <- NA
|
||||
# Combine/Bind
|
||||
rbind(eval.opg, eval.ref)
|
||||
},
|
||||
coef = function(type = c('Refinement', 'OPG')) {
|
||||
type <- match.arg(type)
|
||||
if (type == 'Refinement') {
|
||||
|
|
|
|||
|
|
@ -0,0 +1,163 @@
|
|||
library(keras)
|
||||
|
||||
num_classes <- 10L
|
||||
epochs <- 20L
|
||||
batch_size <- 128L
|
||||
|
||||
################################################################################
|
||||
### Loading & Prepair MNIST dataset ###
|
||||
################################################################################
|
||||
|
||||
c(c(x_train, y_train), c(x_test, y_test)) %<-% dataset_mnist()
|
||||
|
||||
x_train <- array_reshape(x_train, c(nrow(x_train), prod(dim(x_train)[-1])))
|
||||
x_test <- array_reshape(x_test , c(nrow(x_test ), prod(dim(x_test )[-1])))
|
||||
|
||||
# x_train <- x_train / 255
|
||||
# x_test <- x_test / 255
|
||||
center <- apply(x_train, 2, mean)
|
||||
x_train <- (x_train - center) / 128
|
||||
x_test <- (x_test - center) / 128
|
||||
|
||||
y_train <- to_categorical(y_train, num_classes)
|
||||
y_test <- to_categorical(y_test , num_classes)
|
||||
|
||||
################################################################################
|
||||
### Model Creation ###
|
||||
################################################################################
|
||||
|
||||
model <- keras_model_sequential(name = 'base_model')
|
||||
model %>%
|
||||
layer_dense(units = 256L, activation = 'relu',
|
||||
input_shape = ncol(x_train)) %>%
|
||||
layer_dropout(rate = 0.4) %>%
|
||||
layer_dense(units = 128L, activation = 'relu') %>%
|
||||
layer_dropout(rate = 0.3) %>%
|
||||
layer_dense(units = num_classes, activation = 'softmax')
|
||||
|
||||
summary(model)
|
||||
|
||||
model %>% compile(
|
||||
loss = 'categorical_crossentropy',
|
||||
optimizer = 'RMSProp',
|
||||
metrics = c('accuracy')
|
||||
)
|
||||
|
||||
################################################################################
|
||||
### Base Model Training ###
|
||||
################################################################################
|
||||
|
||||
history.base <- model %>% fit(
|
||||
x_train, y_train,
|
||||
batch_size = batch_size,
|
||||
epochs = epochs,
|
||||
verbose = 1L,
|
||||
validation_split = 0.1
|
||||
)
|
||||
|
||||
plot(history.base)
|
||||
|
||||
score <- model %>% evaluate(x_test, y_test, verbose = 0L)
|
||||
|
||||
cat('Test loss: ', score[['loss']], '\n',
|
||||
'Test accuracy: ', score[['accuracy']], '\n', sep = '')
|
||||
|
||||
################################################################################
|
||||
### OPG Data Reduction ###
|
||||
################################################################################
|
||||
library(tensorflow)
|
||||
library(ggplot2)
|
||||
|
||||
G <- local({
|
||||
X = tf$cast(x_train, 'float32')
|
||||
with(tf$GradientTape() %as% tape, {
|
||||
tape$watch(X)
|
||||
Y <- model(X)
|
||||
})
|
||||
as.matrix(tape$gradient(Y, X))
|
||||
})
|
||||
eig <- eigen(var(G), symmetric = TRUE)
|
||||
B.opg <- eig$vectors[, 1:2]
|
||||
|
||||
# ggplot(data.frame(values = eig$values[1:25]), aes(x = seq_along(values), y = values)) +
|
||||
# geom_line()
|
||||
|
||||
ggplot(data.frame(x_test %*% B.opg, y = factor(apply(y_test, 1, which.max))),
|
||||
aes(x = X1, y = X2, group = y, color = y)) +
|
||||
geom_point()
|
||||
|
||||
################################################################################
|
||||
### Refinement Model ###
|
||||
################################################################################
|
||||
weights <- model$get_weights()
|
||||
|
||||
model.ref <- keras_model_sequential(name = 'Refinement')
|
||||
model.ref %>%
|
||||
layer_dense(units = ncol(B.opg), activation = 'relu',
|
||||
input_shape = ncol(x_train), use_bias = FALSE,
|
||||
weights = list(B.opg)) %>%
|
||||
layer_dense(units = 256L, activation = 'relu',
|
||||
weights = list(crossprod(B.opg, weights[[1]]), weights[[2]])) %>%
|
||||
layer_dropout(rate = 0.4) %>%
|
||||
layer_dense(units = 128L, activation = 'relu',
|
||||
weights = weights[3:4]) %>%
|
||||
layer_dropout(rate = 0.3) %>%
|
||||
layer_dense(units = num_classes, activation = 'softmax',
|
||||
weights = weights[5:6])
|
||||
|
||||
summary(model.ref)
|
||||
|
||||
model.ref %>% compile(
|
||||
loss = 'categorical_crossentropy',
|
||||
optimizer = 'RMSProp',
|
||||
metrics = c('accuracy')
|
||||
)
|
||||
|
||||
################################################################################
|
||||
### Refinement Model Training ###
|
||||
################################################################################
|
||||
|
||||
history.ref <- model.ref %>% fit(
|
||||
x_train, y_train,
|
||||
batch_size = batch_size,
|
||||
epochs = epochs,
|
||||
verbose = 1L,
|
||||
validation_split = 0.1
|
||||
)
|
||||
|
||||
plot(history.ref)
|
||||
|
||||
score <- model.ref %>% evaluate(x_test, y_test, verbose = 0L)
|
||||
|
||||
cat('Test loss: ', score[['loss']], '\n',
|
||||
'Test accuracy: ', score[['accuracy']], '\n', sep = '')
|
||||
|
||||
### Combine Histories
|
||||
hist <- structure(list(
|
||||
params = list(
|
||||
verbose = min(history.base$params$verbose, history.ref$params$verbose),
|
||||
epochs = history.base$params$epochs + history.ref$params$epochs,
|
||||
steps = max(history.base$params$steps, history.ref$params$steps)
|
||||
),
|
||||
metrics = lapply(structure(names(history.base$metrics), names = names(history.base$metrics)),
|
||||
function(name) c(history.base$metrics[[name]], history.ref$metrics[[name]]))
|
||||
), class = "keras_training_history")
|
||||
|
||||
plot(hist, smooth = FALSE)
|
||||
|
||||
|
||||
B.ref <- model.ref$get_weights()[[1]]
|
||||
|
||||
ggplot(data.frame(x_test %*% B.ref, y = factor(apply(y_test, 1, which.max))),
|
||||
aes(x = X1, y = X2, group = y, color = y)) +
|
||||
geom_point()
|
||||
|
||||
|
||||
B.pca <- eigen(var(x_train), symmetric = TRUE)$vectors[, 1:2]
|
||||
ggplot(data.frame(x_test %*% B.pca, y = factor(apply(y_test, 1, which.max))),
|
||||
aes(x = X1, y = X2, group = y, color = y)) +
|
||||
geom_point()
|
||||
|
||||
image.ref <- matrix(((B.ref - min(B.ref)) / abs(diff(range(B.ref))))[, 2], 28, 28)
|
||||
plot(c(0, 28), c(0, 28), type = "n", xlab = "", ylab = "")
|
||||
rasterImage(image.ref, 0, 0, 28, 28, interpolate = TRUE)
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
library(ggplot2)
|
||||
|
||||
################################################################################
|
||||
### General Helpers ###
|
||||
################################################################################
|
||||
|
||||
# Read/Combine simulation data logs
|
||||
read.logs <- function(pattern) {
|
||||
# Folder containing log files
|
||||
path <- if (file.exists('results/')) './' else './simulations/'
|
||||
path <- paste0(path, 'results/')
|
||||
# Read all log files and augment with meta-parameters
|
||||
file.names <- list.files(path, pattern, full.names = TRUE)
|
||||
sim <- do.call(rbind, lapply(file.names, function(path) {
|
||||
# Read simulation log (one file)
|
||||
sim <- read.csv(path, comment.char = '#')
|
||||
# Add simulation arguments as columns
|
||||
args <- Filter(function(line) startsWith(line, '#'), readLines(path))
|
||||
args <- sub('# ?', '', args)
|
||||
args <- regmatches(args, regexpr(' ', args), invert = TRUE)
|
||||
# Try to convert meta-parameters from string into int/num/bool/...
|
||||
for (arg in args) {
|
||||
val <- tryCatch(
|
||||
eval(parse(text = arg[2])),
|
||||
error = function(err) arg[2]
|
||||
)
|
||||
if (length(val) > 1) val <- paste(val, collapse = ',')
|
||||
sim[[arg[1]]] <- val
|
||||
}
|
||||
sim
|
||||
}))
|
||||
# Convert methods to factors
|
||||
sim$method <- factor(sim$method,
|
||||
levels = c("opg", "mave", "cve", "sir", "save", "phdy", "nn.opg", "nn.ref"),
|
||||
labels = c("OPG", "MAVE", "CVE", "SIR", "SAVE", "PHD", "NN-OPG", "NN-Ref")
|
||||
)
|
||||
sim
|
||||
}
|
||||
|
||||
|
||||
################################################################################
|
||||
### Bit Data ###
|
||||
################################################################################
|
||||
|
||||
# Read/Combine big data simulation logs
|
||||
sim <- read.logs('sim_big_.*csv')
|
||||
|
||||
# Compute repetition mean and standard deviation over replications
|
||||
(aggr <- merge(
|
||||
aggregate(dist.subspace ~ dataset + n + p + method, sim, mean),
|
||||
aggregate(dist.subspace ~ dataset + n + p + method, sim, sd),
|
||||
by = c("dataset", "n", "p", "method"),
|
||||
suffixes = c(".mean", ".sd")
|
||||
))
|
||||
|
||||
# plots and tables
|
||||
ggplot(aggr, aes(x = n, y = dist.subspace.mean,
|
||||
group = interaction(dataset, method),
|
||||
color = method, linetype = dataset)) +
|
||||
geom_line() +
|
||||
geom_errorbar(aes(
|
||||
ymin = dist.subspace.mean - dist.subspace.sd,
|
||||
ymax = dist.subspace.mean + dist.subspace.sd
|
||||
), width = 0.2) +
|
||||
scale_x_continuous(trans = 'log2')
|
||||
|
||||
################################################################################
|
||||
### Binary Response ###
|
||||
################################################################################
|
||||
|
||||
# Read/Combine binary data simulation logs
|
||||
sim <- read.logs('sim_binary_[0-9_]*\\.csv')
|
||||
|
||||
# Aggregated Tables
|
||||
aggr.formula <- cbind(dist.subspace, accuracy) ~ dataset + method
|
||||
aggr <- merge(
|
||||
aggregate(aggr.formula, sim, mean,
|
||||
na.action = na.pass),
|
||||
aggregate(aggr.formula, sim, sd,
|
||||
na.action = na.pass),
|
||||
by = attr(terms(aggr.formula), "term.labels"),
|
||||
suffixes = c(".mean", ".sd")
|
||||
)
|
||||
print(aggr[with(aggr, order(dataset, dist.subspace.mean)), ], digits = 3)
|
||||
|
||||
|
||||
# box-plot subspace comparison
|
||||
ggplot(sim, aes(x = method, y = dist.subspace,
|
||||
group = interaction(dataset, method),
|
||||
color = dataset)) +
|
||||
geom_boxplot() +
|
||||
labs(title = "Sim. Binary", x = "Methods", y = "Subspace Dist.", color = "Datasets")
|
||||
|
|
@ -11,7 +11,7 @@ suppressPackageStartupMessages({
|
|||
args <- parse.args(defaults = list(
|
||||
# Simulation configuration
|
||||
reps = 100, # Number of replications
|
||||
dataset = '1', # Name (number) of the data set
|
||||
dataset = 'M1', # Name (number) of the data set
|
||||
# Neuronal Net. structure/definitions
|
||||
hidden_units = 512L,
|
||||
activation = 'relu',
|
||||
|
|
@ -24,7 +24,8 @@ args <- parse.args(defaults = list(
|
|||
))
|
||||
|
||||
## Generate reference data (gets re-sampled for each replication)
|
||||
ds <- dataset(args$dataset) # Generates a list with `X`, `Y`, `B` and `name`
|
||||
# Generates a list with `X`, `Y`, `B` and `name`
|
||||
ds <- dataset(args$dataset, n = 100)
|
||||
|
||||
## Build Dimension Reduction Neuronal Network model (matching the data)
|
||||
nn <- nnsdr$new(
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ suppressPackageStartupMessages({
|
|||
args <- parse.args(defaults = list(
|
||||
# Simulation configuration
|
||||
reps = 10L, # Number of replications
|
||||
dataset = '6', # Name (number) of the data set
|
||||
dataset = 'M6', # Name (number) of the data set
|
||||
# Sets if reference methods shall be evaluated
|
||||
run_mave = TRUE,
|
||||
run_cve = TRUE,
|
||||
|
|
@ -34,6 +34,8 @@ args <- parse.args(defaults = list(
|
|||
# Number of observations are irrelevant for the reference to generate a matching
|
||||
# `NNSDR` estimator
|
||||
ds <- dataset(args$dataset, n = 100L, p = args$p) # Generates a list with `X`, `Y`, `B` and `name`
|
||||
# normalize dataset name (before written to the log/results file)
|
||||
args$dataset <- ds$name
|
||||
|
||||
## Build Dimension Reduction Neuronal Network model (matching the data)
|
||||
nn <- nnsdr$new(
|
||||
|
|
|
|||
|
|
@ -10,24 +10,24 @@ user_interupt() {
|
|||
exit
|
||||
}
|
||||
|
||||
# Simulation for big data with `p` proportional to `sqrt(n)`
|
||||
for ds in 6 8; do
|
||||
command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=1000 --p=32 --epochs=200,400"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=4000 --p=63 --epochs=100,200"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=16000 --p=126 --epochs=50,100"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=64000 --p=253 --epochs=25,50"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=256000 --p=506 --epochs=12,25"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
done
|
||||
# # Simulation for big data with `p` proportional to `sqrt(n)`
|
||||
# for ds in 6 8; do
|
||||
# command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=1000 --p=32 --epochs=200,400"
|
||||
# echo -e "\n$command"
|
||||
# time eval "$command"
|
||||
# command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=4000 --p=63 --epochs=100,200"
|
||||
# echo -e "\n$command"
|
||||
# time eval "$command"
|
||||
# command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=16000 --p=126 --epochs=50,100"
|
||||
# echo -e "\n$command"
|
||||
# time eval "$command"
|
||||
# command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=64000 --p=253 --epochs=25,50"
|
||||
# echo -e "\n$command"
|
||||
# time eval "$command"
|
||||
# command="Rscript simulations_bigdata.R --reps=10 --run_mave=FALSE --run_cve=FALSE --dataset=$ds --n=256000 --p=506 --epochs=12,25"
|
||||
# echo -e "\n$command"
|
||||
# time eval "$command"
|
||||
# done
|
||||
|
||||
# Simulation for big data with `p` proportional to `n` (note: for the base case
|
||||
# of `n = 1000`, `p = 32` see above)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
#!/usr/bin/env Rscript
|
||||
|
||||
library(MAVE)
|
||||
library(CVarE)
|
||||
Sys.setenv(TF_CPP_MIN_LOG_LEVEL = "3") # Suppress `tensorflow` notes/warnings
|
||||
suppressPackageStartupMessages({
|
||||
library(dr)
|
||||
library(NNSDR)
|
||||
})
|
||||
|
||||
|
|
@ -11,97 +10,21 @@ suppressPackageStartupMessages({
|
|||
args <- parse.args(defaults = list(
|
||||
# Simulation configuration
|
||||
reps = 100, # Number of replications
|
||||
dataset = 'B2', # Name ('B' for Binary) of the data set
|
||||
dataset = 'B1', # Name ('B' for Binary) of the data set
|
||||
# Neuronal Net. structure/definitions
|
||||
hidden_units = 512L,
|
||||
activation = 'relu',
|
||||
trainable_reduction = TRUE,
|
||||
# Neuronal Net. training
|
||||
epochs = c(100L, 200L), # Number of training epochs for (`OPG`, Refinement)
|
||||
epochs = c(3L, 5L), # Number of training epochs for (`OPG`, Refinement)
|
||||
batch_size = 32L,
|
||||
initializer = 'fromOPG',
|
||||
seed = 956294L
|
||||
))
|
||||
|
||||
################################################################################
|
||||
|
||||
dataset <- function(name = "M1", n = NULL, p = 20, sd = 0.5, ...) {
|
||||
name <- toupper(name)
|
||||
if (nchar(name) == 1) { name <- paste0("M", name) }
|
||||
|
||||
if (name == "B1") {
|
||||
if (missing(n)) { n <- 400 }
|
||||
if (missing(sd)) { sd <- 1 }
|
||||
eps <- sqrt(.Machine$double.eps)
|
||||
|
||||
B <- diag(1, p, 2)
|
||||
Z <- matrix(rnorm(2 * n, 0, sd), n, 2)
|
||||
Y <- sample(c(FALSE, TRUE), n, replace = TRUE)
|
||||
theta <- rnorm(n, Y * pi, 0.25 * pi)
|
||||
X <- cbind(
|
||||
10 * (cos(theta) + 0.75 * (2 * Y - 1)) + Z[, 1],
|
||||
10 * sin(theta) + Z[, 2],
|
||||
matrix(rnorm(n * (p - 2), 0, sd), n)
|
||||
)
|
||||
} else if (name == "B2") {
|
||||
if (missing(n)) { n <- 400 }
|
||||
if (missing(sd)) { sd <- 0.2 }
|
||||
eps <- sqrt(.Machine$double.eps)
|
||||
|
||||
B <- diag(1, p, 2)
|
||||
X <- matrix(runif(n * p, -2, 2), n, p)
|
||||
XB <- X %*% B
|
||||
Y <- (sin(XB[, 1]) / (XB[, 2]^2 + eps) + rnorm(n, 0, sd)) > 0
|
||||
# } else if (name == "B2") {
|
||||
# if (missing(n)) { n <- 400 }
|
||||
# if (missing(sd)) { sd <- 0.2 }
|
||||
# eps <- sqrt(.Machine$double.eps)
|
||||
|
||||
# B <- diag(1, p, 2)
|
||||
# X <- matrix(runif(n * p, -2, 2), n, p)
|
||||
# XB <- X %*% B
|
||||
# Y <- (sin(XB[, 1]) / (XB[, 2]^2 + eps) + rnorm(n, 0, sd)) > 0
|
||||
} else {
|
||||
stop("Got unknown dataset name.")
|
||||
}
|
||||
|
||||
return(list(X = X, Y = as.matrix(Y), B = B, name = name))
|
||||
}
|
||||
|
||||
## Generate reference data (gets re-sampled for each replication)
|
||||
ds <- dataset(args$dataset, n = 100) # Generates a list with `X`, `Y`, `B` and `name`
|
||||
# plot(ds$X %*% ds$B, col = 2 * (ds$Y + 1))
|
||||
|
||||
################################################################################
|
||||
|
||||
metric.subspace <- function(B_true, name = "metric.subspace", normalize = FALSE) {
|
||||
if (!is.matrix(B_true))
|
||||
B_true <- as.matrix(B_true)
|
||||
P_true <- B_true %*% solve(crossprod(B_true), t(B_true))
|
||||
P_true <- tf$constant(P_true, dtype = 'float32')
|
||||
|
||||
if (normalize) {
|
||||
rankSum <- 2 * ncol(B_true)
|
||||
c <- 1 / sqrt(min(rankSum, 2 * nrow(B_true) - rankSum))
|
||||
} else {
|
||||
c <- sqrt(2)
|
||||
}
|
||||
c <- tf$constant(c, dtype = 'float32')
|
||||
|
||||
structure(function(model) {
|
||||
B <- model$get_layer('reduction')$weights
|
||||
function(y_true, y_pred) {
|
||||
P <- tf$linalg$matmul(B, B, transpose_b = TRUE)
|
||||
diff <- P_true - P
|
||||
c * tf$sqrt(tf$reduce_sum(tf$math$multiply(diff, diff)))
|
||||
}
|
||||
},
|
||||
class = c("nnsdr.metric", "Refinement"),
|
||||
name = name
|
||||
)
|
||||
}
|
||||
|
||||
ds <- dataset(args$dataset)
|
||||
# Generates a list with `X`, `Y`, `B` and `name`
|
||||
ds <- dataset(args$dataset, n = 1000)
|
||||
|
||||
## Build Dimension Reduction Neuronal Network model (matching the data)
|
||||
nn <- nnsdr$new(
|
||||
|
|
@ -112,36 +35,62 @@ nn <- nnsdr$new(
|
|||
trainable_reduction = args$trainable_reduction,
|
||||
output_activation = 'sigmoid',
|
||||
loss = 'binary_crossentropy',
|
||||
metrics = list('accuracy', metric.subspace(ds$B, normalize = TRUE))
|
||||
# metrics = list('accuracy')
|
||||
metrics = list(
|
||||
'accuracy',
|
||||
metric.subspace(ds$B, ds$X, ds$Y, type = "OPG", normalize = TRUE),
|
||||
metric.subspace(ds$B, type = "Refinement", normalize = TRUE)
|
||||
)
|
||||
)
|
||||
|
||||
with(ds, {
|
||||
## Sample test dataset
|
||||
ds.test <- dataset(ds$name, n = 1000)
|
||||
## Open simulation log file, write simulation configuration and header
|
||||
log <- file(format(Sys.time(), "results/sim_binary_%Y%m%d_%H%M.csv"), "w", blocking = FALSE)
|
||||
cat(paste('#', names(args), args, sep = ' ', collapse = '\n'), '\n',
|
||||
'method,replication,dist.subspace,dist.grassmann,accuracy\n',
|
||||
sep = '', file = log, append = TRUE)
|
||||
|
||||
## Set seed for sampling simulation data (NOT effecting the `NN` initialization)
|
||||
set.seed(args$seed)
|
||||
|
||||
## Repeated simulation runs
|
||||
for (rep in seq_len(args$reps)) {
|
||||
## Re-sample seeded data for each simulation replication
|
||||
with(dataset(ds$name), {
|
||||
## Sample test dataset
|
||||
ds.test <- dataset(ds$name, n = 1000)
|
||||
|
||||
## Starting with the reference methods `SIR`, `SAVE` and `PHD`
|
||||
for (method in c("sir", "save", "phdy")) {
|
||||
fit <- dr(Y ~ X, method = method)
|
||||
d.sub <- dist.subspace(B, dr.basis(fit, ncol(B)), normalize = TRUE)
|
||||
d.gra <- dist.grassmann(B, dr.basis(fit, ncol(B)))
|
||||
accuracy <- NA
|
||||
cat('"', method, '",', rep, ',', d.sub, ',', d.gra, ',', accuracy,
|
||||
'\n', sep = '', file = log, append = TRUE)
|
||||
}
|
||||
|
||||
## Fit `NNSDR` model
|
||||
nn$fit(X, Y, epochs = args$epochs,
|
||||
batch_size = args$batch_size, initializer = args$initializer)
|
||||
# Model evaluation (with metrics)
|
||||
eval <- nn$evaluate(ds.test$X, ds.test$Y)
|
||||
# `OPG` estimate
|
||||
d.sub <- dist.subspace(B, coef(nn, 'OPG'), normalize = TRUE)
|
||||
d.gra <- dist.grassmann(B, coef(nn, 'OPG'))
|
||||
accuracy <- eval[["OPG", "accuracy"]]
|
||||
cat('"nn.opg",', rep, ',', d.sub, ',', d.gra, ',', accuracy,
|
||||
'\n', sep = '', file = log, append = TRUE)
|
||||
# Refinement estimate
|
||||
d.sub <- dist.subspace(B, coef(nn), normalize = TRUE)
|
||||
d.gra <- dist.grassmann(B, coef(nn))
|
||||
accuracy <- eval[["Refinement", "accuracy"]]
|
||||
cat('"nn.ref",', rep, ',', d.sub, ',', d.gra, ',', accuracy,
|
||||
'\n', sep = '', file = log, append = TRUE)
|
||||
})
|
||||
|
||||
## Reset model
|
||||
nn$reset()
|
||||
nn$fit(X, Y, epochs = args$epochs,
|
||||
batch_size = args$batch_size, initializer = args$initializer,
|
||||
verbose = 2L)
|
||||
}
|
||||
|
||||
# `OPG` estimate
|
||||
cat("OPG subspace: ", dist.subspace(B, coef(nn, 'OPG'), normalize = TRUE), '\n')
|
||||
cat("OPG grassmann:", dist.grassmann(B, coef(nn, 'OPG')), '\n')
|
||||
# Refinement estimate
|
||||
cat("Ref subspace: ", dist.subspace(B, coef(nn), normalize = TRUE), '\n')
|
||||
cat("Ref grassmann:", dist.grassmann(B, coef(nn)), '\n')
|
||||
# MSE
|
||||
cat("MSE: ", mean((nn$predict(ds.test$X) - ds.test$Y)^2), '\n')
|
||||
})
|
||||
|
||||
library(ggplot2)
|
||||
|
||||
ggplot(nn$history, aes(x = epoch)) +
|
||||
geom_line(aes(y = loss), col = 'red') +
|
||||
geom_line(aes(y = accuracy), col = 'blue')
|
||||
|
||||
with(dataset('B2', n = 400), {
|
||||
ggplot(data.frame(XB1 = (X %*% B)[, 1], XB2 = (X %*% B)[, 2], Y = Y)) +
|
||||
geom_point(aes(x = XB1, y = XB2, col = Y))
|
||||
})
|
||||
## Finished, close simulation log file
|
||||
close(log)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,24 @@
|
|||
#!/bin/bash
|
||||
|
||||
# Catch termination signal `SIGINT` and invoke `user_interupt`
|
||||
trap user_interupt SIGINT
|
||||
|
||||
# Reports an user interupt and exits the simulation script (do not continue next
|
||||
# statement, allows to exit bash loop with `^C`)
|
||||
user_interupt() {
|
||||
echo -e '\nUser Interrupt -> stopping simulation\n'
|
||||
exit
|
||||
}
|
||||
|
||||
command="Rscript simulations_binary.R --reps=100 --dataset=B1 --hidden_units=1024 --epochs=5,10"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_binary.R --reps=100 --dataset=B2"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_binary.R --reps=100 --dataset=B3 --hidden_units=1024,128,32 --epochs=10,200"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
command="Rscript simulations_binary.R --reps=100 --dataset=B4 --hidden_units=1024,128,32 --epochs=10,200"
|
||||
echo -e "\n$command"
|
||||
time eval "$command"
|
||||
Loading…
Reference in New Issue