I keep getting the error:
Error in checkFunc(Func2, times, y, rho) :
The number of derivatives returned by func() (175) must equal the length of the initial conditions vector (51)
I am trying to create a model based off of Brigatti et al 2009 (pred-prey model w a spatial component)
x<-c(1:40000)
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:length(state) / 2]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(prey, pred, dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 51)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
A few problems. First, missing parentheses.
prey = state[1:length(state) / 2]
should read
prey = state[1:(length(state) / 2)]
Second, your initial conditions are an odd number in length. state should specify the initial conditions for both prey and predator (in that order). So, for each location there should be two values and, consequently, the vector should always be a multiple of two in length.
Thirdly, your function dxdt should return list(c(dprey, dpred)). There is no reason to return the values for the state variables, because the ODE solver will calculate those.
Fix those and this is what you get:
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:(length(state) / 2)]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 50)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
Related
I am trying to set up an "interface model for dosage adjustment connects hematotoxicity to pharmacokinetics". In this model there is a feedback loop and the influx must not only be amplified but also be delayed. Is there any good starting point to implement such models
Image and equations Shown below.
dCc <- -k12 * c_central + k21 * r * c_peripheral - k10 * c_central
dCp <- k12 / r * c_central - k21 * c_peripheral
dy=-alphaexp[-beta(y)]*y+[c_central -gamma]*H[c_central -gamma] ; Y(0)=0
dg=kskww0*phi[w,param]*m[y,u]-{ks+n[y,v]}*g
dw=g*(time-delay)-kw*w
m[y(t),u]=exp(-uy(t)]
n[y(t),v]=vy(t)
initial condition
phi[w(t),param]=[w(t)/W0]^-param
H <- function(x) {
ifelse(x < 0, 0, 1)
}
diffeq <- function(t, state, params) {
with(as.list(c(state, params)), {
dCc <- -k12 * c_central + k21 * c_peripheral - k10 * c_central
dCp <- k12 * c_central - k21 * c_peripheral
dy <- -alpha * exp(-beta * y) * y + (c_central - gamma) *H(c_central - gamma)
ds <- ks*kw*((w/w0)^-0.2)*(1-exp(-u*y))- ks * s
dw <- -kw * w + (t-k) * s
return(list(c(ds, dw, dCc, dCp,dy)))
})
}
# Set the initial conditions and parameter values
y0<-0
s0 <- 10
w0 <- 3
c_central0 <- 500/5
c_peripheral0 <- 0
params <- c(Rs = 1, d = 0.1, k = 1.65, kw = 1, ks = 0.5, theta = 1, W = 100, K = 100,
alpha = 0.85, beta = 1.5*10-4, gamma = 0.2,u=5.6*10-4,
k12 =1.263*10-1, k21 = 3.547*10-1, k10 = 9.461*10-2, r = 10000/42000)
# Solve the differential-delay equation using an ODE solver
result <- ode(y = c(y = y0,s = s0, w = w0, c_central = c_central0, c_peripheral = c_peripheral0),
times = seq(0, 40, by = 0.1), func = diffeq, parms = params)
# Plot the solution
plot(result[, "time"], result[, "c_central"], type = "l", xlab = "Time (t)", ylab = "Neutrophil Progenitor Cells (s(t))")
lines(result[, "time"], result[, "s"], col = "red")
lines(result[, "time"], result[, "c_central"], col = "blue")
lines(result[, "time"], result[, "c_peripheral"], col = "green")
I tried binary logistic regression with BFGS using maxlik, but i have included the feature as per the syntax i attached below, but the result is, but i get output like this
Maximum Likelihood estimation
BFGS maximization, 0 iterations
*Return code 100: Initial value out of range.
https://docs.google.com/spreadsheets/d/1fVLeJznB9k29FQ_BdvdCF8ztkOwbdFpx/edit?usp=sharing&ouid=109040212946671424093&rtpof=true&sd=true (this is my data)*
library(maxLik)
library(optimx)
data=read_excel("Book2.xlsx")
data$JKLaki = ifelse(data$JK==1,1,0)
data$Daerah_Samarinda<- ifelse(data$Daerah==1,1,0)
data$Prodi2 = ifelse(data$Prodi==2,1,0)
data$Prodi3 = ifelse(data$Prodi==3,1,0)
data$Prodi4 = ifelse(data$Prodi==4,1,0)
str(data)
attach(data)
ll<- function(param){
mu <- param[1]
beta <- param[-1]
y<- as.vector(data$Y)
x<- cbind(1, data$JKLaki, data$IPK, data$Daerah_Samarinda, data$Prodi2, data$Prodi3, data$Prodi4)
xb<- x%*%beta
pi<- exp(xb)
val <- -sum(y * log(pi) + (1 - y) * log(1 - pi),log=TRUE)
return(val)
}
gl<- funtion(param){
mu <- param[1]
beta <- param[-1]
y <- as.vector(data$Y)
x <- cbind(0, data$JKLaki,data$IPK,data$Daerah_Samarinda,data$Prodi2,data$Prodi3,data$Prodi4)
sigma <- x*beta
pi<- exp(sigma)/(1+exp(sigma))
v= y-pi
vx=as.matrix(x)%*%as.vector(v)
gg= colSums(vx)
return(-gg)}
mle<-maxLik(logLik=ll, grad=gl,hess=NULL,
start=c(mu=1, beta1=0, beta2=0, beta3=0, beta4=0, beta5=0, beta6=0,beta7=0), method="BFGS")
summary(mle)
can i get some help, i tired get this solution, please.
I have been able to optimize the log-likelihood with the following code :
library(DEoptim)
library(readxl)
data <- read_excel("Book2.xlsx")
data$JKLaki <- ifelse(data$JK == 1, 1, 0)
data$Daerah_Samarinda <- ifelse(data$Daerah == 1, 1, 0)
data$Prodi2 <- ifelse(data$Prodi == 2, 1, 0)
data$Prodi3 <- ifelse(data$Prodi == 3, 1, 0)
data$Prodi4 <- ifelse(data$Prodi == 4, 1, 0)
ll <- function(param, data)
{
mu <- param[1]
beta <- param[-1]
y <- as.vector(data$Y)
x <- cbind(1, data$JKLaki, data$IPK, data$Daerah_Samarinda, data$Prodi2, data$Prodi3, data$Prodi4)
xb <- x %*% beta
pi <- exp(mu + xb)
val <- -sum(y * log(pi) + (1 - y) * log(1 - pi))
if(is.nan(val) == TRUE)
{
return(10 ^ 30)
}else
{
return(val)
}
}
lower <- rep(-500, 8)
upper <- rep(500, 8)
obj_DEoptim_Iter1 <- DEoptim(fn = ll, lower = lower, upper = upper,
control = list(itermax = 5000), data = data)
lower <- obj_DEoptim_Iter1$optim$bestmem - 0.25 * abs(obj_DEoptim_Iter1$optim$bestmem)
upper <- obj_DEoptim_Iter1$optim$bestmem + 0.25 * abs(obj_DEoptim_Iter1$optim$bestmem)
obj_DEoptim_Iter2 <- DEoptim(fn = ll, lower = lower, upper = upper,
control = list(itermax = 5000), data = data)
obj_Optim <- optim(par = obj_DEoptim_Iter2$optim$bestmem, fn = ll, data = data)
$par
par1 par2 par3 par4 par5 par6 par7
-350.91045436 347.79576145 0.05337466 0.69032735 -0.01089112 0.47465162 0.38284804
par8
0.42125664
$value
[1] 95.08457
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Assume that iid random sample X_i\sim Bernoulli(\pi) for i=1,\dots, 100 and sample size is 100. We want to do a hypothesis test that
H_0: \pi\ge 0.6,\, H_a: \pi<0.6
I want to get a plot of the relation between our true parameter pi and power. I have got the function power. But I can only input each true pi=0.50, 0.51, 0.52, 0.53, ..., 0.59. How to plot a similar figure?
My code is as follows.
n=100
pi0=0.60
##power function
power_fun=function(N,pi,alpha)
{
pvalue=c()
power=c()
rej=c()
for (i in 1:N) {
set.seed(i)
y=rbinom(n,size=1,prob=pi)
pi_hat=mean(y)
z=(pi_hat-pi0)/sqrt(1/n*pi_hat*(1-pi_hat))
rej[i]=ifelse(z<qnorm(0.05,mean=0,sd=1),1,0)
pvalue[i]=pnorm(q=z,mean=0,sd=1)
c_value=qnorm(alpha,mean=0,sd=1)
aug_term=(pi-pi0)/sqrt(1/n*pi_hat*(1-pi_hat))
power[i]=pnorm(c_value-aug_term,mean=0,sd=1)
}
mean_pvalue=mean(pvalue)
sd_pvalue=sd(pvalue)
mean_power=ifelse(pi<pi0,mean(power),NA)
sd_power=sd(power)
rej_rate=mean(pvalue<alpha)
type1_error=ifelse(pi>=pi0,rej_rate,NA)
type2_error=ifelse(pi<pi0,1-mean_power,NA)
type2_error_emp=ifelse(pi<pi0,1-rej_rate,NA)
mc_se=sqrt(1/N*rej_rate*(1-rej_rate))
df_out=data.frame("pvalue"=mean_pvalue,"pvalue2"=sd_pvalue,"power"=mean_power,"ESE_power"=sd_power,
"rejection rate"=rej_rate,
"Type I error"= type1_error,"type_II_error"=type2_error,"Type_II_error"=type2_error_emp,
"MC_SE"=mc_se)
rownames(df_out)=paste0("N=",N,", pi=",pi, ", alpha=", alpha)
df_out=round(df_out,3)
return(df_out)
}
For each pi, we can get power.
power_fun(N=1000,pi=0.5,alpha=0.05)
#power=0.643
power_fun(N=1000,pi=0.51,alpha=0.05)
# power=0.566
power_fun(N=1000,pi=0.52,alpha=0.05)
power_fun(N=1000,pi=0.53,alpha=0.05)
power_fun(N=1000,pi=0.54,alpha=0.05)
But this is too complicated. Is there an easy way to get the power of these pi values and plot their graph of pi and power?
This is more like a code-review.
I think that you thought that you could vectorise over N, pi, and alpha.
I don't think you can that with your current implementation.
Following #Limey's advice:
#' Power function
#'
#'
#' #param N Total number of replications
#' #param pi
#' #param alpha Significance level
#' #param pi0
#' #param n Size of the replication
#'
#' #return
#'
power_fun <- function(N, pi, alpha, pi0, n) {
pvalue <- vector(mode = "numeric", length = N)
power <- vector(mode = "numeric", length = N)
rej <- vector(mode = "numeric", length = N)
for (i in seq_len(N)) {
# why?
# set.seed(i)
y = rbinom(n, size = 1, prob = pi)
pi_hat = mean(y)
z = (pi_hat - pi0) / sqrt(1 / n * pi_hat * (1 - pi_hat))
rej[i] = ifelse(z < qnorm(0.05, mean = 0, sd = 1), 1, 0)
pvalue[i] = pnorm(q = z, mean = 0, sd = 1)
c_value = qnorm(alpha, mean = 0, sd = 1)
aug_term = (pi - pi0) / sqrt(1 / n * pi_hat * (1 - pi_hat))
power[i] = pnorm(c_value - aug_term, mean = 0, sd = 1)
}
mean_pvalue = mean(pvalue, na.rm = TRUE)
sd_pvalue = sd(pvalue, na.rm = TRUE)
# mean_power = ifelse(pi < pi0, mean(power), NA)
mean_power = mean(power, na.rm = TRUE)
sd_power = sd(power, na.rm = TRUE)
rej_rate = mean(pvalue < alpha, na.rm = TRUE)
type1_error = ifelse(pi >= pi0, rej_rate, NA)
type2_error = ifelse(pi < pi0, 1 - mean_power, NA)
type2_error_emp = ifelse(pi < pi0, 1 - rej_rate, NA)
mc_se = sqrt(1 / N * rej_rate * (1 - rej_rate))
df_out <- data.frame(
N = N,
pi = pi,
alpha = alpha,
pvalue = mean_pvalue,
pvalue2 = sd_pvalue,
power = mean_power,
ESE_power = sd_power,
rejection_rate = rej_rate,
Type_I_error = type1_error,
type_II_error = type2_error,
Type_II_error = type2_error_emp,
MC_SE = mc_se
)
# moved this to above
# rownames(df_out) = paste0("N=", N, ", pi=", pi, ", alpha=", alpha)
# why?
# df_out = round(df_out, 3)
return(df_out)
}
Please read the comments and the changes.
library(tidyverse)
n <- 100
pi0 <- 0.6
# testing the function
power_fun(N=1000,pi=0.5,alpha=0.05, pi0 = pi0, n = n)
#' Plot for all pi going from 0.5 to 1.
seq.default(0, 0.65, length.out = 200) %>%
# seq.default(0.5, 1., length.out = 2) %>%
map_df(function(pi) power_fun(N=1000,pi=pi,alpha=0.05, pi0 = pi0, n = n)) %>%
as_tibble() ->
power_df
# power_df %>% View()
power_df %>% {
ggplot(., aes(pi, power)) +
geom_line() +
# geom_point() +
geom_vline(xintercept = pi0, linetype = "dashed") +
NULL
}
I am trying to implement the following formula in R where r0, t, theta0 and alpha are constants. Also, I is a Modified Bessel function of the first kind. My issue, I suppose, is from the Sum term to the end of the formula. I set n = 150 given that the function converges to zero fast so there is no need to go beyond 150. I am using the "Bessel" package.
Formula1
Formula2
Results to reproduce first row = t, second row = Defaultcorr in %
Here is what I have thus far. I can't seem to find my mistake. Defaultcorr should be 0.04 % when t = 1 (according to the image "Results to reproduce").
To obtain this result " m " should be equal to 6.234611709.
V1 = 5
V2 = 5
K1 = 1
K2 = 1
sigma1 = 0.3
sigma2 = 0.3
Z1 = log((V1/K1)/sigma1)
Z2 = log((V2/K2)/sigma2)
t = 1
rho = 0.4
#One firm default -> Firm #1 when lambda = mu
PD_asset1 = 2 * pnorm(-(Z1/sqrt(t)))
PD_asset1
PD_asset2 = 2 * pnorm(-(Z2/sqrt(t)))
PD_asset2
#Results assuming that lambda = mu
#Conditions for alpha, theta0, r0
if (rho < 0) { #alpha
alpha = atan(-(sqrt(1-rho^2)) / rho)
} else {
alpha = pi + atan(-(sqrt(1-rho^2)) / rho)
}
if (rho > 0) { #theta0
theta0 = atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
} else {
theta0 = pi + atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
}
r0 = (Z2 / sin(theta0)) #r0
#Simplified function
h = function(n) {
(sin((n * pi * theta0)/alpha)/n)
}
n = seq(1, 150, 2)
Bessel1 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) + 1)), FALSE))
Bessel2 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) - 1)), FALSE))
l = matrix(data = n, ncol = n)
m = apply((h(l)*(Bessel1 + Bessel2)), 2, FUN = sum)
PD_asset1_or_asset2 = 1 - (((2 * r0)/(sqrt(2*pi*t))) * (exp(-(r0^2)/(4*t))) * m)
PD_asset1_or_asset2
Var_asset1 = PD_asset1 * (1 - PD_asset1)
Var_asset1
Var_asset2 = PD_asset2 * (1 - PD_asset2)
Var_asset2
PD_asset1_and_asset2 = PD_asset1 + PD_asset2 - PD_asset1_or_asset2
PD_asset1_and_asset2
Defaultcorr = (PD_asset1_and_asset2 - (PD_asset1 * PD_asset2)) / (sqrt(Var_asset1 * Var_asset2))
Defaultcorr
Any help would be appreciated. Thank you
Consider the following example of nonlinear optimization problem. The procedure is too slow to apply in simulation studies. For example, in case of my studies, it takes 2.5 hours for only one replication. How to speed up the process so that the processing time could also be optimized?
library(mvtnorm)
library(alabama)
n = 200
X <- matrix(0, nrow = n, ncol = 2)
X[,1:2] <- rmvnorm(n = n, mean = c(0,0), sigma = matrix(c(1,1,1,4),
ncol = 2))
x0 = matrix(c(X[1,1:2]), nrow = 1)
y0 = x0 - 0.5 * log(n) * (colMeans(X) - x0)
X = rbind(X, y0)
x01 = y0[1]
x02 = y0[2]
x1 = X[,1]
x2 = X[,2]
pInit = matrix(rep(0.1, n + 1), nrow = n + 1)
outopt = list(kkt2.check=FALSE, "trace" = FALSE)
f1 <- function(p) sum(sqrt(pmax(0, p)))/sqrt(n+1)
heq1 <- function(p) c(sum(x1 * p) - x01, sum(x2 * p) - x02, sum(p) - 1)
hin1 <- function(p) p - 1e-06
sol <- alabama::auglag(pInit, fn = function(p) -f1(p),
heq = heq1, hin = hin1,
control.outer = outopt)
-1 * sol$value