Nothing
#' @title Sets list with meta info, to be used in other checks
#' @description
#' Set network meta info
#' @keywords internal
setMeta <- function(data, hidden.layers, regression, autoencoder) {
# Check if network has no hidden layers, set n_hidden layers accordingly
if ( is.null(hidden.layers) || all(is.na(hidden.layers)) ) {
no_hidden <- TRUE
n_hidden <- 0
} else {
no_hidden <- FALSE
n_hidden <- length(hidden.layers)
}
# Set number of nodes in input and output layer
n_in <- ncol(data$X)
n_out <- ncol(data$y)
# Set number of observations
n_obs <- nrow(data$X)
return( list(no_hidden = no_hidden, n_hidden = n_hidden, n_in = n_in,
n_out = n_out, n_obs = n_obs, regression = regression,
classes = data$classes, names = data$names,
hidden_layers = hidden.layers, autoencoder = autoencoder) )
}
#' @title Check the input data
#' @description
#' Set and check data
#' @keywords internal
setData <- function(X, y, regression, y_names = NULL) {
# Convert X to matrix
X <- as.matrix(X)
# (ERROR) missing values in X and y
miss_X <- any(is.na(X))
miss_y <- any(is.na(y))
if ( miss_X && miss_y ) {
stop('X and y contain missing values', call. = FALSE)
} else if ( miss_X ) {
stop('X contain missing values', call. = FALSE)
} else if ( miss_y ) {
stop('y contain missing values', call. = FALSE)
}
# (ERROR) matrix X all numeric columns
if ( !all(apply(X, 2, is.numeric)) ) {
stop('X should be numeric', call. = FALSE)
}
# Checks on y for regression and classification
if ( regression ) {
# Convert y to matrix
y <- as.matrix(y)
# (ERROR) matrix y all numeric columns
if ( !all(apply(y, 2, is.numeric)) ) {
stop('y should be numeric for regression', call. = FALSE)
}
# Set names to class names (used in predict.ANN() )
y_names <- colnames(y)
# If names are NULL, set
if ( is.null(y_names) ) {
y_names <- paste0('y_', seq(1,ncol(y)))
}
} else {
# (ERROR) matrix y not single column
if ( NCOL(y) != 1 ) {
stop('y should be a vector or single-column matrix containing classes for classification',
call. = FALSE)
}
# (ERROR) not enough classes for classification in y
if ( length(unique(y)) < 1 ) {
stop('y contains one or less classes, minimum of two required for classification',
call. = FALSE)
}
# Convert y to matrix
y <- as.matrix(y)
# If y_names NULL (first training run) then y_names should be derived
# from the data. If not NULL, y_names of first training run are used
if ( is.null(y_names) ) {
y_names <- as.character(sort(unique(y)))
}
# One-hot encode y and store classes
y <- 1 * outer(c(y), y_names, '==')
}
# Set number of observations
n_obs <- nrow(X)
# (ERROR) not same number of observations in X and y
if ( n_obs != nrow(y) ) {
stop('Unequal numbers of observations in X and y', call. = FALSE)
}
# Collect parameters in list
return ( list(X = X, y = y, y_names = y_names, n_obs = n_obs) )
}
#' @title Check user input related to network structure
#' @description
#' Set and check network parameter list
#' @keywords internal
setNetworkParams <- function(hidden.layers, standardize, verbose, meta) {
# Booleans for standardizing X and y
stand_X <- standardize
stand_y <- ifelse(meta$regression, standardize, FALSE)
# Check if hidden layers NULL
if ( meta$no_hidden ) {
# Only input and output layers
num_nodes <- as.integer( c(meta$n_in, meta$n_out) )
} else {
# (ERROR) missing in hidden.layers
if ( any(is.na(hidden.layers)) ) {
stop('hidden.layers contains NA', call. = FALSE)
}
# (ERROR) non-integers in hidden.layers
if ( !all(hidden.layers %% 1 == 0) ) {
stop('hidden.layers contains non-integers', call. = FALSE)
}
# Set vector with structure (number of nodes) in the network
num_nodes <- as.integer( c(meta$n_in, hidden.layers, meta$n_out) )
}
# Collect parameters in list
return ( list(num_nodes = num_nodes, stand_X = stand_X, stand_y = stand_y,
verbose = verbose, regression = meta$regression,
autoencoder = meta$autoencoder) )
}
#' @title Check user input related to activation functions
#' @description
#' Set and check activation parameter list
#' @keywords internal
setActivParams <- function(activ.functions, step.H, step.k, meta) {
allowed_types <- c('tanh', 'sigmoid', 'relu', 'linear', 'ramp', 'step')
# Determine output type
output_type <- ifelse(meta$regression, 'linear', 'softmax')
# Check if no hidden layers
if ( meta$no_hidden ) {
# (WARN) no hidden layers so activ.functions will not be used
if ( !is.null(activ.functions) && !all(is.na(activ.functions)) ) {
warning('network with no hidden layers, specified activ.functions not used',
call. = FALSE)
}
# Append activation type of output layer (and 'input', not used)
types <- c('input', output_type)
} else {
# (ERROR) activ.functions not of allowed types
if ( !(all(activ.functions %in% allowed_types)) ) {
stop('activ.functions not all one of types ',
paste(allowed_types, collapse = ', '), call. = FALSE)
}
# Single activ.function specified by user (or incorrect number of values)
if ( length(activ.functions) != meta$n_hidden ) {
# Broadcasting or throw error
if ( length(activ.functions) == 1 ) {
# Broadcast single activ.function over all hidden layers
types <- c('input', rep(activ.functions, meta$n_hidden), output_type)
} else {
# (ERROR) length of activ.functions either 1 (broadcasting) or equal to the
# number of hidden layers
stop('length of activ.functions should be either one (for broadcasting) or equal to number of hidden layers',
call. = FALSE)
}
} else {
# No broadcasting
types <- c('input', activ.functions, output_type)
}
}
# Check parameters H and k, only for step activation function
if ( 'step' %in% activ.functions ) {
# (ERROR) number of steps H should be a whole number larger than zero
if ( step.H %% 1 != 0 || step.H < 1 ) {
stop('step.H should be an integer larger than zero', call. = FALSE)
}
# (ERROR) smoothing parameter k should be and integer larger than zero
if ( step.k %% 1 != 0 || step.k < 1 ) {
stop('step.k should be an integer larger than zero', call. = FALSE)
}
}
# Collect parameters in list
return ( list(types = types, step_H = step.H, step_k = step.k) )
}
#' @title Check user input related to optimizer
#' @description
#' Set and check optimizer parameter list
#' @keywords internal
setOptimParams <- function(optim.type, learn.rates, L1, L2, sgd.momentum,
rmsprop.decay, adam.beta1, adam.beta2, meta) {
# Allowed optimizer types
allowed_types <- c('sgd', 'rmsprop', 'adam')
# (ERROR) optim.type not of allowed type
if ( !(optim.type %in% allowed_types) ) {
stop('optim.type not one of types ', paste(allowed_types, collapse = ', '))
}
# (ERROR) missing learn.rates
if ( is.null(learn.rates) || any(is.na(learn.rates)) ) {
stop('missing value in learn.rates or learn.rates is NULL', call. = FALSE)
}
# (ERROR) learn.rate incorrect value
if ( any(learn.rates <= 0) ) {
stop('learn rates should be larger than 0', call. = FALSE)
}
# (ERROR) L1 and/or L2 incorrect value(s)
if ( L1 < 0 || L2 < 0 ) {
stop('L1 and/or L2 negative', call. = FALSE)
}
# Checks specific to SGD optimizer
if ( optim.type == 'sgd' ) {
# (ERROR) momentum incorrect value
if ( sgd.momentum >= 1 || sgd.momentum < 0 ) {
stop('sgd.momentum larger than or equal to one or smaller than zero', call. = FALSE)
}
# Checks specific to RMSprop optimizer
} else if ( optim.type == 'rmsprop' ) {
# (ERROR) rmsprop.decay incorrect value
if ( rmsprop.decay >= 1 || rmsprop.decay <= 0 ) {
stop('rmsprop.decay should be between zero and one', call. = FALSE)
}
# Checks specific to ADAM optimizer
} else if ( optim.type == 'adam' ) {
# (ERROR) adam.beta1 incorrect value
if ( adam.beta1 >= 1 || adam.beta1 <= 0 ) {
stop('adam.beta1 should be between zero and one', call. = FALSE)
}
# (ERROR) adam.beta2 incorrect value
if ( adam.beta2 >= 1 || adam.beta2 <= 0 ) {
stop('adam.beta2 should be between zero and one', call. = FALSE)
}
} else {
# Not implemented optimizer
stop('optim.type not supported')
}
# Length of learn.rates does not mach number of optimizers
if ( length(learn.rates) != meta$n_hidden + 1 ) {
# Broadcasting or throw error
if ( length(learn.rates) == 1 ) {
# Broadcast single activ.function over all layers
rates <- c(0, rep(learn.rates, meta$n_hidden + 1))
} else {
# (ERROR) length of learn.rates should be either 1 (broadcasting) or
# equal to the number of hidden layers + 1
stop('length of learn.rates should be one or equal to number of hidden layers + 1',
call. = FALSE)
}
} else {
# No broadcasting
rates <- c(0, learn.rates)
}
# Collect parameters in list
return ( list(type = optim.type, learn_rates = rates, L1 = L1, L2 = L2,
sgd_momentum = sgd.momentum, rmsprop_decay = rmsprop.decay,
adam_beta1 = adam.beta1, adam_beta2 = adam.beta2) )
}
#' @title Check user input related to loss function
#' @description
#' Set and check loss parameter list
#' @keywords internal
setLossParams <- function(loss.type, huber.delta, meta) {
allowed_types <- c('log', 'squared', 'absolute', 'huber', 'pseudo-huber')
# (ERROR) loss.type one of allowed types
if ( !(loss.type %in% allowed_types) ) {
stop('loss.type not one of ', paste(allowed_types, collapse = ', '),
call. = FALSE)
}
# (ERROR) do not use log loss for regression
if ( meta$regression && loss.type == 'log' ) {
stop('Do not use loss.type "log" for regression', call. = FALSE)
}
# (ERROR) use log loss for classification
if ( !meta$regression && loss.type != 'log' ) {
stop('Use loss.type "log" for classification', call. = FALSE)
}
# Checks on parameters specific to huber and pseudo-huber
if ( loss.type %in% c('huber', 'pseudo-huber') ) {
# (ERROR) delta should be non-negative
if ( huber.delta < 0 ) {
stop('huber.delta smaller than zero', call. = FALSE)
}
# (WARN) use absolute loss if delta equals zero
if ( huber.delta == 0 ) {
warning ('huber.delta equal to zero, this is equivalent to using absolute loss but less efficient',
call. = FALSE)
}
}
# Collect parameters in list
return ( list(type = loss.type, huber_delta = huber.delta) )
}
#' @title Check user input related to training
#' @description
#' Set training parameters
#' @keywords internal
setTrainParams <- function (n.epochs, batch.size, val.prop, drop.last,
random.seed, data) {
# Set random seed with set.seed(), this also sets the seed for RcppArmadillo
# If NULL, we use the current time to set a seed. This is to prevent the exact
# same result of neuralnetwork(), autoencoder() and train() if the seed has
# not been changed between consecutive runs
if ( is.null(random.seed) ) {
random.seed <- as.integer(format(Sys.time(), '%H%M%S'))
}
set.seed(random.seed)
# (ERROR) n.epochs not positive
if ( n.epochs <= 0 ) {
stop('n.epochs should be larger than zero', call. = FALSE)
}
# (ERROR) n.epochs not whole number
if ( n.epochs %% 1 != 0 ) {
stop('n.epochs not an integer', call. = FALSE)
}
# (ERROR) batch.size not positive
if ( batch.size <= 0 ) {
stop('batch.size should be larger than zero', call. = FALSE)
}
# (ERROR) batch.size not whole number
if ( batch.size %% 1 != 0 ) {
stop('batch.size not an integer', call. = FALSE)
}
# (ERROR) val.prop incorrect value
if ( val.prop < 0 || val.prop >= 1) {
stop('val.prop should be smaller than one and larger than or equal to zero',
call. = FALSE)
}
# Size of training and validation sets
n_train <- ceiling( data$n_obs * (1 - val.prop) )
n_val <- data$n_obs - n_train
# (ERROR) batch.size larger than n_obs
if ( batch.size > data$n_obs ) {
stop('batch.size larger than total number of observations in X and y',
call. = FALSE)
}
# (ERROR) batch.size larger than n_train
if ( n_val > 0 && batch.size > n_train ) {
stop('batch.size larger than size of training data (after training/validation subsetting)',
call. = FALSE)
}
# (WARN) small validation set
if ( val.prop > 0 && n_val < 25 ) {
warning('small validation set, only ', n_val, ' observations', call. = FALSE)
}
# Collect parameters in list
return ( list(n_epochs = n.epochs, batch_size = batch.size, val_prop = val.prop,
drop_last = drop.last) )
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.