ODE waring messages in simple ODE problem - r

I am working on a complicated model to study the population dynamics. I am getting some warning messages and not sure why? I am not sure does it have any effect on the solution.
I am reproducing the same error in a sample Lotka-Volterra Model. Please consider this as an example, it may not correspond to actual dynamics of the model.
(1) Could you pleases explain, how to eliminate these warnings?
(2) Does it have any effect on the output?
Thanks for reading. Here is the code:
library(deSolve)
predpreyLV<-function(t,y,p){
N<-y[1]
P<-y[2]
with(as.list(p),{
dNdt<- r*N*(1-(N/1000))-a*P*N
dPdt<- -b*P+f*P*N
return(list(c(dNdt,dPdt)))
})
}
rootfun <- function (t,y,parms){
if (t>=200 && y[2]>130)
return (0)
else
return (1)
}
eventfun <- function (t,y,parms){
y[2] = y[2]*0.99
return (y)
}
r<-0.5; a<-0.01; f<-0.01; b<-0.2;
p<-c(r=r,a=a, b=b, f=f)
y0<-c(N=25, P=5)
times<-seq(0,500,0.01)
LV.out<-ode(y=y0,times,predpreyLV, p,method="lsodar",
rootfunc = rootfun, events = list(func=eventfun, time = seq(198,200,0.01)))
I am getting following warnings and need to why it is happening:
*Warning messages:
1: In checkevents(events, times, Ynames, dllname, TRUE) :
Not all event times 'events$time' are in output 'times' so they are automatically included.
2: In checkevents(events, times, Ynames, dllname, TRUE) :
Some time steps were very close to events - only the event times are used in these cases.*

One method is to round both time vectors to the required precision:
times <- round(seq(0,500,0.01), 2)
evtime <- round(seq(198,200,0.01), 2)
evtime %in% times ## check if all events are in 'times'
LV.out<-ode(y=y0,times,predpreyLV, p,method="lsodar",
rootfunc = rootfun, events = list(func=eventfun, time = evtime))
plot(LV.out)
Hope it helps!

Related

Subscript out of bounds error with custom function in lidR::catalog_apply()

