#' Create a TRACE network
#'
#' A Network object is just a list of Nodes. The print function shows the number
#' of nodes of each type, the timespan of the network and the number of updates
#' applied.
#'
#' @param feature_input a matrix of feature values over time
#' @param lexicon a lexicon data-frame
#' @return a list of interconnected feature, phoneme, and word nodes
#' @export
initialize_network <- function(feature_input, lexicon) {
start_sys_time <- Sys.time()
# Make sure lexicon includes silence
if (!is.element("-", lexicon$Word)) {
lexicon %<>% rbind(data.frame(Word = "-", Sounds = "-"))
}
n_timeslices <- ncol(feature_input)
feature_count <- length(feature_input)
nonzero_features <- make_feature_dataframe(feature_input) %>%
filter(Weight != 0)
message("Creating ", n_timeslices, " input units")
bias_layer <- Map(InputNode$new, timeslices = seq_len(n_timeslices))
message("Creating ", feature_count, " feature units")
feature_layer <- Map(FeaturePool, time = seq_len(n_timeslices))
# feature_layer has a sublist for each timeslice. Flatten into a single list
# to help with some operations later on.
feature_layer_flat <- unlist(feature_layer, use.names = FALSE)
assert_that(
length(bias_layer) == n_timeslices,
length(feature_layer) == n_timeslices,
length(feature_layer_flat) == feature_count
)
bias_layer_tags <- bias_layer %>% summarize_pool %>%
select(BiasTag = tag, Time = t_start, -t_end)
feature_layer_tags <- feature_layer_flat %>% summarize_pool %>%
select(Time = t_start,
Feature = type,
Value = value,
FeatureTag = tag)
edges_to_add <- feature_layer_tags %>%
inner_join(nonzero_features, by = c("Feature", "Value", "Time")) %>%
left_join(bias_layer_tags, by = "Time")
message("Creating ", nrow(edges_to_add), " input-to-feature edges")
bias_feature_pool <- c(bias_layer, feature_layer_flat)
lambda_connect <- function(x_tag, y_tag, weight, pool = bias_feature_pool) {
connect_tag_onto_tag(x_tag, y_tag, weight, pool)
}
Map(lambda_connect,
x_tag = edges_to_add$BiasTag,
y_tag = edges_to_add$FeatureTag,
weight = edges_to_add$Weight) %>% invisible
phoneme_layer <- PhonemePool(n_timeslices)
features_per_phoneme <- phonemes %>% group_by(Phoneme) %>%
filter(Weight != 0) %>% tally
phoneme_layer_df <- phoneme_layer %>%
summarize_pool %>%
rename(Phoneme = type) %>%
left_join(features_per_phoneme, by = "Phoneme") %>%
mutate(n_features = t_end - t_start + 1,
n_paths = n_features * n)
feature_to_phoneme <- sum(phoneme_layer_df$n_paths)
message("Creating ", feature_to_phoneme, " feature-to-phoneme edges")
connect_feature_pool_to_phoneme <- function(phoneme_node) {
compatible_features <- get_phoneme_features(phoneme_node$type) %>%
filter(Weight != 0) %>%
select(Phoneme, Feature, value = Value, -Weight)
feature_pools <- feature_layer[phoneme_node$timeslices] %>%
unlist(use.names = FALSE)
# Get tags of all compatible feature nodes
feature_tags <- feature_pools %>% summarize_pool %>%
rename(Feature = type) %>%
inner_join(compatible_features, by = c("Feature", "value")) %>%
extract2("tag")
# Extract those nodes
matching_tags <- feature_pools %>% get_tag %>% is.element(feature_tags)
feature_nodes <- feature_pools[matching_tags] %>% unlist(use.names = FALSE)
lifted_pnode <- list(phoneme_node)
Map(connect_onto, feature_nodes, lifted_pnode, trace_params$excite_feat_phon) %>% invisible
}
Map(connect_feature_pool_to_phoneme, phoneme_layer) %>% invisible
word_pool <- WordPool(n_timeslices, lexicon)
message("Checking ", length(phoneme_layer) * length(word_pool), " phoneme-word edges")
for (phoneme in phoneme_layer) {
for (word in word_pool) {
connect_phoneme_to_word(phoneme, word)
}
}
Sys.time() %>% subtract(start_sys_time) %>%
as.numeric(units = "secs") %>% round(1) %>%
paste0("Construction completed in ", ., " seconds") %>%
message
structure(c(bias_layer, feature_layer_flat, phoneme_layer, word_pool),
class = c("Network", "list"))
}
#' @export
uptick <- function(x, n_ticks = 1) UseMethod("uptick")
#' @export
uptick.Network <- function(x, n_ticks = 1) {
start_sys_time <- Sys.time()
x <- x %>% unclass %>% uptick(n_ticks)
Sys.time() %>% subtract(start_sys_time) %>%
as.numeric(units = "secs") %>% round(1) %>%
paste0(n_ticks, " network ticks completed in ", ., " seconds") %>%
message
x
}
#' @export
uptick.default <- function(x, n_ticks = 1) {
for(tick in seq_len(n_ticks)) {
x %>% lapply(function(n) n$receive()) %>% invisible
x %>% lapply(function(n) n$uptick()) %>% invisible
}
x
}
#' @export
get_history <- function(pool) {
# Wrapper for Node$remember method so we can vectorize it
remember <- function(node) node$remember()
p <- pool %>% lapply(remember) %>% rbind_all
# if (compress) {
# # Remove nodes if their activation is constantly 0
# on_sometimes <- p %>% group_by(tag) %>%
# summarize(never_on = all(activation == 0)) %>%
# filter(!never_on) %>%
# extract2("tag")
# p %<>% filter(is.element(tag, on_sometimes))
# }
# Get timing, NodeClass, type information from summarize_pool
summary <- pool %>% summarize_pool %>%
select(-edges_in, -matches("sounds"), -activation)
p %>% inner_join(summary, by = c("tag"))
}
#' Get the current state of a pool of units
#' @export
summarize_pool <- function(pool) {
# Wrapper for Node$describe method so we can vectorize it
describe <- function(node) {
# quickdf trick from http://adv-r.had.co.nz/Profiling.html#be-lazy
l <- node$describe()
l$NodeClass <- node %>% class %>% head(1)
class(l) <- "data.frame"
attr(l, "row.names") <- .set_row_names(length(l[[1]]))
l
}
# Make a data-frame summary of nodes in the pool
pool %>% lapply(describe) %>% rbind_all
}
#' @export
print.Network <- function(x, ...) {
pool_df <- summarize_pool(x)
d <- pool_df %>% group_by(NodeClass) %>%
tally %>%
mutate(Class = str_replace(NodeClass, "Node", ""))
pool_facts <- list(
NodeCounts = structure(as.list(d$n), names = d$Class),
Timeslices = max(pool_df$t_end),
Ticks = x[[1]]$tick)
cat("Network summary: \n")
str(pool_facts, give.attr = FALSE, give.head = FALSE, no.list = TRUE, ...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.