I'm attempting to use the constrOptim() function in R to optimise:
2x + 2y + 3z
subject to:
-2x + y + z <= 1
4x - y + 3z <= 3
x, y, z >= 0
What I have so far is this:
ui = matrix(c(2,-1,-1,-4, 1,-3, 1, 0, 0, 0, 1, 0, 0, 0, 1),
nrow = 5,
byrow = T)
ci = c(-1, -3, 0, 0, 0)
theta = c(0, 1, 0)
constrOptim(
theta = theta,
f = func,
ui = ui,
ci = ci)
This gives me the error that "initial value is not in the interior of the feasible region". However, if I run the following as a test:
ui = matrix(c(2,-1,-1,-4, 1,-3, 1, 0, 0, 0, 1, 0, 0, 0, 1),
nrow = 5,
byrow = T)
ci = c(-1, -3, 0, 0, 0)
theta = c(0, 1, 0)
ui %*% theta - ci
I get (0 4 0 1 0), which is definitely >=0.
My question is why do I get an error telling me that ui %*% theta - ci is not >= 0, when it clearly is? What am I missing?
Edit: managed to sort it out thanks to Stéphane Laurent.
Any ideas how best to plot the feasible region in R? Any useful packages?
The starting value must be in the interior of the feasible region, so you need > 0 and not >= 0. You can use theta = c(0.1, 1, 0.1)
ui = matrix(c(2,-1,-1,-4, 1,-3, 1, 0, 0, 0, 1, 0, 0, 0, 1),
nrow = 5,
byrow = T)
ci = c(-1, -3, 0, 0, 0)
theta = c(0.1, 1, 0.1)
all(ui %*% theta - ci > 0) # TRUE
constrOptim(
theta = theta,
f = function(xyz) c(crossprod(c(2,2,3), xyz)),
grad = NULL,
ui = ui,
ci = ci)
BTW, it seems obvious to me that the solution is c(0,0,0).
The cause of error has been explained from the answer by Stéphane Laurent.
An alternative of constrOptim is to use fmincon from package pracma, and you can run the code without any error even with initial values on the boundary, i.e., theta = c(0,1,0)
ui = matrix(c(2,-1,-1,-4, 1,-3, 1, 0, 0, 0, 1, 0, 0, 0, 1),
nrow = 5,
byrow = T)
ci = c(-1, -3, 0, 0, 0)
theta = c(0, 1, 0)
func <- function(v) crossprod(c(2,2,3),v)
res <- pracma::fmincon(theta,
f = func,
A = -ui,
b = -ci)
such that
> res
$par
[1] 0 0 0
$value
[,1]
[1,] 0
$convergence
[1] 0
$info
$info$lambda
$info$lambda$lower
[,1]
[1,] 0
[2,] 0
[3,] 0
$info$lambda$upper
[,1]
[1,] 0
[2,] 0
[3,] 0
$info$lambda$ineqlin
[1] 0 0 2 2 3
$info$grad
[,1]
[1,] 2
[2,] 2
[3,] 3
$info$hessian
[,1] [,2] [,3]
[1,] 1 0.00 0
[2,] 0 0.03 0
[3,] 0 0.00 1
Related
I am trying to make run this model. I am trying to maximize:x[4]
w.r.t Mv = c(0,0,0,0)
lb < v < ub
But I have 2 problems, first matrix multiplication.
library(ompr)
lb <- c(-200, 0, -200, -200)
ub <- c(1000, 1000, 1000, 1000)
M <- matrix(rbind(
c(-1, 0, -1, 0), # A
c(-1, 0, 0, -2), # B
c(1, -2, 0, 0), # C
c(1, 0, 0, 2), # D
c(0, 2, -1, 0), # E
c(0, 0, 1, -1) # F
), nrow = 6)
n <- 4
rhs <- rep(0, n)
model <- MIPModel() %>%
add_variable(x[i], i = 1:n, type = "continuous") %>%
set_objective(x[4]) %>%
add_constraint(M[i, ] %*% x == rhs[i], i = 1:n)
I got the following error.
Error in M[i, ] %*% x : requires numeric/complex matrix/vector
arguments
Second, I am trying to set the bounds in a vectorized way, but I don't know how to do that. I tried the following:
set_bounds(x[i], ub = ub[i], lb = lb[i], i = 1:n)
This gives:
object 'i' not found
Any help would be very useful!
Works like this, but the solution is (0, 0, 0, 0):
library(ompr)
library(ompr.roi)
library(ROI.plugin.glpk)
library(magrittr)
lb <- c(-200, 0, -200, -200)
ub <- c(1000, 1000, 1000, 1000)
M <- matrix(rbind(
c(-1, 0, -1, 0), # A
c(-1, 0, 0, -2), # B
c(1, -2, 0, 0), # C
c(1, 0, 0, 2), # D
c(0, 2, -1, 0), # E
c(0, 0, 1, -1) # F
), nrow = 6)
n <- 4
rhs <- rep(0, n)
model <- MIPModel() %>%
add_variable(x[i], i = 1:n, type = "continuous") %>%
set_objective(x[4], "max") %>%
add_constraint(sum_over(M[i, j] * x[j], j = 1:4) == rhs[i], i = 1:n) %>%
add_constraint(x[i] <= ub[i], i = 1:n) %>%
add_constraint(x[i] >= lb[i], i = 1:n) %>%
solve_model(with_ROI(solver = "glpk"))
get_solution(model, x[i])
I built my own function like this:
library(VineCopula)
Matrix <- c(5, 2, 3, 1, 4,
0, 2, 3, 4, 1,
0, 0, 3, 4, 1,
0, 0, 0, 4, 1,
0, 0, 0, 0, 1)
Matrix <- matrix(Matrix, 5, 5)
family <-par <- par2 <- list()
for(i in 1:3){
# define R-vine pair-copula family matrix
family[[i]] <- c(0, 1, 3, 4, 4,
0, 0, 3, 4, 1,
0, 0, 0, 4, 1,
0, 0, 0, 0, 3,
0, 0, 0, 0, 0)
family[[i]] <- matrix(family[[i]], 5, 5)
# define R-vine pair-copula parameter matrix
par[[i]] <- c(0, 0.2, 0.9, 1.5, 3.9,
0, 0, 1.1, 1.6, 0.9,
0, 0, 0, 1.9, 0.5,
0, 0, 0, 0, 4.8,
0, 0, 0, 0, 0)
par[[i]] <- matrix(par[[i]], 5, 5)
# define second R-vine pair-copula parameter matrix
par2[[i]] <- matrix(0, 5, 5)
}
my_func <- function(Matrix, family, par, par2){
x <- list()
for(i in 1:3){
x[[i]] <- RVineMatrix(Matrix = Matrix,family=family[[i]],par=par[[i]],par2 = par2[[i]])
}
x
}
This will return me a list. How can I then extract specific element from my function. For example, how I can get my_func$Matrix or my_func$par[1]
Note: family <– par <– par2 <– list(). I also tried return(x[i]$family[i]) and return NULL.
To run the function:
y <- my_func(Matrix = Matrix,family = family,par = par,par2 = par2)
> y$Matrix
NULL
Your function's return value is a listof class RVineMatrix with an element named Matrix. See the help page ?RVineMatrix, section Value. So you need y[[1]]$Matrix.
y <- my_func(Matrix, family, par, par2)
class(y)
[1] "list"
class(y[[1]])
[1] "RVineMatrix"
y[[1]]$Matrix
[,1] [,2] [,3] [,4] [,5]
[1,] 5 0 0 0 0
[2,] 2 2 0 0 0
[3,] 3 3 3 0 0
[4,] 1 4 4 4 0
[5,] 4 1 1 1 1
You'll need to assign the outcome of that function to something. For example:
y <- my_func(Matrix = ... , family = ..., par = ..., par2 = ...)
where ... above are the values of your arguments. Based on your my_func definition, the end result is an unnamed list so to access its elements you use:
y[[1]]
y[[2]]
y[[3]]
or just y to access all elements.
I've created a matrix which looks like this:
[,1] [,2] [,3] [,4] [,5] [,6] [,7]
[1,] 5 5 4 1.0 1 0 0
[2,] 5 2 0 2.0 0 2 3
[3,] 4 1 -1 2.0 -1 -1 -1
[4,] 36 37 -1 0.5 -1 -1 -1
When I ask my function to return a specific column, like this:
return( tree[,2])
It returns the value: [1] 4 0 -1 -1, which obviously is not the same value given by the matrix. This also happens when returning the value of [,3], where it gives [1] 0 3 -1 -1. It seems columns are skipped in the matrix. What could be the problem here?
I need the matrix to use its values in the next part of my code, with this problem I can not continue and I could not find this problem elsewhere.
Data
structure(c(5, 5, 4, 36, 5, 2, 1, 37, 4, 0, -1, -1, 1, 2, 2,
0.5, 1, 0, -1, -1, 0, 2, -1, -1, 0, 3, -1, -1), .Dim = c(4L, 7L))
dput(tree) information, as requested below:
`structure(c(1, 2, 2, 0.5, 1, 0, -1, -1, 0, 2, -1, -1), .Dim = c(4L,
3L))
structure(c(5, 2, 1, 37, 4, 0, -1, -1, 1, 2, 2, 0.5, 1, 0, -1,
-1, 0, 2, -1, -1), .Dim = 4:5)
structure(c(5, 5, 4, 36, 5, 2, 1, 37, 4, 0, -1, -1, 1, 2, 2,
0.5, 1, 0, -1, -1, 0, 2, -1, -1, 0, 3, -1, -1), .Dim = c(4L,
7L))`
EDIT 2:
I'm trying to build a classification tree where as an output I would like to return Nclass0, Nclass1, BestS and Best I for each split made in an other function tree.bestsplit.
`tree.grow = function(matrix, class, nmin=2, minleaf=1) {
nClass0 = length(which(class == 0))
nClass1 = length(which(class == 1))
if(nrow(matrix) < nmin || nClass0 == 0 || nClass1 == 0){
return(list(nClass0, nClass1, BestS = -1, BestR = -1))
}
bestR = -1
bestS = 0
bestI = 0
for (i in 1:ncol(matrix)) {
result = tree.bestsplit(matrix[,i], class, minleaf)
if(result[2] > bestR) {
bestR = result[2]
bestS = result[1]
bestI = i
}
}
if(is.null(bestI)){
return(list(nClass0, nClass1))
}
tree <- data.frame(nClass0, nClass1, bestI, bestS)
left = matrix[matrix[,bestI] <= bestS,]
leftClass = class[matrix[,bestI] <= bestS]
right = matrix[matrix[,bestI] > bestS,]
rightClass = class[matrix[,bestI] > bestS]
leftG = tree.grow(left, leftClass, nmin, minleaf)
rightG = tree.grow(right, rightClass, nmin, minleaf)
Lijst = list(nClass0, nClass1, bestI, bestS, leftG, rightG)
tree <- unlist(Lijst)
tree <- matrix(tree, nrow = 4)
return(tree)
}
`
I've been given a matrix:
P <- matrix(c(0, 0, 0, 0.5, 0, 0.5, 0.1, 0.1, 0, 0.4, 0, 0.4, 0, 0.2, 0.2, 0.3, 0, 0.3, 0, 0, 0.3, 0.5, 0, 0.2, 0, 0, 0, 0.4, 0.6, 0, 0, 0, 0, 0, 0.4, 0.6), nrow = 6, ncol = 6, byrow = TRUE)
Using the functions, mpow, rows_equal, matrices_equal. I want to find when P^n converges, in other words what n is, when all the rows are equal in the matrix and when P^n = P^(n+1).
By just looking at the functions i have managed to deduce that around n=19-21 the matrix will converge.
Although, I want to find the right n using a loop. Here under are the functions mpow, rows_equal and matrices_equal. I know they can be written differently but please keep them as they are.
mpow <- function(P, n, d=4) {
if (n == 0) diag(nrow(P)))
else if (n== 1) P
else P %*% mpow(P, n - 1))
}
rows_equal <- function(P, d = 4) {
P_new <- trunc(P * 10^d)
for (k in 2:nrow(P_new)) {
if (!all(P_new[1, ] == P_new[k, ])) {
return(FALSE)}
}
return(TRUE)
}
matrices_equal <- function(A, B, d = 4) {
A_new <- trunc(A * 10^d)
B_new <-trunc(B * 10^d)
if (all(A_new == B_new)) TRUE else FALSE
}
Now, to write the loop, we should do it something along the lines of:
First creating a function like so:
when_converged <- function(P) {...}
and
for (n in 1:50)
To try for when t.ex n = 50.
Although i don't know how to write the code correctly to do so, can anyone help me with that?
Thank you for reading my question.
Actually, a much better way is to do this:
## transition probability matrix
P <- matrix(c(0, 0, 0, 0.5, 0, 0.5, 0.1, 0.1, 0, 0.4, 0, 0.4, 0, 0.2, 0.2, 0.3, 0, 0.3, 0, 0, 0.3, 0.5, 0, 0.2, 0, 0, 0, 0.4, 0.6, 0, 0, 0, 0, 0, 0.4, 0.6), nrow = 6, ncol = 6, byrow = TRUE)
## a function to find stationary distribution
stydis <- function(P, tol = 1e-16) {
n <- 1; e <- 1
P0 <- P ## transition matrix P0
while(e > tol) {
P <- P %*% P0 ## resulting matrix P
e <- max(abs(sweep(P, 2, colMeans(P))))
n <- n + 1
}
cat(paste("convergence after",n,"steps\n"))
P[1, ]
}
Then when you call the function:
stydis(P)
# convergence after 71 steps
# [1] 0.002590674 0.025906736 0.116580311 0.310880829 0.272020725 0.272020725
The function stydis, essentially continuously does:
P <- P %*% P0
until convergence of P is reached. Convergence is numerically determined by the L1 norm of discrepancy matrix:
sweep(P, 2, colMeans(P))
The L1 norm is the maximum, absolute value of all matrix elements. When the L1 norm drops below 1e-16, convergence occurs.
As you can see, convergence takes 71 steps. Now, we can obtain faster "convergence" by controlling tol (tolerance):
stydis(P, tol = 1e-4)
# convergence after 17 steps
# [1] 0.002589361 0.025898057 0.116564506 0.310881819 0.272068444 0.271997814
But if you check:
mpow(P, 17)
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,] 0.002589361 0.02589806 0.1165645 0.3108818 0.2720684 0.2719978
# [2,] 0.002589415 0.02589722 0.1165599 0.3108747 0.2720749 0.2720039
# [3,] 0.002589738 0.02589714 0.1165539 0.3108615 0.2720788 0.2720189
# [4,] 0.002590797 0.02590083 0.1165520 0.3108412 0.2720638 0.2720515
# [5,] 0.002592925 0.02592074 0.1166035 0.3108739 0.2719451 0.2720638
# [6,] 0.002588814 0.02590459 0.1166029 0.3109419 0.2720166 0.2719451
Only the first 4 digits are the same, as you put tol = 1e-4.
A floating point number has a maximum of 16 digits, so I would suggest you use tol = 1e-16 for reliable convergence test.
Looking for sensible code to solve the following problem without a stack of "if" comparisons:
dput(acell)
structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0), .Dim = c(5L, 5L))
dput(bcell)
structure(c(0, 0, 1, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0,
1, 0, 1, 0, 0, 0, 0, 1), .Dim = c(5L, 5L))
It's guaranteed by construction (elsewhere in my code) that there is at least one nonzero entry in bcell in the four locations left,right,up,down one cell from the location of the nonzero value ([2,3]) in acell . Is there some better way to return the indices of all such nonzero cells? I'm currently using (pseudocode), for coords i,j referring to the nonzero element of acell ,
if( bcell[i-1,j]>0 ) found_values<-rbind(found_values,c(i-1,j))
if (bcell[i+1,j]>0 ) found_values<-rbind(found_values,c(i+1,j))
and so on.
Another possibility
# index of non-zero in acell
id <- which(acell == 1, arr.ind = TRUE)
# index of neighbors
rows <- id[1] + c(0, 0, -1, 1)
cols <- id[2] + c(-1, 1, 0, 0)
idx <- cbind(rows, cols)
# values of neighbors in bcell
vals <- bcell[idx]
# index of non-zero neighbors
idx[vals != 0, ]
# rows cols
# [1,] 2 2
# [2,] 3 3
Update: An alternative
# index of non-zero in acell
id <- which(acell == 1, arr.ind = TRUE)
id
# create a matrix with cells adjacent to 'id'
# 'non-neighbor' cells are multiplied by zero
m <- matrix(c(0, 1, 0,
1, 0, 1,
0, 1, 0), ncol = 3) *
bcell[id[1] + (-1:1), id[2] + (-1:1)]
# index of non-zero neighbours
idx <- which(m != 0, arr.ind = TRUE)
# 'de-center' the centered indices
idx2 <- sapply(1:2, function(x) id[x] + (idx[ , x] - 2))
colnames(idx2) <- c("rows", "cols")
idx2
# rows cols
# [1,] 2 2
# [2,] 3 3
Here is a start:
dim <- dim(acell)
lookfor <- which(acell != 0)
lookup <- which(bcell != 0)
if (!((lookfor %% dim[1]) %in% c(1L,0L)) &
!((lookfor %% dim[2]) %in% c(1L,0L)) ) {
neighborsR <- lookup[abs(lookfor-lookup) == 1L]
neighborsC <- lookup[(lookfor %% dim[1] == lookup %% dim[1]) &
abs(lookfor %/% dim[1] - lookup %/% dim[1]) == 1L]
}
neighbors <- c(neighborsR, neighborsC)
res <- cbind(neighbors %% dim[1], neighbors %/% dim[1]+1)
colnames(res) <- c("row", "col")
# row col
#[1,] 3 3
#[2,] 2 2
This can only handle one lookfor value, which is not in the first/last row/column.
neighbors <- function(mat) {
nr <- nrow(mat)
nc <- ncol(mat)
ones <- which(mat == 1)
adjacent <- c(
Filter(function(x) x %% nr != 0, ones - 1) ## above
, Filter(function(x) x %% nr != 1, ones + 1) ## below
, ones - nr ## left
, ones + nr ## right
)
adjacent <- unique(Filter(function(x) x > 0 && x <= nr * nc, adjacent))
out <- matrix(FALSE, nr, nc)
out[adjacent] <- TRUE
out
}
which(neighbors(acell) & bcell, arr.ind = TRUE)
## rows cols
## [1,] 2 2
## [2,] 3 3