I am attempting to create a raster of pixel metrics for a large collection of lidar data using the lidR:: package. I want to first remove any outlier points in the point cloud, normalize the point cloud to a digital terrain model, and finally, calculate the standard z pixel metrics on a 20 m X 20 m grid. I followed the guidance on the lidR:: package's book and its vignettes for using the catalog_apply() engine. I have created a "low level API" function that first has a conditional to check if the input is a LAScatalog, and then runs the function through catalog_apply , then checks if the input is a LAScluster, and then runs the function directly and clips the chunk buffers from the output, and then finally checks if the input is a LAS, and then explicitly runs the function. I am struggling with getting the function to run properly on a LAScatalog. When I run the function on a LAS file, it works with out error, however, when I run it on a LAScatalog, all chunks show an error on the plot, and when the routine finishes, it throws this error:
Error in any_list[[1]] : subscript out of bounds
In addition: There were 15 warnings (use warnings() to see them)
This error makes me think that I am missing some sort of catalog_apply engine or SpatRaster driver option that tells the function how to merge the output chunks back together to form the final output, but I am not sure which option that would be, and I haven't been able to find any answers on the lidR:: wiki page, vignettes, or book, nor can I find a similar issue here on Stackoverflow. Any advice would be much appreciated. Below is my reproducible example:
##Loading Necessary Packages##
library(lidR)
library(future)
#Reading in the data##
LASfile <- system.file("extdata", "MixedConifer.laz", package="lidR")
ctg <- readLAScatalog(LASfile) # As LAScatalog
las<-readLAS(LASfile) # As LAS
####Custom function####
raster_metrics<-function(las, dtm_ras, grid_size, sensitivity){#start function
if(is(las, "LAScatalog")){#Start first conditional for LASCatalog
options <-list(automerge=TRUE, need_buffer=TRUE)
output<-catalog_apply(las, raster_metrics, grid_size=grid_size, sensitivity=sensitivity, .options=options)
return(output)
} else { #end first condition start first else
if (is(las, "LAScluster")){ #start second conditional for LAScluster
las<-readLAS(las)
if (is.empty(las)){return(NULL)}#Conditional for empty chunk (self contained)
output_tmp<-raster_metrics(las, dtm_ras, grid_size, sensitivity)
bbox<-sf::st_bbox(las)
output<-st_crop(output_tmp, bbox)
return(output)
} else {# End second conditional begin second else
if (is(las, "LAS")){
p95 <- pixel_metrics(las, ~quantile(Z, probs = 0.95), grid_size)
las <- merge_spatial(las, p95, "p95")
las <- filter_poi(las, Z < p95*sensitivity)
las$p95 <- NULL
norm<-las - dtm_ras
output<-pixel_metrics(norm, .stdmetrics_z, grid_size)
return(output)
}else { #end final conditional begin final else
stop("This type is not supported.")
}#end final else
} #end second else
} #end first else
} #end function
##Creating a rasterized dtm to feed to the function##
dtm_ras<-rasterize_terrain(ctg, algorithm = knnidw())
##Defining some function and engine option setttings##
grid_size<-20.0
sensitivity<-1.2
chunk_size<-grid_size*50
chunk_buffer<-grid_size*2
##Setting driver and engine option parameters##
opt_output_files(ctg)<-paste0(tempdir(), "/{XCENTER}_{YCENTER}_{ID}_Norm_Height")
opt_chunk_size(ctg)<-chunk_size
opt_chunk_buffer(ctg)<-chunk_buffer
opt_wall_to_wall(ctg)<-TRUE
opt_stop_early(ctg)<-FALSE
opt_filter(ctg)<-"-drop_withheld"
opt_select(ctg)<-"xyz"
ctg#output_options$drivers$SpatRaster$param$overwrite<-TRUE
##Setting up parallel processing##
plan(multisession, workers = nbrOfWorkers()-1)
set_lidr_threads(nbrOfWorkers()-1)
##Running the function##
example1<-raster_metrics(las=ctg, dtm_ras = dtm_ras, grid_size = grid_size, sensitivity = sensitivity)#Throws error
example2<-raster_metrics(las=las, dtm_ras = dtm_ras, grid_size = grid_size, sensitivity = sensitivity)#Works without error
UPDATE 2/3/2023
Doing a little digging on my own, it appears that this error gets thrown by the internal lidR::: function engine_merge(), which has an argument any_list=. This makes me think that somehow my function violates one of the template rules of catalog_apply(), but I copied the template verbatim from the vignette. Hoping this elucidates the source of my error.
You missed to propagate dtm_ras
output<-catalog_apply(las, raster_metrics, dtm_ras = dtm_ras, grid_size=grid_size, sensitivity=sensitivity, .options=options)
You used incorrect package to crop
bbox <-terra::ext(las)
output<-terra::crop(output_tmp, bbox)
With the following function it works in sequential mode
raster_metrics<-function(las, dtm_ras, grid_size, sensitivity)
{
if(is(las, "LAScatalog"))
{
options <-list(automerge=FALSE, need_buffer=TRUE)
output<-catalog_apply(las, raster_metrics, dtm_ras = dtm_ras, grid_size=grid_size, sensitivity=sensitivity, .options=options)
return(output)
}
else if (is(las, "LAScluster"))
{
las<-readLAS(las)
if (is.empty(las)){return(NULL)}
output_tmp <- raster_metrics(las, dtm_ras, grid_size, sensitivity)
bbox <-terra::ext(las)
output<-terra::crop(output_tmp, bbox)
return(output)
}
else if (is(las, "LAS"))
{
p95 <- pixel_metrics(las, ~quantile(Z, probs = 0.95), grid_size)
las <- merge_spatial(las, p95, "p95")
las <- filter_poi(las, Z < p95*sensitivity)
las$p95 <- NULL
norm <- las - dtm_ras
output<-pixel_metrics(norm, .stdmetrics_z, grid_size)
return(output)
}
else
{
stop("This type is not supported.")
}
}
However it does not work in parallel because terra's SpatRaster are not serializable. To say it simple, when the dtm_ras is sent to each worker, it no longer exists. This is not an issue with lidR it is an issue with terra. In lidR functions, I use an internal workarounds to deal with SpatRaster by converting them to raster.
On your side the simplest option is to use a RasterLayer from raster.

