Solving a single variable equation in R using unitroot - r

I have a complicated equation for which I have written the code as follows:
sigma = 1.336449027;
f_t = 0.500185113;
alpha = 0.364; #elasticity of capital
beta = 0.115; #elasticity of labor
R = 3.131696599;
chi = 0.5;
M = log(1056);
sigma = 1.336449027; #degree of product substitutability
W = log(29448.08908);
P = 3.0686;
aval = 1.25;
c = 0.5;
f = function(b){
loutpow = sigma/(beta*(sigma-1)-sigma);
lconst1 = sigma/(beta*(sigma-1));
lconst2 = (aval*kval^alpha)^((1 - sigma)/sigma);
lconst3 = (R*P^(sigma-1))^(1/sigma);
lval = (W/b*lconst2/lconst3*lconst1)^loutpow;
profit_first_term = (R*P^(sigma-1))^(1/sigma)*(aval*kval^alpha*lval^beta)^(1-(1/sigma));
profit_middle_terms = kval - kprimeval - f_t*kprimeval - c(kval - kprimeval)^2
profit_last_term = W/b*lval
profit = profit_first_term + profit_middle_terms - profit_last_term
bankruptcy = profit - chi*dval
}
For a range of kval,kprimeval,dval from 1 to 10000, I want to find the roots of this equation, that is the value of b. It is possible that for some values of kval,kprimeval,dval roots do not exist.

apparently your function has not a zero:
curve(f(x), -1, 1e9)

Related

How to tune the hyperparameters of a Bayesian ODE fit in Julia?

I have been trying to replicate https://diffeqflux.sciml.ai/dev/examples/BayesianNODE_NUTS/, using different ODE equation, but I have received this result without uncertainty quantification, is it because I did the initial value u0 is higher :
Could you please tell me what was wrong?
using DiffEqFlux, OrdinaryDiffEq, Flux, Optim, Plots, AdvancedHMC, MCMCChains
using JLD, StatsPlots
function Arps!(du,u,p,t)
y= u[1]
#x, y = u
# Di,b,n,tau = p
n,tau = p
#du[1]=dx=-(x * Di * x^b)
du[1]=dy=-(n *((t^n)/tau) * y/t)
end
tspan=(1.0,50.0)
tsteps = 1:1:50
u0 = [16382.9]
p=[0.48,15.92]
prob_trueode = ODEProblem(Arps!,u0,tspan,p)
ode_data = Array(solve(prob_trueode, Tsit5(), saveat = tsteps))
ode_data =ode_data[1,:]
dudt= FastChain(FastDense(1, 30, tanh),
FastDense(30, 1))
prob_neuralode = NeuralODE(dudt, tspan, Tsit5(), saveat = tsteps)
function predict_neuralode(p)
Array(prob_neuralode(u0, p))
end
function loss_neuralode(p)
pred = predict_neuralode(p)
loss = sum(abs2, ode_data .- pred)
return loss, pred
end
l(θ) = -sum(abs2, ode_data .- predict_neuralode(θ)) - sum(θ .* θ)
function dldθ(θ)
x,lambda = Flux.Zygote.pullback(l,θ)
grad = first(lambda(1))
return x, grad
end
metric = DiagEuclideanMetric(length(prob_neuralode.p))
h = Hamiltonian(metric, l, dldθ)
integrator = Leapfrog(find_good_stepsize(h, Float64.(prob_neuralode.p)))
prop = AdvancedHMC.NUTS{MultinomialTS, GeneralisedNoUTurn}(integrator)
adaptor = StanHMCAdaptor(MassMatrixAdaptor(metric), StepSizeAdaptor(0.45, prop.integrator))
samples, stats = sample(h, prop, Float64.(prob_neuralode.p), 500, adaptor, 500; progress=true)
losses = map(x-> x[1],[loss_neuralode(samples[i]) for i in 1:length(samples)])
################### RETRODICTED PLOTS: TIME SERIES #################
pl = scatter(tsteps, ode_data, color = :red, label = "Data: Var1", xlabel = "t", title = "Spiral Neural ODE")
for k in 1:300
resol = predict_neuralode(samples[100:end][rand(1:400)])
plot!(tsteps,resol[1,:], alpha=0.04, color = :red, label = "")
end
idx = findmin(losses)[2]
prediction = predict_neuralode(samples[idx])
plot!(tsteps,prediction[1,:], color = :black, w = 2, label = "")
The most likely reason for this is because the loss function magnitude is too high for the posterior samples, due to which the posterior sample results are out of range and not visible on your plot.
This can be possibly fixed by (a) adding a scaling factor the Neural ODE output and making sure that the loss function does not start from a very high magnitude or (b) increasing the number of layers in the neural network architecture/ changing the activation function.
By adding scaling factor to the Neural ODE, I have got good results as shown in the figure below:

