Nothing
#' Initializes a Subnetwork based on the Processed Additive Predictor
#'
#' @param pp list of processed predictor lists from \code{processor}
#' @param deep_top keras layer if the top part of the deep network after orthogonalization
#' is different to the one extracted from the provided network
#' @param orthog_fun function used for orthogonalization
#' @param split_fun function to split the network to extract head
#' @param shared_layers list defining shared weights within one predictor;
#' each list item is a vector of characters of terms as given in the parameter formula
#' @param param_nr integer number for the distribution parameter
#' @param selectfun_in,selectfun_lay functions defining which subset of pp to
#' take as inputs and layers for this subnetwork; per default the \code{param_nr}'s entry
#' @param gaminputs input tensors for gam terms
#' @param summary_layer keras layer that combines inputs (typically adding or concatenating)
#' @return returns a list of input and output for this additive predictor
#'
#' @export
#'
subnetwork_init <- function(pp, deep_top = NULL,
orthog_fun = orthog_tf,
split_fun = split_model,
shared_layers = NULL,
param_nr = 1,
selectfun_in = function(pp) pp[[param_nr]],
selectfun_lay = function(pp) pp[[param_nr]],
gaminputs,
summary_layer = layer_add_identity)
{
# instead of passing the respective pp,
# subsetting is done within subnetwork_init
# to allow other subnetwork_builder to
# potentially access all pp entries
pp_in <- selectfun_in(pp)
pp_lay <- selectfun_lay(pp)
# generate pp parts
gaminput_nrs <- sapply(pp_in, "[[", "gamdata_nr")
has_gaminp <- !sapply(gaminput_nrs,is.null)
gaminput_comb <- sapply(pp_in[which(has_gaminp)], "[[", "gamdata_combined")
inputs <- makeInputs(pp_in, param_nr = param_nr)
org_inputs_for_concat <- list()
if(sum(has_gaminp)){
for(i in 1:sum(has_gaminp)){
# concatenate inputs or replace?
concat <- gaminput_comb[[i]]
nr <- which(has_gaminp)[i]
if(!is.null(concat) && concat){
org_inputs_for_concat <- c(
org_inputs_for_concat,
inputs[[nr]]
)
inputs[[nr]] <- layer_concatenate_identity(
list(gaminputs[[gaminput_nrs[[nr]]]], inputs[[nr]])
)
}else{
inputs[[nr]] <- gaminputs[[gaminput_nrs[[nr]]]]
}
}
inputs_to_replace <- which(has_gaminp)[gaminput_comb]
keep_inputs_in_return <- setdiff(1:length(inputs), (which(has_gaminp)[!gaminput_comb]))
}else{
inputs_to_replace <- c()
keep_inputs_in_return <- 1:length(inputs)
}
layer_matching <- 1:length(pp_in)
names(layer_matching) <- layer_matching
if(!is.null(shared_layers))
{
names_terms <- get_names_pfc(pp_in)
for(group in shared_layers){
layer_ref_nr <- which(names_terms==group[1])
layer_opts <- get("layer_args", environment(pp_lay[[layer_ref_nr]]$layer))
layer_opts$name <- paste0("shared_",
makelayername(paste(group, collapse="_"),
param_nr))
layer_ref <- do.call(get("layer_class", environment(pp_lay[[layer_ref_nr]]$layer)),
layer_opts)
terms_replace_layer <- which(names_terms%in%group)
layer_matching[terms_replace_layer] <- layer_ref_nr
for(i in terms_replace_layer) pp_lay[[i]]$layer <- layer_ref
}
}
if(all(sapply(pp_in, function(x) is.null(x$right_from_oz)))){ # if there is no term to orthogonalize
outputs <- lapply(1:length(pp_in), function(i) pp_lay[[layer_matching[i]]]$layer(inputs[[i]]))
outputs <- summary_layer(outputs)
# replace original inputs
if(length(org_inputs_for_concat)>0)
inputs[inputs_to_replace] <- org_inputs_for_concat
return(list(inputs[keep_inputs_in_return], outputs))
}else{
# define the different types of elements
outputs_w_oz <- unique(unlist(sapply(pp_in, "[[", "right_from_oz")))
outputs_used_for_oz <- which(sapply(pp_in, function(x) !is.null(x$right_from_oz)))
outputs_onlyfor_oz <- outputs_used_for_oz[!sapply(pp_in[outputs_used_for_oz], "[[", "left_from_oz")]
outputs_wo_oz <- setdiff(1:length(pp_in), c(outputs_w_oz, outputs_onlyfor_oz))
outputs <- list()
if(length(outputs_wo_oz)>0) outputs <-
layer_add_identity(lapply((1:length(pp_in))[outputs_wo_oz],
function(i) pp_lay[[layer_matching[i]]]$layer(inputs[[i]])))
ox_outputs <- list()
k <- 1
for(i in outputs_w_oz){
inputs_for_oz <- which(sapply(pp_in, function(ap) i %in% ap$right_from_oz))
ox <- layer_concatenate_identity(inputs[inputs_for_oz])
if(is.null(deep_top)){
deep_splitted <- split_fun(pp_lay[[layer_matching[i]]]$layer)
}else{
deep_splitted <- list(pp_lay[[layer_matching[i]]]$layer, deep_top)
}
deep <- deep_splitted[[1]](inputs[[i]])
ox_outputs[[k]] <- deep_splitted[[2]](orthog_fun(deep, ox))
k <- k + 1
}
if(length(ox_outputs)>0) outputs <- summary_layer(c(outputs, ox_outputs))
if(length(org_inputs_for_concat)>0)
inputs[inputs_to_replace] <- org_inputs_for_concat
return(list(inputs[keep_inputs_in_return], outputs))
}
}
#' Convenience layer function
#'
#' @param inputs list of tensors
#' @return tensor
#' @details convenience layers to work with list of inputs where \code{inputs}
#' can also have length one
#'
#' @export
#' @rdname convenience_layers
#'
#'
layer_add_identity <- function(inputs)
{
if(length(inputs)==1) return(inputs[[1]])
return(tf$keras$layers$add(inputs))
}
#' @export
#' @rdname convenience_layers
layer_concatenate_identity <- function(inputs)
{
if(length(inputs)==1) return(inputs[[1]])
return(tf$keras$layers$concatenate(inputs))
}
#' Convenience layer function
#'
#' @param pp processed predictors
#' @param param_nr integer for the parameter
#' @return input tensors with appropriate names
#'
#' @export
#'
#'
makeInputs <- function(pp, param_nr)
{
lapply(pp, function(ap){
if(length(ap$input_dim)>1)
inp <- as.list(as.integer(ap$input_dim)) else
inp <- list(as.integer(ap$input_dim))
return(
tf$keras$Input(
shape = inp,
name = paste0("input_", strtrim(make_valid_layername(ap$term), options()$cutoff_names),
"_", param_nr))
)
}
)
}
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.