replacement has length zero in list() in r

I'm trying to run this code, and I'm using mhadaptive package, but the problem is that when I run these code without writing metropolis_hastings (that is one part of mhadaptive package) error does not occur, but when I add mhadaptive package the error occur. What should I do?
li_F1<-function(pars,data) #defining first function
{
a01<-pars[1] #defining parameters
a11<-pars[2]
epsilon<<-pars[3]
b11<-pars[4]
a02<-pars[5]
a12<-pars[6]
b12<-pars[7]
h<-pars[8]
h[[i]]<-list() #I want my output is be listed in the h
h[[1]]<-0.32082184 #My first value of h is known and other values should calculate by formula
for(i in 2:nrow(F_2_))
{
h[[i]]<- ((a01+a11*(h[[i-1]])*(epsilon^2)*(h[[i-1]])*b11)+(F1[,2])*((a02+a12*(h[[i-1]])*(epsilon^2)+(h[[i-1]])*b12)))
pred<- h[[i]]
}
log_likelihood<-sum(dnorm(prod(h[i]),pred,sd = 1 ,log = TRUE))
return(h[i])
prior<- prior_reg(pars)
return(log_likelihood + prior)
options(digits = 22)
}
prior_reg<-function(pars) #defining another function
{
epsilon<<-pars[3] #error
prior_epsilon<-pt(0.95,5,lower.tail = TRUE,log.p = FALSE)
return(prior_epsilon)
}
F1<-as.matrix(F_2_) #defining my importing data and simulatunig data with them
x<-F1[,1]
y<-F1[,2]
d<-cbind(x,y)
#using mhadaptive package
mcmc_r<-Metro_Hastings(li_func = li_F1,pars=c(10,15,10,10,10,15),par_names=c('a01','a02','a11','a12','b11','b12'),data=d)
By running this code this error occur.
Error in h[[i]] <- list() : replacement has length zero
I'll so much appreciate who help me.

R - numerical errors with analytical gradient?