How to Set a User-Defined Colormap in Octave?

I have a trivial piece of code that calculates some quantity and plots it as contours:
%Calculate Biot number vs. h for a selected material
h = (0:5:1000)';
mat = "Copper";
lambda = 386;
r = (0:0.25:50); %In cm
R = r./100; %In m
%Calculate matrix of Bi values
% R = length(h) x C = length(r)
Bi = (h.*R)/lambda;
%Contour Plot of results
%Set boundaries at Bi = 0, 0.1, 1
conts = [0, 0.1, 1];
ptitle = ["Biot Number for a ", mat, " Sphere"];
%Create a personalized colormap with 30 values.
% 0<Bi<0.1 Green
% 0.1<=Bi<1 Yellow
% Bi >= 1 Red
my_green = [229,255,204]./255;
my_yellow = [255,255,204]./255;
my_pink = [255,229,204]./255;
my_cmap = [repmat(my_green, 10, 1); repmat(my_yellow, 10, 1); repmat(my_pink, 10, 1) ];
clf;
colormap (my_cmap);
contourf(h, r, Bi, conts, 'showtext', 'on');
title(ptitle)
xlabel ("h(W/m^2*K)");
ylabel ("r(cm)");
The result is missing the intermediate color (yellow):
What can be done about this?
You have too few contours, so the wrong color is chosen. If you do contourf(h, r, Bi, 0:0.2:1, 'showtext', 'on'); you get:
Also, I'd suggest to make the "green" and the "yellow" more different, as it might be difficult to differentiate them on some displays.
Here's what I meant by "playing around with L, M, N:
conts = [0, 0.1, 1];
ptitle = ["Biot Number for a ", mat, " Sphere"];
%Create a personalized colormap
my_green = [229,255,204]./255;
my_yellow = [255,255,204]./255;
my_pink = [255,229,204]./255;
my_cmap = [repmat(my_green, 10, 1); repmat(my_yellow, 90, 1); repmat(my_pink, 1, 1) ];
figure(); contourf(h, r, Bi, conts, 'showtext', 'on');
colormap (my_cmap);
caxis([0 1.01])
title(ptitle)
xlabel ("h(W/m^2*K)");
ylabel ("r(cm)");
BTW, I ran this on MATLAB R2018a in case you're wondering why you're not getting the exact same thing.
Adding the code below to define countours and to generate the colormap, the process can be automated.
conts = [0, 0.05, 0.1, 0.3, 0.7, 1];
%Create a personalized colormap with 50 values distributed proportionally to Bi values
step = 50/max(max(Bi));
L = ceil(step*0.1);
M = ceil(step*(1-0.1));
H = ceil(step*(max(max(Bi))-1));
my_green = [229,255,204]./255;
my_yellow = [255,255,204]./255;
my_pink = [255,229,204]./255;
my_cmap = [repmat(my_green, L, 1); repmat(my_yellow, M, 1); repmat(my_pink, H, 1)];
Obtaining:

Editing a function from a package in R?

