Initial CommitHEADmaster

7 files changed, 273 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..d978257
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,8 @@
+*.db
+*.db-journal
+*.lintr
+*demo*
+*notes*
+*test*
+!test_gen.r
+*version*
\ No newline at end of file
diff --git a/Layer_refCls.r b/Layer_refCls.r
new file mode 100644
index 0000000..71b31a4
--- /dev/null
+++ b/Layer_refCls.r
@@ -0,0 +1,100 @@
+source(paste(getwd(), "lib_act_func.r", sep = "/"))
+
+attr_list <- list(
+	node_count = "numeric",
+	inputs = "numeric",
+	act_func = "function",
+	d_act_func = "function",
+	weights = "matrix",
+	biases = "numeric",
+	act_out_val = "numeric",
+	z_in_val = "numeric",
+	act_in_val = "numeric",
+	dc_dw_arr = "array",
+	dc_db_arr = "array"
+)
+
+# init method as passable variable
+func_i <- function(node_count, inputs, act_func_name) {
+	node_count <<- node_count
+	inputs <<- inputs
+	init_w()
+	biases <<- rep(0, node_count)
+	act_func <<- sel_g(act_func_name)
+	d_act_func <<-  sel_d(act_func_name)
+	dc_dw_arr <<- array(0, dim = 0)
+	dc_db_arr <<- array(0, dim = 0)
+}
+
+# activation function caller as passable variable
+func_1 <- function(act_in) {
+	act_in_val <<- act_in
+	z_in_val <<- z_input(act_in)
+	act_out_val <<- act_func(z_in_val)
+	return(act_out_val)
+}
+
+# z expression caller as passable variable
+func_2 <- function(act_in) {
+	res <- weights %*% act_in
+	res <- res + biases
+	return(as.vector(res))
+}
+
+# weight initialization as passable function
+# Xavier Initialization
+func_3 <- function() {
+	weights <<- matrix(
+		rnorm(
+			inputs * node_count,
+			sd = sqrt(2 / (inputs + node_count))
+		),
+		ncol = inputs,
+		nrow = node_count
+	)
+}
+
+# back propogation method as passable variable
+func_4 <- function(dc_dao) {
+	dao_dz <- d_act_func(z_in_val)
+	dz_dw <- matrix(
+		act_in_val,
+		ncol = inputs,
+		nrow = node_count,
+		byrow = TRUE
+	)
+	dc_dw <- dc_dao * dao_dz * dz_dw
+	dc_db <- dc_dao * dao_dz
+	dz_dai <- weights
+	dc_dai <- colSums(dc_dao * dao_dz * dz_dai)
+
+	if (dim(dc_dw_arr)[1] == 0) {
+		dc_dw_arr <<- array(dc_dw, dim = c(dim(weights), 1))
+		dc_db_arr <<- array(dc_db, dim = c(1, length(biases)))
+	} else {
+		dc_dw_arr <<- array(append(dc_dw_arr, dc_dw), dim = c(dim(weights), dim(dc_dw_arr)[3] + 1))
+		dc_db_arr <<- rbind(dc_db_arr, dc_db)
+	}
+	
+	return(dc_dai)
+}
+
+# gradient descent implementer method as passable variable
+func_5 <- function(l_rate) {
+	weights <<- weights - l_rate * apply(dc_dw_arr, MARGIN = c(1, 2), FUN = mean)
+	biases <<- biases - l_rate * colMeans(dc_db_arr)
+
+	dc_dw_arr <<- array(0, dim = 0)
+	dc_db_arr <<- array(0, dim = 0)
+}
+
+meth_list <- list(
+	initialize = func_i,
+	act_out = func_1,
+	z_input = func_2,
+	init_w = func_3,
+	back_prop = func_4,
+	grad_desc = func_5
+)
+
+Layer <- setRefClass("Layer", fields = attr_list, methods = meth_list)
diff --git a/NNetwork_refCls.r b/NNetwork_refCls.r
new file mode 100644
index 0000000..886cb94
--- /dev/null
+++ b/NNetwork_refCls.r
@@ -0,0 +1,60 @@
+source(paste(getwd(), "Layer_refCls.r", sep = "/"))
+
+attr_list <- list(
+	node_counts = "numeric",
+	l_rate = "numeric",
+	layers = "list"
+)
+
+func_i <- function(node_counts, l_rate, act_func_names) {
+	node_counts <<- node_counts
+	l_rate <<- l_rate
+	layers <<- list()
+	for (i in 1:(length(node_counts) - 1)) {
+		layers <<- c(
+			layers,
+			Layer(
+				node_counts[i + 1],
+				node_counts[i],
+				act_func_names[i + 1]
+			)
+		)
+	}
+}
+
+# forward propagation caller as passable variable
+func_1 <- function(act_in) {
+    act_i <- act_in
+	for (i in 1:length(layers)) {
+		act_i <- layers[[i]]$act_out(act_i)
+	}
+	return(act_i)
+}
+
+# back propagation caller as passable variable
+func_2 <- function(act_in, tar_out) {
+	act_out <- fw_prop(act_in)
+	cost <- sum((act_out - tar_out) ^ 2)
+	dc_da <- 2 * (act_out - tar_out)
+	for (i in length(layers):1) {
+		dc_da <- layers[[i]]$back_prop(dc_da)
+	}
+	return(cost)
+}
+
+# gradient descent as passable variable
+func_3 <- function() {
+	for (i in length(layers):1) {
+		layers[[i]]$grad_desc(l_rate)
+	}
+}
+
+# these are class methods, so not adjustable instance-to-instance
+meth_list <- list(
+	initialize = func_i,
+	fw_prop = func_1,
+	back_prop = func_2,
+	grad_desc = func_3
+)
+
+NNetwork <- setRefClass("NNetwork", fields = attr_list, methods = meth_list)
diff --git a/lib_act_func.r b/lib_act_func.r
new file mode 100644
index 0000000..2329892
--- /dev/null
+++ b/lib_act_func.r
@@ -0,0 +1,35 @@
+# Activation function library
+
+relu <- function(x) return(x * (x > 0))
+Drelu <- function(x) {
+	lx <- as.numeric(x > 0)
+	attributes(lx) <- attributes(x)
+	return(lx)
+}
+
+sigmoid <- function(x) 1 / (1 + exp(-x))
+Dsigmoid <- function(x) eval(D(expression(1 / (1 + exp(-x))), "x"))
+
+#tanh
+Dtanh <- function(x) return(eval(D(expression(tanh(x)), "x")))
+
+no_func <- function(x) return(x)
+Dno_func <- function(x) {
+	lx <- rep(1, length(x))
+	attributes(lx) <- attributes(x)
+	return(lx)
+}
+
+sel_g <- function(func_name) {
+	if (func_name == "relu") return(relu)
+	if (func_name == "sigmoid") return(sigmoid)
+	if (func_name == "tanh") return(tanh)
+	if (func_name == "no_func") return(no_func)
+}
+
+sel_d <- function(func_name) {
+	if (func_name == "relu") return(Drelu)
+	if (func_name == "sigmoid") return(Dsigmoid)
+	if (func_name == "tanh") return(Dtanh)
+	if (func_name == "no_func") return(Dno_func)
+}
\ No newline at end of file
diff --git a/readme.md b/readme.md
new file mode 100644
index 0000000..48e7ff2
--- /dev/null
+++ b/readme.md
@@ -0,0 +1,3 @@
+# Simple Neural Network as R Reference Class
+
+Currently in progress to build experience.
\ No newline at end of file
diff --git a/test_gen.r b/test_gen.r
new file mode 100644
index 0000000..1b5fc56
--- /dev/null
+++ b/test_gen.r
@@ -0,0 +1,29 @@
+test_input <- function(input_node_count) {
+	return(floor(runif(input_node_count, max = 2)))
+}
+
+test_output <- function(test_input) {
+	inc <- length(test_input)
+	onc <- packBits(as.integer(c(rep(1, inc), rep(0, 32 - inc))), "integer") + 1
+	tar_int <- packBits(as.integer(c(test_input, rep(0, 32 - inc))), "integer")
+	tar_out <- rep(0, onc)
+	tar_out[tar_int + 1] <- 1
+	return(tar_out)
+}
+
+read_input <- function(test_input) {
+	inc <- length(test_input)
+	tar_int <- packBits(as.integer(c(test_input, rep(0, 32 - inc))), "integer")
+	return(tar_int)
+}
+
+read_output <- function(output_signal) {
+	tar_int <- which(output_signal == 1) - 1
+	return(tar_int)
+}
+
+clean_output <- function(output_signal) {
+	mo <- max(output_signal)
+	tar_int <- which(output_signal == mo) - 1
+	return(tar_int)
+}
\ No newline at end of file
diff --git a/train_loop.r b/train_loop.r
new file mode 100644
index 0000000..48fa0c1
--- /dev/null
+++ b/train_loop.r
@@ -0,0 +1,38 @@
+source(paste(getwd(), "NNetwork_refCls.r", sep = "/"))
+source(paste(getwd(), "test_gen.r", sep = "/"))
+
+ni <- 5
+no <- packBits(as.integer(c(rep(1, ni), rep(0, 32 - ni))), "integer") + 1
+
+nnetwork_1 <- NNetwork(
+	node_counts = c(ni, 32, 32, no),
+	l_rate = 0.01,
+	act_func_names = c("no_func", "relu", "relu", "no_func")
+)
+
+cost_chk <- rep(0, no)
+res_chk <- rep(0, no)
+
+for (i in 0:10000) {
+
+	ti <- test_input(ni)
+	tar_out <- test_output(ti)
+
+	ao <- nnetwork_1$fw_prop(ti)
+	cost <- nnetwork_1$back_prop(ti, tar_out)
+
+	tar_int <- read_input(ti)
+	act_int <- clean_output(ao)
+
+	if (tar_int == 3) {print(c(cost, ao[4], act_int))}
+
+	cost_chk[tar_int + 1] <- cost
+	res_chk[tar_int + 1] <- act_int
+
+	if (i %% 1 == 0) {
+		nnetwork_1$grad_desc()
+	}
+}
+
+cost_chk
+res_chk