I've got the following code:
theta=0.05
n=1000
m=200
r=rnorm(2000)
#ER check function
nu=Vectorize(function(a,tau){return(abs(tau-(a<0))*a^2)})
#Selecting 10 lowest sum values (lowest10 function returns indices)
lowest10=function(x){
values=sort(x)[1:min(10,length(x))]
indices=match(values,x)
return(indices)
}
sym.expectile=function(beta,e,abs.r){return(beta[1]+beta[2]*e+beta[3]*abs.r)}
ERsum=function(beta,tau,start,end){
y=r[(start+1):end]
X1=rep(1,n-1)
X3=abs(r[start:(end-1)])
X2=c()
X2[1]=e.sym.optimal[start-m]
for (i in 2:(n-1)){
X2[i]=sym.expectile(beta,X2[i-1],X3[i-1])
}
X=matrix(c(X1,X2,X3),ncol=3)
res=y-X%*%beta
sum.nu=mean(nu(res,tau))
return(sum.nu)
}
ERsum.gr=function(beta,tau,start,end){
y=r[(start+1):end]
X1=rep(1,n-1)
X3=abs(r[start:(end-1)])
X2=c()
X2[1]=e.sym.optimal[start-m]
for (i in 2:(n-1)){
X2[i]=sym.expectile(beta,X2[i-1],X3[i-1])
}
X=matrix(c(X1,X2,X3),ncol=3)
partial.beta0=c()
for (i in 1:(n-1)){partial.beta0[i]=-(1-beta[2]^(i))/(1-beta[2])}
gr.beta0=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta0)/1000
partial.beta1=c()
partial.beta1[1]=-X2[1]
for (i in 2:(n-1)){partial.beta1[i]=partial.beta1[i-1]*beta[2]-X2[i]}
gr.beta1=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta1)/1000
partial.beta2=c()
partial.beta2[1]=-X3[1]
for (i in 2:(n-1)){partial.beta2[i]=partial.beta2[i-1]*beta[2]-X3[i]}
gr.beta2=2/T*sum(abs(tau-(y<X%*%beta))*(y-X%*%beta)*partial.beta2)/1000
c(gr.beta0,gr.beta1,gr.beta2)
}
beta=matrix(nrow=1e4,ncol=3)
beta[,1]=runif(1e4,-1,0)#beta0
beta[,2]=runif(1e4,0,1)#beta1
beta[,3]=runif(1e4,-1,0)#beta2
e.sym.optimal=c()
tau.found.sym.optim=0.02234724
library('expectreg')
e.sym.optimal[1]=expectile(r[1:m],tau.found.sym.optim)
ERsums.sym=c()
for (i in 1:nrow(beta)){
ERsums.sym[i]=ERsum(beta[i,],tau.found.sym.optim,m+1,m+n)
}
initialbeta.esym=beta[lowest10(ERsums.sym),]
intermedietebeta.esym=matrix(ncol=3,nrow=10)
for (i in 1:10){
intermedietebeta.esym[i,]=optim(initialbeta.esym[i,],ERsum,
gr=ERsum.gr,tau=tau.found.sym.optim,
start=m+1,end=m+n,
method="BFGS")$par
}
I tried to replace the optim function with optimx, but got the following error:
Error: Gradient function might be wrong - check it!
To check if my gradient is ok I tried to evaluate values of gradient function using function grad from numDeriv and directly calling my ERsum.gr function. For the sample vector
beta
[1] -0.8256490 0.7146256 -0.4945032
I obtained following results:
>grad(function(beta) ERsum(c(beta[1],beta[2],beta[3]),tau.found.sym.optim,m+1,m+n),beta)
[1] -0.6703170 2.8812666 -0.5573101
> ERsum.gr2(beta,tau.found.sym.optim,m+1,m+n)
[1] -0.6696467 2.8783853 -0.5567527
So here is my question: is it possible that these differences are just some numerical errors caused by rounding down the partial.beta0, partial.beta1, partial.beta2 which are just the components of the sum representing gradient? I think so, because if my analytical formula for gradient misses something, the discrepancies would be probably much larger, but how can I be sure? If this is a case is there any other way to obtain more accurate values of gradient?
You've got further problems down the line even if you solve the question of whether that is really a proper gradient, which I see as too complex to tackle. If you take out the gr argument and try to run with only optimx instead of optim, you get:
Error in intermedietebeta.esym[i, ] <- optimx(initialbeta.esym[i, ], ERsum, :
number of items to replace is not a multiple of replacement length
This probably relates to the fact that optimx does not return the same structure as is returned by optim:
> optimx(initialbeta.esym[i,],ERsum,
+ tau=tau.found.sym.optim,
+ start=m+1,end=m+n,
+ method="BFGS")$par
NULL
> optimx(initialbeta.esym[i,],ERsum,
+ tau=tau.found.sym.optim,
+ start=m+1,end=m+n,
+ method="BFGS") # leave out `$par`
p1 p2 p3 value fevals gevals niter convcode kkt1 kkt2 xtimes
BFGS -1.0325 0.2978319 0.04921863 0.09326904 102 100 NA 1 TRUE FALSE 3.366
If you disagree with the decision to allow a default gradient estimate, hten you need to narrow down your debugging to the function that throws the error:
Error: Gradient function might be wrong - check it!
> traceback()
3: stop("Gradient function might be wrong - check it! \n", call. = FALSE)
2: optimx.check(par, optcfg$ufn, optcfg$ugr, optcfg$uhess, lower,
upper, hessian, optcfg$ctrl, have.bounds = optcfg$have.bounds,
usenumDeriv = optcfg$usenumDeriv, ...)
1: optimx(initialbeta.esym[i, ], ERsum, gr = ERsum.gr, tau = tau.found.sym.optim,
start = m + 1, end = m + n, method = "BFGS")
And look at the documentation (there was no help page) and code for optimx:::optimx.check. This is the section of code that does the checking:
if (!is.null(ugr) && !usenumDeriv) {
gname <- deparse(substitute(ugr))
if (ctrl$trace > 0)
cat("Analytic gradient from function ", gname,
"\n\n")
fval <- ufn(par, ...)
gn <- grad(func = ufn, x = par, ...)
ga <- ugr(par, ...)
teps <- (.Machine$double.eps)^(1/3)
if (max(abs(gn - ga))/(1 + abs(fval)) >= teps) {
stop("Gradient function might be wrong - check it! \n",
call. = FALSE)
optchk$grbad <- TRUE
}

Error message with objects in 'lsoda' in R

Very new user here. I am trying to use lsoda to solve differential equations stratified into two layers (as denoted by the for(s in 1:2) loop).
When running this full code, I keep getting the error message
object 'N' not found
no matter where or how I try to define N.
Can anyone help spot the error or advise on what I'm doing wrong? Thanks in advance.
R code:
library(deSolve)
Dyn <- function(t, var,par) {
with(as.list(c(par, var)), {
for(s in 1:2){
#Derivatives
dX[s] <- mu*N[s] - sigma*X[s] - (c[s]*beta*(InD[s] +ID[s]+ IdT[s])/N[s])*X[s] - mu*X[s]
dXint[s] <- sigma*X[s] - (1-omega)*(c[s]*beta*(InD[s] +ID[s]+ IdT[s])/N[s])*Xint[s] - mu*Xprep[s]
dInD[s] <- (c[s]*beta*(InD[s] +ID[s]+ IdT[s])/N[s])*X[s] - psi*InD[s]- mu*InD[s]
dID[s] <- (1-omega)*(c[s]*beta*(InD[s] +ID[s]+ IdT[s]) /N[s])*Xint[s]+ psi*InD[s]- mu*ID[s]
N[s] <- X[s]+Xint[s]+InD[s]+ID[s]
diffs <- c(dX[s], dXint[s], dInD[s], dID[s], N[s])}
return(list(diffs))
})}
#Defining parameter and initial values
par <- c(mu=0.033, sigma=0.29, beta=0.40, c=c(2, 30), Ctot=1773600, N=c(332550, 36950), psi=0.022, omega=0.44)
init <- c(X=c(332550,36950), Xint=c(0,0), InD=c(1,1), ID=c(0,0))
t <- seq(0, 30, by=0.1)
#Numerical solution#
Hom.sol <- lsoda(init, t, Dyn,par)
I think you are mixing up parameters and variables. N seems to be defined as a parameter par with dimension 2. However, in your model definition you are updating N with dimension 1.

Check the return values from function Gammad and Truncate (from package distr and truncdist)

After searching the forum, I did not find similair questions. If you find one, please let me know. I would really appreciate.
In R, I need to check the return values from function Gammad and Truncate (from lib distr and truncdist).
It means that if they fail to generate the Gammad and Truncate pdf, a fail value or exception can be returned so that I can handle it.
G0 <- Gammad(scale = s, shape = sh)
# what if Gammad() fails ?
TG <- Truncate(G0, lower = lowerbound, upper = upperbound)
# what if Truncate() fails ?
Thanks !
From the rgamma help page: "Invalid arguments will result in return value NaN, with a warning."
If this is what you see, you could use
ow <- options("warn")
options(warn=2)
G0 <- try(Gammad(scale = s, shape = sh), silent=TRUE)
if(inherits(G0, "try-error")) # handle invalid arguments
options(warn=ow)

Resources