How to include matrix multiplication in constraint? - r

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])

Related

Iterate through elements in a list with shared element names in R

I have a list that looks something like this (a must-reduced version of a list with 301 sub-elements):
myList <- list()
myList$Speaker1 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
myList$Speaker2 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
myList$Speaker3 <- list("ID" = c(1, 2, 3, 4, 5),
"S1C1.Sonorant" = c(0, 0, 0, 0.5, 0, -1),
"S1C1.Consonantal" = c(0, 0, 0, 0, 0, 1),
"S1C1.Voice" = c(0, 0, 1, 1, 1, -1),
"S1C1.Nasal" = c(0, 0, 1, 0, 1, -1))
For each speaker, I want to run some functions through all the sub-elements that include the string S1C1.. So far, I have the following, which calls each column containing S1C1 individually:
my_matrix <- lapply(myList, FUN = function(element) {
ones <- rep(1, nrow(element)) # count repeated rows
sonorant_vec.S1C1 <- element$S1C1.Sonorant
sonorant_mat.S1C1 <- (sonorant_vec.S1C1 %*% t(ones) - ones %*% t(sonorant_vec.S1C1))^2
consonantal_vec.S1C1 <- element$S1C1.Consonantal
consonantal_mat.S1C1 <- (consonantal_vec.S1C1 %*% t(ones) - ones %*% t(consonantal_vec.S1C1))^2
voice_vec.S1C1 <- element$S1C1.Voice
voice_mat.S1C1 <- (voice_vec.S1C1 %*% t(ones) - ones %*% t(voice_vec.S1C1))^2
nasal_vec.S1C1 <- element$S1C1.Nasal
nasal_mat.S1C1 <- (nasal_vec.S1C1 %*% t(ones) - ones %*% t(nasal_vec.S1C1))^2
mat.S1C1 <- sonorant_mat.S1C1 +
consonantal_mat.S1C1 +
voice_mat.S1C1 +
nasal_mat.S1C1
rownames(mat.S1C1) <- element$S1C1.S1C1
colnames(mat.S1C1) <- element$S1C1.S1C1
all_mat <- sqrt(mat.S1C1[,])
return(all_mat)
})
Is there a way I can iterate through all the sub-elements that start with the string S1C1.? The current code works but is very long!

constrOptim initial values

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

dplyr split-apply-combine with list column

Say I have a tibble with two columns: a group variable (grp) and a list-column
containing matrices of equal dimension (mat).
mat1 <- matrix(c(2, 0, 0, 0), nrow = 2)
mat2 <- matrix(c(0, 0, 0, 0), nrow = 2)
mat3 <- matrix(c(0, 0, 0, 2), nrow = 2)
mat4 <- matrix(c(0, 0, 0, 0), nrow = 2)
df <- tibble(grp = c('a', 'a', 'b', 'b'),
mat = list(mat1, mat2, mat3, mat4))
Edit:
I want to calculate the mean matrix by group, and add it as a new list-column. I.e. The new column should be:
list(matrix(c(1, 0, 0, 0), nrow = 2),
matrix(c(1, 0, 0, 0), nrow = 2),
matrix(c(0, 0, 0, 1), nrow = 2),
matrix(c(0, 0, 0, 1), nrow = 2))
The best I can do is:
df_out <- df %>%
group_by(grp) %>%
mutate(n = n(),
mean_mat = list(Reduce('+', mat) / n)) %>%
ungroup()
It works, but I'm trying to understand why the call to list is necessary, and also hoping to find an alternative approach (either tidyverse or base R) that is perhaps simpler.

how to use the dmvnorm function and mapply together

set.seed(1)
### i would like to do this
dmvnorm(c(.5,.5), mean= c(2,15), matrix(c(3, 0, 0, 9), 2))
dmvnorm(c(.6,.6), mean= c(5,18), matrix(c(6, 0, 0, 15), 2))
##### BUT using mapply instead... how can that be done?
u1 = c(2,15)
sigma1 = matrix(c(3, 0, 0, 9), 2)
u2 = c( 5, 18)
sigma2 = matrix(c(6, 0, 0, 15), 2)
parameters = list(mu = list(u1, u2), sigma = list(sigma1, sigma2))
mapply( c(c(.5,.5),c(.6,.6)), dmvnorm,
mean = c(parameters$mu[[1]], parameters$mu[[2]] ) ,
sigma= c(parameters$sigma[[1]],parameters$sigma[[2]]
) )
Put every parameters to the same argument in a list:
library(mvtnorm)
u <- list(u1 = c(2,15), u2 = c( 5, 18))
sigma <- list(sigma1 = matrix(c(3, 0, 0, 9), 2),
sigma2 = matrix(c(6, 0, 0, 15), 2))
x <- list(c(0.5, 0.5), c(0.6, 0.6))
result <- mapply(dmvnorm, x, u, sigma)
# [1] 1.780234e-07 1.384004e-07
This is equivalent to:
result <- numeric(length(x))
for (i in 1:length(x))
result[i] <- dmvnorm(x[[i]], u[[i]], sigma[[i]])

efficient way to find neighbors to specified cell?

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

Resources