I have the following code:
nth <- expression(((1/p)*a0/2)+sum(((1/p)*a*cos(i*pi*x/p)))+sum((1/p)*b*sin(i*pi*x/p)))
nth <- as.expression(gsub('pi',pi,nth))
nth <- as.expression(gsub('p',p,nth))
nth <- as.expression(gsub('a0',a0,nth))
nth <- as.expression(gsub('a',a,nth))
nth <- as.expression(gsub('b',b,nth))
this results to the expression:
"((1/1) * 1.26424111790395/2) + sum(((1/1) * 0.251688909862584 * cos(i * 3.14159265358979 * x/1))) + sum((1/1) * -1.03501509824516e-16 * sin(i * 3.14159265358979 * x/1))"
What I want to do next is to evaluate i with a list (eg. i = 1:3) without evaluating x. So what I want to get is something like:
"((1/1) * 1.26424111790395/2) + sum(((1/1) * 0.251688909862584 * cos(1 * 3.14159265358979 * x/1)), ((1/1) * 0.251688909862584 * cos(2 * 3.14159265358979 * x/1)), ((1/1) * 0.251688909862584 * cos(3 * 3.14159265358979 * x/1))) + sum(((1/1) * 0.251688909862584 * sin(1 * 3.14159265358979 * x/1)), ((1/1) * 0.251688909862584 * sin(2 * 3.14159265358979 * x/1)), ((1/1) * 0.251688909862584 * sin(3 * 3.14159265358979 * x/1)))"
How can I do this? Thanks.
Why not try this. You will see that I wrapped the values you needed in a loop and put all output in a new "finished" dataframe that will be updated as you roll through the loop. You can specify how many i's there are and change the expression as you wish:
# Define the initial variables that might be changed here
var_1 <- 3.14159265358979 # This referred to pi in your initial expression
var_2 <- 1 # This referred to p in your initial expression
var_3 <- 1.26424111790395 # This refers to a0 in your initial expression
var_4 <- 0.251688909862584 # This refers to a in your initial expression
var_5 <- -1.03501509824516e-16 # This refers to b in your initial expression
n <- 3 # This is the number of equations that will be run through
# Create an empty dataframe to hold the outputted expressions
finished = c() # Empty data frame
# Create an array holding values from 1 to the number of n's that will be run through
cycle <- c(1:n)
# Convert cycle to a matrix
cycle <- as.matrix(cycle)
# The variable we will be changing is i ... Create the initial loop
for (i in 1:3 ) {
nth <- expression(((1/p)*a0/2)+sum(((1/p)*a*cos(i*pi*x/p)))+sum((1/p)*b*sin(i*pi*x/p))) # Write the expression to be changed
# Substitute in all the relevant values. Note that this is made to be more explicity
nth <- as.expression(gsub('pi',var_1,nth))
nth <- as.expression(gsub('p',var_2,nth))
nth <- as.expression(gsub('a0',var_3,nth))
nth <- as.expression(gsub('a',var_4,nth))
nth <- as.expression(gsub('b',var_5,nth))
# I will also, for each value, substitue in relevant value from the cycle array
# This will change the i values for you
i_index <- cycle[i,1]
i_index <- as.character(i_index)
nth <- as.expression(gsub('i',i_index,nth)) # Append the nth equation
# I will then bind this solution into the finished data frame to hold all solutions
finished[i] = nth
}
This is the output that was generated after running the code:
expression("((1/1) * 1.26424111790395/2) + sum(((1/1) * 0.251688909862584 * cos(1 * 3.14159265358979 * x/1))) + sum((1/1) * -1.03501509824516e-16 * s1n(1 * 3.14159265358979 * x/1))",
"((1/1) * 1.26424111790395/2) + sum(((1/1) * 0.251688909862584 * cos(2 * 3.14159265358979 * x/1))) + sum((1/1) * -1.03501509824516e-16 * s2n(2 * 3.14159265358979 * x/1))",
"((1/1) * 1.26424111790395/2) + sum(((1/1) * 0.251688909862584 * cos(3 * 3.14159265358979 * x/1))) + sum((1/1) * -1.03501509824516e-16 * s3n(3 * 3.14159265358979 * x/1))")
This should get you going. You were definitely on the right track with gsub.
Notice that j in the original expression is being replaced with 1, 2, and 3, respectively. I went with j because gsub with i interferes with sin and pi. Hope it helps...
> expres <- "(((1/p)*a0/2)+sum(((1/p)*a*cos(j*pi*x/p)))+sum((1/p)*b*sin(j*pi*x/p)))"
> noquote(sapply(1:3, function(j){
GS <- gsub("j", as.numeric(j), expres)
paste0("expression(", GS, ")")
}))
[1] expression((((1/p)*a0/2)+sum(((1/p)*a*cos(1*pi*x/p)))+sum((1/p)*b*sin(1*pi*x/p))))
[2] expression((((1/p)*a0/2)+sum(((1/p)*a*cos(2*pi*x/p)))+sum((1/p)*b*sin(2*pi*x/p))))
[3] expression((((1/p)*a0/2)+sum(((1/p)*a*cos(3*pi*x/p)))+sum((1/p)*b*sin(3*pi*x/p))))
Another possible solution is to use substitute
g = function(i){
env = list(pi=pi, p=1, a0=1.26424111790395, a=0.251688909862584, b=-1.03501509824516e-16, i=i)
as.character(as.expression(substitute(((1/p)*a0/2)+sum(((1/p)*a*cos(i*pi*x/p)))+sum((1/p)*b*sin(i*pi*x/p)), env)))
}
paste(lapply(1:3, g), collapse=", ")
Related
I want to compute the following sequence using R, without loops, i.e. for cycles.
1 + (2/3) + ((2/3)*(4/5)) + ((2/3)*(4/5)*(6/7)) + ... + ((2/3)*(4/5)*...(20/21))
So far, I tried different approaches with a sequence as well as a while function, but could not came up with a suitable solution. Help would be highly appreciated.
We may use cumprod
v1 <- seq(2, 20, by = 2)
v2 <- seq(3, 21, by = 2)
1 + sum(cumprod(v1/v2))
[1] 4.945724
-manual calculation
1 + (2/3) + ((2/3)*(4/5)) + ((2/3)*(4/5)*(6/7)) + ((2/3)*(4/5)*(6/7) * (8/9)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11) * (12/13)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11) * (12/13) * (14/15)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11) * (12/13) * (14/15) * (16/17)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11) * (12/13) * (14/15) * (16/17) * (18/19)) + ((2/3)*(4/5)*(6/7) * (8/9) * (10/11) * (12/13) * (14/15) * (16/17) * (18/19) * (20/21))
[1] 4.945724
Suppose I have the following function and output:
library('pracma')
xlag= c(1,3,5,8,12,16,19,20,22,24)
f1 <- function(beta){
xlag[1]*exp(beta[1] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[2]*exp(beta[1] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[3]*exp(beta[1] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f1,c(1))
[,1]
[1,] 0.8488091
I wrote a few for loops in the function so I can extend the model for any value s.
h <-function(beta){
s = 1:3
xlag= 1:9
n <-c()
for (i in s) {
n[i] <- exp(beta[1] * s[i])
}
sal <-sum(n)
z <-c()
for (i in s) {
z[i] <- xlag[i]*exp(beta[1] * s[i])/sal
}
sum(z)
}
pracma::jacobian(h,c(1))
[,1]
[1,] 0.8488091
Now I would like to write f for xlag[1:3], xlag[4:6] xlag[7:9].
Such that the Jacobian becomes a matrix with 1 column and 3 rows. Where the first entry is the one specified above. And the second entry is:
f2 <- function(beta){
xlag[4]*exp(beta[4] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[5]*exp(beta[5] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[6]*exp(beta[6] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f2,c(1))
[,1]
[1,] 1.697618
The third entry:
f3 <- function(beta){
xlag[7]*exp(beta[4] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[8]*exp(beta[5] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[9]*exp(beta[6] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f3,c(1))
[,1]
[1,] 0.706992
So I would like h to output:
[,1]
[1,] 0.8488091
[2,] 1.697618
[3,] 0.706992
The jacobian function is structured as follow
library('pracma')
jacobian(f, x0, heps = .Machine$double.eps^(1/3), ...)
f: m functions of n variables.
x0: Numeric vector of length n.
heps: This is h in the derivative formula.
jacobian(): Computes the derivative of each function f_j by variable x_i separately, taking the discrete step h.
So I need 3 functions f1,f2,f3 of one variable. Yielding a matrix of 1 column and 3 rows.
Could anyone help me rewrite h such that I get the desired output?
I have found the solution.
h <-function(beta){
s = 1:3
xlag #total set of xlag variables
u =1:(length(xlag)-length(s)) #basis for loop
n <-c()
for (i in s) {
n[i] <- exp(beta[1] * s[i]) #nominator expo almon
}
sal <-sum(n) #denominator expo almon
z <-c()
for (i in s) {
z[i] <- exp(beta[1] * s[i])/sal #expoalmon
}
final <-c()
for (i in u) {
final[i] <- sum(xlag[(i):(i+2)]*z[1:3])
}
final
}
pracma::jacobian(h,c(1))
*
* *
* * *
* * * *
* * * * *
* * * *
* * *
* *
*
This is my code so far, but it throws an error:
Error in " " * (rows - i - 1) : non-numeric argument to binary operator
Calls: pyramid -> print
Execution halted
#R version 3
pyramid<-function(rows){for (i in rows){print(" "*(rows-i-1)+"*"*(i+1))}
for(j in (rows-1|0|-1)){print(" "*(rows-j)+"*"*(j))}}
rows<-5
pyramid(rows)
You can find plenty of (pseudo-code) examples on the net. That should've been your first approach towards solving your problem. SO is not a free code writing service, and you'll get a much more positive response if you demonstrate a genuine attempt at solving the problem yourself.
That aside, here is a "crude" R implementation of a code example I found here. The code can and probably should be "R-ified", and I encourage you to spend some time doing so. I promise that you'll learn a lot. For example, it should be possible to replace most (all?) explicit for loops by making use of vectorised functions.
diamond <- function(max) {
# Upper triangle
space <- max - 1
for (i in 0:(max - 1)) {
for (j in 0:space) cat(" ")
for (j in 0:i) cat("* ")
cat("\n")
space <- space - 1
}
# Lower triangle
space = 1;
for (i in (max - 1):1) {
for (j in 0:space) cat(" ")
for (j in 0:(i - 1)) cat("* ")
cat("\n")
space <- space + 1
}
}
diamond(5)
# *
# * *
# * * *
# * * * *
#* * * * *
# * * * *
# * * *
# * *
# *
Below is a 3*4 matrix, where 2 columns represent the lat/lon coordinates of one location and the other two are coordinates of a second location. I'm trying to apply the great circle distance formula to each row. I'm pretty sure I should use something in the apply family, but can't figure out how.
d=as.data.frame(split(as.data.frame(c( 33.43527 ,-112.01194 , 37.72139 , -122.22111, -3.78444 , -73.30833 , -12.02667 , -77.12278,37.43555,38.88333,40.97667,28.81528)* pi/180),1:4))
colnames(d)=c('lat','lon','lat2','lon2')
This is the equation I would like to be applied to each of the 3 rows:
sum(acos(sin(lat) * sin(lat2) + cos(lat) * cos(lat2) * cos(lon2 -lon)) * 6371)*0.62137
The lat, lon, lat2, lon2 represent the column names in matrix d.
The final vector would look like this:
answer= 645.0978, 626.3632, 591.4725
Any help would be much appreciated.
You can use mapply and provide all 4 columns as parameter to the function as:
An option is to write as:
mapply(function(lat,lon,lat2,lon2)sum(acos(sin(lat) * sin(lat2) +
cos(lat) * cos(lat2) * cos(lon2 -lon)) * 6371)*0.62137,
d[,"lat"],d[,"lon"],d[,"lat2"],d[,"lon2"])
#Result: With updated data
#[1] 645.0978 626.3632 591.4725
We subset the columns of 'd' with [ (as it is a matrix - for data.frame, $ can also work), and then do the arithmetic
(acos(sin(d[,"lat"]) * sin(d[,"lat2"]) +
cos(d[,"lat"]) * cos(d[,"lat2"]) *
cos(d[,"lon2"] -d[,"lon"])) * r)*0.62137
#[1] 3153.471 10892.893 6324.854
This can also be done in a loop with apply
apply(d, 1, function(x) (acos(sin(x[1]) * sin(x[3]) +
cos(x[1]) * cos(x[3]) * cos(x[4] - x[2])) * r)* 0.62137)
#[1] 3153.471 10892.893 6324.854
The with function would allow you to use the expression:
(acos(sin(lat) * sin(lat2) + cos(lat) * cos(lat2) * cos(lon2 -lon)) * 6371)*0.62137
but you would need to transform it the d-matrix to a dataframe:
with(data.frame(d), ( acos( sin(lat) * sin(lat2) +
cos(lat) * cos(lat2) * cos(lon2 -lon) ) * 6371) *
0.62137
)
[1] 3153.471 10892.893 6324.854
The sum should not be used since the +, sin,cos, and acos functions are all vectorized but the sum function is not. I've tried to rearrange the indentation so the terms are easier to recognize.
I wrote a function, which returns a function based on certain properties.
The problem is that I had to use "paste", which makes the returned object a string. Here an example of the returned object:
the_problem <- "beta['v_p'] * 0.1 * ((3.99 * exp(-0.144 * time)) +
(4.78 * exp(-0.0111 * time))) + 0.1 * beta['ktrans_1'] * (3.99 * (exp(-
beta['kep_1']* time) - exp(- 0.144 * time)) * (0.144 -
beta['kep_1'])**(-1) + (4.78 * (exp(- beta['kep_1'] * time)- exp(-
0.0111 * time)) * (0.0111 - beta['kep_1'])**(-1)))"
I would like to manipulate the object "the_problem" to make it usable as function. Something like:
dcemri_func <- function(beta){
return(get.rid.of.string(the_problem))}
I already tried "as.function", but this does not work.
Any ideas?
Thanks and best whishes,
Chris
You could try using eval(parse(text = ..)), i.e.:
the_problem <- paste0('function(beta) ', the_problem)
dcemri_func <- eval(parse(text = the_problem))