0 vector result in R after running function - r

After I finished running my function, I kept on getting 0s as my answer:
niv_density <- function(returns, mu, delta, alpha, beta, t)
{
t <- 1/t
gamma <- sqrt(alpha^2 - beta^2)
result <- rep(0, (1/t))
for(i in 1:(1/t))
{
term3 <- exp(delta*gamma*t + beta*(returns[i] - mu*t))
term1 <- alpha*delta*t/pi
term2_1 <- besselY(alpha*sqrt(delta^2*t^2 + (returns[i] - mu*t)^2), 1)
term2_2 <- sqrt(delta^2*t^2 + (returns[i] - mu*t)^2)
term2 <- term2_1/term2_2
result[i] <- (term1*term2*term3)
}
}
niv_density(returns, 0, 2, 50, 0, 10)
result
After executing the last part, I get a vector of 0s. I think I'm having a problem with global vs. local scopes, but I'm not sure how to fix it.
dput(returns)
structure(c(-0.003859212, 0.011873365, -0.004826217, -0.004006846,
-0.004527209, -0.005597606, -0.001446292, 0.004890173, 0.001260653,
-0.005469839, 0.001715495, 0.00776223, -6.79514e-05, -0.002405413,
-0.00344927, 0.013203733, 0.009007395, -0.002918161, -0.000682757,
0.003600917, -0.001584568, 0.001778635, 0.003881849, -0.003228443,
0.00809855, -0.003407655, 0.006570117, -0.001629285, -0.001479157,
-0.000683758, 0.007489741, 0.007807378, 0.001399056, -0.000578823,
-0.002437511, -0.000593349, -0.004020762, 0.004744014, -0.001815119,
0.007757796, -0.002401808, -0.00225831, -0.005162853, -0.002256747,
0.032891919, 0.005882631, -0.011822966, -0.005744899, -0.004359233,
0.00405189, 0.017035644, 0.001079738, 0.001845759, -0.004758891,
0.006067706, -0.006027932, -0.00224155, -0.010844493, 0, -0.003861616,
-0.004698823, 0.000397524, 0.001840917, 0.013599978, -0.008376557,
1.92494e-05, 0.010797502, -0.004105023, 0.003119424, -0.004797368,
-0.001962367, 0.002663974, 0.008489008, 0.007827146, -0.000566674,
-0.003404669, -0.000160508, -0.003953786, -0.000635631, 0.0023086,
0.008931147, -0.002761431, 0.013046559, -0.009673618, 0.007572105,
-0.011309217, 0.003777911, -0.004767721, -0.004096769, 0.003915212,
-0.005571037, 0.008566323, -0.009063831, -0.011191246, -0.000639167,
0.002834983, -0.009156367, 0.00189252, 0.007166451, -0.001788182,
-0.002437146, 0.00226261, -0.010459432, -0.001511577, 0.00039628,
-0.00349739, 0.009561965, 0.063504871, 0.003492974, 0.009233691,
0.004795333, -0.003995969, -0.002552804, 6.81834e-05, 0.006134657,
0.006713932, -0.006875273, -0.005108732, 0.006239377, 0.002293386,
-0.01121192, -0.005666844, 0.000894577, -0.012511724, 0.00351622,
-0.009671627, -0.004480382, 0.007385228, -0.009143379, 0.005467177,
0.017094141, 0.005918621, 0.001514995, -0.001356959, 0.015656296,
0.001101646, 0.001457523, 0.0051402, -0.005516804, 0.002832519,
-0.002196811, -0.007752963, 0.009050809, 0.006380147, 0.001995102,
0.002319077, -0.001788715, 0.000845096, -0.009821598, 0.012634302,
-0.001457121, 0.000582262, -0.004083585, -0.004021717, -0.000571503,
0.006159289, -0.010822168, -0.015789222, -0.000657867, 0.013935285,
0.001312777, -0.001172312, 0.003031039, 0.002482838, -0.010634785,
0.014015267, 0.005435065, -0.034817949, 0.005145224, -0.007217488,
0.00458109, 0.012581199, 0.001853981, 0.002118571, -0.011151137,
-0.007933775, 0.011336262, 0.018212375, 0.007815775, 0.006103632,
-0.007270438, -0.001066825, 0.001892988, -0.009740379, 0.012057142,
0.00024459, -0.003702988, 0.014628744, -0.001902607, -7.49322e-05,
-0.005903797, -0.002481339, -0.004266069, 0.01150386, -0.019888508,
0.007657512, -0.004649027, 0, 0.002523089, -0.00072238, -0.021153782,
-0.007969763, 0.005775428, -0.010897333, 0.007468107, -0.009508927,
0.000464995, -0.002430182, 0.010796022, 0.008898853, -0.013079549,
0.027112561, -0.015413991, -0.007630787, 0.007033724, -0.017738864,
-0.015961032, -0.015579591, -0.011802317, -0.002187586, 0.003065715,
0.013389559, -0.000885034, -0.013701533, 0.001976838, 0.001041955,
-0.003616062, 0.005344799, 0.007148373, -0.002877552, -0.007681476,
0.021591165, 0.017966863, -0.058771073, -0.019551973, 0.005203616,
0.002169669, 0.003884158, -0.022568915, 0.002769004, -0.007779571,
0.018998803, -0.001212088, 0.002446011, 0.007740844, 0.012532807,
0.006287039, 0.003958813, 0.01407559, 0.001064047, -0.00862106,
-0.012296938, -0.013967015, 0.010524923, -0.010789529, 0.011953286,
0.000738662, -0.016492003, -0.00257709, -0.015437029, 0.004315983,
0.023337948, 0.008138125, 0.005972748, 0.005915635, 0.010493804,
-0.011895336, -0.005245454, 0.007409717, 0.012596218, -0.005221382,
-0.005462129, 0.008785043, 0.009134618, 0.015541224, 0.016072839,
-0.003827797, 0.000403703, 0.03749696, -0.003386946, -0.008627298,
-0.030790478, -0.003861794, -0.011426323, 0.001393173, 0.008541783,
0.009361445, -0.023851831, 0.024814864, -0.019724128, 0.002621807,
-0.017904622, -0.003584294, -0.019299804, -0.00234839, -0.002685042,
0.002685042, 0.016590137, 0.001401377, -0.006120481, 0.006690448,
-0.004740457, -0.005027981, 0.013204038, -0.002742491, 0.005110009,
-0.006393429, 0.00464228, -0.00270551, -0.011552836, 0.003074876,
0.005139878, 0.002032361, 0.007603533, 0.010491222, 0.000658875,
0.003909991, 0.00236732, 0.019192366, -0.00361624, 0.005696264,
-0.005852811, 0.014805765, 0.00313454, 0.006385073, -0.005475311,
-0.009195918, 0.008472618, -0.000559148, -0.007272851, 0.003748203,
0.001156269, 0.004328552, -0.006107929, -0.012121056, 0.002812434,
-0.009577213, 0.005689626, -0.001941957, 0.006145673, -0.002275509,
-0.006578825, -0.005345298, -0.000327811, 0.003751791, 0.005053343,
0.005157952, -0.022100394, -0.007461083, 0.003576376, 0.00093598,
0.006738706, 0.006976768, 0.001078282, -0.006256189, 0.003313743,
-0.005955287, 0.011771523, 0.001644383, -0.003459295, 0.032863111,
-0.007369908, -0.001099451, 0.004745151, 0.012094786, 0.001167328,
-0.00404787, -0.004345022, -0.001121192, 0.004333763, -0.008483142,
-0.001578184, -0.00046999, 0.005079249, -0.005970832, 0.005543307,
0.006722626, 0, 0.001715197, 0.011776868, 0.013308783, -0.004160112,
-0.000304697, 0.014924613, 0.007204855, -0.00509816, 0.007186504,
0.002287253, -0.009948655, -0.001000861, -0.00431929, -0.00347645,
0.005015994, -0.007540969, 0.00558486, -0.005661924, -0.006602168,
-0.002824197, 0.001939661, 0.006563001, -0.009757559, -0.00978824,
-0.001247868, 0.002622219, -0.009097288, -0.014394158, -0.00292424,
0.002644891, -0.005572549, -0.003181826, 0.002676673, 0.007032888,
0.002127581, 0.005281961, 0.016021024, 0.001232531, 0.005515082,
0.000450254, 0.003568462, 0.006277841, -0.003823264, -0.032527132,
0.021873831, -0.003231721, -0.000368515, -0.001397511, -0.010973353,
-0.011563657, -0.010061858, 0.005714484, 0.007472816, 0.003407539,
-0.000612977, -0.000800283, -0.001900635, -0.000865432, -0.003630001,
0.00562073, 0.001858425, 0.010064273, -0.006584881, -0.001470899,
0.005433816, -0.002510864, -0.001071656, -0.005130965, 2.35065e-05,
0.003445676, 0.01374472, -0.001123534, 0.006067276, 0.004050843,
-0.000773321, -0.003401186, 0.001908336, -0.003562041, -0.001180884,
-0.003133416, 0.005819655, -0.002096198, -4.92007e-05, 0.002838133,
-0.010010669, 0.00557654, -0.000122526, 0.022760252, -0.005618111,
0.014434193, 0.001716112, 0.01567573, 0.001566116, -0.003071945,
-0.018146189, -0.012123038, -0.007480614, 0.007735601, -0.00436506,
0.003091618, 0.004704796, 0.001184206, 0.010066361, 0.005389096,
-0.007021784, -0.004211278, -0.001740557, -0.00628043, 0.002434464,
-0.000333944, 0.010815674, 0.016910153, 0, -0.01318228, -0.002858256,
0.024721185, 0.001006412, -0.003651077, 0.009682259, -0.007093437,
-0.002005597, 0.002424598, -0.015024047, 0.015051995, 0.004720944
), na.action = structure(504L, class = "omit"))


