I have the following equation and would like R to solve for L.
Any thought?
Average = 370.4
m = 2
p = 0.2
n = 5
#L = ?
log10(Average) = 0.379933834 -0.107509315* m + 0.104445717 * p + 0.016517169 * n -0.025566689* L + 0.014393465 * m * p + 0.001601271 * m * n - 0.014250365 * n * L + 0.002523518 * m^2 + 0.237090759 * L^2
Your equation is a quadratic, so the quadratic formula works. Alternatively, you can solve numerically using uniroot:
Average = 370.4
m = 2
p = 0.2
n = 5
#L = ?
f0 <- function(L) {
0.379933834 - 0.107509315*m + 0.104445717*p + 0.016517169*n - 0.025566689*L + 0.014393465*m*p + 0.001601271*m*n - 0.014250365*n*L + 0.002523518*m^2 + 0.237090759*L^2 - log10(Average)
}
# solve numerically using uniroot
(nroots <- c(uniroot(f0, c(0, 10))$root, uniroot(f0, c(-10, 0))$root))
#> [1] 3.304099 -2.895724
# solve analytically using the quadratic formula
a <- 0.237090759
b <- -0.025566689 - 0.014250365*n
c <- 0.379933834 - 0.107509315*m + 0.104445717*p + 0.016517169*n + 0.014393465*m*p + 0.001601271*m*n + 0.002523518*m^2 - log10(Average)
(aroots <- (-b + c(1, -1)*sqrt(b^2 - 4*a*c))/(2*a))
#> [1] 3.304084 -2.895724
# check the solutions
f0(c(nroots, aroots))
#> [1] 2.255707e-05 -5.932209e-08 4.440892e-16 4.440892e-16
Related
I have an equation which goes like this,
2* (1-x-a-b)^2 * x * *theta* + 2 * (1-a-b-x) * x^2 * *theta* - 2 * b * x^2 + 2 * a * (1-a-b-x)^2 = 0
I want to create a function in R, that selects a and b with restriction (a + b < 1 - a + b) from an uniform distribution. After selecting, I want it to find the solutions for x (both negative and positive).
I want to repeat this process t amount of time in a for loop where I will give the theta value as an input.
After that I want it to create a 3D density plot where solutions are shown with respect to values of a,b on two axes and x on one axis.
So far I have tried to use polynom package and solve function. But I am having hard time with R when it comes to mathematics.
You need to rewrite the polynomial in standard form a0 + a1*x + a2*x^2 + a3*x^3, then you can use the base function polyroot() to find the roots. For example,
a0 <- 2 * a * (1 - a - b)^2
a1 <- 2 * (1 - a - b)^2 * theta - 4 * a * (1 - a - b)
a2 <- -4 * (1 - a - b) * theta + 2 * (1 - a - b) * theta - 2 * b + 2 * a
a3 <- 0
So this is a quadratic equation, not a cubic as it appears at first glance.
Then use
polyroot(c(a0, a1, a2))
to find the roots. Select the real roots, and put them together into a matrix roots with columns a, b, root, then use rgl::plot3d(roots) to display them.
I think you have a typo in your restriction, so I'll ignore it, and this is the plot I get for theta == 1:
theta <- 1
a <- runif(1000)
b <- runif(1000)
a0 <- 2*a*(1-a-b)^2
a1 <- 2*(1-a-b)^2*theta -4*a*(1-a-b)
a2 <- -4*(1-a-b)*theta + 2*(1-a-b)*theta-2*b+2*a
result <- matrix(numeric(), ncol = 3, dimnames = list(NULL, c("a", "b", "root")))
for (i in seq_along(a)) {
root <- polyroot(c(a0[i], a1[i], a2[i]))
if (max(Im(root)) < 1.e8)
result <- rbind(result, cbind(a[i], b[i], Re(root)))
}
library(rgl)
plot3d(result)
Created on 2022-06-14 by the reprex package (v2.0.1)
Most of the roots are really small, but for some of them a2 is nearly zero, and then they can be very large.
You can create a table with a column for each variable and filter the rows not satisfying your equation:
library(tidyverse)
set.seed(1337)
n <- 1000
tibble(
a = runif(n),
b = runif(n)
) |>
filter(a + b < 1 - a + b) |>
expand_grid(
theta = seq(0, 1, by = 1),
x = seq(0, 1, by = 1)
) |>
filter(
2 * (1 - x - a - b)^2 * x * theta + 2 * (1 - a - b - x) * x^2 * theta - 2 *
b * x^2 + 2 * a * (1 - a - b - x)^2 == 0
)
#> # A tibble: 0 × 4
#> # … with 4 variables: a <dbl>, b <dbl>, theta <dbl>, x <dbl>
Created on 2022-06-13 by the reprex package (v2.0.0)
Unfortunately, there is no point in the sampled space satisfying your equation. This is probably due to ==0 instead of <e where e is a very small error. One needs to allow small errors in numerical sampling solutions.
Why just not solve the roots of the equation analytically?
I have to write a code for this equations to find μ_0 and σ_0. equations
Here, Φ[.] is the cumulative standard Normal distribution. There are given values for σ = 2, E[M] = 10 and p = Pr[8 ≤ M ≤12] = 2/3.
My results should be μ_0 ≈ 0.28 and σ_0 ≈ 0.21, but something is wrong with my functions, i think. Can you pls help me?
sigma <- 2
E_M <- 10
Pr <- 2/3
a <- 8
b <- 12
#From first equation we take log(E[M]) = mu_0 + 1/2sigma^2 + 1/2sigma_0^2,
#As sigma = 2 and E[M] = 10 -> mu_0 = 0.303 - 1/2 sigma_0^2
fun <- function(sigma_0)
{pnorm((log(b) - 2 - 0.303 + 1/2 * sigma_0^2)/sigma_0, mean = 0.303 - 1/2 * sigma_0^2, sd = sigma_0) -
pnorm((log(a) - 2 -0.303 + 1/2 * sigma_0^2)/sigma_0, mean = 0.303 - 1/2 * sigma_0^2, sd = sigma_0) - Pr}
sigma_0 <- seq(0.1, 2, 0.05)
uniroot(fun, upper = 2, lower = 0.1)
Suppose I have the following simple formula
y[t] = alpha * y[t-1] + beta * y[t-2]
Where y[t-1] and y[t-2] are known observations.
Now the next observation at time t+1 can be written as
y[t+1] = alpha * y[t] + beta * y[t-1]
Using previous information of y[t] yields
y[t+1] = alpha * (alpha * y[t-1] + beta * y[t-2]) + beta * y[t-1]
Simplifying
y[t+1] = alpha^2 * y[t-1] + alpha * beta * y[t-2] + beta * y[t-1]
The next observation
y[t+2] = alpha^2 * y[t] + alpha * beta * y[t-1] + beta * y[t]
Where again y[t] can be inserted.
Now my question is how do I write a for loop such that I can construct y at time t+h where h is an integer value.
Something like this?
y = c(1, 2, rep(0, 49))
alpha <- .4
beta <- .9
for (t in 3:length(y)) {
y[t] <- alpha * y[t-1] + beta * y[t-2]
}
nms <- paste0('y[', as.character(seq(-2, 48, 1)), ']')
`names<-`(y, nms)
#> y[-2] y[-1] y[0] y[1] y[2] y[3]
#> 1.000000 2.000000 1.700000 2.480000 2.522000 3.240800
#> y[4] y[5] y[6] y[7] y[8] y[9]
#> 3.566120 4.343168 4.946775 5.887561 6.807122 8.021654
#> y[10] y[11] y[12] y[13] y[14] y[15]
#> 9.335072 10.953517 12.782971 14.971354 17.493216 20.471505
#> y[16] y[17] y[18] y[19] y[20] y[21]
#> 23.932496 27.997353 32.738188 38.292893 44.781526 52.376214
#> y[22] y[23] y[24] y[25] y[26] y[27]
#> 61.253859 71.640136 83.784528 97.989934 114.602048 134.031760
#> y[28] y[29] y[30] y[31] y[32] y[33]
#> 156.754547 183.330403 214.411254 250.761864 293.274874 342.995627
#> y[34] y[35] y[36] y[37] y[38] y[39]
#> 401.145637 469.154319 548.692801 641.716008 750.509925 877.748377
#> y[40] y[41] y[42] y[43] y[44] y[45]
#> 1026.558283 1200.596853 1404.141196 1642.193646 1920.604534 2246.216095
#> y[46] y[47] y[48]
#> 2627.030519 3072.406693 3593.290144
Created on 2021-06-12 by the reprex package (v2.0.0)
I have the following model I want to calculate:
where
My data is the following:
D0= 100
variance = 3
T = 20
uf = 0.3
ue = 0.7
CRRA = 0.1
theta = 0.7
Q = 1
X1=1
# DIVIDENDS:
epsilon <- c(0,0, 6, rep(0,18))
DD_t <- D0
for (t in 2:(T+1)) {
DD_t[t] <- epsilon[t]+DD_t[t-1]
}
# PRICE in t0 t1 t2
PP_t<- c(rep(0,21))
PP_t[1] <- DD_t[1] - 0.1*(3^2)*(18 + (1/0.3))
PP_t[2] <- DD_t[2] + (ue/uf)*theta^(1-1) - CRRA*(variance^2)*Q*(T-1-1 + (1/uf))
PP_t[3] <- DD_t[3] + (ue/uf)*theta^(2-1) - CRRA*(variance^2)*Q*(T-2-1 + (1/uf))
Up until here, everything is correct. Now, I want to calculate P_3 to P_20 and this is were the following code yields the wrong solution unfortunately.
# PRICE in t3 t4 to t20
for (t in 3:(T-1)) {
t1 <- (t + 1)
XX_t <- 0
for (k in 1:(t-1)) {
XX_t <- XX_t + (theta^(k-1))*(PP_t[t1-k]-PP_t[t1-k-1])
}
XX_t <- (1-theta)*XX_t + theta^(t-1)*1
PP_t[t1] <- DD_t[t1] + XX_t*(ue/uf) - CRRA*(variance^2)*Q*(T - t - 1 + (1/uf))
}
What this gives me is:
PP_t
[1] 80.80000 83.13333 89.33333 95.22667 98.26400 98.66093 97.36051 95.53206 94.15252 93.77109 94.47277 95.99211 97.89801 99.77274 101.33323 102.47560 103.25258
[18] 103.81069 104.31816 104.90794 0.00000
However, the correct solution looks like this:
[1] 80.80000 83.13333 89.33333 94.08333 96.66333 97.22033 96.46413 95.28555 94.43488 94.33895 95.07011 96.43089 98.09417 99.74021 101.15038 102.24238 103.05407
[18] 103.69603 104.29659 104.95801 105.73360
I cannot find the mistake in my code unfortunately. It must be slight one, since the values are not that far off.
I am trying to simulate cell uptake in R, having ported a model from Berkeley Madonna. The model is comprised of several constants and differential equations to calculate amounts and concentrations. A portion of the code is listed:
library(deSolve)
fb = 0.0510
Km = 23.5
Pdif = 0.429
Vmax = 270
Vol_cell = 9.33
Vol_media = 150
S = 10 #concentration of dosing media
yini = c(Amt_media=(S*Vol_media)-(S*fb*Vol_cell),
Amt_cell=S*fb*Vol_cell,
Amt_total=S*Vol_media,
Con_media=S-(S*fb),
Con_cell=S*fb)
Uptake = function(t, y, p){
dy1 = (- (Pdif * y[1]) + (Pdif * y[2]) - ((Vmax * y[4])/(Km + y[4])))
dy2 = (+ (Pdif * y[1]) - (Pdif * y[2]) + ((Vmax * y[4])/(Km + y[4])))
dy3 = dy1 + dy2
dy4 = dy1 / Vol_media
dy5 = dy2 / Vol_cell
list(c(dy1, dy2, dy3, dy4, dy5))}
times1 = seq(from=0, to=15, by=0.01)
out1 = ode(y=yini, times=times1, func=Uptake, parms=NULL, method="rk4")
The rest of the code is for output to dataframes and plotting. My question then is how to have the code structured to use "S" as a list of several concentrations such that each concentration can be applied to the differential equations (essentially giving me an out1 for S1, out2 for S2, etc, that can then be passed onto a dataframe)? In Berkeley Madonna this was achieved by writing over 35 differential equations, though I'd like to use a simplified approach in R if possible.
The only part where S is used is in the initialization of the yini values. Basically we just need to move that part and the part that runs ode with those values into a new function. Then you can call that function for what ever values you want. For example
#set up
library(deSolve)
fb <- 0.0510
Km <- 23.5
Pdif <- 0.429
Vmax <- 270
Vol_cell <- 9.33
Vol_media <- 150
Uptake <- function(t, y, p){
dy1 = (- (Pdif * y[1]) + (Pdif * y[2]) - ((Vmax * y[4])/(Km + y[4])))
dy2 = (+ (Pdif * y[1]) - (Pdif * y[2]) + ((Vmax * y[4])/(Km + y[4])))
dy3 = dy1 + dy2
dy4 = dy1 / Vol_media
dy5 = dy2 / Vol_cell
list(c(dy1, dy2, dy3, dy4, dy5))}
times1 <- seq(from=0, to=15, by=0.01)
# function with S as a parameter
runConc <- function(S) {
yini <- c(Amt_media=(S*Vol_media)-(S*fb*Vol_cell),
Amt_cell=S*fb*Vol_cell,
Amt_total=S*Vol_media,
Con_media=S-(S*fb),
Con_cell=S*fb)
ode(y=yini, times=times1, func=Uptake, parms=NULL, method="rk4")
}
#run for concentrations 10,20,30
out <- lapply(c(10,20,30), runConc)
This will result in a list object with the results for each concentration. So out[[1]] is the result for S=10, out[[2]] is S=20, etc. We can see the first few lines of each of the results with
lapply(out, head, 3)
# [[1]]
# time Amt_media Amt_cell Amt_total Con_media Con_cell
# [1,] 0.00 1495.242 4.75830 1500 9.490000 0.510000
# [2,] 0.01 1488.103 11.89710 1500 9.442408 1.275145
# [3,] 0.02 1481.028 18.97216 1500 9.395241 2.033457
#
# [[2]]
# time Amt_media Amt_cell Amt_total Con_media Con_cell
# [1,] 0.00 2990.483 9.51660 3000 18.98000 1.020000
# [2,] 0.01 2976.550 23.44980 3000 18.88711 2.513377
# [3,] 0.02 2962.739 37.26072 3000 18.79504 3.993646
#
# [[3]]
# time Amt_media Amt_cell Amt_total Con_media Con_cell
# [1,] 0.00 4485.725 14.27490 4500 28.47000 1.53000
# [2,] 0.01 4465.153 34.84653 4500 28.33286 3.73489
# [3,] 0.02 4444.761 55.23920 4500 28.19690 5.92060