myfnS <- function(S,T,pH,D,f,r,I0) {
f1 <- 0.78*sqrt(S/35)*exp(T/26)
f2 <- 42*exp(T/17)
alpha <- 0.106*((f1*f^2)/(f1^2 + f^2))*exp((pH - 8)/0.56) + 0.52*(1 + T/43)*(S/35)*((f2*f^2)/(f2^2 + f^2))*exp(-D/6) + 0.00049*f^2*exp(-(T/27 + D/16))
TLsph <- (20*log(r*1000, base = 10))
I <- I0 - TLsph - ((alpha)*r)
return(I)
}
I'm trying to plug in I, to get a value for r but I'm not sure how to do that.
values for other things remain fixed;
for example for (I=50, S=34, T=10.5, pH-8.1, D=0.0395, f=10.3, I0=192) - how do i find the value of r?
In R there's no way that I know of to run a function in reverse. However, you could use something similar to Newton's method to zero in on a value of r that gives you an I of 50.
First though, the function needs to be cleaned up. Using T as an argument is a problem since that's also short for TRUE, so I changed it to tt. I also added in * operators where implied before.
myfnS <- function(S,tt,pH,D,f,r,I0) {
f1 <- 0.78*sqrt(S/35)*exp(tt/26)
f2 <- 42*exp(tt/17)
alpha <- 0.106*((f1*f^2)/(f1^2 + f^2))*exp((pH - 8)/0.56) +
0.52*(1 + (tt)/43)*(S/35)*((f2*f^2)/(f2^2 + f^2))*exp(-D/6) +
0.00049*f^2*exp(-(tt/27 + D/16))
TLsph <- (20*log(r*1000, base = 10))
I <- I0 - TLsph - ((alpha)*r)
return(I) }
Then a way to iterate through values of r to get closer to an I of 50. As r goes up, I goes down. Once a value for r is found that gets within 1 of 50, r is returned. This threshold can be adjusted to get a more precise guess.
iterateR <- function(I=50, r=1){
if (abs(I - myfnS(r, S=34, tt=10.5, pH=8.1, D=0.0395, f=10.3, I0=192)) < 1) {
return(r)
}
else if(I - myfnS(r, S=34, tt=10.5, pH=8.1, D=0.0395, f=10.3, I0=192) > 1) {
iterateR(r=r-1)
}
else if(I - myfnS(r, S=34, tt=10.5, pH=8.1, D=0.0395, f=10.3, I0=192) < 1) {
iterateR(r=r+1)
}
}
iterateR(I=50, r=1)
#> 47
myfnS(r=47, S=34, tt=10.5, pH=8.1, D=0.0395, f=10.3, I0=192)
#> 50.8514607488626
An r of 47 gives an I of 50.85
Related
I am new to R (I only started learning a few weeks ago) and I need some help with a question on my homework. I have asked my professor several times already and mostly that's resulted in me being more confused.
The question is as follows:
Recall that the Taylor expansion of log(1+x) is:
log(x+1) = sum((-1)^(i+1)*x^i/i)
How many terms do you need to get within 10^(−6) of the correct solution when x = 0.99?
My professor gave me some hints:
n should not be equal to length of x. n should be figured out from the loop. It is the iteration number of the last loop.
the condition of the while loop should depend on the difference between the approximated value and the true value of the function. Not on n any more.
in each iteration, you need to calculate (-1)^(i+1)*x^2/i and add it to the sum of the previous iterations so that you accumulate the sum. Check the example about factorial function in class.
You should include your while loop in a function. The function should have a single argument x.
I'm not asking for anyone to give me the answer, but I would appreciate any help or advice. Thank you!
Below is some code of what I've tried. It is incomplete still and I'm not sure what is missing:
taylorexp <- function(x){
i = 1
approximation = 1
while((log(1+x) - approximation) > 10^(-6)){
z=sum((-1)^(i+1)*x^i/i)
i=i+1
}
return(i)
}
taylorexp(0.99)
Here is an example with repeat
s <- 0
i <- 1
x <- 0.99
repeat{
if (abs(log(1 + x) - s) <= 1e-6) break
s <- s + (-1)**(i + 1) * x**i / i
i <- i + 1
}
or with while
s <- 0
i <- 1
x <- 0.99
while(abs(log(1 + x) - s) > 1e-6) {
s <- s + (-1)**(i + 1) * x**i / i
i <- i + 1
}
and we will get
> i
[1] 661
Update
You can wrap all the required information in a list as the output of function taylorexp, e.g.,
taylorexp <- function(x, tol) {
s <- 0
i <- 1
while (abs(log(1 + x) - s) > tol) {
s <- s + (-1)**(i + 1) * x**i / i
i <- i + 1
}
list(approx = s, err = log(1 + x) - s, n = i)
}
such that
> taylorexp(0.99,1e-6)
$approx
[1] 0.6881336
$err
[1] 9.911419e-07
$n
[1] 661
> taylorexp(0.99,1e-7)
$approx
[1] 0.6881345
$err
[1] 9.966883e-08
$n
[1] 863
Answer Update:
taylor = function(x,n){
out = 0
for(i in 1:n){
out = out + ((-1)^(i+1))*(x^i/i)
}
out
}
true_val = log(1 + 0.99)
true_val
approx_val = taylor(0.99, 10)
approx_val
How can I set a loop to run to a maximum value (Dend)?
I just want to see how fast and deep it will grow but I want to set a maximum to say that it can't grow beyond Dend.
I get an error stating
In if (D == Dend) { :
the condition has length > 1 and only the first element will be used
Code
D0 <- 0
Dend <- 4200
r <- 5 growth rate
days <- 1000
n_steps <- days*1
D <- rep(NA, n_steps+1)
D <- D0
for (time in seq_len(n_steps)){
if (D == Dend){
break} else
D[time + 1] <- r + D[time]
}
D
plot(-D, las=1)
If you want a for loop, it might be something like below
for (time in seq_len(n_steps)){
if (tail(D,1) >= Dend) break
D[time + 1] <- r + D[time]
}
I think what you want can be achieved with seq without any loops :
D <- seq(D0, Dend, r)
If you have to use for loop you can use :
for (time in seq_len(n_steps)){
temp <- r + D[time]
if (temp >= Dend) break
D[time + 1] <- temp
}
We can also use a while loop :
i <- 1
while(TRUE) {
temp <- r + D[i]
if(temp > Dend) break
i <- i + 1
D[i] <- temp
}
I have an exercise that compares efficiency of loop functions.
I have function
banana <- function(x)
{d <- length(x)
xi <- x[1:(d-1)]
xnext <- x[2:d]
sum <- sum(100*(xnext-xi^2)^2 + (xi-1)^2)
y <- sum
return(y)
}
I want to re-write the above using a for loop (or any loop). I have so far
for (i in x){
n = length(x)
y <- 100*(x[i+1]-x[i]^2)^2 +(x[i]-1)^2
}
I want the function to stop at n-1 and having difficulty knowing where to add the break. Can someone help?
Thanks in advance,
Sean
You don't really have to add a break statement, you can just loop over all but the nth i.
[-length(x)] removes the last element from the sequence.
y <- 0
for (i in seq_along(x)[-length(x)]) {
y <- y + 100 * (x[i + 1] - x[i])^2 + (x[i] - 1)^2
}
I'm new to R, and I'm trying to code a function which requires it only chooses values in a certain interval, so I have decided to go with k=1 if it lies in [lower, upper] and 0 if it lies elsewhere (where lower and upper have been defined earlier in the function. However, when I try to assign values to the function, it always comes back with this
myfun(10,0.5,0.05)
#Error in k[i] <- function(p) ifelse(p >= lower & p <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
I don't really know what this means, I've tried finding an answer, but most pages just say how to fix their particular problem rather than saying what it actually means. Maybe I haven't been looking hard enough, and I apologise if I haven't, but any help would be greatly appreciated. Here is the full function, if it would help:
myfun <- function(a, q, m) {
k <- rep(0,a+1)
bin.prob <- rep(0,a+1)
for (i in 1:(a+1)) {
x <- i-1
qhat <- x/a
z <- qnorm(1-m/2)
upper <- qhat+(z*sqrt(qhat*(1-qhat)*(a^-1)))
lower <- qhat-(z*sqrt(qhat*(1-qhat)*(a^-1)))
k[i] <- function(q) ifelse(q>=lower & q<=upper, 1, 0)
bin.prob[i] <- dbinom(x,a,q)
}
C <- sum(k*bin.prob)
return(C)
}
myfun(10,0.5,0.05)
#Error in k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
NEW PROBLEM
Hey, I'm encountering a new problem when trying to adjust this function when trying to adjust the data set, i.e a becomes a+4 and x becomes x+2
> myfun2 <- function(a,q,m) {
+ fn <- function(a) a+4
+ abar <- fn(a)
+ kadj <- rep(0,abar+1)
+ bin.prob.adj <- rep(0,abar+1)
+ for (j in 1:(abar+1)) {
+ x <- j-1
+ fx <- function(x) x+2
+ xbar <- fx(x)
+ qhatadj <- xbar/abar
+ z <- (1-(m/2))
+ upperadj <- qhatadj+(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ loweradj <- qhatadj-(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ kadj[j] <- q>=loweradj & q<=upperadj
+ bin.prob.adj[j] <- dbinom(xbar,abar,q)
+ }
+ D <- sum(kadj*bin.prob.adj)
+ return(D)
+ }
> myfun2(10,0.5,0.05)
[1] NA
Warning messages:
1: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
2: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
3: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
4: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
I've been trying to find an answer as to why this has arised, and have found that the NaNs warning could mean there is a negative square root? However I can't see why that would have arisen. It may be bad coding on my part, or could be something else entirely (I'm new to R). Thanks for any help.
As the error message suggests, the problem starts at the line:
k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0)
In the line above you are assigning a function function(q) ifelse(q >= lower & q <= upper, 1, 0) to each element of the vector k, when you really want to be assigning the result of evaluating this function on the scalar q given as an argument to the original function. Note also that the closure function(q) has an environment separate from that of the function in which it is defined. It must be explicitly called with an argument in order for it to evaluate. Hence, when you hit the line:
C <- sum(k * bin.prob)
R tries to multiply the function function(q) itself by bin.prob, throwing an error, when what you want to be doing is multiplying the result of evaluating function(q) for the scalar q defined in the arguments to the original function. In this case, there appears to be no need for you to define function(q) at all. The assignment can be replaced with:
k[i] <- ifelse(q >= lower & q <= upper, 1, 0)
Since R coerces logical vectors to numeric vectors where necessary, treating TRUE as 1 and FALSE as 0, the above assigment can be expressed more succinctly as:
k[i] <- q >= lower & q <= upper
I'm trying to get solution of cubic equations analytically in R, not numerically.
I looked up on the internet and get the formula for cubic roots and wrote the following code:
The link is: http://www.math.vanderbilt.edu/~schectex/courses/cubic/
cub <- function(a,b,c,d) {
p <- -b/3/a
q <- p^3 + (b*c-3*a*(d))/(6*a^2)
r <- c/3/a
x <- (q+(q^2+(r-p^2)^3)^0.5)^(1/3)+(q-(q^2+(r-p^2)^3)^0.5)^(1/3)+p
x
}
However this function doesn't work in most cases and I guess it's because of the power of negative numbers inside the formula, for example I noticed R cannot get the real root of (-8)^(1/3) which is -2. But Im not sure how I could fix my code so that it can be used to solve for exact cubic solutions in general.
Thanks.
I'd use polyroot(). See here for more details.
polyroot(z = c(8,0,0,1))
# [1] 1+1.732051i -2+0.000000i 1-1.732051i
Try this:
# calcaulate -8 as a complex number
z <- as.complex(-8) # or z <- -8 + 0i
# find all three cube roots
zroot3 <- z^(1/3) * exp(2*c(0:2)*1i*pi/3)
zroot3
## [1] 1+1.732051i -2+0.000000i 1-1.732051i
# check that all three cube roots cube to original
zroot3^3
## [1] -8+0i -8+0i -8-0i
If you only want the real root then here is another option:
> x <- c( -8,8 )
> sign(x) * abs(x)^(1/3)
[1] -2 2
Or you may be interested in the Ryacas package or the polynom package for other options.
Here is a function to compute all the analytical solutions: 'cubsol' . Any comments would be most welcome. One question - at the moment the code searches rather inefficiently for which the real solution is amongst the three complex ones produced by ... s2 = cuberoot(q-s0^0.5); xtemp[1:3] <- s1+ s2 +p; Is there a more efficient way of knowing which one it would be before calculating it?
# - - - - - - - - - - - - - - - - - - - -
# Return all the complex cube roots of a number
cuberoot <- function(x){
return( as.complex(x)^(1/3)*exp(c(0,2,4)*1i*pi/3) );
}
# - - - - - - - - - - - - - - - - - - - -
# cubsol solves analytically the cubic equation and
# returns a list whose first element is the real roots and the
# second element the complex roots.
# test with :
#a = -1; b=-10; c=0; d=50; x=0.01*(-1000:1500); plot(x,a*x^3+b*x^2+c*x+d,t='l'); abline(h=0)
# coefs = c(a,b,c,d)
cubsol <- function(coeffs) {
if (!(length(coeffs) == 4)){
stop('Please provide cubsol with a 4-vector of coefficients')
}
a = coeffs[1]; b=coeffs[2]; c=coeffs[3]; d=coeffs[4];
rts = list();
p <- -b/3/a
q <- p^3 + (b*c-3*a*(d))/(6*a^2)
r <- c/3/a
s0 = q^2+(r-p^2)^3;
xtemp = as.complex(rep(0,9));
if (s0 >= 0){ nReRts=1; } else {nReRts=3; }
# Now find all the roots in complex space:
s0 = as.complex(s0);
s1 = cuberoot(q+s0^0.5)
s2 = cuberoot(q-s0^0.5);
xtemp[1:3] <- s1+ s2 +p; # I think this is meant to always contain
# the sure real soln.
# Second and third solution;
iSqr3 = sqrt(3)*1i;
xtemp[4:6] = p - 0.5*(s1+s2 + iSqr3*(s1-s2));
xtemp[7:9] = p - 0.5*(s1+s2 - iSqr3*(s1-s2));
ind1 = which.min(abs(a*xtemp[1:3]^3 + b*xtemp[1:3]^2 +c*xtemp[1:3] +d))
ind2 = 3+which.min(abs(a*xtemp[4:6]^3 + b*xtemp[4:6]^2 +c*xtemp[4:6] +d))
ind3 = 6+which.min(abs(a*xtemp[7:9]^3 + b*xtemp[7:9]^2 +c*xtemp[7:9] +d))
if (nReRts == 1){
rts[[1]] = c(Re(xtemp[ind1]));
rts[[2]] = xtemp[c(ind2,ind3)]
} else { # three real roots
rts[[1]] = Re(xtemp[c(ind1,ind2,ind3)]);
rts[[2]] = numeric();
}
return(rts)
} # end of function cubsol