replacing nested for loop with sapply in R - r

So I have 10 parameters, with 7 fixed and 3 varying using seq. Each varying parameter has 10 possibilities. Right now I create an empty data frame and fill it after going through a bunch of functions and generating an output for each combination of parameters. So there is 1000 (10*10*10) possibilities. Right now I use nested for loops. Lets say m,g, and x are my varying parameters. Here is an example.
m.c <- seq(1,10, by=1)
m.i <- seq(1,10, by=1) * 0.5
a <- .5
b <- 1
c <- .5
gg <- seq(.02,.2, by=.02)
n <- 7
r <- .25
alpha <- 2
dt <- 1
X <- seq(.01,.1, by=.01)
intervention.data <- data.frame(intervention = numeric())
parameter.data <- data.frame(m=numeric(), g=numeric(), X=numeric())
A.c = function(m = m.c,a,b,c,g,n,r,alpha,dt,X) {
1 - exp(-dt*(1/(alpha*dt)*log(1+(alpha*b*dt*m*a^2*c*X*exp(-g*n))/(a*c*X+g))))
}
A.i = function(m = m.i,a,b,c,g,n,r,alpha,dt,X) {
1 - exp(-dt*(1/(alpha*dt)*log(1+(alpha*b*dt*m*a^2*c*X*exp(-g*n))/(a*c*X+g))))
}
for (i in 1:length(mm)) {
m = mm[i]
for (ii in 1:length(gg)) {
g = gg[ii]
for (iii in 1:length(XX)) {
X = XX[iii]
parameter.data = rbind(parameter.data, data.frame(m=m, g=g, X=X))
a.c = A.c(m = m.c,a,b,c,g,n,r,alpha,dt,X)
a.i = A.i(m = m.i,a,b,c,g,n,r,alpha,dt,X)
intervention.effect= a.i/a.c
intervention.data = rbind(intervention.data, data.frame( intervention = intervention.effect))
}
}
}
all.intervention.data = cbind(parameter.data, intervention.data)
What I have works but seems pretty inefficient so I have been trying to find how to use sapply or lapply but have not been successful in understanding to use them so all the combos. are made. Any help is appreciated.

You seem to have lost mm in your data, so I can not follow perfectly, but a better way to do this would be to vectorize:
all.data <- expand.grid(m.c = m.c,gg = gg,X = X)
all.data$m.i <- all.data$m.c * 0.5
all.data$a.c <- A.c(m = all.data$m.c,a,b,c,all.data$gg,n,r,alpha,dt,all.data$X)
all.data$a.i <- A.i(m = all.data$m.i,a,b,c,all.data$gg,n,r,alpha,dt,all.data$X)

Related

BDe score calculation

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

storing multiple images (3D arrays) into a 4D array, in R, with for loop

