Related
We have a function. t ~ Weibull(alpha, lambda) and c ~ Exponential(beta):
Given p = 0.10, alpha = 1, lambda = 4. Find the value of beta.
We want to integrate this function for t then to c. Then find the value of beta where integral equals to p using uniroot function.
See the code below:
alpha = 1
lambda = 4
p = 0.10
func1 <- function(t, c, beta) {alpha * lambda * exp(-lambda * t^ alpha)*
beta * exp(- beta * c) }
func2 <- function(c, beta){integrate(func1, lower = c, upper = Inf, c=c,
beta=beta)}
func3 <- function(beta){integrate(func2, lower = 0, upper = Inf, beta =
beta)$value - cen.p}
uniroot(func3 ,lower = 0.001, upper = 10, extendInt = "yes")$root
However it throws the error:
Error in integrate(func1, lower = c, upper = Inf, c = c, beta = beta)
: length(lower) == 1 not TRUE
Answer should be 0.444
I corrected typos (substituted cen.p to p) and vectorized function arguments for func2 and func3, since the integrate function returns one value (scalar). However as a first argument integrate should accept vector of numeric values, not a scalar.
alpha <- 1
lambda <- 4
p <- 0.10
func1 <- function(t, c, beta)
alpha * lambda * t^(alpha - 1) * exp(-lambda * t^alpha) * beta * exp(-beta * c)
func2 <- function(c, beta)
integrate(func1, lower = c, upper = Inf, c = c, beta = beta)$value)
func3 <- function(beta)
integrate(Vectorize(func2), lower = 0, upper = Inf, beta = beta)$value - p
uniroot(Vectorize(func3), lower = 0.001, upper = 10, extendInt = "yes")$root
Output:
[1] 0.4444242.
w1 <- 1000
w2 <- 600
a <- c(w1,w2)
fun1 <- function(a){
return(exp(1)^1.5*a[1]^0.2*a[2]^(1-0.2))
}
#constraint - a[1]+a[2]=10000
Answer1 <- constrOptim(c(w1,w2), fun1, NULL,
ui = c(1,1), ci = c(10000),
control = list(fnscale = -1))
Trying to optimize the function
However, getting an error
"Error in constrOptim(c(1, 1), fun1, NULL, ui = c(1, 1), ci = c(10000), :
initial value is not in the interior of the feasible region"
What could be the issue?
You can consider the following approach :
library(DEoptim)
fun1 <- function(a1)
{
a2 <- 10000 - a1
val <- exp(1) ^ 1.5 * a1 ^ 0.2 * a2 ^ 0.8
if(is.na(val) | is.nan(val))
{
return(10 ^ 30)
}else
{
return(-val)
}
}
obj_DEoptim <- DEoptim(fn = fun1, lower = 0, upper = 10000)
obj_DEoptim$optim$bestmem
Note that you have an "equality" constraint consisting of only two variables, which actually can be denoted by x and 10000-x respectively. In this case, optim is sufficient for your purpose, e.g.,
f <- function(x) {
return(exp(1.5) * x^0.2 * (10000 - x)^(1 - 0.2))
}
optim(1000,
f,
method = "Brent",
lower = 0,
upper = 10000,
control = list(fnscale = -1)
)
and you will obtain
$par
[1] 2000
$value
[1] 27171.88
$counts
function gradient
NA NA
$convergence
[1] 0
$message
NULL
By the way, you can visualize the cost function f using curve(f, 0, 10000), which shows
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
I am new to R. I want to do some parameters estimation by using Maximum Likelihood Estimation.
Here is my attempt:
The data are
my_data = c(0.1,0.2,1,1,1,1,1,2,3,6,7,11,12,18,18,18,18,18,21,32,36,40,
45,45,47,50,55,60,63,63,67,67,67,67,72,75,79,82,82,83,
84,84,84,85,85,85,85,85,86,86)
and
lx <- function(p,x){
l <- p[1]
b <- p[2]
a <- p[3]
n <- length(x)
lnL <- n*log(l)+n*log(b)+n*log(a)+(b-1)*sum(log(x))+(a-1)*sum(log(1+l*x^b))+n-sum(1+l*x^b)
return(-lnL)
}
Note: l is λ, b is β, and a is α.
And here is the optim function
optim(p=c(1,1,1),fn = lx, method = "L-BFGS-B",
lower = c(0.0001, 0.0001, 0.0001),
control = list(), hessian = FALSE, x = my_data)
After I run this code, I get an error message:
Error in optim(p = c(1, 1, 1), fn = lx, method = "L-BFGS-B", lower = c(1e-04, :
objective function in optim evaluates to length 50 not 1
What's wrong with my code? Can you help me to fix it? Thanks in advance!
Instead of a log-likelihood, use MASS::fitdistr.
#
# Power Generalized Weibull distribution
#
# x > 0, alpha, beta, lambda > 0
#
dpowergweibull <- function(x, alpha, beta, lambda){
f1 <- lambda * beta * alpha
f2 <- x^(beta - 1)
f3 <- (1 + lambda * x^beta)^(alpha - 1)
f4 <- exp(1 - (1 + lambda * x^beta)^alpha)
f1 * f2 * f3 * f4
}
ppowergweibull <- function(q, alpha, beta, lambda){
1 - exp(1 - (1 + lambda * q^beta)^alpha)
}
my_data <- c(0.1,0.2,1,1,1,1,1,2,3,6,7,11,12,18,18,18,18,18,21,32,36,40,
45,45,47,50,55,60,63,63,67,67,67,67,72,75,79,82,82,83,
84,84,84,85,85,85,85,85,86,86)
start_par <- list(alpha = 0.1, beta = 0.1, lambda = 0.1)
y1 <- MASS::fitdistr(my_data, dpowergweibull, start = start_par),
start_par2 <- list(shape = 1, rate = 1)
y2 <- MASS::fitdistr(my_data, "gamma", start = start_par2)
hist(my_data, freq = FALSE)
curve(dpowergweibull(x, y1$estimate[1], y1$estimate[2], y1$estimate[3]),
from = 0.1, to = 90, col = "red", add = TRUE)
curve(dgamma(x, y2$estimate[1], y2$estimate[2]),
from = 0.1, to = 90, col = "blue", add = TRUE)
I have a big deal with an optimization problem.
I have got a time series of a stock and a transformation function:
K_z <- function(z, theta, beta_z, n) {
z*((1+((z^2+0.5)^beta_z-0.5^ beta_z)/n)^(n*theta))
}
K_fd_z <- function(z, theta, beta_z, n) {
( (1+( (z^2+0.5)^beta_z - 0.5^beta_z)/n)^n )^(theta-1) * ( ( (1+( (z^2+0.5)^beta_z - 0.5^beta_z)/n)^n ) + theta * z * (2*beta_z * z * (1 + ( (z^2+0.5)^beta_z - 0.5^beta_z)/n)^(n-1) * ( z^2+0.5)^(beta_z-1) ) )
}
where: y is the stock
y <- get.hist.quote("ALV", quote="Adj", start="2000-01-01",end="2014-12-31", retclass="zoo")
y <- na.locf(y)
y <- diff(log(y))
y <- exp(y)-1
theta, beta_z, n are parameters and z is
z <- rnorm(length(y), mean = 0, sd = 1)
Now I need this inverse function:
K_inv <- function(y)
{
uniroot(function(z) K_z(z, theta, beta_z, n)-y , lower=9,upper=11)$root
}
K_inverse <- Vectorize(K_inv, "y")
the uniroot should be:
K_m1 <- K_inverse(y)
and this function should be analyzed:
f_Y <- function(z, theta, n, beta_z)
{
K_m1 <- K_inverse(y)
(dnorm(K_m1))/( K_fd_z(K_m1))
}
# curve(f_Y(x,theta=0.2,n=5,beta_z=0.5),-10,10)
#Error in uniroot(function(z) K_z(z, theta, beta_z, n) - y,lower = 9, :
#f() values at end points not of opposite sign
Parameter optimization and boundaries could be something like:
p3 <- optim(c(-0.2, mean(y)-0.2, 0.01, 1, 0.4), loglike, NULL, method = "L-BFGS-B",lower = c(-0.2, mean(y)-0.2, 0.01, 1, 0.4), upper = c(0.2, mean(y)+0.2, 0.5, 250, 1.8)
oi3<-solve(p3$hessian)
It doesn't work...I am quite new in R and don't understand my errors,maybe somebody is able to help me?!?
Thank You in advance...