BDe score calculation - r

I tried to calculate BDe Score in R without using the built in function of different R packages.
`
library(bnlearn)
library(tidyverse)
# Load the ALARM network
# load("http://www.bnlearn.com/bnrepository/alarm/alarm.bif.gz")
alarmNetwork_ls <- read.bif("alarm.bif.gz")
# Load the ALARM data
data("alarm")
# Select a subset of the data for testing
test_data <- alarm[sample(nrow(alarm), 1000), ]
# The functions above match on names;
# the name of one of the nodes in the network is "LVFAILURE",
# but this name in the alarm dataset is "LVF".
# We fixed the column name using the code below.
test_data <- test_data %>%
rename(
HISTORY = HIST,
HREKG = HREK,
HRSAT = HRSA,
PRESS = PRSS,
EXPCO2 = ECO2,
MINVOL = MINV,
MINVOLSET = MVS,
HYPOVOLEMIA = HYP,
ANAPHYLAXIS = APL,
INSUFFANESTH = ANES,
PULMEMBOLUS = PMB,
INTUBATION = INT,
KINKEDTUBE = KINK,
DISCONNECT = DISC,
LVEDVOLUME = LVV,
STROKEVOLUME = STKV,
CATECHOL = CCHL,
LVFAILURE = LVF,
ERRLOWOUTPUT = ERLO,
ERRCAUTER = ERCA,
SHUNT = SHNT,
PVSAT = PVS,
ARTCO2 = ACO2,
VENTALV = VALV,
VENTLUNG = VLNG,
VENTTUBE = VTUB,
VENTMACH = VMCH
)
# calculate log-likelihood of data under the network
log_likelihood <- function(data, bn) {
n <- nrow(data)
nodes <- nodes(bn)
parents <- parents(bn)
logprob <- rep(0, n)
for (i in 1:n) {
prob <- 1
for (j in 1:length(nodes)) {
node <- nodes[[j]]
node_name <- node$name
node_parents <- parents[[j]]
if (length(node_parents) == 0) {
prob_node <- cpquery(bn, node_name, list(), data[i,])
} else {
parent_values <- data[i,node_parents]
prob_node <- cpquery(bn, node_name, list(parents = parent_values), data[i,])
}
prob <- prob * prob_node
}
logprob[i] <- log(prob)
}
return(sum(logprob))
}
# calculate number of parameters in the model
num_params <- function(bn) {
nodes <- nodes(bn)
parents <- parents(bn)
n_params <- 0
for (i in 1:length(nodes)) {
node <- nodes[[i]]
node_states <- length(node$levels[[1]])
n_parents <- length(parents[[i]])
n_params <- n_params + node_states * (n_parents + 1)
}
return(n_params)
}
# calculate BDe score
BDe_score <- function(data, bn) {
n <- nrow(data)
LL <- log_likelihood(data, bn)
d <- ncol(data)
k <- num_params(bn)
score <- LL - 0.5 * log(n) * k
return(score)
}
# test function on alarm data and network
BDe_score(test_data, alarmNetwork_ls)
`
I tried ro run the above code but got follwing error:
Error in check.nodes(nodes = node, graph = x, max.nodes = 1) : no node specified.
I know there are several R packages to calculate BDe score but can anyone help me to resolve my issue without using those built-in functions? Or if anyone can help me to code the proposition 18.2 of Probabilistic Graphical Models: Principles and Techniques Book by Daphne Koller and Nir Friedman

Related

search for the best number of k that minimizes the absolute value of the error between the mean of datas and the mean of frequency table

I wrote this function which gives me as output a frequency table divided in K classes, the mean of datas and the the mead of the frequency table.
Data_Frame <- function(x, k) {
if(k<=1) {
print("insert a number greter then 1") }
else {
data_range <- range(x)
interval_width <- (max(data_range)-min(data_range))/k
cutting_values <- seq (from = min(data_range),
to = max(data_range),
by= interval_width,)
lower_bounds <- cutting_values[1:k]
upper_bounds <- cutting_values[2:(k+1)]
counts <- numeric(length = k)
for (k in seq_along(counts)) {
counts[k] <- length(
x[which((x>=cutting_values[k]) & (x<=cutting_values[(k+1)]))])
}
DF <- data.frame(low.bounds = lower_bounds,
up.bounds = upper_bounds,
freq = counts)
Data_m <- mean(x)
DF_m <- sum((DF$low.bounds+DF$up.bounds)/2*DF$freq)/
sum(DF$freq)
result <- list(DF, Data_m = Data_m, DF_m = DF_m)
return(result)
}
}
### Code for using functions
set.seed(4321)
x <- rnorm(1000, 10, 2)
k <- 5L
result_function_1 <- Data_Frame(x, k)
print(result_function_1)
I have to write a second function which must search for the best number of k that minimizes the absolute value of the error between the mean of datas (Data_m) and the mean of frequency table (DF_m). Starting from k = 2 to K = max_K I have to return the optimal k.
Could someone help me out?
thanks