I am using the referenceIntervals package in R, to do some data analytics.
In particular I am using the refLimit function which calculates reference and confidence intervals. I want to edit it to remove certain functionality (for instance it runs a shapiro normalitiy test, which stops the entire code if the data larger than 5000, it wont allow you to parametrically test samples less than 120). To do this I have been typing refLimit into the terminal - copying the function definition, then saving it as a separate file (below is the full original definition of the function).
singleRefLimit =
function (data, dname = "default", out.method = "horn", out.rm = FALSE,
RI = "p", CI = "p", refConf = 0.95, limitConf = 0.9)
{
if (out.method == "dixon") {
output = dixon.outliers(data)
}
else if (out.method == "cook") {
output = cook.outliers(data)
}
else if (out.method == "vanderLoo") {
output = vanderLoo.outliers(data)
}
else {
output = horn.outliers(data)
}
if (out.rm == TRUE) {
data = output$subset
}
outliers = output$outliers
n = length(data)
mean = mean(data, na.rm = TRUE)
sd = sd(data, na.rm = TRUE)
norm = NULL
if (RI == "n") {
methodRI = "Reference Interval calculated nonparametrically"
data = sort(data)
holder = nonparRI(data, indices = 1:length(data), refConf)
lowerRefLimit = holder[1]
upperRefLimit = holder[2]
if (CI == "p") {
CI = "n"
}
}
if (RI == "r") {
methodRI = "Reference Interval calculated using Robust algorithm"
holder = robust(data, 1:length(data), refConf)
lowerRefLimit = holder[1]
upperRefLimit = holder[2]
CI = "boot"
}
if (RI == "p") {
methodRI = "Reference Interval calculated parametrically"
methodCI = "Confidence Intervals calculated parametrically"
refZ = qnorm(1 - ((1 - refConf)/2))
limitZ = qnorm(1 - ((1 - limitConf)/2))
lowerRefLimit = mean - refZ * sd
upperRefLimit = mean + refZ * sd
se = sqrt(((sd^2)/n) + (((refZ^2) * (sd^2))/(2 * n)))
lowerRefLowLimit = lowerRefLimit - limitZ * se
lowerRefUpperLimit = lowerRefLimit + limitZ * se
upperRefLowLimit = upperRefLimit - limitZ * se
upperRefUpperLimit = upperRefLimit + limitZ * se
shap_normalcy = shapiro.test(data)
shap_output = paste(c("Shapiro-Wilk: W = ", format(shap_normalcy$statistic,
digits = 6), ", p-value = ", format(shap_normalcy$p.value,
digits = 6)), collapse = "")
ks_normalcy = suppressWarnings(ks.test(data, "pnorm",
m = mean, sd = sd))
ks_output = paste(c("Kolmorgorov-Smirnov: D = ", format(ks_normalcy$statistic,
digits = 6), ", p-value = ", format(ks_normalcy$p.value,
digits = 6)), collapse = "")
if (shap_normalcy$p.value < 0.05 | ks_normalcy$p.value <
0.05) {
norm = list(shap_output, ks_output)
}
else {
norm = list(shap_output, ks_output)
}
}
if (CI == "n") {
if (n < 120) {
cat("\nSample size too small for non-parametric confidence intervals, \n \t\tbootstrapping instead\n")
CI = "boot"
}
else {
methodCI = "Confidence Intervals calculated nonparametrically"
ranks = nonparRanks[which(nonparRanks$SampleSize ==
n), ]
lowerRefLowLimit = data[ranks$Lower]
lowerRefUpperLimit = data[ranks$Upper]
upperRefLowLimit = data[(n + 1) - ranks$Upper]
upperRefUpperLimit = data[(n + 1) - ranks$Lower]
}
}
if (CI == "boot" & (RI == "n" | RI == "r")) {
methodCI = "Confidence Intervals calculated by bootstrapping, R = 5000"
if (RI == "n") {
bootresult = boot::boot(data = data, statistic = nonparRI,
refConf = refConf, R = 5000)
}
if (RI == "r") {
bootresult = boot::boot(data = data, statistic = robust,
refConf = refConf, R = 5000)
}
bootresultlower = boot::boot.ci(bootresult, conf = limitConf,
type = "basic", index = 1)
bootresultupper = boot::boot.ci(bootresult, conf = limitConf,
type = "basic", index = 2)
lowerRefLowLimit = bootresultlower$basic[4]
lowerRefUpperLimit = bootresultlower$basic[5]
upperRefLowLimit = bootresultupper$basic[4]
upperRefUpperLimit = bootresultupper$basic[5]
}
RVAL = list(size = n, dname = dname, out.method = out.method,
out.rm = out.rm, outliers = outliers, methodRI = methodRI,
methodCI = methodCI, norm = norm, refConf = refConf,
limitConf = limitConf, Ref_Int = c(lowerRefLimit = lowerRefLimit,
upperRefLimit = upperRefLimit), Conf_Int = c(lowerRefLowLimit = lowerRefLowLimit,
lowerRefUpperLimit = lowerRefUpperLimit, upperRefLowLimit = upperRefLowLimit,
upperRefUpperLimit = upperRefUpperLimit))
class(RVAL) = "interval"
return(RVAL)
}
However when I then execute this file a large number of terms end up being undefined, for instance when I use the function I get 'object 'nonparRanks' not found'.
How do I edit the function in the package? I have looked at trying to important the package namespace and environment but this has not helped. I have also tried to find the actual function in the package files in my directory, but not been able to.
I am reasonably experienced in R, but I have never had to edit a package before. I am clearly missing something about how functions are defined in packages, but I am not sure what.
In the beginning of the package there is a line
data(sysdata, envir=environment())
See here: https://github.com/cran/referenceIntervals/tree/master/data/sysdata.rda
I suspect that "nonparRanks" is defined there as I don't see it defined anywhere else. So perhaps you could download that file, write your own function, then run that same line before running your function and it may work.
EDIT:
Download the file then run:
load("C:/sysdata.rda")
With your path to the file and then your function will work.
nonparRanks is a function in the referenceIntervals package:
Table that dictate the ranks for the confidence intervals
around thecalculated reference interval
Your method of saving and editing the function is fine, but make sure you load all the necessary underlying functions to run it too.
The easiest thing to do might be to:
save your copied and pasted R function as a different name, e.g. singleRefLimit2, then
call library("referenceIntervals"), which will load all the underlying functions you need and then
load your function source("singelRefLimit2.R"), with whatever edits you choose to make.

