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 :)
Related
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
}
for (i in 2:100 )
{
count <- 0
for (j in i )
if( (i %% j ) == 0 )
count <- count + 1
if(count == 2 )
print(i)
}
I am trying to print print prime numbers in R. Could any one help me to resolve
Let us look at your code and show what went wrong. It's the inner loop that did not loop at all:
for (i in 2:100 )
{
count <- 0
for (j in 1:i ) # you forgot to provide a vector here
if( i %% j == 0 )
count <- count + 1
if(count == 2)
print(i)
}
The answer above tries to optimise the code some more and is a more efficient solution. For example does it only test odd numbers because even ones clearly aren't prime numbers.
The below code creates the function prime_numbers which returns prime numbers up to an inputted number.
prime_numbers <- function(n) {
if (n >= 2) {
x = seq(2, n)
prime_nums = c()
for (i in seq(2, n)) {
if (any(x == i)) {
prime_nums = c(prime_nums, i)
x = c(x[(x %% i) != 0], i)
}
}
return(prime_nums)
}
else {
stop("Input number should be at least 2.")
}
}
## return the answer to your question
prime_numbers(100)
If you wanted the range 3:100, after running the above code you could run something like this:
a<-prime_numbers(100)
a[a>3]
I hope this helps!
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 am trying to build a matrix model which ends if certain conditions are invoked - however for some reason the break() command isn't working, although stop() does. Unfortunately stop() is not what I need as I need to run the model a number of times.
The first break command in the model works, but I have left it in with dth>100 so that you can see for yourselves
n.steps <- 200
ns <- array(0,c(14,n.steps))
ns[13,1]<-rpois(1,3)
ns[14,1] <- 1
k<-0
for (i in 1:n.steps){
k<-k+1
ns[13,1]<-rpois(1,2)
death<-sample(c(replicate(1000,
sample(c(1,0), prob=c(surv.age.a, 1-surv.age.a), size = 1))),1)
ns[14,k] <- death
if (death == 0) {
dth <- sample(1:100, 1)
if (dth > 100) {
ns[14,k]<-0
print("stop.1")
break()
} else {
while (death == 0) {
if (ns[13, k] > 0) {
rep.vec[i]<-ns[13,k]
ns[13, k] <- ns[13, k] - 1
ns[14,k+1]<-1
print("replace")
} else {
if (ns[13, k] == 0) {
print("stop.2")
ns[14,k+1]<-0
break()
}
}
}
}
}
}
Try this (only showing the relevant portions):
for (i in 1:n.steps){
# ...
break.out.of.for <- FALSE
while (death == 0) {
if (ns[13, k-1] > 0) {
# ...
} else {
if (ns[13, k] == 0) {
# ...
break.out.of.for = TRUE
break
}
}
if (break.out.of.for) {
break
}
}
Using:
mean (x, trim=0.05)
Removes 2.5% from each side of the distribution, which is fine for symmetrical two-tailed data. But if I have one tailed or highly asymmetric data I would like to be able to remove just one side of the distribution. Is there a function for this or do I have write myself a new one? If so, how?
Just create a modified mean.default. First look at mean.default:
mean.default
Then modify it to accept a new argument:
mean.default <-
function (x, trim = 0, na.rm = FALSE, ..., side="both")
{
if (!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
warning("argument is not numeric or logical: returning NA")
return(NA_real_)
}
if (na.rm)
x <- x[!is.na(x)]
if (!is.numeric(trim) || length(trim) != 1L)
stop("'trim' must be numeric of length one")
n <- length(x)
if (trim > 0 && n) {
if (is.complex(x))
stop("trimmed means are not defined for complex data")
if (any(is.na(x)))
return(NA_real_)
if (trim >= 0.5)
return(stats::median(x, na.rm = FALSE))
lo <- if( side=="both" || side=="right" ){ floor(n * trim) + 1 }else{1}
hi <- if( side=="both" || side=="left" ){ n + 1 - (floor(n * trim) + 1 ) }else{ n}
x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
cat(c(length(x), lo , hi) )
}
.Internal(mean(x))
}
I don't know of a function. Something like the following would trim off the upper tail of the distribution before taking the mean.
upper.trim.mean <- function(x,trim) {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])
}
This should account for either side, or both sides for trimming.
trim.side.mean <- function(x, trim, type="both"){
if (type == "both") {
mean(x,trim)}
else if (type == "right") {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])}
else if (type == "left"){
x <- sort(x)
mean(x[max(1,floor(length(x)*trim)):length(x)])}}
one.sided.trim.mean <- function(x, trim, upper=T) {
if(upper) trim = 1-trim
data <- mean(x[x<quantile(x, trim)])
}
I found that all the answers posted do not match when checked manually. So I created one of my own. Its long but simple enough to understand
get_trim <- function(x,trim,type)
{
x <- sort(x)
ans<-0
if (type=="both")
{
for (i in (trim+1):(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-(2*trim)))
}
else if(type=="left")
{
for (i in (trim+1):(length(x)))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
else if (type=="right")
{
for (i in 1:(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
}