together with you, I have recently made the following function (the content is not important right now). It seems to be correct but when I try to process it, the following error turns up: Error: unexpected '}' in " }". Do you know what I´ve made wrong?
Here´s the function, thank you in advance (btw I have checked every bracket):
Edit: Now it works:
CI <- function(x, s, z, Fall) {
if (Fall == "Fall1") {
result <- mean(x) + c(-1,1)* qnorm(1-z/2)*(s/sqrt(length(x)))
} else if (Fall == "Fall2") {
result <- mean(x) + c(-1,1)* qt(p=1-a/2, df=length(x)- 1)*(sd(x)/sqrt(length(x)))
} else if (Fall == "Fall3") {
result <-mean(x)+c(-1,1)qnorm(1-z/2(s/sqrt(length(x))))
} else if (Fall == "Fall4"){
result <- mean(x)+c(-1,1)qt(p=1-a/2, df=length(x)-1)(sd(x)/sqrt(length(x)))
} else {result<-NA}
return(result)
}
CI(x=x, s=15, z=0.05, Fall="Fall1")
There are couple of errors - 1) else would not have a condition check, instead use else if, 2), the values to compare should be quoted "Fall1"
CI <- function(x, mean, sd, z, Fall)
{
if (Fall == "Fall1") {
result <- mean(x) + c(-1, 1) * qnorm(1 - z / 2) * (sd / sqrt(length(x)))
} else if (Fall == "Fall2") {
result <-
mean(x) + c(-1, 1) * qt(p = 1 - a / 2, df = length(x) - 1) * (sd(x) / sqrt(length(x)))
} else if (Fall == "Fall3") {
result <- mean(x) + c(-1, 1) * qnorm(1 - z / 2 *
(sd / sqrt(length(x))))
} else if (Fall == "Fall4") {
result <-
mean(x) + c(-1, 1) * qt(p = 1 - a / 2, df = length(x) - 1) * (sd(x) / sqrt(length(x)))
}
else {
result <- NA_real_
}
return(result)
}
Related
Is it possible to change an if-else statement to include OR in an R-Script? Like 70% of the time would turn into this, while the remaining 30% would turn into something else. Similar to increasing the probability to change?
if (w0[i, j] == 1) { w1[i, j] <- rL[nNeigh + 1]
} else { w1[i, j] <- rD[nNeigh + 1] }
This is the statement where the result is deterministic, but I want to change it into a probabilistic function.
if (w0[i, j] == 1) { w1[i, j] <- rL[nNeigh + 1] || w1[i, j] <- rL[nNeigh]
} else { w1[i, j] <- rD[nNeigh + 1] || w1[i, j] <- rL[nNeigh] }
I know this is not the right way to even do it, but I'm at a loss
Just a quick idea:
coin <- rbinom(1, 1, 0.3)
if (w0[i, j] == 1) {
w1[i, j] <- coin * rL[nNeigh + 1] + (1 - coin) * rL[nNeigh]
} else {
w1[i, j] <- coin * rD[nNeigh + 1] + (1 - coin) * rL[nNeigh]
}
It's not clear what the larger context of the question is. However note that Martin Gal's useful answer can be simplified:
coin <- rbinom(1, 1, 0.3)
if (w0[i, j] == 1) {
w1[i, j] <- rL[nNeigh + coin]
} else {
w1[i, j] <- rD[nNeigh + coin]
}
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
}
I have defined multiple different functions, each containing one equation each, like so:
catalanFormula <- function(n){
return( (factorial(2 * n)) / ((factorial(n + 1)) * factorial(n)) )
}
triangularFormula <- function(n){
return( (n * (n+1)) / 2 )
}
I am then plotting each function using the plot() function from base R. What I want to do is be able to include the equation in my plot as a label or text, but in a way that is easily understandable. I know I can use LaTeX to write each equation manually, but I was wondering if there is a package or method anyone knows of that can deparse a mathematical equation in R and turn it into a standard readable mathematical equation. The only math occurring is factorials, multiplication, division, exponents, addition, and subtraction.
For example, I want to convert
(factorial(2 * n)) / ((factorial(n + 1)) * factorial(n))
into something that looks like this.
Then, be able to use the output within the text() function of base R plotting.
With the Ryacas package you can transform a math expression to its corresponding LaTeX code. But the factorial must be given as !:
library(Ryacas)
eq <- yac_symbol("(2 * n)! / ((n + 1)! * n!)")
tex(eq)
# "\\frac{\\left( 2 n\\right) !}{\\left( n + 1\\right) ! n!}"
Another possibility is to call Python from R and use the pytexit library:
from pytexit import py2tex
py2tex("math.factorial(2 * n) / ((factorial(n + 1)) * factorial(n))")
# $$\frac{\operatorname{factorial}\left(2n\right)}{\operatorname{factorial}\left(n+1\right) \operatorname{factorial}\left(n\right)}$$
You can also take a look at PyLaTeX and lax.
Here's a base R function that will walk the abstract syntax tree to replace the factorial and / functions with the corresponding ?plotmath markup so you can add them to R plots.
returnToPlotmath <- function(fun) {
swap <- function(x) {
if (class(x) %in% c("call","(")) {
x <- as.list(x)
if (as.character(x[[1]])=="/") {
x[[1]] = quote(frac)
x[[2]] = swap(x[[2]])
x[[3]] = swap(x[[3]])
} else if (as.character(x[[1]])=="factorial") {
x[[1]] = quote(`*`)
if (is.call(x[[2]])) {
x[[2]] = as.call(list(quote(`(`), x[[2]]))
} else {
x[[2]] = swap(x[[2]])
}
x[[3]] = "!"
} else if (as.character(x[[1]])=="*") {
if(is.call(x[[2]]) | is.call(x[[3]])) {
x[[1]] = quote(`%.%`)
x[[2]] = swap(x[[2]])
x[[3]] = swap(x[[3]])
}
} else {
x[[2]] = swap(x[[2]])
if (length(x)==3) x[[3]] = swap(x[[3]])
}
return(as.call(x))
} else {
return(x)
}
}
body_exprs <- body(fun)[[2]]
swap(body_exprs[[length(body_exprs)]])
}
This does assume that the return is the last statement in the function body {} block. You can get the expression with
returnToPlotmath(catalanFormula)
# frac(((2 * n) * "!"), (((n + 1) * "!") %.% (n * "!")))
returnToPlotmath(triangularFormula)
# frac((n %.% (n + 1)), 2)
And you can add them to plot titles and such
plot(main=returnToPlotmath(catalanFormula), 1, 1)
plot(main=returnToPlotmath(triangularFormula), 1, 1)
This solution is highly specific to the functions you need to transform. But it could be extended if needed.
The expr2latex() function from simsalapar parses expressions to LaTeX, and can be extended to include the factorial symbol with a minor addition to the code:
expr2latex2 <- function(expr) {
L <- length(expr)
c.BinTable <- simsalapar:::c.BinTable
if(!L) "" else {
Symb <- is.symbol(expr)
F <- if(Symb) expr else expr[[1]]
cF <- simsalapar:::mDeparse(F)
FF <- simsalapar:::renderAtom(F, Len=L, d.a = cF)
if(Symb && L != 1)
stop("is.symbol(.), but length(.) = ", L, " != 1")
else if(!Symb && typeof(expr) != "language" && L != 1)
stop("is not language nor symbol), but length(.) = ", L, " != 1")
switch(L,
## length 1:
FF,
{ ## length 2: e.g. "- 1", "+ x", "!TRUE", "~ ff",
#browser()
rhs <- expr2latex2(expr[[2]])
if (cF == "bold") paste0("\\mathbf{", rhs, "}")
else if(cF == "italic") paste0("\\mathit{", rhs, "}")
else if(cF == "factorial") paste0("(",rhs,")!") #extra case added in for factorial
else if(!simsalapar:::isOp(cF)) # not a binary operator ==> "function call":
paste0(FF,"(",rhs,")") ## e.g. "O(n)"
else if(cF == "{") paste0("{", rhs, "}")
else if(cF == "(") paste0("(", rhs, ")")
else paste(FF, rhs)
},
{ ## length 3:
lhs <- expr2latex2(expr[[2]])
rhs <- expr2latex2(expr[[3]])
if(cF == "[") ## subscript
paste0(lhs, "_{", rhs, "}")
else if(cF == "~") ## space
paste(lhs, "\\", rhs)
## not treated, as plotmath() does neither :
## else if(cF == "[[")
## paste0(lhs, "[[", rhs, "]]")
else if(cF %in% c.BinTable)
paste(lhs, simsalapar:::getTab(cF, simsalapar:::BinTable), rhs)
else if(cF %in% c.RelTable)
paste(lhs, simsalapar:::getTab(cF, simsalapar:::RelTable), rhs)
else if(simsalapar:::isOp(cF)) ## e.g. U + x
paste(lhs, FF, rhs)
else ## log(x, 2)
paste0(FF, "(", lhs, ",", rhs, ")")
},
## length >=4 : F(a, b, c, ...)
stop("length(expr) = ",L," (>= 4); not yet implemented") # TODO MM
)## end{switch}
}
}
original function
expr2latex( quote( (factorial(2 * n)) / ((factorial(n + 1)) * factorial(n)) ) )
#[1] "(factorial(2 n)) / ((factorial(n + 1)) factorial(n))"
revised treatment of factorials
expr2latex2( quote( (factorial(2 * n)) / ((factorial(n + 1)) * factorial(n)) ) )
#[1] "((2 n)!) / (((n + 1)!) (n)!)"
I was hoping to automate the following process but have been unable to find a solution. The aim is to use vectors height and area to update each if equation in the function. The function would then use depth (x) to convert to volume.
The equation for each if statement would use the following syntax:
for (i in 2:length(height) {
(x >= height[i - 1] &&
x <= height[i]) {
(((area[i] - area[i - 1]) * (x - height[i - 1]) /
(height[i] - height[i - 1]) + area[i - 1]) * x)
}
Manual method:
height <- c(0.01, seq(0.05, 0.5, by = 0.05))
area <- c(8, 210, 300, 350, 400, 440, 470, 500, 535, 570, 610)
# Height values
Hmin <- min(height)
Hmax <- max(height)
for(i in 2:(length(height) - 1)) {
assign(paste0("H", i-1), height[i])
}
# Area values
Amin <- min(area)
Amax <- max(area)
for(i in 2:(length(area) - 1)) {
assign(paste0("A", i-1), area[i])
}
volume.fn <- function(x) {
if (x < Hmin) { # if less than min height value
x <- 0 # x <- 0
} else if (x >= Hmin && # if between min height and next height value
x <= H1) {
(((A1 - Amin) * (x - Hmin) / (H1 - Hmin) + Amin) * x) # apply this linear interpolation equation to depth column (x)
} else if (x >= H1 && # if x between height1 and height 2
x <= H2) {
(((A2 - A1) * (x - H1) / (H2 - H1) + A1) * x) # apply this linear interpolation equation to depth column (x)
} else if (x >= H2 &&
x <= H3) {
(((A3 - A2) * (x - H2) / (H3 - H2) + A2) * x)
} else if (x >= H3 &&
x <= H4) {
(((A4 - A3) * (x - H3) / (H4 - H3) + A3) * x)
} else if (x >= H4 &&
x <= H5) {
(((A5 - A4) * (x - H4) / (H5 - H4) + A4) * x)
} else if (x >= H5 &&
x <= H6) {
(((A6 - A5) * (x - H5) / (H6 - H5) + A5) * x)
} else if (x >= H6 &&
x <= H7) {
(((A7 - A6) * (x - H6) / (H7 - H6) + A6) * x)
} else if (x >= H7 &&
x <= H8) {
(((A8 - A7) * (x - H7) / (H8 - H7) + A7) * x)
} else if (x >= H8 &&
x <= H9) {
(((A9 - A8) * (x - H8) / (H9 - H8) + A8) * x)
} else if (x >= H9 &&
x <= Hmax) {
(((Amax - A9) * (x - H9) / (Hmax - H9) + A9) * x)
} else {
NA
}
}
Using findInterval you could do:
volume.fn1 <- function(x, height, area) {
volume <- if (x < min(height)) {
0
} else if (x > max(height)) {
NA
} else {
i <- findInterval(x, height, rightmost.closed = TRUE) + 1
((area[i] - area[i - 1]) * (x - height[i - 1]) /
(height[i] - height[i - 1]) + area[i - 1]) * x
}
return(volume)
}
volume.fn(.32)
#> [1] 154.24
volume.fn1(.32, height, area)
#> [1] 154.24
volume.fn(.48)
#> [1] 285.12
volume.fn1(.48, height, area)
#> [1] 285.12
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 :)