nlstools - nlsBoot not working - r

I'm trying to use nlsBoot function from the nlstools package by applying it to a function I created. I get an error when using nlsBoot from the output of my function. However, if I use directly the nls function with the data it works. What is happening and is there a way around this?
# Nonlinear function to generate data
NEE <- function(GPmax, alpha, resp, PAR) {
((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp
}
#some data
plot <- rep(c(1,2), each = 2000)
PAR <- 1:2000
dat <- data.table(plot, PAR)
dat[, GPP := (NEE(12, 0.73, -2, PAR) + rnorm(length(PAR), sd=2))]
library(nlstools)
# Function I created
model.fun <- function(df){
fit <- nls(GPP ~ ((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp,
start = list(GPmax = 12, alpha = 0.73, resp = -2), data = df)
return(list(b = summary(nlsBoot(fit))))
}
models <- dat[, list(model.fun(.SD)) , by = .(plot)]
# Error
# Error in data2[, var1] <- fitted1 + sample(scale(resid1, scale = FALSE), :
# object of type 'closure' is not subsettable
# Using nls directly outside of the function I created for plot 1.
mod1 <- nls(GPP ~ ((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp,
start = list(GPmax = 12, alpha = 0.73, resp = -2), data = dat[plot==1])
# Bootstrap of residuals
summary(nlsBoot(mod1,niter=5))
mod2 <- nls(GPP ~ ((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp,
start = list(GPmax = 12, alpha = 0.73, resp = -2), data = dat[plot==2])
# Bootstrap of residuals
summary(nlsBoot(mod2,niter=5))
# works

I would write the bootstrapping myself. This gives you more control and you avoid this kind of scoping issues:
library(boot)
model.fun <- function(dt){
fit <- nls(GPP ~ ((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp,
start = list(GPmax = 12, alpha = 0.73, resp = -2), data = dt)
#this copy should be avoided if you have big data, but I don't have time right now:
df <- copy(dt)
df[, fitted := fitted(fit)]
df[, resid := residuals(fit)]
fun <- function(df, inds) {
df[, bootGPP := fitted + resid[inds]]
tryCatch(coef(nls(bootGPP ~ ((alpha * PAR * GPmax)/((alpha * PAR)+ GPmax)) - resp,
start = list(GPmax = 12, alpha = 0.73, resp = -2), data = df)),
error = function(e) c("GPmax" = NA, "alpha" = NA, "resp" = NA))
}
b <- boot(df, fun, R = 1000)
res0 <- b$t0
res1 <- apply(b$t, 2, sd, na.rm = TRUE)
res2 <- res0 - colMeans(b$t, na.rm = TRUE)
return(as.list(setNames(c(sum(!is.na(b$t[,1])), res0, res1, res2), c("n", "GPmax", "alpha", "resp","SEGPmax",
"SEalpha", "SEresp","BiasGPmax", "Biasalpha", "Biasresp"))))
}
set.seed(42)
models <- dat[, model.fun(.SD) , by = .(plot)]
# plot n GPmax alpha resp SEGPmax SEalpha SEresp BiasGPmax Biasalpha Biasresp
#1: 1 1000 12.60382 0.9308744 -1.3579906 1.249449 0.2729928 1.263640 -0.11642169 -0.04376221 -0.11526536
#2: 2 1000 13.58702 0.8660450 -0.5081954 1.109599 0.2085150 1.125234 -0.06664517 -0.02241303 -0.06447617

Related

Delayed Differential Equations using Desolve

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")

How to plot a figure of power and true value of unknown parameter in R?

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 run the MCMC for SIR model code on my R software but there is no output until now

I tried to run code from https://cran.r-project.org/web/packages/MultiBD/vignettes/SIR-MCMC.pdf on my R software - they are still running but no output until now but I can run the following code on an online R compiler. This is the codes:
library(MultiBD)
data(Eyam)
Eyam
loglik_sir <- function(param, data) {
alpha <- exp(param[1]) # Rates must be non-negative
beta <- exp(param[2])
# Set-up SIR model
drates1 <- function(a, b) { 0 }
brates2 <- function(a, b) { 0 }
drates2 <- function(a, b) { alpha * b }
trans12 <- function(a, b) { beta * a * b }
sum(sapply(1:(nrow(data) - 1), # Sum across all time steps k
function(k) {
log(
dbd_prob( # Compute the transition probability matrix
t = data$time[k + 1] - data$time[k], # Time increment
a0 = data$S[k], b0 = data$I[k], # From: S(t_k), I(t_k)
drates1, brates2, drates2, trans12,
a = data$S[k + 1], B = data$S[k] + data$I[k] - data$S[k + 1],
computeMode = 4, nblocks = 80 # Compute using 4 threads
)[1, data$I[k + 1] + 1] # To: S(t_(k+1)), I(t_(k+1))
)
}))
}
logprior <- function(param) {
log_alpha <- param[1]
log_beta <- param[2]
dnorm(log_alpha, mean = 0, sd = 100, log = TRUE) +
dnorm(log_beta, mean = 0, sd = 100, log = TRUE)
}
library(MCMCpack)
alpha0 <- 3.39
beta0 <- 0.0212
post_sample <- MCMCmetrop1R(fun = function(param) { loglik_sir(param, Eyam) + logprior(param)
}, theta.init = log(c(alpha0, beta0)), mcmc = 500, burnin = 100)
plot(as.vector(post_sample[,1]), type = "l", xlab = "Iteration", ylab =
expression(log(alpha)))
plot(as.vector(post_sample[,2]), type = "l", xlab = "Iteration", ylab = expression(log(beta)))
library(ggplot2)
x = as.vector(post_sample[,1])
y = as.vector(post_sample[,2])
df <- data.frame(x, y)
ggplot(df,aes(x = x,y = y)) +
stat_density2d(aes(fill = ..level..), geom = "polygon", h = 0.26) +
scale_fill_gradient(low = "grey85", high = "grey35", guide = FALSE) +
xlab(expression(log(alpha))) +
ylab(expression(log(beta)))
quantile(exp(post_sample[,1]), probs = c(0.025,0.975))
quantile(exp(post_sample[,2]), probs = c(0.025,0.975))
I realize that this is the part of the codes that took long time to run but produce no output :
post_sample <- MCMCmetrop1R(fun = function(param) { loglik_sir(param, Eyam) + logprior(param)},
theta.init = log(c(alpha0, beta0)), mcmc = 500, burnin = 100)
I think my R software is the problem but what is it?

Censoring in rjags - Invalid parent values

I'm having troubles reimplementing a model from winbugs on rjags. I'm getting the Invalid parent values error which is the error you get when censoring was not correctly setup, but I can't see my mistake.
This is the original model on WinBugs:
model {
for(i in 1 : N) {
times[i] ~ dweib(v, lambda[i]) T(censor[i],)
lambda[i] <- exp(beta0 + beta1*type[i])
S[i] <- exp(-lambda[i]*pow(times[i],v));
f[i] <- lambda[i]*v*pow(times[i],v-1)*S[i]
h[i] <- f[i]/S[i]
}
beta0 ~ dnorm(0.0, 0.0001)
beta1 ~ dnorm(0.0, 0.0001)
v ~ dexp(0.001)
median0 <- pow(log(2) * exp(-beta0), 1/v)
median1 <- pow(log(2) * exp(-beta0-beta1), 1/v)
}
Setting up a reproducible example:
type <- as.factor(c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0))
censor <- c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,882,892,1031,
1033,1306,1335,0,1452,1472,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,381,0,0,0,0,0,0,0,0,0,529,0,
0,0,0,0,0,0,0,0,945,0,0,1180,0,0,1277,1397,1512,1519)
times <-c (17,42,44,48,60,72,74,95,103,108,122,144,167,170,183,185,193,195,197,208,234,235,254,307,315,401,
445,464,484,528,542,567,577,580,795,855,NA,NA,NA,NA,NA,NA,1366,NA,NA,1,63,105,129,182,216,250,262,
301,301,342,354,356,358,380,NA,383,383,388,394,408,460,489,499,524,NA,535,562,675,676,748,748,778,
786,797,NA,955,968,NA,1245,1271,NA,NA,NA,NA)
df <- tibble(type = type, censor = censor, time = times) %>%
mutate(censor_limit = replace(censor, censor == 0, max(times, na.rm = TRUE))) %>%
mutate(is_censored = ifelse(is.na(time), 1, 0)) %>%
mutate(time_init = ifelse(is_censored == 1, censor_limit + 1, NA))
df$censor <- NULL
head(df)
And this is the rjags part:
m <- textConnection("model {
for(i in 1 : N) {
isCensored[i] ~ dinterval(times[i], censorLimit[i])
times[i] ~ dweib(v, lambda[i])
lambda[i] <- exp(beta0 + beta1*type[i])
S[i] <- exp(-lambda[i]*pow(times[i],v));
f[i] <- lambda[i]*v*pow(times[i],v-1)*S[i]
h[i] <- f[i]/S[i]
}
beta0 ~ dnorm(0.0, 0.0001)
beta1 ~ dnorm(0.0, 0.0001)
v ~ dexp(0.001)
# Median survival time
median0 <- pow(log(2) * exp(-beta0), 1/v)
median1 <- pow(log(2) * exp(-beta0-beta1), 1/v)
}")
d <- list(N = nrow(df), times = df$time, type = df$type, isCensored = df$is_censored,
censorLimit = df$censor_limit)
inits1 = function() {
inits = list(v = 1, beta0 = 0, beta1=0, times = df$time_init)
}
mod <- jags.model(m, data = d, inits = inits1, n.chains = 3)
update(mod, 1e3)
mod_sim <- coda.samples(model = mod, variable.names = c("lambda", "median0", "median1"), n.iter = 5e3)
mod_csim <- as.mcmc(do.call(rbind, mod_sim))
Output:
Compiling model graph
Resolving undeclared variables
Allocating nodes
Graph information:
Observed stochastic nodes: 164
Unobserved stochastic nodes: 19
Total graph size: 910
Initializing model
Deleting model
Error in jags.model(m, data = d, inits = inits1, n.chains = 3): Error in node h[35]
Invalid parent values

Error in R-script: error in abs (alpha) non-numeric argument to mathematical function

I am trying to reproduce some results from the book "Financial Risk Modelling and Portfolio Optimisation with R" and I get an error that I can't seem to get my head around.
I get the following error in the COPPosterior function:
error in abs(alpha) : non-numeric argument to mathematical function
Is anyone able to see why I get the error?
The error is from the following script:
library(urca)
library(vars)
library(fMultivar)
## Loading data set and converting to zoo
data(EuStockMarkets)
Assets <- as.zoo(EuStockMarkets)
## Aggregating as month-end series
AssetsM <- aggregate(Assets, as.yearmon, tail, 1)
head(AssetsM)
## Applying unit root tests for sub-sample
AssetsMsub <- window(AssetsM, start = start(AssetsM),
end = "Jun 1996")
## Levels
ADF <- lapply(AssetsMsub, ur.df, type = "drift",
selectlags = "AIC")
ERS <- lapply(AssetsMsub, ur.ers)
## Differences
DADF <- lapply(diff(AssetsMsub), ur.df, selectlags = "AIC")
DERS <- lapply(diff(AssetsMsub), ur.ers)
## VECM
VEC <- ca.jo(AssetsMsub, ecdet = "none", spec = "transitory")
summary(VEC)
## Index of time stamps in back test (extending window)
idx <- index(AssetsM)[-c(1:60)]
ANames <- colnames(AssetsM)
NAssets <- ncol(AssetsM)
## Function for return expectations
f1 <- function(x, ci, percent = TRUE){
data <- window(AssetsM, start = start(AssetsM), end = x)
Lobs <- t(tail(data, 1))
vec <- ca.jo(data, ecdet = "none", spec = "transitory")
m <- vec2var(vec, r = 1)
fcst <- predict(m, n.ahead = 1, ci = ci)
LU <- matrix(unlist(fcst$fcst),
ncol = 4, byrow = TRUE)[, c(2, 3)]
RE <- rep(0, NAssets)
PView <- LU[, 1] > Lobs
NView <- LU[, 2] < Lobs
RE[PView] <- (LU[PView, 1] / Lobs[PView, 1] - 1)
RE[NView] <- (LU[NView, 1] / Lobs[NView, 1] - 1)
names(RE) <- ANames
if(percent) RE <- RE * 100
return(RE)
}
ReturnEst <- lapply(idx, f1, ci = 0.5)
qv <- zoo(matrix(unlist(ReturnEst),
ncol = NAssets, byrow = TRUE), idx)
colnames(qv) <- ANames
tail(qv)
library(BLCOP)
library(fPortfolio)
## Computing returns and EW-benchmark returns
R <- (AssetsM / lag(AssetsM, k = -1) -1.0) * 100
## Prior distribution
## Fitting of skewed Student's t distribution
MSTfit <- mvFit(R, method = "st")
mu <- c(MSTfit#fit[["beta"]])
S <- MSTfit#fit[["Omega"]]
skew <- c(MSTfit#fit[["alpha"]])
df <- MSTfit#fit[["df"]]
CopPrior <- mvdistribution("mvst", dim = NAssets, mu = mu,
Omega = S, alpha = skew, df = df)
## Pick matrix and view distributions for last forecast
RetEstCop <- ReturnEst[[27]]
RetEstCop
PCop <- matrix(0, ncol = NAssets, nrow = 3)
colnames(PCop) <- ANames
PCop[1, ANames[1]] <- 1
PCop[2, ANames[2]] <- 1
PCop[3, ANames[4]] <- 1
Sds <- apply(R, 2, sd)
RetViews <- list(distribution("norm", mean = RetEstCop[1],
sd = Sds[1]),
distribution("norm", mean = RetEstCop[2],
sd = Sds[2]),
distribution("norm", mean = RetEstCop[4],
sd = Sds[4])
)
CopViews <- COPViews(pick = PCop, viewDist = RetViews,
confidences = rep(0.5, 3),
assetNames = ANames)
## Simulation of posterior
NumSim <- 10000
CopPost <- COPPosterior(CopPrior, CopViews,
numSimulations = NumSim)
print(CopPrior)
print(CopViews)
slotNames(CopPost)
look at the structure of MSTfit:
str(MSTfit)
You can see that if you want the estimated alpha value, you need to access it via:
MSTfit#fit$estimated[['alpha']]
rather than
MSTfit#fit[['alpha']]

Resources