R upper and lower bounds for a regression function

I am trying to bound the following variables in a function
lower = c(Hyp.b = 0.01, Hyp.Di = .0000001),
upper = c(Hyp.b = 1.01, Hyp.Di = .1)
The script is as follows:
Hyp.q.forward.fun = function( time, Hyp.qi, Hyp.b, Hyp.Di ){ # time in days
Hyp.q.theo = Hyp.qi*(1 + Hyp.b*Hyp.Di*time)^(-1/Hyp.b)
return(Hyp.q.theo)
}
residfun = function(x,x.days,y.prod){
Hyp.qi = x[1]
Hyp.b = x[2]
Hyp.Di = x[3]
q.theo = (365.25/12)*Hyp.q.forward.fun(
time=x.days,
Hyp.qi=Hyp.qi,
Hyp.b=Hyp.b,
Hyp.Di=Hyp.Di)
#plot(x.days,y.prod); lines(x.days,q.theo)
residual = sqrt(sum((q.theo-y.prod)^2))
return(residual)
}
I'm not sure if I'm even using the correct method to bound the two variable. Any help would be much appreciated.

R:Time dependent parameters in a differential equations model

I have a differential equations model (see below), I am looking for some way to change some of the values of the parameters at a certain time step or at a certain value of one of the state variables (or another way if it works better). For example, I would like to change GammaQR and GammaQD from 0 to .02 at time step 5 (or possibly, if it works better, when H > .04). I have no clue how to go about this and would really appreciate any advice! Thanks!
VS = 0.01
VE = 0.01
VH = 0.01
BSE = 10 #
BSI = 10 #
THE = 1/10
TEI = 1/3
DeltaID = .5
GammaIR = .5
XIQ = 0.001
XEQ = 0.01
XHQ = 0.05
GammaQR = .02
GammaQD = .02
library(deSolve)
pars <- c(VS, VE, VH, BSE, BSI, THE, TEI, DeltaID, GammaIR, XIQ, XEQ, XHQ, GammaQR)
init.values <- c(S = .99 , H = .01 , E = 0 , V = 0, I = 0 , Q = 0 , D = 0 , R = 0 )
times <- seq(0, 60, by = 1)
Smallpox <- function(time, y.values, parameters){
with(as.list(c(y.values, parameters)), {
dS.dt = -VS*S - BSI*S*I - BSE*E*S
dH.dt = BSI*S*I + BSE*E*S - THE*H - XHQ*H - VH*H
dE.dt = THE*H - XEQ*E - VE*E - DeltaID*E - TEI*E
dV.dt = VS*S + VE*E + VH*H
dI.dt = TEI*E - XIQ*I - GammaIR*I - DeltaID*I
dQ.dt = XHQ*H + XIQ*I + XEQ*E - GammaQR*Q - GammaQD*Q
dD.dt = DeltaID*I + DeltaID*E + GammaQD*Q
dR.dt = GammaQR*Q + DeltaID*I
return(list(c(dS.dt, dH.dt, dE.dt, dV.dt, dI.dt, dQ.dt, dD.dt, dR.dt)))
})
}
out <- as.data.frame(ode(func = Smallpox, y = init.values, parms = pars, times = times))
tail(out)
matplot(out$time, out[ ,2:9], type = "l", xlab = "time", ylab = "percent of population", main = "Model Name", lwd = 2, col = c("black", "red", "green", "Blue", "cyan", "purple", "grey", "magenta"), lty = 1:8)

Resources