I made a loop to generate a Markov Chain. If the proposal does not satisfy a condition, I want to restart the iteration with a new proposal? Is there a way to do this? My current code is shown below for reference. Currently, it sets the current chain's value to the previous one. But I don't want that. I want it to just restart the "i". So if i=2, and the condition in line 4 is not satisfied, I then want it to stay at i=2 until it is satisfied. Thanks in advance.
ABC_MCMC<-function(n){
for (i in 2:n){
prop<-rnorm(1,mean=chain[i-1],sd=1)
if (ABC(prop)==T & prop>=0){
h_ratio<-(dgamma(prop,shape=prior_alpha,rate=prior_beta)/dgamma(chain[i-1],shape=prior_alpha,rate=prior_beta))*
(dnorm(x=chain[i-1],mean=prop,sd=1)/dnorm(x=prop,mean=chain[i-1],sd=1))
u<-runif(1)
if (min(1,h_ratio)>u) {chain[i]=prop} else {chain[i]=chain[i-1]}
}
else{chain[i]=chain[i-1]}
}
return(chain<<-chain)
}
This is more of a comment than of an answer but to keep the code formatting I'm posting as an answer.
Replace the code inside the for loop for the code below.
while(TRUE) {
prop <- rnorm(1, mean = chain[i - 1L], sd = 1)
if (ABC(prop) && prop >= 0) {
h_ratio<-(dgamma(prop,shape=prior_alpha,rate=prior_beta)/dgamma(chain[i-1],shape=prior_alpha,rate=prior_beta))*
(dnorm(x=chain[i-1],mean=prop,sd=1)/dnorm(x=prop,mean=chain[i-1],sd=1))
u<-runif(1)
if (min(1,h_ratio)>u) {chain[i]=prop} else {chain[i]=chain[i-1]}
break
} else {chain[i] <- chain[i-1]}
}
Edit
The function below seems to be what is asked for.
ABC_MCMC <- function(n){
for (i in 2:n){
# loops until condition (ABC(prop) & prop >= 0) is met
while(TRUE) {
prop <- rnorm(1, mean = chain[i-1], sd = 1)
if (ABC(prop) & prop >= 0) {
h_ratio <- (dgamma(prop, shape = prior_alpha, rate = prior_beta)/dgamma(chain[i - 1L], shape = prior_alpha, rate = prior_beta)) *
(dnorm(chain[i - 1L], prop, 1)/dnorm(prop, chain[i - 1L], 1))
u <- runif(1)
if (min(1, h_ratio) > u) {
chain[i] <- prop
} else {
chain[i] <- chain[i - 1L]
}
break
}
}
}
# function return value
chain
}
IS <- function(N,K,sigma,t,r,S_0,a,b,tol){
funct_1 <- function(x){
return((S_0*(exp(-0.5*(sigma^2)*t+sigma*sqrt(t)*x))*(sigma*sqrt(t)-x))+
(exp(-r*t))*K*x)
}
bisection_method <- function(a, b, tol, f = funct_1){
if (f(a)*f(b) > 0){
print("No root found.")
} else
while ((b - a)/2.0 > tol){
midpt= (a + b)/2.0
if (f(midpt) == 0){
return(midpt)
} else if (f(a)*f(midpt) < 0){
b = midpt
} else
a = midpt
}
return(midpt)
}
}
The above function will produce nothing for you. My goal that to input the values of "N,K,sigma,t,r,S_0, a,b" and somehow return "midpt" for me. I have searched a lot but could not come up with anything that makes sense. I have many problems, assume that I input everything things, then how the function "funct_1" will output expression, this expression needs to be recalled to the next function "bisection_method} along with the value of a and b then finally obtain the "midpt" value. Any suggestions are really appreciated. Please let me know if there is anything not clear to you at all.
Your main function doesn't return anything. It just creates the auxiliary functions and then do nothing. That's why you're getting no output.
Try returning the bisection method with appropriate parameters in your main function instead. I also edited so you get NULL output when no root is found.
IS <- function(N,K,sigma,t,r,S_0,a,b,tol){
funct_1 <- function(x){
return((S_0*(exp(-0.5*(sigma^2)*t+sigma*sqrt(t)*x))*(sigma*sqrt(t)-x))+
(exp(-r*t))*K*x)
}
bisection_method <- function(a, b, tol, f = funct_1){
if (f(a)*f(b) > 0){
print("No root found."); return(NULL)
} else
while ((b - a)/2.0 > tol){
midpt= (a + b)/2.0
if (f(midpt) == 0){
return(midpt)
} else if (f(a)*f(midpt) < 0){
b = midpt
} else
a = midpt
}
return(midpt)
}
return(bisection_method(a,b,tol,funct_1))
}
Figured out some parameter combination that makes sense:
IS(1,1,1,4,5,1,.1,9,10^-4)
[1] 2.000023
I was asked to implement function that calculates n-dimensional matrix determinant using Laplace expansion. This involves recursion. I developed this:
minor<-function(A,i,j) {
return(A[c(1:(i-1),(i+1):dim(A)[1]),c(1:(j-1),(j+1):dim(A)[2])])
}
determinantRec<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1) return(X[1][1])
else {
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k][i]*(-1)^(k+i)*determinantRec(minor(X,k,i),k)
}
return(s)
}
}
where k in determinantRec(X,k) function indicates which row I want to use Laplace expansion along of.
My problem is when I run determinantRec(matrix(c(1,2,3,4),nrow = 2,ncol = 2),1) this error appears:
C stack usage 7970628 is too close to the limit
What is wrong with my code?
#julia, there is one simple type in your code. Just remove the '*' at the end of the definition of 's'. And don't indent the recursion.
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)
determinantRek(X[-k,-i],k)
}
return(s)
}
I did this way and works just fine, although it is super slow, compared to the det function in base R
laplace_expansion <- function(mat){
det1 <- function(mat){
mat[1]*mat[4]-mat[2]*mat[3]
}
determinant <- 0
for(j in 1:ncol(mat)){
mat1 <- mat[-1,-j]
if(nrow(mat1) == 2){
determinant <- determinant+mat[1,j]*(-1)^(1+j)*det1(mat1)
}else{
val <- mat[1,j]*(-1)^(1+j)
if(val != 0){
determinant <- determinant+val*laplace_expansion(mat1)
}
}
}
return(determinant)
}
This is my approach, I think it's cleaner.
deter <- function(X) {
stopifnot(is.matrix(X))
stopifnot(identical(ncol(X), nrow(X)))
if (all(dim(X) == c(1, 1))) return(as.numeric(X))
i <- 1:nrow(X)
out <- purrr::map_dbl(i, function(i){
X[i, 1] * (-1)^(i + 1) * deter(X[-i, -1, drop = FALSE])
})
return(sum(out))
}
Thank you #ArtemSokolov and #MrFlick for pointing the problem cause, it was it. I also discovered that this code does not calculate properly the determinant of 2x2 matrix. After all it looks like that:
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)*
determinantRek(X[-k,-i],k)
}
return(s)
}
Debuging with browser() was also helpful :)
I am having a very odd problem in R. The question was to make a function for global and semi global allignment. Appropriate algorithms were made which are able to "print out" the correct allignment. However "returning" the alginment seems to be a problem for the semi global algorithm.
Below are the functions for both alignments which both contain two functions: one computing the score matrix and the other outputs the alignment. As you can see, the output function for semi global was inspired by the global one but although it is able to print out values A and B, when returning A and B a value NULL is returned.
It came to my attention that when making defining A and B, they also contain a NULL part which seen by printing the structures of A and B at the end. This is also the case in the global alignment but does not seem to be a problem here.
Global Alignment Algorithm
########### GLOBAL ALLIGNMENT ALGORITHM ############
GA_score = function(v,w,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=(length(v)+1),ncol = (length(w)+1) )
S[1,1] = 0
for(j in 2:dim(S)[2]){
S[1,j] = score.gap*(j-1)
}
for(i in 2:dim(S)[1]){
S[i,1] = score.gap*(i-1)
for(j in 2:dim(S)[2]){
if(v[i-1]==w[j-1]){diag = S[i-1,j-1] + score.match} else {diag = S[i-1,j-1] + score.mismatch}
down = S[i-1,j] + score.gap
right = S[i,j-1] + score.gap
S[i,j] = max(diag,down,right)
}
}
return(S)
}
GA_output = function(v,w,S,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
GA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
return(list(v=A,w=B))
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
else if (S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
GA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
else {
A.temp = c("-",A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return( GA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
Semi-Global Alignment Algorithm
########### SEMI GLOBAL ALLIGNMENT ALGORITHM ############
SGA_score = function(sequence1,sequence2,score.gap=-1,score.match=1,score.mismatch=-1){
v=sequence2
w=sequence1
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=length(v)+1,ncol=length(w)+1)
for(i in 1:(length(w)+1)){
for( j in 1:(length(v)+1)){
if (i==1|j==1){S[i,j]=0}
else{
if((i==length(w)+1) | (j==length(v)+1)){
from.top = S[i,j-1]
from.left = S[i-1,j]
}
else{
from.top = max(S[i,j-1]+score.gap) # Max is artifact from max(0,... )
from.left = max(S[i-1,j]+score.gap)
}
if(w[i-1] == v[j-1]){
from.diag = S[i-1,j-1]+score.match
}
else{
from.diag = S[i-1,j-1]+score.mismatch
}
S[i,j] = max(from.top,from.left,from.diag)
}
}
}
return(S)
}
SGA_output = function(v,w,S,score.gap=-1,score.match=1,score.mismatch=-1){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
print(str(A))
print(str(B))
SGA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
print(A)
print(B)
out = list(v=A,w=B)
#print(out)
print(str(A))
print(str(B))
print(str(out))
return(out)
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
SGA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
#####
if ( j==length(w)+1) { # Are we in last row?
score.temp = score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
score.gap = score.temp
SGA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
score.gap=score.temp
####
if(i==length(v)+1){
score.temp=score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i,j-1] + score.gap)){
A.temp = c("-",A)
B.temp = c(w[j-1],B)
score.gap=score.temp
SGA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return(SGA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
S1 = SGA_score("ACGTCAT","TCATGCA")
S1
align = SGA_output("ACGTCAT","TCATGCA",S1)
align
I am surpised that the global alignment works but the semi global one doesn't, even tough they both have this NULL part (can someone maybe explain what this is? Has it something to do with internal objects in a function?) and the semi global knows what A and B is.
Any help is greatly appreciated!
SGA_rec seems to be missing a return value. You need an else {return(<something>)) after the last if.
Illustration:
fun <- function() if (FALSE) 1
x <- fun()
x
#NULL
Read help("NULL") to learn what it means.