I am trying to get an average of 3 pictures. I made a function to do that, but i have an issue with storing each of the images following some image manipulation. I am getting an error:
Warning messages:
1: In b$b_arr[i] <- m : number of items to replace is not a multiple of replacement length
2: In b$b_arr[i] <- m : number of items to replace is not a multiple of replacement length
3: In b$b_arr[i] <- m : number of items to replace is not a multiple of replacement length
This is the code that I used to do it. I know I can do this manually, but I want to make a function (and learn what is my issue with this for loop).
library(OpenImageR)
imgs <- c("img1.png", "img2.png", "img3.png")
b <- data.frame(conc = imgs,
b_arr = array(dim = c(length(imgs),831, 651, 3)))
base_fun <- functienter code hereon(imgs) {
for (i in 1:length(imgs)) {
m <- readImage(imgs[i])
m[ , , 2] = 0
m[ , , 3] = 0
m <- cropImage(m, new_width = 250:1080,
new_height = 650:1300,
type = 'user_defined')
b$b_arr[i] <<- m
}
avg_b <<- (b$b_arr[1,,,] + b$b_arr[2,,,] + b$b_arr[3,,,])/3
}
base_fun(img)
Within your code the problem is that b is a data.frame of dimension 3 times 2. This means that the b_arr column is actually three 4 dimensional arrays.
I don't have any images laying around, but something like the code below should work.
library(OpenImageR)
imgs <- c("img1.png", "img2.png", "img3.png")
b <- lapply(imgs, function(x){
img <- readImage(x)
cropImage(img, new_width = 250:1080, new_height = 650:1300, type = 'user_defined')
})
# Convert list to array
b_arr <- array(dim = c( length(imgs), 831, 651, 3))
for(i in seq(length(imgs))
b_arr[,, i] <- b[[i]]
# calculate the mean across the first dimension (why?)
apply(b_arr, 1, mean)
Oliver's answer worked (with small modification), but I figured out how to do it in a function (helps with scalability and readability).
b <- function(imgs) {
b <<- array(dim = c(length(imgs), w_to-w_from+1, h_to-h_from+1, 3))
for (i in seq(length(imgs))) {
m <- readImage(imgs[i])
m[ , , 2] = 0
m[ , , 3] = 0
m <- cropImage(m, new_width = w_from:w_to,
new_height = h_from:h_to, type = 'user_defined')
b[i,,,] <<- m
}
m_avg <<- (b[1,,,] + b[2,,,] + b[3,,,])/3
}

Vectorizing this function in R

Hi so I have the following function:
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
I'd like to vectorize this without using any for loops or apply statements, can't seem to get around doing so. Help would be appreciated. Thanks.
EDIT: Given the responses, here are my answers to the questions posed.
Given requests for clarification, I will elaborate on the function inputs and on the user defined function inside the function given. So X here is a dataset in the form of a vector, specifically, a vector of length 7 in the dataset I used as an input to this function. The X I used this function for is c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041). s is a single scalar point set at 0.2 for the use of this function. kde is a user - defined function that I wrote. Here is the implementation:
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
in this function, X is the same vector of data points used in kde.cv. s is also the same scalar value of 0.2 used in kde.cv. x is a vector of evaluation points for the function, I used seq(-2.5, -0.5, by = 0.1).
Here is an option using sapply
kde.cv = function(X,s)
sum(sapply(1:length(X), function(i) log(kde(X[i], X[-i], s))))
For convenience, please provide a more complete example. For example, the kde() function. Is that a customized function?
Alternative to sapply, you can try Vectorize(). There are some examples you can find on stack overflow.
Vectorize() vs apply()
Here is an example
f1 <- function(x,y) return(x+y)
f2 <- Vectorize(f1)
f1(1:3, 2:4)
[1] 3 5 7
f2(1:3, 2:4)
[1] 3 5 7
and the second example
f1 <- function(x)
{
new.vector<-c()
for (i in 1:length(x))
{
new.vector[i]<-sum(x[i] + x[-i])
}
return(sum(new.vector))
}
f2<-function(x)
{
f3<-function(y, i)
{
u<-sum(y[i]+y[-i])
return(u)
}
f3.v<-Vectorize(function(i) f3(y = x, i=i))
new.value<-f3.v(1:length(x))
return(sum(new.value))
}
f1(1:3)
[1] 24
f2(1:3)
[1] 24
Note: Vectorize is a wrapper for mapply
EDIT 1
According to the response, I edited your kde.cv function.
kde.cv = function(X,s) {
l = length(X)
log.fhat.vector = c()
for (i in 1:l) {
current.log.fhat = log ( kde(X[i],X[-i],s) )
log.fhat.vector[i] = current.log.fhat
}
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde = function(x,X,s){
l = length(x)
b = matrix(X,l,length(X),byrow = TRUE)
c = x - b
phi.matrix = dnorm(c,0,s)
d = rowMeans(phi.matrix)
return(d)
}
##### Vectorize kde.cv ######
kde.cv.v = function(X,s)
{
log.fhat.vector = c()
kde.v<-Vectorize(function(i) kde(X[i], X[-i], s))
CV.score <- sum(log(kde.v(1:length(X))))
return(CV.score)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
x<-seq(-2.5, -0.5, by = 0.1)
kde.cv(X, s)
[1] -10.18278
kde.cv.v(X, s)
[1] -10.18278
EDIT 2
Well, I think the following function may match your requirement. BTW, since the little x is not used in your kde.cv, I just edited both two functions
kde.cv.2 <- function(X,s)
{
log.fhat.vector<-log(kde.2(X, s))
CV.score = sum(log.fhat.vector)
return(CV.score)
}
kde.2<-function(X, s)
{
l <- length(X)
b <- matrix(rep(X, l), l, l, byrow = T)
c <- X - b
diag(c) <- NA
phi.matrix <- dnorm(c, 0, s)
d <- rowMeans(phi.matrix, na.rm = T)
return(d)
}
X<-c(-1.1653, -0.7538, -1.3218, -2.3394, -1.9766, -1.8718, -1.5041)
s<-0.2
kde.cv(X,s)
[1] -10.18278
kde.cv.2(X, s)
[1] -10.18278

R How do I form a matrix by using a loop to repeat function and binding each answer to the original function

I am new to programming so my knowledge is very limited at the moment but I am always looking to improve.
I have this function called gillespied detailed below to show the gillespie algorithm
> print(gillespied)
function (N, T = 100, dt = 1, ...)
{
tt = 0
n = T%/%dt
x = N$M
S = t(N$Post - N$Pre)
u = nrow(S)
v = ncol(S)
xmat = matrix(ncol = u, nrow = n)
i = 1
target = 0
repeat {
h = N$h(x, tt, ...)
h0 = sum(h)
if (h0 < 1e-10)
tt = 1e+99
else tt = tt + rexp(1, h0)
while (tt >= target) {
xmat[i, ] = x
i = i + 1
target = target + dt
if (i > n)
return(ts(xmat, start = 0, deltat = dt))
}
j = sample(v, 1, prob = h)
x = x + S[, j]
}
}
And I use
out = gillespied(LV,T=100,dt=1)
I would like to create a matrix which corresponds to the first column of this out result, but then I'd like to repeat this out result a further 19 times (so I have 20 in total) and bind each result to my original matrix, this would give me a 20X100 matrix.
This is my attempt at it, and I'm not sure if it is correct as my R freezes when I try to view my matrix M
M=matrix(out[,1],ncol=1)
for (i in 1:19) {
out = gillespied(LV, T=100, dt=1)
M = cbind(M,out[,1])
i = i+1
}
print(M)
I was wondering if this is correct, and if it is not what adjustments I should be making
You don't need to increment i, the for loop does this for you.
E.g.
M <- matrix(rnorm(5), ncol = 1)
for (i in 1:5){
out <- rnorm(5)
M <- cbind(M, out)
}
> M
out out out out out
[1,] 0.21701968 2.0296134 -0.26425755 0.3904337 0.1438060 -0.5340556
[2,] 0.07689991 -2.0589758 0.01443763 -0.7506177 -0.8498391 1.0487328
[3,] -0.73329583 0.2709055 0.42298869 0.3271687 1.0450811 -0.9313009
[4,] -1.68460070 0.2864797 -1.83408494 -0.2878682 -0.4297308 0.5282630
[5,] 0.08921503 -1.4390101 0.89112111 -1.6711018 -2.0863797 -0.6924083
Something like i = i+1 is usually used in a while loop. Otherwise your code appears to do what you want.
How big is your matrix? It might struggle to print to console. What happens if you try head(M)?

R: creating a matrix with unknown number of rows

I have written the code below to generate a matrix containing what is, to me, a fairly complex pattern. In this case I determined that there are 136 rows in the finished matrix by trial and error.
I could write a function to calculate the number of matrix rows in advance, but the function would be a little complex. In this example the number of rows in the matrix = ((4 * 3 + 1) + (3 * 3 + 1) + (2 * 3 + 1) + (1 * 3 + 1)) * 4.
Is there an easy and efficient way to create matrices in R without hard-wiring the number of rows in the matrix statement? In other words, is there an easy way to let R simply add a row to a matrix as needed when using for-loops?
I have presented one solution that employs rbind at each pass through the loops, but that seems a little convoluted and I was wondering if there might be a much easier solution.
Sorry if this question is redundant with an earlier question. I could not locate a similar question using the search feature on this site or using an internet search engine today, although I think I have found a similar question somewhere in the past.
Below are 2 sets of example code, one using rbind and the other where I used trial and error to set nrow=136 in advance.
Thanks for any suggestions.
v1 <- 5
v2 <- 2
v3 <- 2
v4 <- (v1-1)
my.matrix <- matrix(0, nrow=136, ncol=(v1+4) )
i = 1
for(a in 1:v2) {
for(b in 1:v3) {
for(c in 1:v4) {
for(d in (c+1):v1) {
if(d == (c+1)) l.s = 4
else l.s = 3
for(e in 1:l.s) {
my.matrix[i,c] = 1
if(d == (c+1)) my.matrix[i,d] = (e-1)
else my.matrix[i,d] = e
my.matrix[i,(v1+1)] = a
my.matrix[i,(v1+2)] = b
my.matrix[i,(v1+3)] = c
my.matrix[i,(v1+4)] = d
i <- i + 1
}
}
}
}
}
my.matrix2 <- matrix(0, nrow=1, ncol=(v1+4) )
my.matrix3 <- matrix(0, nrow=1, ncol=(v1+4) )
i = 1
for(a in 1:v2) {
for(b in 1:v3) {
for(c in 1:v4) {
for(d in (c+1):v1) {
if(d == (c+1)) l.s = 4
else l.s = 3
for(e in 1:l.s) {
my.matrix2[1,c] = 1
if(d == (c+1)) my.matrix2[1,d] = (e-1)
else my.matrix2[1,d] = e
my.matrix2[1,(v1+1)] = a
my.matrix2[1,(v1+2)] = b
my.matrix2[1,(v1+3)] = c
my.matrix2[1,(v1+4)] = d
i <- i+1
if(i == 2) my.matrix3 <- my.matrix2
else my.matrix3 <- rbind(my.matrix3, my.matrix2)
my.matrix2 <- matrix(0, nrow=1, ncol=(v1+4) )
}
}
}
}
}
all.equal(my.matrix, my.matrix3)
If you have some upper bound on the size of the matrix,
you can create a matrix
large enough to hold all the data
my.matrix <- matrix(0, nrow=v1*v2*v3*v4*4, ncol=(v1+4) )
and truncate it at the end.
my.matrix <- my.matrix[1:(i-1),]
This is the generic form to do it. You can adapt it to your problem
matrix <- NULL
for(...){
...
matrix <- rbind(matriz,vector)
}
where vector contains the row elements
I stumbled upon this solution today: convert the matrix to a data.frame. As new rows are needed by the for-loop those rows are automatically added to the data.frame. Then you can convert the data.frame back to a matrix at the end if you want. I am not sure whether this constitutes something similar to iterative use of rbind. Perhaps it becomes very slow with large data.frames. I do not know.
my.data <- matrix(0, ncol = 3, nrow = 2)
my.data <- as.data.frame(my.data)
j <- 1
for(i1 in 0:2) {
for(i2 in 0:2) {
for(i3 in 0:2) {
my.data[j,1] <- i1
my.data[j,2] <- i2
my.data[j,3] <- i3
j <- j + 1
}
}
}
my.data
my.data <- as.matrix(my.data)
dim(my.data)
class(my.data)
EDIT: July 27, 2015
You can also delete the first matrix statement, create an empty data.frame then convert the data.frame to a matrix at the end:
my.data <- data.frame(NULL,NULL,NULL)
j <- 1
for(i1 in 0:2) {
for(i2 in 0:2) {
for(i3 in 0:2) {
my.data[j,1] <- i1
my.data[j,2] <- i2
my.data[j,3] <- i3
j <- j + 1
}
}
}
my.data
my.data <- as.matrix(my.data)
dim(my.data)
class(my.data)

Resources