I am trying to solve these equations for q1 and q2. However, the output is giving me "NaN". Does anyone have an idea how to avoid those?
k2<-2
k1<-2
a<- 20
b<- -0.03
w <- 1.1
model <- function(q) {
pi1 <- -exp(-a*(w*(100*q[1]-0.5*q[1]^2-0.5*q[1]*q[2])-k1)*(-a*(w*(100-q[1]-0.5*q[2])-k1)))
pi2 <- -exp(-a*(w*(100*q[2]-0.5*q[2]^2-0.5*q[1]*q[2])-k2)*(-a*(w*(100-q[2]-0.5*q[1])-k2)))
c(pi1 = pi1, pi2 = pi2)
}
ss1 <- rootSolve::multiroot(f = model, start = c(1, 1))
ss1
Thanks in advance!!!
I have been able to find the roots with the following code :
model <- function(q, bool_Print = FALSE)
{
k2 <- 2
k1 <- 2
a <- 20
b <- -0.03
w <- 1.1
pi1 <- exp( -a * (w * (100 * q[1] - 0.5 * q[1] ^ 2 - 0.5 * q[1] * q[2]) - k1) * (-a * (w * (100 - q[1] - 0.5 * q[2]) - k1)))
pi2 <- exp( -a * (w * (100 * q[2] - 0.5 *q[2] ^2 - 0.5 * q[1] * q[2]) - k2) * (-a * (w * (100 - q[2] - 0.5 * q[1]) - k2)))
val <- pi1 ^ 2 + pi2 ^ 2
names(val) <- NULL
if(bool_Print == TRUE)
{
print("pi1")
print(pi1)
print("pi2")
print(pi2)
print("Val")
}
if(is.na(val) | is.nan(val) | is.infinite(val))
{
return(10 ^ 30)
}else
{
return(val)
}
}
library(DEoptim)
obj_DEoptim <- DEoptim(fn = model, lower = rep(-1000, 2), upper = rep(1000, 2))
model(q = obj_DEoptim$optim$bestmem, bool_Print = TRUE)
[1] "pi1"
par1
0
[1] "pi2"
par2
0
[1] "Val"
[1] 0
Related
I am a) new to stackoverflow and b) an advanced beginner to R ;-)
i saw some bird artworks of Yeganeh with the associated functions in the web Drawing Birds in Flight With Mathematics and wanted to reproduce them in R to experiment a bit with colouring and so on.
However, while this one yielded a quite good result:
k <- 1:9830
X <- function(k) {
sin(pi * k / 20000) ^ 12 *
(0.5 * cos(31 * pi * k / 10000) ^ 16 *
sin(6 * pi * k / 10000) + (1 / 6 * sin(31 * pi * k / 10000)) ^ 20) +
3 * k / 20000 + cos(31 * pi * k / 10000) ^ 6 *
sin((pi / 2) * ((k - 10000) / 10000) ^ 7 - pi / 5)
}
Y <- function(k) {
-9 / 4 * cos(31 * pi * k / 10000) ^ 6 *
cos(pi / 2 * ((k - 10000) / 10000) ^ 7 - pi / 5) *
(2 / 3 + (sin(pi * k / 20000) * sin(3 * pi * k / 20000)) ^ 6) +
3 / 4 * cos(3 * pi * ((k - 10000) / 100000)) ^ 10 *
cos(9 * pi * ((k - 10000) / 100000)) ^ 10 *
cos(36 * pi * ((k - 10000) / 100000)) ^ 14 +
7 / 10 * ((k - 10000) / 10000) ^ 2
}
R <- function(k) {
sin(pi * k / 20000) ^ 10 *
(1 / 4 * cos(31 * pi * k / 10000 + 25 * pi / 32) ^ 20 +
1 / 20 * cos(31 * pi * k / 10000) ^ 2) +
1 / 30 * (3 / 2 - cos(62 * pi * k / 10000) ^ 2)
}
bird <- data.frame(x = X(k), y = Y(k), r = R(k))
library(tidyverse)
library(ggforce)
q <- ggplot() +
geom_circle(aes(x0 = x, y0 = y, r = r),
data = bird,
n = 30) +
coord_fixed() +
theme_void()
the following code yielded some weird result which should basically be related to the difference in the function. (x-A(k))+(y-B(k))=(R(k)) for the parrot below, whlie the bird above "simply" consisted of the k-th circle (X(k), Y(k)) and the radius of the k-th circle R(k)
k <- -10000:10000
A <- function(k) {
(3*k/20000)+(cos(37*pi*k/10000))*sin((k/10000)*(3*pi/5))+(9/7)*(cos(37*pi*k/10000))*(cos(pi*k/20000))*sin(pi*k/10000)
}
B <- function(k) {
(-5/4)*(cos(37*pi*k/10000))*cos((k/10000)*(3*pi/5))*(1+3*(cos(pi*k/20000)*cos(3*pi*k/20000)))+(2/3)*(cos(3*pi*k/200000)*cos(9*pi*k/200000)*cos(9*pi*k/100000))
}
R <- function(k) {
(1/32)+(1/15)*(sin(37*pi*k/10000))*((sin(pi*k/10000))+(3/2)*(cos(pi*k/20000)))
}
parrot <- data.frame(a = A(k), b = B(k), r = R(k))
q <- ggplot() +
geom_circle(aes(x0 = a, y0 = b, r = r),
data = parrot,
n=30) +
coord_fixed() +
theme_void()
q
Any help would be very much appreciated. Cartesian coords already applied as [explained here] (https://www.wikiwand.com/en/Hamid_Naderi_Yeganeh). From the visual point of view, it seems like the function is plotted properly but the "view" on it needs to be changed...
Thanks in advance!
Suppose I have the following function and output:
library('pracma')
xlag= c(1,3,5,8,12,16,19,20,22,24)
f1 <- function(beta){
xlag[1]*exp(beta[1] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[2]*exp(beta[1] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[3]*exp(beta[1] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f1,c(1))
[,1]
[1,] 0.8488091
I wrote a few for loops in the function so I can extend the model for any value s.
h <-function(beta){
s = 1:3
xlag= 1:9
n <-c()
for (i in s) {
n[i] <- exp(beta[1] * s[i])
}
sal <-sum(n)
z <-c()
for (i in s) {
z[i] <- xlag[i]*exp(beta[1] * s[i])/sal
}
sum(z)
}
pracma::jacobian(h,c(1))
[,1]
[1,] 0.8488091
Now I would like to write f for xlag[1:3], xlag[4:6] xlag[7:9].
Such that the Jacobian becomes a matrix with 1 column and 3 rows. Where the first entry is the one specified above. And the second entry is:
f2 <- function(beta){
xlag[4]*exp(beta[4] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[5]*exp(beta[5] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[6]*exp(beta[6] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f2,c(1))
[,1]
[1,] 1.697618
The third entry:
f3 <- function(beta){
xlag[7]*exp(beta[4] * 1)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[8]*exp(beta[5] * 2)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3)) +
xlag[9]*exp(beta[6] * 3)/(exp(beta[1] * 1)+exp(beta[1] * 2)+exp(beta[1] * 3))
}
pracma::jacobian(f3,c(1))
[,1]
[1,] 0.706992
So I would like h to output:
[,1]
[1,] 0.8488091
[2,] 1.697618
[3,] 0.706992
The jacobian function is structured as follow
library('pracma')
jacobian(f, x0, heps = .Machine$double.eps^(1/3), ...)
f: m functions of n variables.
x0: Numeric vector of length n.
heps: This is h in the derivative formula.
jacobian(): Computes the derivative of each function f_j by variable x_i separately, taking the discrete step h.
So I need 3 functions f1,f2,f3 of one variable. Yielding a matrix of 1 column and 3 rows.
Could anyone help me rewrite h such that I get the desired output?
I have found the solution.
h <-function(beta){
s = 1:3
xlag #total set of xlag variables
u =1:(length(xlag)-length(s)) #basis for loop
n <-c()
for (i in s) {
n[i] <- exp(beta[1] * s[i]) #nominator expo almon
}
sal <-sum(n) #denominator expo almon
z <-c()
for (i in s) {
z[i] <- exp(beta[1] * s[i])/sal #expoalmon
}
final <-c()
for (i in u) {
final[i] <- sum(xlag[(i):(i+2)]*z[1:3])
}
final
}
pracma::jacobian(h,c(1))
fellow programmers. I'm studying a book on numerical solutions for economics (Judd 1998). I'm trying to reproduce a problem from that same book in R so I can use the optim package to see if I can get similar results.
The problem established by the author is this one: and his results were these.
I have tried to transcribe this problem to R, which resulted in this code chunk:
DisutilityJudd <- function(L){
if(L == 0){
return(0)
}else{
return(0.1)
}
}
AgentUtilityJudd <- function(w, L){
(-exp(-2*w) + 1) - DisutilityJudd(L)
}
reservation.utility.judd <- AgentUtilityJudd(1, 1)
MaxEffortUtility <- function(w1, w2, L = 1){
0.8 * AgentUtilityJudd(w1, L) + 0.2 * AgentUtilityJudd(w2, L)
}
LeastEffortUtility <- function(w1, w2, L = 0){
0.4 * AgentUtilityJudd(w1, L) + 0.6 * AgentUtilityJudd(w2, L)
}
UtilityDifferenceJudd <- function(w1, w2){
MaxEffortUtility(w1, w2) - LeastEffortUtility(w1, w2)
}
PenaltyFunctionJudd <- function(w1, w2, P = 100000){
if(length(w1) == 2){
y <- -1 * (0.8 * (2 - w1[1]) - 0.2 * w1[2] - P *
(pmax(0, -MaxEffortUtility(w1[1], w1[1]) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1[1], w1[1])))^2)
}else{
y <- -1 * (0.8 * (2 - w1) - 0.2 * w2 - P *
(pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd))^2 -
P * (pmax(0, -UtilityDifferenceJudd(w1, w2)))^2)
}
return(y)
}
There were no errors, but the results generated by my code were nowhere near to what I was expecting:
optim(c(1.1, 0.5), PenaltyFunctionJudd)
$par
[1] 1.343909e+49 -2.370681e+51
$value
[1] -4.633849e+50
$counts
function gradient
501 NA
$convergence
[1] 1
$message
NULL
Perhaps there is a problem to my penalty function. I'm assuming that it is due to the pmax function. Could somebody help me identify it? Thank you, I appreciate your attention.
Edit: a typo.
I believe you meant w1[2] in when if(length(w1) == 2) is true.
I have modified your code, without touching how you define the previous function. It is not clear if it the result expected : what does IV(-1) mean, is it the result minus 1 ? a power if 10 ?
PenaltyFunctionJudd <- function(w1, w2, P = 1e5){
if(length(w1) > 1){
w2 <- w1[2]
w1 <- w1[1]
}
# cat("length is 2 \n")
y <- 0.8 * (2 - w1) - 0.2 * w2 - P *
( pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd) )^2 -
P * ( pmax(0, -UtilityDifferenceJudd(w1, w2)) )^2
# cat("pmax1 :", pmax(0, -MaxEffortUtility(w1, w2) - reservation.utility.judd), "\n")
# cat("pmax2 :", pmax(0, -UtilityDifferenceJudd(w1, w2)), "\n")
return(y)
}
optim(c(1.1, 0.5), PenaltyFunctionJudd, control = list(fnscale = -1) )
optim(c(11, 5), PenaltyFunctionJudd, method = "BFGS", control = list(fnscale = -1, maxit = 100) )
You can use cat or print to check your values (here I noticed some Inf and 0 the leaded me to notice code error).
Friendly warning : provided you defined correctly the previous function, there is lot of instability in optimisation (problem badly set ? More penalty needed ?). Indeed when running twice or more the algorithm parameters fluctuate a lot...
I need to calculate a double integral on two variables (B0 and B1) in R.
Till now, nothing complicated with the int2 function.
But, my function to integrate includes gamma incomplete function (gammainc in R ) !
The following error message appears :
Error in gammainc(1/eta, lambda * exp(B0 + B1 * z_arm) * tmax^eta) :
Arguments must be of length 1; function is not vectorized.
Any advice to help me ?
tmax = 5
Sig = matrix ( c(0.2, 0, 0, 0.4) , ncol = 2 )
Mu = matrix ( c(1, 0) , ncol = 1 )
eta = 0.5
lambda = 0.8
z_arm = c(rep(0.5,10), rep(1,15))
to.integrate = function(B0, B1)
{
first.int = 1/eta *(lambda * exp(B0 + B1 * z_arm))^(-1/eta)* gammainc(1/eta, lambda * exp(B0 + B1 * z_arm)*tmax^eta)['lowinc']
B = matrix(c(B0, B1), ncol=1)
multi.norm = 1 / (2 * pi * det(Sig)^(1/2)) * exp (- 0.5 * t( B - Mu ) * solve(Sig) * ( B - Mu ) )
return (first.int * multi.norm)
}
int2(to.integrate , a=c(-Inf,-Inf), b=c(Inf,Inf), eps=1.0e-6, max=16, d=5)
Thanks for any help!
I am wondering if there is any package which allows us to use the Lanczos filter. I found other filters such as butterworth but I am looking for Lanczos low pass filter.
How different is Lanczos filter from butterworth filter ? Any suggestions or hints is appreciated.
Thanks.
Using the web I find this MATLAB implementation.
If you skipped the first part(arguments check), it looks simple to write its R equivalent.
# Cf - Cut-off frequency (default: half Nyquist)
# M - Number of coefficients (default: 100)
lanczos_filter_coef <- function(Cf,M=100){
lowpass_cosine_filter_coef <- function(Cf,M)
coef <- Cf*c(1,sin(pi*seq(M)*Cf)/(pi*seq(M)*Cf))
hkcs <- lowpass_cosine_filter_coef(Cf,M)
sigma <- c(1,sin(pi*seq(M)/M)/(pi*seq(M)/M))
hkB <- hkcs*sigma
hkA <- -hkB
hkA[1] <- hkA[1]+1
coef <- cbind(hkB, hkA)
coef
}
To test it for example:
dT <- 1
Nf <- 1/(2*dT)
Cf <- Nf/2
Cf <- Cf/Nf
lanczos_filter_coef(Cf,5)
hkB hkA
[1,] 5.000000e-01 5.000000e-01
[2,] 2.977755e-01 -2.977755e-01
[3,] 1.475072e-17 -1.475072e-17
[4,] -5.353454e-02 5.353454e-02
[5,] -4.558222e-18 4.558222e-18
[6,] 2.481571e-18 -2.481571e-18
PS I don't know very well MATLAB(used it many years ago), so I I used this link For the R/MATLAB analogy. I hope that someone with more R/MATLAB/Scilab knowledge can test my code.
I used the method provided in this link https://www.atmos.umd.edu/~ekalnay/syllabi/AOSC630/METO630ClassNotes13.pdf and wrote this function:
`
lanczos_weights<-function(window=101,sampl_rate=1,type="lowpass",low_freq=1/100,high_freq=1/10){
low_freq=sampl_rate*low_freq
high_freq=sampl_rate*high_freq
if (type=="lowpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]}
else if (type=="highpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w=w[-c(1,length(w))]
w=-w
w[order]=1-2*fc }
else if (type=="bandpass"){
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=low_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w1=w[-c(1,length(w))]
order = ((window - 1) %/% 2 ) + 1
nwts = 2 * order + 1
fc=high_freq
w = seq(0,0,length=nwts)
n = nwts %/% 2
w[n+1] = 2 * fc
k = seq(1, n-1)
sigma = sin(pi * k / n) * n / (pi * k)
firstfactor = sin(2 *pi * fc * k) / (pi * k)
w[n:2] = firstfactor * sigma
w[(n+2):(length(w)-1)] = firstfactor * sigma
w2=w[-c(1,length(w))]
w=w2-w1}
else {print("Please specify a valid filter type: either 'lowpass', 'highpass' or 'bandpass'")}
return(w)}
`
#### the inputs are:
#### window: Filter length=number of weights. Corresponds to the total number of points to be lost. Should be odd: window=2N-1. The formula for N is taken from Poan et al. (2013)
#### sampl_rate: sampling rate=number of observation per time unit. ( eg: if time unit is one day, hourly data have sampl_rate=1/24)
#### type= one of "lowpass", "highpass" and "bandpass"
#### low_freq: the lowest frequency
#### high_freq: the highest frequency
I have compared my weights to those obtained using NCL filwgts_lanczos and they are exactly the same.