Your version is not working because result is local to the function's body and it is lost as you exit the function. I suspect you have another result object in your global environment (a vector of zeroes) and that's what you always get when you try to check your result.
Instead, make your function explicitly return result by adding a return statement at the end:
niv_density <- function(returns, mu, delta, alpha, beta, n) {
t <- 1/n
gamma <- sqrt(alpha^2 - beta^2)
result <- rep(0, n)
for(i in seq_len(n)) {
term3 <- exp(delta*gamma*t + beta*(returns[i] - mu*t))
term1 <- alpha*delta*t/pi
term2_1 <- besselY(alpha*sqrt(delta^2*t^2 + (returns[i] - mu*t)^2), 1)
term2_2 <- sqrt(delta^2*t^2 + (returns[i] - mu*t)^2)
term2 <- term2_1/term2_2
result[i] <- (term1*term2*term3)
}
return(result)
}
And when calling the function, assign the result as follows:
result <- niv_density(returns, 0, 2, 50, 0, 10)
(and maybe you should avoid calling a variable result, I'm sure you can find a more descriptive name from the context.)

Related

deSolve: Can't understand how to early stop ode solver with root functions

I am confused about how to stop the solver when a certain condition is met. I prepared a dummy SIR model that should stop once the I compartment reaches a certain value. But in my code the solver simply continues on:
library(deSolve)
library(dplyr)
pars <- c(beta = .1, gamma = .04)
init <- c(S = 100, I = .01, R = 0, trig = 0)
rootFun <- function(t, y, pars) {
r <- 1
if (y['I'] > 10 & y['trig'] == 0) r <- 0
if (y['I'] > 80) r <- 2
if (r == 2) print('should finish')
return(r)
}
eventFun <- function(t, y, pars) {
message('First threshold passed!')
y['trig'] <- 1
y
}
derFun <- function(t, y, pars) {
with(as.list(c(y, pars)), {
dS = -S * I * beta
dI = S * I * beta - I * gamma
dR = I * gamma
list(c(dS, dI, dR, 0))
})
}
ode(y = init, func = derFun, parms = pars, times = 1:100, events = list(func = eventFun, root = TRUE, terminalroot = 2),
rootfun = rootFun) %>% invisible()
The solver should stop if the root evaluates to 2, trigger an event if evaluates to zero and continue in all the other cases. But instead the root being 2 does not stop it.

In the event(root=>action) mechanism, the event is located at a root of a continuous function of the state. In your case, the root functions would be y['I']-10 and y['I']-80, rootfun is the list of these functions (or the function returning the list of their values).
This function gets evaluated frequently on all parts of the solution curve to detect a sign change (it might also work, for some steppers, if a component is piecewise constant and the root function hits exactly zero). The interval of a sign change is then refined with a bracketing method. Apart from providing these values, no processing should and can happen in the root function.
The action on the state is encoded in eventfun, it returns the new state after the event. Internally, the integration is stopped at the root and restarted anew with the returned state as initial value.
Termination is encoded with the terminalroot variable. It is an index and determines which root function provides the termination event.
So
rootFun <- function(t, y, pars) {
return(c(y['I']-10, y['I']-80))
}
should work with all the other lines unchanged. Note that the trigger component is now unused and could be removed.

replacement has length zero in fibonacci sequence in R code

So I have this code for the fibonacci sequence, and I keep getting an error when I try to print out the value of the function.
fibonacci <- function(nn) {
if (!(nn%%1==0) | (nn<1)){
return(0)
}
my.fib <- c(1,1)
for (kk in 3:nn){
my.fib[kk] <- my.fib[kk-1] + my.fib[kk-2]
}
return(my.fib[nn])
}
fibonacci(7)
fibonacci(5)
fibonacci(1)
fibonacci(1.5)
fibonacci(0)
It prints everything correctly for 7,5,1.5 and 0, as it gives me the vaules 13, 5, 0, and 0. But when trying to print fibonacci(1), I get the error
Error in my.fib[kk] <- my.fib[kk - 1] + my.fib[kk - 2] :
replacement has length zero
I want to leave as much as the code the same as possible.

Add another if condition to check for nn = 1.
fibonacci <- function(nn) {
if (!(nn%%1==0) | (nn<1)){
return(0)
} else if(nn == 1) return(1)
my.fib <- c(1,1)
for (kk in 3:nn){
my.fib[kk] <- my.fib[kk-1] + my.fib[kk-2]
}
return(my.fib[nn])
}

Return simulated pricing result

I am quite new to R and try to do a pricing simulation. The goal is to have a vector with length n, that gives a percentage for the coupon that will be received. When I use print, I get exactly the result I want. However, for my subsequent calculations I cannot proceed with results in print format. I tried replacing it with return but this just gives me one result.
Any input is appreciated.
(package used for rgpd is POT)
bond_coupon <- function(n, l) {
events <- rpois(n, l) #simulates the rate of arrival according to a Poisson process
for (i in 1:length(events)){
cat <- rgpd(events[i], loc=1000, scale=100, shape=1) #simulates the severance of each event
if(events[i]>1){
coupon <- prod(1-((cat-1000)/cat))
} else if(events[i]==1){
coupon<- 1-((cat-1000)/cat)
} else{
coupon<- 1.00
}
print(coupon)
}
}

Your coupon is overwritten at each iteration of loop, hence return only returns the last one.
You could create a vector coupon and fill it at each iteration:
bond_coupon <- function(n, l) {
events <- rpois(n, l) #simulates the rate of arrival according to a Poisson process
coupon = numeric(length(events))
for (i in 1:length(events)){
cat <- rgpd(events[i], loc=1000, scale=100, shape=1) #simulates the severance of each event
if(events[i]>1){
coupon[i] <- prod(1-((cat-1000)/cat))
} else if(events[i]==1){
coupon[i]<- 1-((cat-1000)/cat)
} else{
coupon[i]<- 1.00
}
}
return(coupon)
}
Alternatively you could delegate creation and looping to apply family of functions:
bond_coupon <- function(n, l) {
#simulates the rate of arrival according to a Poisson process
events <- rpois(n, l)
coupon <- sapply(X = seq_along(events), FUN = function(i) {
#simulates the severance of each event
cat <- rgpd(events[i], loc = 1000, scale = 100, shape = 1)
if (events[i] > 1) {
prod(1 - ((cat - 1000) / cat))
} else if (events[i] == 1) {
1 - ((cat - 1000) / cat)
} else {
1.00
}
}
)
return(coupon)
}

'non-finite-function value' Error when call 'integrate' with 'maxLik' function

I want to use the maximum likelihood method to estimate the parameters of a function which involves integration. However, when i tried to run it, i got a message that "non-finite function value".
Here are the codes:
library("maxLik")
integrand <− function(x,para)
{
# print(para)
# dv, dv_T, dn, dn_T are the actual input data, here only gives one set of value for easy debugging
dv <- -1.4527280
dv_T <- 0.2038909
dn <- 17.5174383
dn_T <- 26.6993828
beta10 = para[1];
beta11 = para[2];
beta12 = para[3];
alpha1 = para[4];
beta20 = para[5];
beta21 = para[6];
beta22 = para[7];
alpha2 = para[8];
U_Cur = exp(beta10 + beta11*dv + beta12*dn + alpha1*x);
U_Tgt = exp(beta20 + beta21*dv_T + beta22*dn_T + alpha2*x);
# Update Start - 03/10/2021
if (is.infinite(U_Cur))
{
if (U_Cur<0)
{U_Cur=-2^1000}
else
{U_Cur=2^1000}
}
if (is.infinite(U_Tgt))
{
if (U_Tgt <0)
{U_Tgt =-2^1000}
else
{U_Tgt =2^1000}
}
# Update End - 03/10/2021
# print(U_Cur)
# print(U_Tgt)
P <- (U_Cur/(U_Cur+U_Tgt))
# print(P)
return(P)
}
integrand2 <− function(para1) {integrate( integrand, lower = -2 , upper = 2, para=para1)$value }
MLE<-maxLik(logLik=integrand2,start=c(0.5, 0.2, 0.1, 0.3, -0.5, 0.2, 0.1, 0.6))
After debug, i find the reason of the error is the value of U_Cur or U_Tgt sometimes may be 0 or Inf.
I have no idea about how to deal with that, I really appreciate any related proposal.
===================================
EDIT:
I have update the value of U_Cur, U_Tgt, if they are (-)infinite, set their value as (-)2^1000 (the code is added in the function body above, between “# Update - 03/10/2021”).

I could be misreading your code, but it looks like you are maximizing the following (log)likelihood:
LL = int^2_{-2} exp(5+x+theta) dx = exp(5+theta)int^2_{-2} exp(x) dx.
That likelihood will be maximized by sending theta to infinity. Is that the log likelihood you want?

(R) Error in optim - attempt to apply non-function, when function is defined

not sure what I'm doing wrong here. I'm trying to get a cross-validation score for a mixture-of-two-gammas model.
llikGammaMix2 = function(param, x) {
if (any(param < 0) || param["p1"] > 1) {
return(-Inf)
} else {
return(sum(log(
dgamma(x, shape = param["k1"], scale = param["theta1"]) *
param["p1"] + dgamma(x, shape = param["k2"], scale = param["theta2"]) *
1
(1 - param["p1"])
)))
}
}
initialParams = list(
theta1 = 1,
k1 = 1.1,
p1 = 0.5,
theta2 = 10,
k2 = 2
)
for (i in 1:nrow(cichlids)) {
SWS1_training <- cichlids$SWS1 - cichlids$SWS1[i]
SWS1_test <- cichlids$SWS1[i]
MLE_training2 <-
optim(
par = initialParams,
fn = llikGammaMix2,
x = SWS1_training,
control = list(fnscale = -1)
)$par
LL_test2 <-
optim(
par = MLE_training2,
fn = llikGammaMix2,
x = SWS1_test,
control = list(fnscale = -1)
)$value
}
print(LL_test2)
This runs until it gets to the first optim(), then spits out Error in fn(par, ...) : attempt to apply non-function.
My first thought was a silly spelling error somewhere, but that doesn't seem to be the case. Any help is appreciated.

I believe the issue is in the return statement. It's unclear if you meant to multiply or add the last quantity (1 - param["p1"])))) to the return value. Based on being a mixture, I'm guessing you mean for it to be multiplied. Instead it just hangs at the end which throws issues for the function:
return(sum(log(dgamma(x, shape = param["k1"], scale = param["theta1"]) *
param["p1"] +
dgamma(x, shape = param["k2"], scale = param["theta2"]) *
(1 - param["p1"])))) ## ISSUE HERE: Is this what you meant?
There could be other issues with the code. I would double check that the function you are optimizing is what you think it ought to be. It's also hard to tell unless you give a reproducible example we might be able to use. Try to clear up the above issue and let us know if there are still problems.

Resources