R: object .... not found

So I'm trying to process the data ("final_ts") in order to make a forecast for the time series using kernel functions and doing parallel computing. The analysis is made this way: 1) analyse the empirical time series, 2) run a standard variable
selection to subset only those variables and their time-lags that provide the best validation error. 3) Run the same analysis described above to choose the optimal regularization parameters and kernel function of the regularized algorithm. As a result I show the RMSE (root mean squared error).
The code is not mine, and I'm trying to set it without problems, but as I do not have so much experience, I can't understand how to solve (I've spent 2 days trying to find the solution so if you help me I would be so grateful) the problem which occured: "The object '....' not found".
So the MAIN CODE looks like this (I'll try to make explanation on what happens, please don't judge me):
#download the libraries:
rm(list=ls(all=TRUE))
suppressMessages(library(Matrix))
suppressMessages(library(quantreg))
suppressMessages(library(parallel))
suppressMessages(library(compiler))
suppressMessages(library(lars))
suppressMessages(library(elasticnet))
suppressMessages(library(caret))
options(warn=-1)
#####################################################################################
#Download the sources (I'll show them in the end as a code)
###########Take the file###
ShowPlot = FALSE
lags = TRUE
ModelName = 'final_ts'
FileName = paste(ModelName, '.txt', sep = '')
########Calculate the logspace and the standard error functions #################
logspace <- function(d1, d2, n) exp(log(10)*seq(d1, d2, length.out=n))
std_err <- function(x) sd(x)/sqrt(length(x))
############# Choose the kernel function: we have 4 of them, but we try the second one #####
Kernel.Options = c('Exponential.Kernel', 'Epanechnikov.Kernel', 'TriCubic.Kernel', 'Matern.Kernel')
Regression.Kernel = Kernel.Options[1]
############# Choose the parameters for cross validation ####
lambda = logspace(-3,0,15)
if(Regression.Kernel == 'Exponential.Kernel'){
tht = seq(from = 0., to = 10, length = 30)
}else{
tht = seq(from = 0.1, to = 3, length = 20)
}
parameters_on_grid = expand.grid(tht, lambda)
### Read Time series
d = as.matrix(read.table(FileName, header= T))
######################
original.Embedding = c('Pro', 'Syn','Piceu')
original.TargetList = original.Embedding
d = d[, original.Embedding]
#### Here you take combinations of lags (best lag are 1 - 2) #####
x.lag = 1; y.lag = 2; z.lag = 1
sp.lag.selection = c(x.lag, y.lag, z.lag)
lagged.time.series = make.lagged.ts(d, sp.lag.selection)
d = lagged.time.series$time.series
original.col = lagged.time.series$original.variables
if(lags == TRUE){ var.sel = original.col; }else{ var.sel = colnames(d)}
##### Names and embedding in the laged dataset
if(lags == TRUE){ colnames(d) = Embedding = TargetList = LETTERS[1:ncol(d)]}else{
Embedding = TargetList = original.Embedding
}
##### length of training and test set (2 points for testing, 28 - for training)
length.testing = 2
length.training = nrow(d) - length.testing
#### Preserve training for the interactions
ts.train.preserved = d[1:length.training, var.sel]
std.ts.train = Standardizza(ts.train.preserved)
#### Preserve testing for the test (you want your algorithm to learn the real structure of the model)
ts.test.preserved = d[(length.training + 1):nrow(d), var.sel]
#### Training set:
d.training = Standardizza(d[1:length.training, ])
#### You now need to standardize the test set using mean and sd of the training set
d.testing = Standardizza.test(ts.test.preserved,ts.train.preserved)
############## Prepare for parallel computing
Lavoratori = detectCores() - 2
cl <- parallel::makeCluster(Lavoratori, setup_strategy = "sequential")
####
RegressionType = ELNET_fit_
alpha = 0.85
### should you compute all the variables or not?
BestModel = BestModelLOOCV(cl, d.training, TargetList, Embedding, parameters_on_grid, RegressionType,alpha)
I also found a fourmula for calculation of kernel function (it may be put in a SPECIAL r (SOURCE 1)):
Exponential.Kernel <- function(dst, theta){
dbar <- mean(dst)
krnl <- exp(-theta*dst/dbar)
return(krnl)
}
Exponential.Kernel <- cmpfun(Exponential.Kernel)
The formulas for finding the best leave-one-out cross-validation parameters is below (SOURCE 2):
########################### Cross Validation (Leave-one-out) ##################################
BestModelLOOCV <- function(cl, X, TargetList, Embedding, grid, RegressionType,alpha){
mine_output = Jacobian_(cl, X, TargetList, Embedding, grid, RegressionType,alpha)
theta_opt = mine_output$th
lambda_opt = mine_output$lm
mine_c0 = mine_output$c0
mine_output = mine_output$J
J_ = list()
C0_ = do.call(cbind, lapply(1:ncol(X), function(x, M) unlist(M[[x]]), mine_c0))
colnames(C0_) = sapply(TargetList,function(x) paste("c0_", x, sep = ""))
for(k in 1:(nrow(X) - 1)){
J_[[k]] = do.call(rbind, lapply(1:ncol(X), function(x, M, i) unlist(M[[x]][i,]), mine_output, k))
rownames(J_[[k]]) = Embedding
colnames(J_[[k]]) = Embedding
}
BestCoefficients = list()
BestCoefficients$J = J_
BestCoefficients$c0 = C0_
BestParameters = list()
BestParameters$BestTH = theta_opt
BestParameters$BestLM = lambda_opt
return(list(BestCoefficients = BestCoefficients, BestParameters = BestParameters))
}
#####Compute the jacobian
Jacobian_ <- function(cl, X, TargetList, Embedding, grid, RegressionType,alpha){
J = c0 = list()
th = lm = c()
n_ = 1
FUN = match.fun(RegressionType)
for(trg in TargetList){
RegularizedParameters <- LOOCrossValidation(cl, X, trg, Embedding, grid, RegressionType,alpha)
########## Now compute the optimum regularized coefficients
J[[n_]] = FUN(X, trg, Embedding, RegularizedParameters$BestTH, RegularizedParameters$BestLM,alpha)
th = c(th, RegularizedParameters$BestTH)
lm = c(lm, RegularizedParameters$BestLM)
c0[[n_]] = J[[n_]]$c0
J[[n_]] = J[[n_]][-1]
n_ = n_ + 1
}
return(list(J = J, c0 = c0, th = th, lm = lm))
}
In order to compute the elastic-net regularization function you may use this formula (SOURCE 3):
ELNET_fit_ <- function(time.series, targ_col, Embedding, theta, lambda,alp){
Edim <- length(Embedding)
coeff_names <- sapply(colnames(time.series),function(x) paste("d", targ_col, "d", x, sep = ""))
block <- cbind(time.series[2:dim(time.series)[1],targ_col],time.series[1:(dim(time.series)[1]-1),])
block <- as.data.frame(apply(block, 2, function(x) (x-mean(x))/sd(x)))
lib <- 1:dim(block)[1]
pred <- 1:dim(block)[1]
coeff <- array(0,dim=c(length(pred),Edim + 1))
colnames(coeff) <- c('c0', coeff_names)
coeff <- as.data.frame(coeff)
for (ipred in 1:length(pred)){
libs = lib[-pred[ipred]]
q <- matrix(as.numeric(block[pred[ipred],2:dim(block)[2]]),
ncol=Edim, nrow=length(libs), byrow = T)
distances <- sqrt(rowSums((block[libs,2:dim(block)[2]] - q)^2))
### Kernel
Krnl = match.fun(Regression.Kernel)
Ws = Krnl(distances, theta)
############ Fit function
x = as.matrix(block[libs,2:dim(block)[2]])
y = as.matrix(block[libs,1])
x = x[seq_along(y), ]
y = y[seq_along(y)]
Ws = Ws[seq_along(y)]
x = Ws * cbind(1, x)
y = Ws * y
fit <- enet(x, y, lambda = lambda, normalize = TRUE, intercept = FALSE)
coeff[ipred,] <- predict(fit, s = alp, type="coefficients", mode="fraction")$coefficients
}
return(coeff)
}
ELNET_fit_ <- cmpfun(ELNET_fit_)
The auxiliary formulas for computation are as follows (SOURCE 4):
TakeLag <- function(X, species.to.lag, num.lag){
tmp = matrix(0, nrow(X), num.lag)
tmp[,1] = X[,species.to.lag]
tmp[1, 1] = NA
tmp[2:nrow(X), 1] = X[1:(nrow(X) - 1), species.to.lag]
if(num.lag > 1){
for(lag. in 2:num.lag){
tmp[,lag.] = X[,species.to.lag]
tmp[1, lag.] = NA
tmp[2:nrow(X), lag.] = tmp[1:(nrow(tmp) - 1), lag.-1]
}
}
tmp
}
make.lagged.ts <- function(X,sp.lag.selection ){
### X = time series
### sp.lag is a vector whose entry are the lags of each variable
### e.g., sp.lag = c(x.lag, y.lag, ..., u.lag)
s = list()
for(i in 1:length(sp.lag.selection)){
Lag.sp = TakeLag(X, original.Embedding[i], sp.lag.selection[i])
s[[i]] = cbind(X[,original.Embedding[i]], Lag.sp)
}
X = do.call(cbind,s)
### Remove the NA
X = X[-c(1:max(sp.lag.selection)),]
### Save the position of the unlagged variables
original.col = c()
for(k in 1:length(sp.lag.selection)){
if(k == 1){ original.col = c(original.col, 1)}else{
num.lags = sum(unlist(lapply(1:(k-1), function(x,X) X[x], sp.lag.selection)))
original.col = c(original.col, k + num.lags )
}
}
return(list(time.series = X, original.variables = original.col))
}
take.coeff <- function(X, col.to.extract, original.emb){
### To use when prediction are made using lagged variables
### Take as input the sequence X of Jacobian along the attractor
### and the species to look at
### return a new sequence of Jacobian of the interaction among those species
m = lapply(1:length(X$J), function(t, M, specie) M$J[[t]][specie,specie],
X, col.to.extract)
for(i in 1:length(m)){
colnames(m[[i]]) = rownames(m[[i]]) =original.emb
}
return(m)
}
Standardizza <- function(X){
### This return y = (x-meanx)/stdx
for(i in 1:ncol(X)){
X[,i] = (X[,i]- mean(X[,i]))/sd(X[,i])
}
return(X)
}
Standardizza.test <- function(X, Y){
### X = test set
### Y = training set
### This return y = (x-meanY)/stdY
for(i in 1:ncol(X)){
X[,i] = (X[,i]- mean(Y[,i]))/sd(Y[,i])
}
return(X)
}
###########################
#### Here you compute the quality of the forecast as mean correlation coefficient
The problem in the main code sounds like: object 'Regression.Kernel' not found, but I see it in the code, it's written. Maybe the problem is connected with the type of it? But if I take away the quotes in order to make it a "closure", I cannot impose the function restrictions.
Please, help me if you can as I don't know how to solve.
The original dataset ("final_ts.txt"):
decy Temp CTD_S OxFix Pro Syn Piceu Naneu
2011.74221 27.60333 36.20700 27.26667 58638.33333 13107.00000 799.66667 117.66667
2011.74401 26.97950 36.13400 27.05000 71392.50000 13228.50000 1149.00000 116.50000
2011.74617 24.99750 35.34450 24.80000 264292.00000 27514.00000 2434.50000 132.50000
2011.74692 24.78400 35.25800 25.82500 208996.50000 39284.00000 3761.75000 220.75000
2011.74774 27.34225 35.86800 27.82500 114617.25000 23115.00000 2337.00000 139.75000
2011.74950 26.47875 36.18175 27.20000 97008.00000 9775.75000 855.50000 77.50000
2011.75583 26.86500 36.14575 27.47500 76255.00000 10226.75000 783.00000 99.50000
2011.75654 27.04550 36.04950 27.60000 95017.75000 10546.25000 915.25000 77.75000
2011.75962 27.06567 36.46367 26.56667 75750.00000 10194.33333 687.00000 44.00000
2011.76101 27.44700 36.48150 27.90000 38556.50000 8204.75000 791.25000 118.75000
2011.76169 27.32325 36.50075 27.80000 29848.50000 8995.50000 727.00000 159.25000
2011.76245 26.87050 36.57350 26.40000 36323.50000 10897.00000 792.00000 87.50000
2011.76349 27.43900 36.89325 27.90000 17308.50000 9678.50000 559.00000 149.00000
2011.77171 26.74050 36.90550 26.10000 20976.50000 7516.00000 489.50000 41.50000
2011.77224 26.53500 36.77500 27.22500 27229.00000 7578.00000 606.75000 159.50000
2011.77288 26.65450 36.78500 27.32500 37897.50000 10493.50000 1008.75000 209.50000
2011.77444 27.24150 36.73800 26.80000 15551.00000 8159.50000 479.00000 70.50000
2011.77505 26.67560 36.74240 27.30000 27887.80000 5290.80000 510.00000 101.20000
2011.77568 27.65125 36.69225 28.10000 12850.00000 9944.75000 640.75000 120.00000
2011.77693 28.11500 36.32750 27.85000 5694.00000 10288.50000 507.00000 32.00000
2011.77751 28.61950 36.26325 28.72500 20486.75000 10465.00000 430.50000 82.75000
2011.77814 28.60425 36.23100 28.70000 27974.50000 6977.25000 554.00000 80.50000
2011.77968 28.47200 35.69000 28.40000 126778.00000 2840.00000 537.00000 27.00000
2011.78087 28.89400 35.60650 28.35000 49250.00000 5533.00000 1004.00000 5.50000
2011.78190 28.74100 35.46200 28.80000 35698.00000 1298.00000 308.00000 23.00000
2011.78713 28.80500 35.50100 28.70000 99450.00000 5410.00000 637.50000 50.50000
2011.78887 28.39250 35.90900 28.25000 116562.00000 3758.50000 582.50000 60.00000
2011.79078 28.10550 36.40150 28.20000 13403.00000 11285.00000 472.00000 73.50000
2011.79261 27.25650 36.78350 27.45000 11205.00000 10576.00000 630.00000 74.00000
Please, help if you have any guess as I don't have an idea what has gone wrong.

homals package for Nonlinear PCA in R: Error in dimnames(x) <- dn : length of 'dimnames' [1] not equal to array extent

I am trying to implement NLPCA (Nonlinear PCA) on a data set using the homals package in R but I keep on getting the following error message:
Error in dimnames(x) <- dn : length of 'dimnames' [1] not equal to array extent
The data set I use can be found in the UCI ML Repository and it's called dat when imported in R: https://archive.ics.uci.edu/ml/datasets/South+German+Credit+%28UPDATE%29
Here is my code (some code is provided once the data set is downloaded):
nlpcasouthgerman <- homals(dat, rank=1, level=c('nominal','numerical',rep('nominal',2),
'numerical','nominal',
rep('ordinal',2), rep('nominal',2),
'ordinal','nominal','numerical',
rep('nominal',2), 'ordinal',
'nominal','ordinal',rep('nominal',3)),
active=c(FALSE, rep(TRUE, 20)), ndim=3, verbose=1)
I am trying to predict the first attribute, therefore I set it to be active=FALSE.
The output looks like this (skipped all iteration messages):
Iteration: 1 Loss Value: 0.000047
Iteration: 2 Loss Value: 0.000044
...
Iteration: 37 Loss Value: 0.000043
Iteration: 38 Loss Value: 0.000043
Error in dimnames(x) <- dn :
length of 'dimnames' [1] not equal to array extent
I don't understand why this error comes up. I have used the same code on some other data set and it worked fine so I don't see why this error persists. Any suggestions about what might be going wrong and how I could fix this issue?
Thanks!
It seems the error comes from code generating NAs in the homals function, specifically for your data for the number_credits levels, which causes problems with sort(as.numeric((rownames(clist[[i]])))) and the attempt to catch the error, since one of the levels does not give an NA value.
So either you have to modify the homals function to take care of such an edge case, or change problematic factor levels. This might be something to file as a bug report to the package maintainer.
As a work-around in your case you could do something like:
levels(dat$number_credits)[1] <- "_1"
and the function should run without problems.
Edit:
I think one solution would be to change one line of code in the homals function, but no guarantee this does work as intended. Better submit a bug report to the package author/maintainer - see https://cran.r-project.org/web/packages/homals/ for the address.
Using rnames <- as.numeric(rownames(clist[[i]]))[order(as.numeric(rownames(clist[[i]])))] instead of rnames <- sort(as.numeric((rownames(clist[[i]])))) would allow the following code to identify NAs, but I am not sure why the author did not try to preserve factor levels outright.
Anyway, you could run a modified function in your local environment, which would require to explicitly call internal (not exported) homals functions, as shown below. Not necessarily the best approach, but would help you out in a pinch.
homals <- function (data, ndim = 2, rank = ndim, level = "nominal", sets = 0,
active = TRUE, eps = 0.000001, itermax = 1000, verbose = 0) {
dframe <- data
name <- deparse(substitute(dframe))
nobj <- nrow(dframe)
nvar <- ncol(dframe)
vname <- names(dframe)
rname <- rownames(dframe)
for (j in 1:nvar) {
dframe[, j] <- as.factor(dframe[, j])
levfreq <- table(dframe[, j])
if (any(levfreq == 0)) {
newlev <- levels(dframe[, j])[-which(levfreq == 0)]
}
else {
newlev <- levels(dframe[, j])
}
dframe[, j] <- factor(dframe[, j], levels = sort(newlev))
}
varcheck <- apply(dframe, 2, function(tl) length(table(tl)))
if (any(varcheck == 1))
stop("Variable with only 1 value detected! Can't proceed with estimation!")
active <- homals:::checkPars(active, nvar)
rank <- homals:::checkPars(rank, nvar)
level <- homals:::checkPars(level, nvar)
if (length(sets) == 1)
sets <- lapply(1:nvar, "c")
if (!all(sort(unlist(sets)) == (1:nvar))) {
print(cat("sets union", sort(unlist(sets)), "\n"))
stop("inappropriate set structure !")
}
nset <- length(sets)
mis <- rep(0, nobj)
for (l in 1:nset) {
lset <- sets[[l]]
if (all(!active[lset]))
(next)()
jset <- lset[which(active[lset])]
for (i in 1:nobj) {
if (any(is.na(dframe[i, jset])))
dframe[i, jset] <- NA
else mis[i] <- mis[i] + 1
}
}
for (j in 1:nvar) {
k <- length(levels(dframe[, j]))
if (rank[j] > min(ndim, k - 1))
rank[j] <- min(ndim, k - 1)
}
x <- cbind(homals:::orthogonalPolynomials(mis, 1:nobj, ndim))
x <- homals:::normX(homals:::centerX(x, mis), mis)$q
y <- lapply(1:nvar, function(j) homals:::computeY(dframe[, j], x))
sold <- homals:::totalLoss(dframe, x, y, active, rank, level, sets)
iter <- pops <- 0
repeat {
iter <- iter + 1
y <- homals:::updateY(dframe, x, y, active, rank, level, sets,
verbose = verbose)
smid <- homals:::totalLoss(dframe, x, y, active, rank, level,
sets)/(nobj * nvar * ndim)
ssum <- homals:::totalSum(dframe, x, y, active, rank, level, sets)
qv <- homals:::normX(homals:::centerX((1/mis) * ssum, mis), mis)
z <- qv$q
snew <- homals:::totalLoss(dframe, z, y, active, rank, level,
sets)/(nobj * nvar * ndim)
if (verbose > 0)
cat("Iteration:", formatC(iter, digits = 3, width = 3),
"Loss Value: ", formatC(c(smid), digits = 6,
width = 6, format = "f"), "\n")
r <- abs(qv$r)/2
ops <- sum(r)
aps <- sum(La.svd(crossprod(x, mis * z), 0, 0)$d)/ndim
if (iter == itermax) {
stop("maximum number of iterations reached")
}
if (smid > sold) {
warning(cat("Loss function increases in iteration ",
iter, "\n"))
}
if ((ops - pops) < eps)
break
else {
x <- z
pops <- ops
sold <- smid
}
}
ylist <- alist <- clist <- ulist <- NULL
for (j in 1:nvar) {
gg <- dframe[, j]
c <- homals:::computeY(gg, z)
d <- as.vector(table(gg))
lst <- homals:::restrictY(d, c, rank[j], level[j])
y <- lst$y
a <- lst$a
u <- lst$z
ylist <- c(ylist, list(y))
alist <- c(alist, list(a))
clist <- c(clist, list(c))
ulist <- c(ulist, list(u))
}
dimlab <- paste("D", 1:ndim, sep = "")
for (i in 1:nvar) {
if (ndim == 1) {
ylist[[i]] <- cbind(ylist[[i]])
ulist[[i]] <- cbind(ulist[[i]])
clist[[i]] <- cbind(clist[[i]])
}
options(warn = -1)
# Here is the line that I changed in the code:
# rnames <- sort(as.numeric((rownames(clist[[i]]))))
rnames <- as.numeric(rownames(clist[[i]]))[order(as.numeric(rownames(clist[[i]])))]
options(warn = 0)
if ((any(is.na(rnames))) || (length(rnames) == 0))
rnames <- rownames(clist[[i]])
if (!is.matrix(ulist[[i]]))
ulist[[i]] <- as.matrix(ulist[[i]])
rownames(ylist[[i]]) <- rownames(ulist[[i]]) <- rownames(clist[[i]]) <- rnames
rownames(alist[[i]]) <- paste(1:dim(alist[[i]])[1])
colnames(clist[[i]]) <- colnames(ylist[[i]]) <- colnames(alist[[i]]) <- dimlab
colnames(ulist[[i]]) <- paste(1:dim(as.matrix(ulist[[i]]))[2])
}
names(ylist) <- names(ulist) <- names(clist) <- names(alist) <- colnames(dframe)
rownames(z) <- rownames(dframe)
colnames(z) <- dimlab
dummymat <- as.matrix(homals:::expandFrame(dframe, zero = FALSE, clean = FALSE))
dummymat01 <- dummymat
dummymat[dummymat == 2] <- NA
dummymat[dummymat == 0] <- Inf
scoremat <- array(NA, dim = c(dim(dframe), ndim), dimnames = list(rownames(dframe),
colnames(dframe), paste("dim", 1:ndim, sep = "")))
for (i in 1:ndim) {
catscores.d1 <- do.call(rbind, ylist)[, i]
dummy.scores <- t(t(dummymat) * catscores.d1)
freqlist <- apply(dframe, 2, function(dtab) as.list(table(dtab)))
cat.ind <- sequence(sapply(freqlist, length))
scoremat[, , i] <- t(apply(dummy.scores, 1, function(ds) {
ind.infel <- which(ds == Inf)
ind.minfel <- which(ds == -Inf)
ind.nan <- which(is.nan(ds))
ind.nael <- which((is.na(ds) + (cat.ind != 1)) ==
2)
ds[-c(ind.infel, ind.minfel, ind.nael, ind.nan)]
}))
}
disc.mat <- apply(scoremat, 3, function(xx) {
apply(xx, 2, function(cols) {
(sum(cols^2, na.rm = TRUE))/nobj
})
})
result <- list(datname = name, catscores = ylist, scoremat = scoremat,
objscores = z, cat.centroids = clist, ind.mat = dummymat01,
loadings = alist, low.rank = ulist, discrim = disc.mat,
ndim = ndim, niter = iter, level = level, eigenvalues = r,
loss = smid, rank.vec = rank, active = active, dframe = dframe,
call = match.call())
class(result) <- "homals"
result
}

Possible ways to incorporate topography in a correlated random walk in R?

I was wondering which possibilities there are for incorporating topography in a correlated random walk in R. I have a digital elevation model (DEM) of the study area. I would like for my random walk to avoid areas with a steep slope.
walk <- function(x0, y0, head0, n, parameterMu, parameterRho, parameterMean, parameterSd)
{
# Get nr of individuals, call it k
k = length(x0)
# Create list to hold data
all.paths <- list()
for (j in 1:k)
{
# Create structure to hold data
steps <- data.frame(matrix(0,n,6))
colnames(steps) <- c("id","x", "y", "steplength", "heading", "turningangle")
# Insert the id, starting location and heading
steps[,"id"] = j
steps[1,"x"] = x0[j]
steps[1,"y"] = y0[j]
steps[1,"heading"] = head0[j]
# Simulate steps
for(i in 2:n)
{
# Draw step length and turning angle, compute heading
steplength = rnorm(n = 1, mean = parameterMean, sd = parameterSd)
turningangle = as.numeric(rwrappedcauchy(n = 1, mu = parameterMu, rho = parameterRho))
newbearing = as.numeric(circular(steps[i-1,"heading"]) + circular(turningangle)) %% (2*pi)
# Get new location
next.xy <- movement(x0=steps[i-1,"x"], y0=steps[i-1,"y"], step=steplength, heading=newbearing)
# Store output (xy on row i, steplength/heading on row i-1)
steps[i,"x"] <- next.xy[1,"x"]
steps[i,"y"] <- next.xy[1,"y"]
steps[i,"steplength"] <- next.xy[1,"step"]
steps[i,"heading"] <- newbearing
steps[i,"turningangle"] <- turningangle
# Store trajectory in list
all.paths[[j]] <- steps
}
# Return output
return(all.paths)
}
The movement function:
movement <- function(x0, y0, step, heading)
{
x_new <- x0 + sin(heading)*step
y_new <- y0 + cos(heading)*step
move.temp <- data.frame(x = x_new,
y = y_new,
step = step,
head = heading)
return(move.temp)
}

Neural Net converges to minima, but only works when all the training data is provided

I am new to Neural Networks and I wrote the following code of Feed forward neural network as to perform 3 bit Binary Counter. What I found with the output of my code was when I tried predicting after training with any of the one 3-bit input it almost always predicts next state wrong , but when I pass cntr_inp(matrix that contains all inputs) as input it predicts next state right for the corresponding state. I couldn't find out what's happening and stuck for some time now.
If someone could find out the mistake I'm doing would me helpful.
Thanks.
#Sigmoid Function
sigmoid <- function(z){
1.0/(1.0+exp(-z))
}
#Derivative of Sigmoid
sigmoid.derivative <- function(z){
z*(1-z)
}
#Randomly Generates Weights
create.weights <- function(layers){
weights <- vector("list",length(layers)-1)
for(i in 1:length(weights)){
weights[[i]] <- matrix(runif(layers[i]*layers[i+1]),nrow = layers[i],ncol = layers[i+1])
}
return(weights)
}
#Randomly Generates Biases
create.biases <- function(layers){
biases <- vector("list",length(layers)-1)
for(i in 1:length(biases)){
biases[[i]] <- runif(layers[i+1])
}
return(biases)
}
#Feedforward / Forward Propogation
feedforward <- function(inp,weights,biases){
layer <- vector("list",length(layers)-1)
for(i in 1:(length(layers)-1)){
if(i==1){
layer[[i]] <- inp %*% weights[[i]] + biases[[i]]
layer_dim <- dim(layer[[i]])
layer[[i]] <- matrix(sigmoid(as.numeric(layer[[i]])),nrow = layer_dim[1],ncol = layer_dim[2],byrow = FALSE)
}else{
layer[[i]] <- layer[[i-1]] %*% weights[[i]] + biases[[i]]
layer_dim <- dim(layer[[i]])
layer[[i]] <- matrix(sigmoid(as.numeric(layer[[i]])),nrow = layer_dim[1],ncol = layer_dim[2],byrow = FALSE)
}
}
return(layer)
}
#Calculating Delta Values
calculate_delta <- function(net_out,out,weights){
Slope <- lapply(net_out,sigmoid.derivative)
delta <- vector("list",length(Slope))
for(i in length(Slope):1){
if(i == length(Slope)){
delta[[i]] <- (out-net_out[[i]]) * Slope[[i]]
}else{
Error_hidden <- delta[[i+1]] %*% t(weights[[i+1]])
delta[[i]] <- Error_hidden * Slope[[i]]
}
}
return(delta)
}
#Updating Weights
updating_weights <- function(weights,inp,delta,net_out,step.size){
for(i in length(weights):1){
if(i != 1){
weights[[i]] <- weights[[i]] + t(net_out[[i-1]]) %*% delta[[i]] * step.size
}else{
weights[[i]] <- weights[[i]] + t(inp) %*% delta[[i]] * step.size
}
}
return(weights)
}
#Updating Biases
updating_biases <- function(biases,delta,step.size){
for(i in 1:length(biases)){
biases[[i]] <- biases[[i]] + colSums(delta[[i]]) * step.size
}
return(biases)
}
#Complete Neural Net operations (Forward and Backward Propogation)
Neural.Net <- function(layers = NULL,inp,out,epoch,step.size = 0.01,error.threshold = 0.01){
weights <- create.weights(layers)
biases <- create.biases(layers)
for(i in 1:epoch){
##Back Propogation
net_out <- feedforward(inp,weights,biases)
delta <- calculate_delta(net_out,out,weights)
weights <- updating_weights(weights,inp,delta,net_out,step.size)
biases <- updating_biases(biases,delta,step.size)
avg_error <- mean(abs(out - net_out[[length(net_out)]]))
##Printing Output for every epoch
cat("\014")
cat("------- Feed Forward Neural Nets -------\n")
cat("Inputs: ",layers[1],"\n")
cat("Outputs: ",layers[length(layers)],"\n")
cat("Hidden Layers:", length(layers)-2,"\n")
cat(paste("Epoch :",i," Avg_error = ",avg_error,"\n"))
cat("Output Values:\n\n")
print(net_out[[length(net_out)]])
Sys.sleep(0.002)
##
if(avg_error <= error.threshold){
message("Optimum values found")
break
}
}
return(list(weights = weights,biases = biases,Net_out = net_out))
}
Neural.Net.Predict <- function(Model,Test.inp){
layer <- feedforward(inp = Test.inp,weights = Model$weights,biases = Model$biases)
return(layer[length(layer)])
}
#Input and Hyper parameters to Neural Network
layers <- c(3,7,3)
cntr_inp <- matrix(c(0,0,0,
0,0,1,
0,1,0,
0,1,1,
1,0,0,
1,0,1,
1,1,0,
1,1,1),byrow = T,nrow = 8,ncol = 3)
cntr_out <- matrix(c(0,0,1,
0,1,0,
0,1,1,
1,0,0,
1,0,1,
1,1,0,
1,1,1,
0,0,0),byrow = T,nrow = 8,ncol = 3)
Output <- Neural.Net(layers = layers,inp = cntr_inp,out = cntr_out,epoch = 100000,step.size = 0.8,error.threshold = 0.01)
###Predicts wrong when one input point is provided
# I don't understand why this is predicting wrong. Need help understanding here
Neural.Net.Predict(Output,matrix(c(1,0,0),ncol = 3,byrow = TRUE))
###Predicts right for all inputs
Neural.Net.Predict(Output,cntr_inp)

Resources