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)
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 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
Consider the cajorls from urca package in R. This is an estimation of the VEC model given the a ca.jo object. How can I by the output of cajorls find the loading matrix alpha? Beta and the other parameters are simply I can't find the loading matrix.
This code below is taken from a textbook. Can you help identify the loading matrix by adding to this piece of code.
library(urca)
set.seed(1234)
n = 250
e1 = rnorm(n, 0, 0.5)
e2 = rnorm(n, 0, 0.5)
e3 = rnorm(n, 0, 0.5)
u1.ar1 = arima.sim(model = list(ar = 0.75), innov = e1, n = n)
u2.ar1 = arima.sim(model = list(ar = 0.3), innov = e2, n = n)
y3 = cumsum(e3)
y1 = 0.8*y3 + u1.ar1
y2 = -0.3*y3 + u2.ar1
y.mat = data.frame(y1,y2,y3)
plot(ts(y.mat))
vecm = ca.jo(y.mat)
jo.results = summary(vecm)
print(jo.results )
# reestimated
vecm.r2 = cajorls(vecm, r = 2)
summary(vecm.r2)
Maybe I should perform operations at mu own?
I ran your skript and found this
print(jo.results)
######################
# Johansen-Procedure #
######################
Test type: maximal eigenvalue statistic (lambda max) , with linear trend
Eigenvalues (lambda):
[1] 0.285347239 0.127915199 0.006887218
Values of teststatistic and critical values of test:
test 10pct 5pct 1pct
r <= 2 | 1.71 6.50 8.18 11.65
r <= 1 | 33.94 12.91 14.90 19.19
r = 0 | 83.32 18.90 21.07 25.75
Eigenvectors, normalised to first column:
(These are the cointegration relations)
y1.l2 y2.l2 y3.l2
y1.l2 1.00000 1.00000000 1.0000000
y2.l2 -43.55337 -0.07138149 0.0528435
y3.l2 -13.58606 -0.73018096 -3.4121605
Weights W:
(This is the loading matrix)
y1.l2 y2.l2 y3.l2
y1.d -0.0007084809 -0.27450042 2.250788e-03
y2.d 0.0174625514 0.03598729 7.150656e-05
y3.d -0.0030589216 -0.02899838 3.086942e-03
Doesn't it say, Wieghts W: (This is the loading matrix)?
Or do you look for something else?
I hope this message finds you well.
I am trying to solve an optimization problem formulated as a Mixed Integer Program with the lpSolveAPI R-package. However, there are indicator functions in the objective function and in some constraints. To be more specific, consider the following optimization problem:
min{ 2.8 * x1 + 3.2 * x2 + 3.5 * x3 +
17.5 * delta(x1) + 2.3 * delta(x2) + 5.5 * delta(x3) }
subject to:
0.4 * x1 + 8.7 * x2 + 4.5 * x3 <=
387 - 3 * delta(x1) - 1 * delta(x2) - 3 * delta(x3)
x1 <= 93 * delta(x1)
x2 <= 94 * delta(x2),
x3 <= 100 * delta(x3), and
x1, x2, and x3 are non-negative integers.
In this problem, for all i in {1, 2, 3}, delta(xi) = 1 if xi > 0, whereas delta(xi) = 0 otherwise.
The R-code I have so far is:
install.packages("lpSolveAPI")
library(lpSolveAPI)
a <- c(3, 1, 3)
b <- c(0.4, 8.7, 4.5)
q <- 387
M <- c(93, 94, 100)
A <- c(17.5, 2.3, 5.5)
h <- c(2.8, 3.2, 3.5)
Fn <- function(u1, u2, u3, u4){
lprec <- make.lp(0, 3)
lp.control(lprec, "min")
set.objfn(lprec, u1)
add.constraint(lprec, u2, "<=", u3)
set.bounds(lprec, lower = rep(0, 3), upper = u4)
set.type(lprec, columns = 1:3, type = "integer")
solve(lprec)
return(list(Soln = get.variables(lprec), MinObj = get.objective(lprec)))
}
TheTest <- Fn(u1 = h, u2 = b, u3 = q, u4 = M)
Please, I was wondering if someone could tell me how to put delta functions into this R-code to solve the aforementioned optimization problem.
Rodrigo.
A constraint like x1 <= 93 * delta(x1) looks very strange to me. I think this is just x1 <= 93. For a MIP solver replace the function delta(x) by a binary variable d. Then add the constraint d <= x <= M*d where M is an upper bound on x. To be explicit, for your model we have:
min 2.8*x1 + 3.2*x2 + 3.5*x3 + 17.5*d1 + 2.3*d2 + 5.5*d3
0.4*x1 + 8.7*x2 + 4.5*x3 <= 387 - 3*d1 - d2 - 3*d3
d1 <= x1 <= 93*d1
d2 <= x2 <= 94*d2
d3 <= x3 <= 100*d3
x1 integer in [0,93]
x2 integer in [0,94]
x3 integer in [0,100]
d1,d2,d3 binary
This is now trivial to solve with any MIP solver. Note that a double inequality like d1 <= x1 <= 93*d1 can be written as two inequalities: d1<=x1 and x1<=93*d1.
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