Related
I am trying to solve a system of n equations in R. n-1 of the equations are non-linear and the last one is linear. If it helps, this is a constrained optimization problem, with the n-1 equation being first order conditions, and the last being a budget constraint. The n-1 non-linear equations can be characterized by:non-linear equations
In case the image doesn't show, it can be defined, element-by-element like:
v_i*epsilon_i*cos(2/pi * e_i/delta_i)-lambda=0
where epsilon,v, e, and delta are vectors of n-1 dimension, and lambda is a scalar common to all equations).
The last equation is a simple linear equation of the form |e|=c. That is, the sum of all elements in e is some known c, called below parms[1,4] or "budget".
I am interested in solving for the vector e and the constant lambda, treating everything else as given.
I tried using rootSolve's multiroot. To do this, I define a single vector X, which is supposed to be the vector e, with lambda appended to it, so that multiroot solves for x, and is given the n equations as a list. All the parameters are saved in a matrix called "parms"
I first define the n-1 non-linear equations
convex_focs <- function(x = numeric(),parms = numeric()){
deltas = parms[,1]
v = parms[,2]
lambda = x[1]
e = x[2:length(x)]
epsilon_2 = exp(parms[,3]) - parms[,1]
return(epsilon_2*cos((pi/2)*(e/deltas))-lambda)
}
This equation uses the matrix notation, and works fine by itself.
I then define the last, linear, equation:
convex_budget <- function(x = numeric(),parms = numeric()){
e = x[2:length(x)]
return(sum(e)-parms[1,4])
}
I then tried convex_system <- function(x,parms) c(convex_focs,convex_budget ) and call:
multiroot(f = convex_system, maxiter = 500000, start = c(0,rep(budget/length(parms[,1]),length(parms[,1]))), parms = parms[,])
This of course doesn't work, as rootSolve recognizes convex_system as two equations, but X as n-dimensions.
If I drop the last equation, and treat lambda as given (so only solving the non-linear equations) I can get a solution. But of course this isn't good, because I don't know lambda.
So my first question is:
1. How do I generate a list of functions from my vectors that rootSolve will recognize as a system?
I tried using lapply, or using vignettes, to create a list of the convex_focs equations, one for every elememt in the vector, but couldn't think of a way to make it work.
2. Why would it recognize my original convex_focs function as a system of equations, but when I add convex_budget it stopped working?
I then (in desperation...) tried manually defining a set of functions, looking at only 3 non-linear, rather than n-1. This is so that my list of functions will look like the manual and other solutions I found online:
convex_system <- function(x,parms) c(F1 =
function(x =x,parms = parms){
deltas = parms[1,1]
v = parms[1,2]
lambda = x[1]
e = x[2]
epsilon_2 = exp(parms[1,3]) - parms[1,1]
return(v*epsilon_2*cos((pi/2)*(e/deltas))-lambda)
}
,
F2 =
function(x = x,parms = parms){
deltas = parms[2,1]
v = parms[2,2]
lambda = x[1]
e = x[3]
epsilon_2 = exp(parms[2,3]) - parms[2,1]
return(v*epsilon_2*cos((pi/2)*(e/deltas))-lambda)
}
,
F3 =
function(x = x,parms = parms){
deltas = parms[3,1]
v = parms[3,2]
lambda = x[1]
e = x[4]
epsilon_2 = exp(parms[3,3]) - parms[3,1]
return(v*epsilon_2*cos((pi/2)*(e/deltas))-lambda)
}
,
F_budget = function(x = x,parms = parms){
e = x[2:length(x)]
return(sum(e)-parms[1,4])}
)
And calling multiroot(f = convex_system, maxiter = 500000, start = c(0,rep(budget/length(parms[1:3,1]),length(parms[1:3,1]))), parms = parms[1:3,])
When I run this I get the error
Error in stode(y, times, func, parms = parms, ...) :
REAL() can only be applied to a 'numeric', not a 'list'
Which I really don't understand - how could the list of functions not be of class 'list'?
So my second question is:
How does one generate a list of functions when they are not simple one-line-functions (as those in the links above)
Finally, I'd greatly appreciate any guidance on how to better solve these types of problems in R.
Thank you for any assistance!
The main problem with your approach is the specification of the function convex_system. The way you have written it implies that it is a vector of functions and it is not being evaluated. Just try the single statement convex_system(start,parms) to see the return value.
Change this to
convex_system <- function(x,parms) c(convex_focs(x,parms),convex_budget(x,parms) )
which returns the values returned for specific values of x and parms.
You have not provided any values for the constants and variables. So we can't try something.
So use fake data:
budget <- 100
lambda <- 5
parms <- matrix(c(1,2,3,
2,3,4,
3,4,5,
105,0,0), ncol=4,byrow=FALSE)
parms
xstart <- c(0,rep(budget/length(parms[1:3,1]),length(parms[1:3,1])))
And please do not forget to show all relevant code even library statements.
I have tried two packages for solving a system of nonlinear equations: nleqslv and rootSolve.
library(nleqslv)
nleqslv(xstart,convex_system,parm=parms)
resulting in
$x
[1] -18.07036 37.79143 34.44652 32.76205
$fvec
[1] 6.578382e-10 -4.952128e-11 -1.673328e-12 0.000000e+00
$termcd
[1] 1
$message
[1] "Function criterion near zero"
$scalex
[1] 1 1 1 1
$nfcnt
[1] 146
$njcnt
[1] 7
$iter
[1] 92
See the documentation of nleqslv for the meaning of the elements of the above list. Additionally nleqslv in this case used the Broyden method which saves Jacobian computations.
Using rootSolve gives:
library(rootSolve)
multiroot(f = convex_system, maxiter = 500000, start = xstart, parms=parms)
$root
[1] -18.07036 37.79143 34.44652 32.76205
$f.root
[1] 1.650808e-06 4.383290e-08 8.365979e-08 1.250555e-11
$iter
[1] 10
$estim.precis
[1] 4.445782e-07
As you can see both give the same results but the results of nleqslv appear to be closer to zero for the constituent function values (compare fvec with f.root). You should be aware of the difference in convergence criteria (see documentation).
Whether this will solve your full problem is up to you to find out.
Addendum
It seems that nleqslv needs more iterations than rootSolve. This is related to the global search method used. By using the function testnslv one can look for a global method using less iterations like this
testnslv(xstart,convex_system,parm=parms)
with the following result
Call:
testnslv(x = xstart, fn = convex_system, parm = parms)
Results:
Method Global termcd Fcnt Jcnt Iter Message Fnorm
1 Newton cline 1 21 12 12 Fcrit 1.770e-24
2 Newton qline 1 21 12 12 Fcrit 2.652e-24
3 Newton gline 1 17 8 8 Fcrit 5.717e-25
4 Newton pwldog 1 45 31 31 Fcrit 9.837e-24
5 Newton dbldog 1 34 26 26 Fcrit 1.508e-25
6 Newton hook 1 65 40 40 Fcrit 2.025e-26
7 Newton none 1 10 10 10 Fcrit 7.208e-25
8 Broyden cline 1 19 2 12 Fcrit 1.775e-19
9 Broyden qline 1 19 2 12 Fcrit 1.768e-19
10 Broyden gline 1 43 3 13 Fcrit 9.725e-18
11 Broyden pwldog 1 161 4 105 Fcrit 1.028e-19
12 Broyden dbldog 1 168 5 111 Fcrit 9.817e-21
13 Broyden hook 1 121 7 67 Fcrit 5.138e-25
14 Broyden none 1 11 1 11 Fcrit 7.487e-22
One can see that for method="Newton" the methods gline and none (pure Newton-Raphson) require the least amount of iterations. And that the Broyden method with no global search at all requires the least number of function evaluations.
Warning
To see why some of the global methods are "better" specify control=list(trace=1) as an argument to nleqslv for e.g. global="none" and global="gline". You will see that pure Newton is not decreasing the function criterion in each iteration. It is just lucky.
I use optim(.) to try to find the best fitting parameters for some function fn(dat, par, out=FALSE) where par must be a vector of two elements and out determines the output format. I use
optim(par=c(1,1), fn, dat=dat)
to identify the best-fitting values of par. Depending on the data in dat, this either works ot throws an error that
function cannot be evaluated at initial parameters
which I understand requires different starting values for optim(.). My problem is that I apply the function to many data sets in parallel and wonder whether I indeed need to try different values by hand or whether there is some way of automatizing this along the lines of
if no error then great
if error try par=c(0.5,1)
if no error then great
if error try par=c(0.5,0.5)
...
You could run a grid search before you start and discard NA parameters. Here is an example.
A test function:
fn <- function(x) {
if (x[1] < 0)
NA
else
prod(x)
}
Now run a grid search.
library("NMOF")
res <- gridSearch(fn,
npar = 2, ## length of x
lower = -1, ## lower bound for x
upper = 3, ## upper bound for x
n = 5) ## number of levels per element in x
## 2 variables with 5, 5 levels: 25 function evaluations required.
The function shows you all the parameter combinations it tried.
res$levels
## [[1]]
## [1] -1 -1
##
## [[2]]
## [1] 0 -1
##
## [[3]]
## [1] 1 -1
##
## ....
And it provides the objective function values associated with these combinations.
res$values
## [1] NA 0 -1 -2 -3 NA 0 0 0 0 NA 0 1 2 3
## [16] NA 0 2 4 6 NA 0 3 6 9
## => many objective functions values are NA
The best (none-NA) solution:
res$minlevels
## [1] 3 -1
## => your starting value for optim:
##
## optim(gridSearch(fn, npar = 2,
## lower = -1, upper = 3, n = 5)$minlevels,
## fn, dat = dat)
Of course, this won't give you a guarantee that at least one none-NAvector is found, but the chances may improve.
I'm trying to implement the "synthesis equation" from the DSP Guide, equation 8-2, so I can resample a time series in the frequency domain. The way I read the equation, N is the number of output points, and given the loop of k from 0 to N/2, I can only resample to twice the original sampling rate, at most.
I tried writing a quick implementation in R, but the results are not anything close to what I expect. My code:
input <- c(1:9)
nin <- 9
nout <- 17
b <-fft(input)
reals <- Re(b) / (nout / 2)
imags <- Im(b) / (nout / 2)
reals[1] <- reals[1] / 2
reals[(nout/2)] <- reals[(nout/2)] / 2
output <- c(1:nout)
for (i in 1:nout)
{
realSum <- 0
imagSum <- 0
for (k in 1:(nout/2))
{
angle <- 2 * pi * (k-1) * (i-1) / nout
realSum <- realSum + (reals[k] * cos(angle))
imagSum <- imagSum - (imags[k] * sin(angle))
}
output[i] <- (realSum + imagSum)
}
For my input (sampled at say 1 second, resampling to 0.5 second)
[1] 1 2 3 4 5 6 7 8 9
I get the output
[1] -0.7941176 1.5150954 0.7462716 1.5022387 1.6478971 1.8357487
2.4029773 2.1965426 3.1585254 2.6178195 3.7284660 3.3721128 3.8433588 4.6390705
[15] 3.4699088 6.3005605 2.8175240
while my expected output is
[1] 1 1.5 2 2.5 3 3.5 4 4.5 5 5.5 6 6.5 7 7.5 8 8.5 9
What am I doing wrong?
The above code does look like the inverse DFT that you referenced in the article. From your expected desired input/output, it seems like you need a cheap linear interpolation rather than a DFT/Inverse DFT solution.
From your desired input/output relationship statement above, it seems like you have a desired relationship between a time series input and a desired time series output.
A inverse DFT, which you coded, will go from frequency domain to time domain.
From what I could gather from your statements, start with the series [1,1->9], do a forward DFT (to get to frequency domain), then take that result into an inverse DFT (to get back to time domain).
Hopefully this is a hint in the right direction for you.
I want to code travelling salesman problem in R. I am going to begin with 3 cities at first then I will expand to more cities. distance matrix below gives distance between 3 cities. Objective (if someone doesn't know) is that a salesman will start from a city and will visit 2 other cities such that he has to travel minimum distance.
In below case he should start either from ny or LA and then travel to chicago and then to the remaining city. I need help to define A_ (my constraint matrix).
My decision variables will of same dimension as distances matrix. It will be a 1,0 matrix where 1 represents travel from city equal to row name to a city equal to column name. For instance if a salesman travels from ny to chicago, 2nd element in row 1 will be 1. My column and row names are ny,chicago and LA
By looking at the solution of the problem I concluded that my constraints will be::
Row sums have to be less than 1 as he cannot leave from same city twice
Column sums have to be less than 1 as he cannot enter the same city twice
total sum of matrix elements has to be 2 as the salesman will be visiting 2 cities and leaving from 2 cities.
I need help to define A_ (my constraint matrix). How should I tie in my decision variables into constraints?
ny=c(999,9,20)
chicago=c(9,999,11)
LA=c(20,11,999)
distances=cbind(ny,chicago,LA)
dv=matrix(c("a11","a12","a13","a21","a22","a23","a31","a32","a33"),nrow=3,ncol=3)
c_=c(distances[1,],distances[2,],distances[3,])
signs = c((rep('<=', 7)))
b=c(1,1,1,1,1,1,2)
res = lpSolve::lp('min', c_, A_, signs, b, all.bin = TRUE)
There are some problems with your solution. The first is that the constraints you have in mind don't guarantee that all the cities will be visited -- for example, the path could just go from NY to LA and then back. This could be solved fairly easily, for example, by requiring that each row and column sum to exactly one rather than at most 1 (although in that case you'd be finding a traveling salesman tour rather than just a path).
The bigger problem is that, even if we fix this problem, your constraints wouldn't guarantee that the selected vertices actually form one cycle through the graph, rather than multiple smaller cycles. And I don't think that your representation of the problem can be made to address this issue.
Here is an implementation of Travelling Salesman using LP. The solution space is of size n^3, where n is the number of rows in the distance matrix. This represents n consecutive copies of the nxn matrix, each of which represents the edge traversed at time t for 1<=t<=n. The constraints guarantee that
At most one edge is traversed each step
Ever vertex is visited exactly once
The startpoint of the i'th edge traversed is the same as the endpoint of the i-1'st
This avoids the problem of multiple small cycles. For example, with four vertices, the sequence (12)(21)(34)(43) would not be a valid solution because the endpoint of the second edge (21) does not match the start point of the third (34).
tspsolve<-function(x){
diag(x)<-1e10
## define some basic constants
nx<-nrow(x)
lx<-length(x)
objective<-matrix(x,lx,nx)
rowNum<-rep(row(x),nx)
colNum<-rep(col(x),nx)
stepNum<-rep(1:nx,each=lx)
## these constraints ensure that at most one edge is traversed each step
onePerStep.con<-do.call(cbind,lapply(1:nx,function(i) 1*(stepNum==i)))
onePerRow.rhs<-rep(1,nx)
## these constraints ensure that each vertex is visited exactly once
onceEach.con<-do.call(cbind,lapply(1:nx,function(i) 1*(rowNum==i)))
onceEach.rhs<-rep(1,nx)
## these constraints ensure that the start point of the i'th edge
## is equal to the endpoint of the (i-1)'st edge
edge.con<-c()
for(s in 1:nx){
s1<-(s %% nx)+1
stepMask<-(stepNum == s)*1
nextStepMask<- -(stepNum== s1)
for(i in 1:nx){
edge.con<-cbind(edge.con,stepMask * (colNum==i) + nextStepMask*(rowNum==i))
}
}
edge.rhs<-rep(0,ncol(edge.con))
## now bind all the constraints together, along with right-hand sides, and signs
constraints<-cbind(onePerStep.con,onceEach.con,edge.con)
rhs<-c(onePerRow.rhs,onceEach.rhs,edge.rhs)
signs<-rep("==",length(rhs))
list(constraints,rhs)
## call the lp solver
res<-lp("min",objective,constraints,signs,rhs,transpose=F,all.bin=T)
## print the output of lp
print(res)
## return the results as a sequence of vertices, and the score = total cycle length
list(cycle=colNum[res$solution==1],score=res$objval)
}
Here is an example:
set.seed(123)
x<-matrix(runif(16),c(4,4))
x
## [,1] [,2] [,3] [,4]
## [1,] 0.2875775 0.9404673 0.5514350 0.6775706
## [2,] 0.7883051 0.0455565 0.4566147 0.5726334
## [3,] 0.4089769 0.5281055 0.9568333 0.1029247
## [4,] 0.8830174 0.8924190 0.4533342 0.8998250
tspsolve(x)
## Success: the objective function is 2.335084
## $cycle
## [1] 1 3 4 2
##
## $score
## [1] 2.335084
We can check the correctness of this answer by using a primitive brute force search:
tspscore<-function(x,solution){
sum(sapply(1:nrow(x), function(i) x[solution[i],solution[(i%%nrow(x))+1]]))
}
tspbrute<-function(x,trials){
score<-Inf
cycle<-c()
nx<-nrow(x)
for(i in 1:trials){
temp<-sample(nx)
tempscore<-tspscore(x,temp)
if(tempscore<score){
score<-tempscore
cycle<-temp
}
}
list(cycle=cycle,score=score)
}
tspbrute(x,100)
## $cycle
## [1] 3 4 2 1
##
## $score
## [1] 2.335084
Note that, even though these answers are nominally different, they represent the same cycle.
For larger graphs, though, the brute force approach doesn't work:
> set.seed(123)
> x<-matrix(runif(100),10,10)
> tspsolve(x)
Success: the objective function is 1.296656
$cycle
[1] 1 10 3 9 5 4 8 2 7 6
$score
[1] 1.296656
> tspbrute(x,1000)
$cycle
[1] 1 5 4 8 10 9 2 7 6 3
$score
[1] 2.104487
This implementation is pretty efficient for small matrices, but, as expected, it starts to deteriorate severely as they get larger. At about 15x15 it starts slowing down quite a bit:
timetsp<-function(x,seed=123){
set.seed(seed)
m<-matrix(runif(x*x),x,x)
gc()
system.time(tspsolve(m))[3]
}
sapply(6:16,timetsp)
## elapsed elapsed elapsed elapsed elapsed elapsed elapsed elapsed elapsed elapsed
## 0.011 0.010 0.018 0.153 0.058 0.252 0.984 0.404 1.984 20.003
## elapsed
## 5.565
You can use the gaoptim package to solve permutation/real valued problems - it's pure R, so it's not so fast:
Euro tour problem (see ?optim)
eurodistmat = as.matrix(eurodist)
# Fitness function (we'll perform a maximization, so invert it)
distance = function(sq)
{
sq = c(sq, sq[1])
sq2 <- embed(sq, 2)
1/sum(eurodistmat[cbind(sq2[,2], sq2[,1])])
}
loc = -cmdscale(eurodist, add = TRUE)$points
x = loc[, 1]
y = loc[, 2]
n = nrow(eurodistmat)
set.seed(1)
# solving code
require(gaoptim)
ga2 = GAPerm(distance, n, popSize = 100, mutRate = 0.3)
ga2$evolve(200)
best = ga2$bestIndividual()
# solving code
# just transform and plot the results
best = c(best, best[1])
best.dist = 1/max(ga2$bestFit())
res = loc[best, ]
i = 1:n
plot(x, y, type = 'n', axes = FALSE, ylab = '', xlab = '')
title ('Euro tour: TSP with 21 cities')
mtext(paste('Best distance found:', best.dist))
arrows(res[i, 1], res[i, 2], res[i + 1, 1], res[i + 1, 2], col = 'red', angle = 10)
text(x, y, labels(eurodist), cex = 0.8, col = 'gray20')
I am using the lpsolveAPI in RStudio. When I type the name of a model with few decision variables, I can read a printout of the current constraints in the model. For example
> lprec
Model name:
COLONE COLTWO COLTHREE COLFOUR
Minimize 1 3 6.24 0.1
THISROW 0 78.26 0 2.9 >= 92.3
THATROW 0.24 0 11.31 0 <= 14.8
LASTROW 12.68 0 0.08 0.9 >= 4
Type Real Real Real Real
Upper Inf Inf Inf 48.98
Lower 28.6 0 0 18
But when I make a model that has more than 9 decision variables, it no longer gives the full summary and I instead see:
> lprec
Model name:
a linear program with 13 decision variables and 258 constraints
Does anyone know how I can see the same detailed summary of the model when there are large numbers of decision variables?
Bonus Question: Is RStudio the best console for working with R?
Here is an example:
>lprec <- make.lp(0,5)
This makes a new model called lprec, with 0 constraints and 5 variables. Even if you call the name now you get:
>lprec
Model name:
C1 C2 C3 C4 C5
Minimize 0 0 0 0 0
Kind Std Std Std Std Std
Type Real Real Real Real Real
Upper Inf Inf Inf Inf Inf
Lower 0 0 0 0 0
The C columns correspond to the 5 variables. Right now there are no constraints and the objective function is 0.
You can add a constraint with
>add.constraint(lprec, c(1,3,4,2,-8), "<=", 0)
This is the constraint C1 + 3*C2 + 4*C3 + 2*C4 - 8*C5 <= 0. Now the print out is:
Model name:
C1 C2 C3 C4 C5
Minimize 0 0 0 0 0
R1 1 3 4 2 -8 <= 0
Kind Std Std Std Std Std
Type Real Real Real Real Real
Upper Inf Inf Inf Inf Inf
Lower 0 0 0 0 0
Anyway the point is that no matter how many constraints, if there are more than 9 variables then I don't get the full print out.
>lprec <- make.lp(0,15)
>lprec
Model name:
a linear program with 15 decision variables and 0 constraints
Write it out to a file for examination
When I work with LPs using lpSolveAPI, I prefer to write them out to a file. The lp format works fine for my needs. I then examine the LP model using any text editor. If you click on the output file in the "Files" panel in RStudio, it will open it too, and you can inspect it.
write.lp(lprec, "lpfilename.lp", "lp") #write it to a file in LP format
You can also write it out as MPS format if you so choose.
Here's the help file on write.lp().
Hope that helps.
Since it is an S3 object of class lpExtPtr,
the function called to display it is print.lpExtPtr.
If you check its code, you will see that it displays the object
differently depending on its size --
details for very big objects would not be very useful.
Unfortunately, the threshold cannot be changed.
class(r)
# [1] "lpExtPtr"
print.lpExtPtr
# function (x, ...)
# {
# (...)
# if (n > 8) {
# cat(paste("Model name: ", name.lp(x), "\n", " a linear program with ",
# n, " decision variables and ", m, " constraints\n",
# sep = ""))
# return(invisible(x))
# }
# (...)
You can access the contents of the object with the various get.* functions,
as the print method does.
Alternatively, you can just change the print method.
# A function to modify functions
patch <- function( f, before, after ) {
f_text <- capture.output(dput(f))
g_text <- gsub( before, after, f_text )
g <- eval( parse( text = g_text ) )
environment(g) <- environment(f)
g
}
# Sample data
library(lpSolveAPI)
r <- make.lp(0,5)
r # Shows the details
r <- make.lp(0,20)
r # Does not show the details
# Set the threshold to 800 variables instead of 8
print.lpExtPtr <- patch( print.lpExtPtr, "8", "800" )
r # Shows the details