I want to maximize a one variable (sum(DeplaQ1$somme_vrai)) with unknow parameters (alpha,VDT,constVPC,constVPP,a,constTC,const2RM,constTaxi) and I want to determine this parametres with a one constraint x1 <= 10000
I do not find this solution. triplaQ1 is a database with time and number of trip per transport mod.I try to use Optimum or LpSolve but it does not work.**
** My program :
fr <- function(alpha,VDT,constVPC,constVPP,a,constTC,const2RM,constTaxi) {
triplaQ1$u_VPC <- - (alpha * alpha + 0.001)*(triplaQ1$time_VPC*VDT + 0.15*triplaQ1$dist_VPC + constVPC)
triplaQ1$u_VPP <- - (alpha * alpha +0.001) * (triplaQ1$time_VPP * VDT) + constVPP
triplaQ1$u_TC <- - (alpha * alpha +0.001) * ((triplaQ1$time_TC/a)*VDT+constTC)
triplaQ1$u_mp <- - (alpha * alpha +0.001) * (triplaQ1$time_MP * VDT)
triplaQ1$u_2RM <- - (alpha * alpha +0.001) * (triplaQ1$time_2RM * VDT + const2RM)
triplaQ1$u_Taxi <- - (alpha * alpha + 0.001) * (triplaQ1$time_Taxi * VDT + 0.3 * triplaQ1$dist_Taxi + constTaxi)
triplaQ1$simuleVPC <- triplaQ1$trip * ((exp(triplaQ1$u_VPC)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$simuleVPP <- triplaQ1$trip * ((exp(triplaQ1$u_VPP)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$simuleTC <- triplaQ1$trip * ((exp(triplaQ1$u_TC)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$simuleMAP <- triplaQ1$trip * ((exp(triplaQ1$u_mp)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$simule2RM <- triplaQ1$trip * ((exp(triplaQ1$u_2RM)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$simuleTaxi <- triplaQ1$trip * ((exp(triplaQ1$u_Taxi)) / (exp(triplaQ1$u_VPC) + exp(triplaQ1$u_VPP) + exp(triplaQ1$u_TC) + exp(triplaQ1$u_mp) + exp(triplaQ1$u_2RM) + exp(triplaQ1$u_Taxi)))
triplaQ1$somme_simule <- triplaQ1$simuleVPC + triplaQ1$simuleVPP + triplaQ1$simuleTC + triplaQ1$simuleMAP + triplaQ1$simule2RM + triplaQ1$simuleTaxi
triplaQ1$shsimuleVPC <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simuleVPC/triplaQ1$trip, 0)
triplaQ1$shsimuleVPP <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simuleVPP/triplaQ1$trip, 0)
triplaQ1$shsimuleTC <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simuleTC/triplaQ1$trip, 0)
triplaQ1$shsimuleMAP <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simuleMAP/triplaQ1$trip, 0)
triplaQ1$shsimule2RM <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simule2RM/triplaQ1$trip, 0)
triplaQ1$shsimuleTaxi <- ifelse(triplaQ1$trip > 0.001, triplaQ1$simuleTaxi/triplaQ1$trip, 0)
triplaQ1$shsommesimule <- triplaQ1$shsimuleVPC + triplaQ1$shsimuleVPP + triplaQ1$shsimuleTC + triplaQ1$shsimuleMAP + triplaQ1$shsimule2RM + triplaQ1$shsimuleTaxi
triplaQ1$VraiVPC <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij_vpc * log(triplaQ1$simuleVPC/triplaQ1$trip),0)
triplaQ1$VraiVPP <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij._vpp * log(triplaQ1$simuleVPP/triplaQ1$trip),0)
triplaQ1$VraiTC <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij._tc * log(triplaQ1$simuleTC/triplaQ1$trip),0)
triplaQ1$VraiMAP <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij._mp * log(triplaQ1$simuleMAP/triplaQ1$trip),0)
triplaQ1$Vrai2RM <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij._2RM * log(triplaQ1$simule2RM/triplaQ1$trip),0)
triplaQ1$VraiTaxi <- ifelse(triplaQ1$trip > 0,triplaQ1$Tij_Taxi * log(triplaQ1$simuleTaxi/triplaQ1$trip),0)
triplaQ1$somme_vrai <- triplaQ1$VraiVPC + triplaQ1$VraiVPP + triplaQ1$VraiTC + triplaQ1$VraiMAP + triplaQ1$Vrai2RM + triplaQ1$VraiTaxi
return(sum(triplaQ1$somme_vrai))
}
x1 <- sqrt((sum(DeplaQ1$dep_VPC) - sum(DeplaQ1$simuleVPC))^2 + (sum(DeplaQ1$dep_VPP) - sum(DeplaQ1$simuleVPP))^2 + (sum(DeplaQ1$dep_TC) - sum(DeplaQ1$simuleTC))^2 + (sum(DeplaQ1$dep_2RM) - sum(DeplaQ1$simule2RM))^2 + (sum(DeplaQ1$dep_MP) - sum(DeplaQ1$simuleMAP))^2 + (sum(DeplaQ1$dep_Taxi) - sum(DeplaQ1$simuleTaxi))^2)
thank you in advance
first translate the EXCEL formula you want to find a target value to to a r-function. I did this for a very simple formula x^2+y^2 here, this is my_fun in the example. Then define a function that gives the squared difference (or any other norm you want to use) between target value and function value for all inputs. Then just put everything into the optim function.
my_fun <- function(x){
x[1]^2 + x[2]^2
}
target <- 2
optim_fun <- function(x){
sum((my_fun(x)-target)^2)
}
res <- optim(c(0,0), optim_fun)
res
To deal with constraints you could introduce a penalty term. Some algorithms in optim also support constraints. There are a lot of more specialised optimisation libraries for R if the very basic optim function does not fit your need.
Related
I generated some data to perfome a regression on it:
library(tidyverse)
library(nnet)
# Generating the data --------------------------
set.seed(100)
helicopter <- rnorm(20, mean = 35, sd = 3)
car <- rnorm(20, mean = 30, sd = 3)
bus <- rnorm(20, mean = 25, sd = 3)
bike <- rnorm(20, mean = 20, sd = 3)
transportation_data <- data.frame(helicopter, car, bus, bike) %>%
pivot_longer(cols = 1:4, values_to = "income", names_to = "mode")
# Setting up the regression -------------------
transportation_regression <- multinom(mode~income, data = transportation_data)
So far, so good. I now want to plot the regression results (probability of choosing a certain mode of transportation based on income) using stat_function:
ins <- coef(transportation_regression)[1:3]
betas <- coef(transportation_regression)[4:6]
transportation_data %>%
ggplot(aes(x = income))+
stat_function(fun = function(x) { 1 / (1 + sum(exp(ins + betas * x))) }, aes(color = "bike"))+
stat_function(fun = function(x) { exp(ins[1] + betas[1] * x) / (1 + sum(exp(ins + betas * x))) }, aes(color = "bus"))+
stat_function(fun = function(x) { exp(ins[2] + betas[2] * x) / (1 + sum(exp(ins + betas * x))) }, aes(color = "car"))+
stat_function(fun = function(x) { exp(ins[3] + betas[3] * x) / (1 + sum(exp(ins + betas * x))) }, aes(color = "helicopter"))
I get this output, which is obviously wrong, and a warning Warning: longer object length is not a multiple of shorter object length where I don't know what it means.
When I use the same functions, but predict data points first, everything works just fine:
income <- seq(0,50,0.1)
result <- matrix( , nrow = length(income), ncol = 4)
i <- 1
for(x in income){
result[i,1] <- 1 / (1 + sum(exp(ins + betas * x))) # bike
result[i,2] <- exp(ins[1] + betas[1] * x) / (1 + sum(exp(ins + betas * x))) # bus
result[i,3] <- exp(ins[2] + betas[2] * x) / (1 + sum(exp(ins + betas * x))) # car
result[i,4] <- exp(ins[3] + betas[3] * x) / (1 + sum(exp(ins + betas * x))) # helicopter
i <- i + 1
}
cbind(income, as.data.frame(result)) %>%
pivot_longer(cols = V1:V4) %>%
ggplot(aes(x = income, y = value, color = name))+
geom_line()
Why don't the stat_function() in ggplot work?
I think it's just a misunderstanding of how the function works. Here's an example of using stat_function() to generate the right result:
library(tidyverse)
library(nnet)
# Generating the data --------------------------
set.seed(100)
helicopter <- rnorm(20, mean = 35, sd = 3)
car <- rnorm(20, mean = 30, sd = 3)
bus <- rnorm(20, mean = 25, sd = 3)
bike <- rnorm(20, mean = 20, sd = 3)
transportation_data <- data.frame(helicopter, car, bus, bike) %>%
pivot_longer(cols = 1:4, values_to = "income", names_to = "mode")
# Setting up the regression -------------------
transportation_regression <- multinom(mode~income, data = transportation_data)
#> # weights: 12 (6 variable)
#> initial value 110.903549
#> iter 10 value 48.674542
#> iter 20 value 46.980349
#> iter 30 value 46.766625
#> iter 40 value 46.734782
#> iter 50 value 46.732249
#> final value 46.732163
#> converged
ins <- coef(transportation_regression)[1:3]
betas <- coef(transportation_regression)[4:6]
transportation_data %>%
ggplot(aes(x = income))+
stat_function(fun = function(x) { 1 / (1 + exp(ins[1] + betas[1] * x) + exp(ins[2] + betas[2] * x) + exp(ins[3] + betas[3] * x)) }, aes(color = "bike"))+
stat_function(fun = function(x) { exp(ins[1] + betas[1] * x) / (1 + exp(ins[1] + betas[1] * x) + exp(ins[2] + betas[2] * x) + exp(ins[3] + betas[3] * x)) }, aes(color = "bus"))+
stat_function(fun = function(x) { exp(ins[2] + betas[2] * x) / (1 + exp(ins[1] + betas[1] * x) + exp(ins[2] + betas[2] * x) + exp(ins[3] + betas[3] * x)) }, aes(color = "car"))+
stat_function(fun = function(x) { exp(ins[3] + betas[3] * x) / (1 + exp(ins[1] + betas[1] * x) + exp(ins[2] + betas[2] * x) + exp(ins[3] + betas[3] * x)) }, aes(color = "helicopter"))
There were a couple of problems originally. Take, for example, the first instance of stat_function(),
stat_function(fun = function(x) {
1 / (1 + sum(exp(ins + betas * x))) },
aes(color = "bike"))
You're expecting ins + betas * x to be equivalent to ins[1] + betas[1] * x + ins[2] + betas[2] * x + ins[3] + betas[3] * x, but it isn't essentially recycling ins and betas to make them vectors as long as x and then multiplying betas by x and adding ins.
The other problem was the sum() around exp(ins ...) Rather than summing the rows, it's summing all rows and columns of the output, making a scalar value.
You could also make it a bit more general using matrix calculations:
b <- coef(transportation_regression)
transportation_data %>%
ggplot(aes(x = income))+
stat_function(fun = function(x) { 1 / (1 + rowSums(exp(cbind(1, x) %*% t(b)))) }, aes(color = "bike"))+
stat_function(fun = function(x) { exp(ins[1] + betas[1] * x) / (1 + rowSums(exp(cbind(1, x) %*% t(b)))) }, aes(color = "bus"))+
stat_function(fun = function(x) { exp(ins[2] + betas[2] * x) / (1 + rowSums(exp(cbind(1, x) %*% t(b)))) }, aes(color = "car"))+
stat_function(fun = function(x) { exp(ins[3] + betas[3] * x) / (1 + rowSums(exp(cbind(1, x) %*% t(b)))) }, aes(color = "helicopter"))
Created on 2023-02-04 by the reprex package (v2.0.1)
> LL_LN<-function(para){
+ ww=para[1] # w
+ alpha=para[2] # alpha
+ beta=para[3]# beta
+ sigma=para[4]
+ n=length(R)
+ psi <- rep(0, n)
+ # read data from file , named as RR
+ psi[1]=0.5 # replace with mean (R) or R(1)
+ sum1 = -n/2*log(2*pi*sigma^2)
+ sum4 = -log(R[1])
+ sum3 = -((log(R[1])-log(psi[1]))+0.5*(sigma^2))^2/(2*(sigma^2))
+ sum=0
+
+ for (i in 2:n) {
+ psi[i]=ww+alpha*psi[i-1]+beta*R[i-1]
+ sum4=sum4-log(R[i])
+ sum3=sum3-((log(R[i])-log(psi[i]))+0.5*(sigma^2))^2/(2*(sigma^2))
+ }
+ sum=sum1+sum3+sum4
+ return(-sum)
+
+ }
> n=10000
> k=5
> sigma=0.25
> mu=-(sigma^2)/2
> result=c(0,0,0,0)
> output<-matrix(0,k,4)
> output<-as.data.frame(output)
> for(j in 1:k){
+ #E<-rexp(n,1)
+ E=rlnorm(n,mu,sigma)
+ w=1
+ a=0.2
+ b=0.3
+ R <- rep(0, n) # To Store R1,R2....R1000
+ X <- rep(0, n) # To Store X1,X2....X1000
+ X[1] = 0.5
+ R[1]=X[1]*E[1]
+
+ for (i in 2:n) # To Find R1,R2....R1000
+ {
+ X[i]=w+a*X[i-1]+b*R[i-1]
+ R[i]=X[i]*E[i]
+ }
+ hist(R)
+ mean(E)
+
+ initial =c(1,0.2,0.3,2)
+ op<-optim(initial,LL_LN)
+ output$V1[j] <- op$par[1]
+ output$V2[j] <- op$par[2]
+ output$V3[j] <- op$par[3]
+ output$V4[j] <- op$par[4]
+
+ print(output)
+ }
V1 V2 V3 V4
1 1.0202418 0.1989128 0.2927711 0.2484346
2 0.9725745 0.2159796 0.2970536 0.2529665
3 1.0648460 0.1692719 0.2987034 0.2492417
4 1.0186746 0.1819587 0.3039954 0.2517418
5 1.0022230 0.2103271 0.2858050 0.2484962
There were 50 or more warnings (use warnings() to see the first 50)
> mean<-cbind(mean(output$V1),mean(output$V2),mean(output$V3),mean(output$V4))
> mean
[,1] [,2] [,3] [,4]
[1,] 1.015712 0.19529 0.2956657 0.2501762
I need help generating an AR(2) model in R and I am new to the software.
I have the following AR(2) process:
y[t] = phi_1 * y[t-1] + phi_2 * y[t-2] + e[t] where e[t] ~ N(0,2)
How can I generate a series of y[t]?
Thanks for the help, much appreciated!
You could do:
set.seed(123)
n <- 200
phi_1 <- 0.9
phi_2 <- 0.7
e <- rnorm(n, 0, 2)
y <- vector("numeric", n)
y[1:2] <- c(0, 1)
for (t in 3:n) {
y[t] <- phi_1 * y[t - 1] + phi_2 * y[t - 2] + e[t]
}
plot(seq(n), y, type = "l")
I am using rootSolve package in R to solve a system of 6 non-linear equations with 6 unknown variables. Here is my model
model <- function(x, parms) c(F1 = x[1] - parms[1] - 1 / ((-parms[7]) * (1 - x[4])),
F2 = x[2] - parms[2] - 1 / ((-parms[7]) * (1 - x[5])),
F3 = x[3] - parms[3] - 1 / ((-parms[7]) * (1 - x[6])),
F4 = x[4] - exp(parms[4] + parms[7] * x[1]) / (1 + exp(parms[4] + parms[7] * x[1]) + exp(parms[5] + parms[7] * x[2]) + exp(parms[6] + parms[7] * x[3])),
F5 = x[5] - exp(parms[5] + parms[7] * x[2]) / (1 + exp(parms[4] + parms[7] * x[1]) + exp(parms[5] + parms[7] * x[2]) + exp(parms[6] + parms[7] * x[3])),
F6 = x[6] - exp(parms[6] + parms[7] * x[3]) / (1 + exp(parms[4] + parms[7] * x[1]) + exp(parms[5] + parms[7] * x[2]) + exp(parms[6] + parms[7] * x[3])),
)
But when I call
new.equi = multiroot(model, start = initial.value, parms = parm)
where I pass value to initial.value and parm, I keep getting the error of
Error in c(F1 = x[1] - parms[1] - 1/((-parms[7]) * (1 - x[4])), F2 = x[2] - : argument 7 is empty
Why is this happening? Why should there be argument 7?
I also tried to specify parameters in the model explicitly, like this, but still get the same error.
model <- function(x) c(F1 = x[1] - 1.265436 - 1 / (2.443700 * (1 - x[4])),
F2 = x[2] - 1.195844 - 1 / (2.443700 * (1 - x[5])),
F3 = x[3] - 1.288660 - 1 / (2.443700 * (1 - x[6])),
F4 = x[4] - exp(4.600528 - 2.443700 * x[1]) / (1 + exp(4.600528 - 2.443700 * x[1]) + exp(3.924360 - 2.443700 * x[2]) + exp(4.643808 - 2.443700 * x[3])),
F5 = x[5] - exp(3.924360 - 2.443700 * x[2]) / (1 + exp(4.600528 - 2.443700 * x[1]) + exp(3.924360 - 2.443700 * x[2]) + exp(4.643808 - 2.443700 * x[3])),
F6 = x[6] - exp(4.643808 - 2.443700 * x[3]) / (1 + exp(4.600528 - 2.443700 * x[1]) + exp(3.924360 - 2.443700 * x[2]) + exp(4.643808 - 2.443700 * x[3])),
)
You have a trailing comma. E.g.:
> c(1,2,)
Error in c(1, 2, ) : argument 3 is empty
I have been trying to estimate a rather messy nonlinear regression model in R for quite some time now. After countless failed attempts using the nls function, I am now trying my luck with optim, which I have used many times in the past. For this example, I'll use the following data:
x1 <- runif(1000,0,7)
x2 <- runif(1000,0,7)
x3 <- runif(1000,0,7)
y <- log(.5 + .5*x1 + .7*x2 + .4*x3 + .05*x1^2 + .1*x2^2 + .15*x3^2 - .05*x1*x2 - .1*x1*x3 - .07*x2*x3 + .02*x1*x2*x2) + rnorm(1000)
I would like to estimate the parameters in the polynomial expression inside the log() function above, and so I have defined the following function to replicate a nonlinear least squares regression:
g <- function(coefs){
fitted <- coefs[1] + coefs[2]*x1 + coefs[3]*x2 + coefs[4]*x3 + coefs[5]*x1^2 + coefs[6]*x2^2 + coefs[7]*x3^2 + coefs[8]*x1*x2 + coefs[9]*x1*x3 + coefs[10]*x2*x3 + coefs[11]*x1*x2*x3
error <- y - log(fitted)
return(sum(error^2))
}
In order to avoid negative starting values inside the log() expression, I first estimate the linear model below:
lm.1 <- lm(I(exp(y)) ~ x1 + x2 + x3 + I(x1^2) + I(x2^2) + I(x3^2) + I(x1*x2) + I(x1*x3) + I(x2*x3) + I(x1*x2*x3))
intercept.start <- ifelse((min(fitted(lm.1)-lm.1$coefficients[1])) <= 0, -(min(fitted(lm.1)-lm.1$coefficients[1])) + .5, .5)
coefs.start <- c(intercept.start,lm.1$coefficients[-1])
Defining intercept.start above guarantees that the expression inside of log() will be strictly positive at the outset. However, when I run the optim command
nl.model <- optim(coefs.start, g, method="L-BFGS-B")
I get the following error message
Error in optim(coefs.start, g, method = "L-BFGS-B") :
L-BFGS-B needs finite values of 'fn'
In addition: Warning message:
In log(fitted) : NaNs produced
Does anyone know how I can force the optim routine to simply disregard parameter estimates that would produce negative values inside of the log() expression? Thanks in advance.
Here's a slightly different approach.
Aside from the typo mentioned in the comment, if the issue is that the argument to the log(...) is < 0 for certain parameter estimates, you can change the function definition to prevent that.
# just some setup - we'll need this later
set.seed(1)
err <- rnorm(1000, sd=0.1) # note smaller error sd
x1 <- runif(1000,0,7)
x2 <- runif(1000,0,7)
x3 <- runif(1000,0,7)
par <- c(0.5, 0.5, 0.7, 0.4, 0.05, 0.1, 0.15, -0.05, -0.1, -0.07, 0.02)
m <- cbind(1, x1, x2, x3, x1^2, x2^2, x3^2, x1*x2, x1*x3, x2*x3, x1*x2*x3)
y <- as.numeric(log(m %*% par)) + err
# note slight change in the model function definition
g <- function(coefs){
fitted <- coefs[1] + coefs[2]*x1 + coefs[3]*x2 + coefs[4]*x3 + coefs[5]*x1^2 + coefs[6]*x2^2 + coefs[7]*x3^2 + coefs[8]*x1*x2 + coefs[9]*x1*x3 + coefs[10]*x2*x3 + coefs[11]*x1*x2*x3
fitted <- ifelse(fitted<=0, 1, fitted) # ensures fitted > 0
error <- y - log(fitted)
return(sum(error^2))
}
lm.1 <- lm(I(exp(y)) ~ x1 + x2 + x3 + I(x1^2) + I(x2^2) + I(x3^2) + I(x1*x2) + I(x1*x3) + I(x2*x3) + I(x1*x2*x3))
nl.model <- optim(coef(lm.1), g, method="L-BFGS-B", control=list(maxit=1000))
nl.model$par
# (Intercept) x1 x2 x3 I(x1^2) I(x2^2) I(x3^2) I(x1 * x2) I(x1 * x3) I(x2 * x3) I(x1 * x2 * x3)
# 0.40453182 0.50136222 0.71696293 0.45335893 0.05461253 0.10210854 0.14913914 -0.06169715 -0.11195476 -0.08497180 0.02531717
with(nl.model, cat(convergence, message))
# 0 CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH
Note that these estimates are pretty close to the actual values. That's because in the setup I used a smaller error term (sd = 0.2 instead of 1). In your example, the error is large compared to the response (y), so you're basically fitting random error.
If you fit the model using the actual parameter values as starting estimates, you get nearly identical results, no closer to the "true" values.
nl.model <- optim(par, g, method="L-BFGS-B", control=list(maxit=1000))
nl.model$par
# [1] 0.40222956 0.50159930 0.71734810 0.45459606 0.05465654 0.10206887 0.14899640 -0.06177640 -0.11209065 -0.08497423 0.02533085
with(nl.model, cat(convergence, message))
# 0 CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH
Try this with the original error (sd = 1) and see what happens.
Here's a log of my efforts to investigate. I put a maximum on the fitted values and got convergence. I then asked myself if increasing that max would do anything th the estimated parameters and found that there was no change... AND there was no difference from the starting values, so I think you messed up in building the function. Perhaps you can investigate further:
> gp <- function(coefs){
+
+ fitted <- coefs[1] + coefs[2]*x1 + coefs[3]*x2 + coefs[4]*x3 + coefs[5]*x1^2 + coefs[6]*x2^2 + coefs[7]*x3^2 + coefs[8]*x1*x2 + coefs[9]*x1*x3 + coefs[10]*x2*x3 + coefs[11]*x1*x2*x3 }
> describe( gp( coefs.start) ) #describe is from pkg:Hmisc
gp(coefs.start)
n missing unique Info Mean .05 .10 .25 .50 .75
1000 0 1000 1 13.99 2.953 4.692 8.417 12.475 18.478
.90 .95
25.476 28.183
lowest : 0.5000 0.5228 0.5684 0.9235 1.1487
highest: 41.0125 42.6003 43.1457 43.5950 47.2234
> g <- function(coefs){
+
+ fitted <- max( coefs[1] + coefs[2]*x1 + coefs[3]*x2 + coefs[4]*x3 + coefs[5]*x1^2 + coefs[6]*x2^2 + coefs[7]*x3^2 + coefs[8]*x1*x2 + coefs[9]*x1*x3 + coefs[10]*x2*x3 + coefs[11]*x1*x2*x3 , 1000)
+ error <- y - log(fitted)
+ return(sum(error^2))
+ }
> nl.model <- optim(coefs.start, g, method="L-BFGS-B")
> nl.model
$par
x1 x2 x3 I(x1^2)
0.77811231 -0.94586233 -1.33540959 1.65454871 0.31537594
I(x2^2) I(x3^2) I(x1 * x2) I(x1 * x3) I(x2 * x3)
0.45717138 0.11051418 0.59197115 -0.25800792 0.04931727
I(x1 * x2 * x3)
-0.08124126
$value
[1] 24178.62
$counts
function gradient
1 1
$convergence
[1] 0
$message
[1] "CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL"
> g <- function(coefs){
+
+ fitted <- max( coefs[1] + coefs[2]*x1 + coefs[3]*x2 + coefs[4]*x3 + coefs[5]*x1^2 + coefs[6]*x2^2 + coefs[7]*x3^2 + coefs[8]*x1*x2 + coefs[9]*x1*x3 + coefs[10]*x2*x3 + coefs[11]*x1*x2*x3 , 100000)
+ error <- y - log(fitted)
+ return(sum(error^2))
+ }
> nl.model <- optim(coefs.start, g, method="L-BFGS-B")
> nl.model
$par
x1 x2 x3 I(x1^2)
0.77811231 -0.94586233 -1.33540959 1.65454871 0.31537594
I(x2^2) I(x3^2) I(x1 * x2) I(x1 * x3) I(x2 * x3)
0.45717138 0.11051418 0.59197115 -0.25800792 0.04931727
I(x1 * x2 * x3)
-0.08124126
$value
[1] 89493.99
$counts
function gradient
1 1
$convergence
[1] 0
$message
[1] "CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL"
.