I need to solve for a n x n (n usually <12) matrix subject to a few constraints:
1.Predetermined row and column sums are satisfied.
2.Each element in the matrix having a row number greater than column number must be zero (so basically the only nonzero elements must be in the top right portion).
3.For a given row, every element more than three columns to the right first nonzero element must also be zero.
So, a 4x4 matrix might look something like this (the row and column constraints will be much larger in practice, usually around 1-3 million):
|3 2 1 0| = 6
|0 2 1 1| = 4
|0 0 2 1| = 3
|0 0 0 4| = 4
3 4 4 6
I have been trying to use some solver approaches to do this in excel and also have tried some R based optimization packages but have been so unsuccessful so far.
Any suggestions on how else I might approach this would be much appreciated.
Thanks!
Test data:
x <- c(2,2,2,1,1,1,1)
rowVals <- c(6,4,3,4)
colVals <- c(3,4,4,6)
Function to construct the appropriate test matrix from (3N-5) parameters:
makeMat <- function(x,n) {
## first and last element of diag are constrained by row/col sums
diagVals <- c(colVals[1],x[1:(n-2)],rowVals[n])
## set up off-diagonals 2,3
sup2Vals <- x[(n-1):(2*n-3)]
sup3Vals <- x[(2*n-2):(3*n-5)]
## set up matrix
m <- diag(diagVals)
m[row(m)==col(m)-1] <- sup2Vals
m[row(m)==col(m)-2] <- sup3Vals
m
}
Objective function (sum of squares of row & column deviations):
objFun <- function(x,n) {
m <- makeMat(x,n)
## compute SSQ deviation from row/col constraints
sum((rowVals-rowSums(m))^2+(colVals-colSums(m))^2)
}
Optimizing:
opt1 <- optim(fn=objFun,par=x,n=4)
## recovers original values, although it takes a lot of steps
opt2 <- optim(fn=objFun,par=rep(0,length(x)),n=4)
makeMat(opt2$par,n=4)
## [,1] [,2] [,3] [,4]
## [1,] 3 2.658991 0.3410682 0.0000000
## [2,] 0 1.341934 1.1546649 1.5038747
## [3,] 0 0.000000 2.5042858 0.4963472
## [4,] 0 0.000000 0.0000000 4.0000000
##
## conjugate gradients might be better
opt3 <- optim(fn=objFun,par=rep(0,length(x)),n=4,
method="CG")
It seems that there are multiple solutions to this problem, which
isn't surprising (since there are 2N constraints on (N-2)+(N-1)+(N-2)=
3N-5 parameters).
You didn't say whether you need integer solutions or not -- if
so you will need more specialized tools ...
Related
`values <- matrix(c(0.174,0.349,1.075,3.1424,0.173,0.346,1.038,3.114,0.171,0.343,1.03,3.09,0.17,0.34,1.02,3.06),ncol=4) `
I am attempting to maximize the total value for the dataset taking only one value from each row, and with associated costs for each column
subject to:
One value column used per row.
cost of each use of column 1 is 4
cost of each use of column 2 is 3
cost of each use of column 3 is 2
cost of each use of column 4 is 1
total cost <= 11
These are stand in values for a larger dataset. I need to be able to apply it directly to all the rows of a dataset.
I have been trying to use the lpSolve package, with no success.
`f.obj <- values
f.con <- c(4,3,2,1)
f.dir <- "<="
f.rhs <- 11
lp("max", f.obj, f.con, f.dir, f.rhs)`
I am getting a solution of "0"
I do not know how to model this in a way that chooses one value per row and then uses a different value in calculating the constraints.
Looks like the problem is as follows:
We have a matrix a[i,j] with values, and a vector c[j] with costs.
We want to select one value for each row such that:
a. total cost <= 11
b. total value is maximized
To develop a mathematical model, we introduce binary variables x[i,j] ∈ {0,1}. With this, we can write:
max sum((i,j), a[i,j]*x[i,j])
subject to
sum((i,j), c[j]*x[i,j]) <= 11
sum(j, x[i,j]) = 1 ∀i
x[i,j] ∈ {0,1}
Implement in R. I use here CVXR.
#
# data
# A : values
# C : cost
#
A <- matrix(c(0.174,0.349,1.075,3.1424,0.173,0.346,1.038,3.114,0.171,0.343,1.03,3.09,0.17,0.34,1.02,3.06),ncol=4)
C <- c(4,3,2,1)
maxcost <- 11
#
# form a matrix cmat[i,j] indicating the cost of element i,j
#
cmat <- matrix(C,nrow=dim(A)[1],ncol=dim(A)[2],byrow=T)
#
# problem:
# pick one value from each row
# such that total value of selected cells is maximized
# and cost of selected cells is limited to maxcost
#
# model:
# min sum((i,j), a[i,j]*x[i,j])
# subject to
# sum((i,j), c[j]*x[i,j]) <= maxcost
# sum(j,x[i,j]) = 1 ∀i
# x[i,j] ∈ {0,1}
#
#
library(CVXR)
x = Variable(dim(A), name="x", boolean=T)
p <- Problem(Maximize(sum_entries(A*x)),
constraints=list(
sum_entries(cmat*x) <= maxcost,
sum_entries(x,axis=1) == 1
))
res <- solve(p,verbose=T)
res$status
res$value
res$getValue(x)*A
The output looks like:
> res$status
[1] "optimal"
> res$value
[1] 4.7304
> res$getValue(x)*A
[,1] [,2] [,3] [,4]
[1,] 0.0000 0 0.000 0.17
[2,] 0.0000 0 0.343 0.00
[3,] 1.0750 0 0.000 0.00
[4,] 3.1424 0 0.000 0.00
The description in the original post is not very precise. For instance, I assumed that we need to select precisely one cell from each row. If we just want "select at most one cell from each row", then replace
sum(j, x[i,j]) = 1 ∀i
by
sum(j, x[i,j]) <= 1 ∀i
As mentioned by Steve, the lpSolve package expects a single objective function not a matrix. You could reformulate as maximize(sum(RowSums(values*xij)) given constraint
Eg, change the matrix to a vector, and change the problem to a integer optimization problem
obj <- as.vector(values)
f.con <- rep(f.con, each = 4)
r <- lp('max', obj, matrix(f.con, nrow = 1), f.dir, f.rhs, int.vec = seq_along(obj))
#' Success: the objective function is 9.899925
When applying Matrix::qr() on the sparse matrix in R, the output is quite different from that of base::qr. There are V, beta, p, R, q but not rank and pivot. Below is a small example code. I want to detect linear dependent columns of the A sparse matrix, which requires the pivot and rank. How should I get these information?
library(Matrix)
A <- matrix(c(0, -2, 1, 0,
0, -4, 2, 0,
1, -2, 1, 2,
1, -2, 1, 2,
1, -2, 1, 2), nrow = 5, byrow = T)
A.s <- as(A, "dgCMatrix")
qrA.M <- Matrix::qr(A.s)
qrA.R <- base::qr(A)
There is another related but not answered question, Get base::qr pivoting in Matrix::qr method
I would reconstruct your example matrix A a little bit:
A <- A[, c(1,4,3,2)]
# [,1] [,2] [,3] [,4]
#[1,] 0 0 1 -2
#[2,] 0 0 2 -4
#[3,] 1 2 1 -2
#[4,] 1 2 1 -2
#[5,] 1 2 1 -2
You did not mention in your question why rank and pivot returned by a dense QR factorization are useful. But I think this is what you are looking for:
dQR <- base::qr(A)
with(dQR, pivot[1:rank])
#[1] 1 3
So columns 1 and 3 of A gives a basis for A's column space.
I don't really understand the logic of a sparse QR factorization. The 2nd column of A is perfectly linearly dependent on the 1st column, so I expect column pivoting to take place during the factorization. But very much to my surprise, it doesn't!
library(Matrix)
sA <- Matrix(A, sparse = TRUE)
sQR <- Matrix::qr(sA)
sQR#q + 1L
#[1] 1 2 3 4
No column pivoting is done! As a result, there isn't an obvious way to determine the rank of A.
At this moment, I could only think of performing a dense QR factorization on the R factor to get what you are looking for.
R <- as.matrix(Matrix::qrR(sQR))
QRR <- base::qr(R)
with(QRR, pivot[1:rank])
#[1] 1 3
Why does this work? Well, the Q factor has orthogonal hence linearly independent columns, thus columns of R inherit linear dependence or independence of A. For a matrix with much more rows than columns, the computational costs of this 2nd QR factorization is negligible.
I need to figure out the algorithm behind a sparse QR factorization before coming up with a better idea.
I've been looking at a similar problem and I ended up not relying on Matrix::qr() to calculate rank and to detect linear dependency. Instead I programmed the function GaussIndependent in the package SSBtools.
In the package examples I included an example that demonstrates wrong conclusion from rankMatrix(x, method = "qr"). Input x is a 44*20 dummy matrix.
Starting with your example matrix, A.s:
library(SSBtools)
GaussIndependent(A.s) # List of logical vectors specifying independent rows and columns
# $rows
# [1] TRUE FALSE TRUE FALSE FALSE
#
# $columns
# [1] TRUE TRUE FALSE FALSE
GaussRank(A.s) # the rank
# [1] 2
I have the following correlation matrix, cor.mat below.
I want to multiply all numbers by 15% except the cell [1,1] [2,2] [3,3] [4,4].
Does anyone have a good code to implent this in R?
1 2 3 4
1 1.0000000 0.1938155 0.1738809 0.2465276
2 0.1938155 1.0000000 0.4045694 0.2729958
3 0.1738809 0.4045694 1.0000000 0.3340883
4 0.2465276 0.2729958 0.3340883 1.0000000
You can use diag which returns the diagonal of a matrix
matrix = matrix*0.15
diag(matrix) = 1
Create a logical matrix excluding the diag and do the multiplication
i1 <- row(m1) != col(m1)
m1[i1] <- m1[i1] * 0.15
I am learning about q-learning and found a Wikipedia post and this website.
According to the tutorials and pseudo code I wrote this much in R
#q-learning example
#http://mnemstudio.org/path-finding-q-learning-tutorial.htm
#https://en.wikipedia.org/wiki/Q-learning
set.seed(2016)
iter=100
dimension=5;
alpha=0.1 #learning rate
gamma=0.8 #exploration/ discount factor
# n x n matrix
Q=matrix( rep( 0, len=dimension*dimension), nrow = dimension)
Q
# R -1 is fire pit,0 safe path and 100 Goal state########
R=matrix( sample( -1:0, dimension*dimension,replace=T,prob=c(1,2)), nrow = dimension)
R[dimension,dimension]=100
R #reward matrix
################
for(i in 1:iter){
row=sample(1:dimension,1)
col=sample(1:dimension,1)
I=Q[row,col] #randomly choosing initial state
Q[row,col]=Q[row,col]+alpha*(R[row,col]+gamma*max(Qdash-Q[row,col])
#equation from wikipedia
}
But I have problem in max(Qdash-Q[row,col] which according to the website is Max[Q(next state, all actions)] How to I programmatically search all actions for next state?
The second problem is this pseudo code
Do While the goal state hasn't been reached.
Select one among all possible actions for the current state.
Using this possible action, consider going to the next state.
Get maximum Q value for this next state based on all possible actions.
Compute: Q(state, action) = R(state, action) + Gamma * Max[Q(next state, all actions)]
Set the next state as the current state.
End Do
Is it this
while(Q<100){
Q[row,col]=Q[row,col]+alpha*(R[row,col]+gamma*max(Qdash-Q[row,col])
}
This post is by no means a complete implementation of Q-learning in R. It is an attempt to answer the OP with regards to the description of the algorithm in the website linked in the post and in Wikipedia.
The assumption here is that the reward matrix R is as described in the website. Namely that it encodes reward values for possible actions as non-negative numbers, and -1's in the matrix represent null values (i.e., where there is no possible action to transition to that state).
With this setup, an R implementation of the Q update is:
Q[cs,ns] <- Q[cs,ns] + alpha*(R[cs,ns] + gamma*max(Q[ns, which(R[ns,] > -1)]) - Q[cs,ns])
where
cs is the current state at the current point in the path.
ns is the new state based on a (randomly) chosen action at the current state. This action is chosen from the collection of possible actions at the current state (i.e., for which R[cs,] > -1). Since the state transition itself is deterministic here, the action is the transition to the new state.
For this action resulting in ns, we want to add its maximum (future) value over all possible actions that can be taken at ns. This is the so-called Max[Q(next state, all actions)] term in the linked website and the "estimate of optimal future value" in Wikipedia. To compute this, we want to maximize over the ns-th row of Q but consider only columns of Q for which columns of R at the corresponding ns-th row are valid actions (i.e., for which R[ns,] > -1). Therefore, this is:
max(Q[ns, which(R[ns,] > -1)])
An interpretation of this value is a one-step look ahead value or an estimate of the cost-to-go in dynamic programming.
The equation in the linked website is the special case in which alpha, the learning rate, is 1. We can view the equation in Wikipedia as:
Q[cs,ns] <- (1-alpha)*Q[cs,ns] + alpha*(R[cs,ns] + gamma*max(Q[ns, which(R[ns,] > -1)]))
where alpha "interpolates" between the old value Q[cs,ns] and the learned value R[cs,ns] + gamma*max(Q[ns, which(R[ns,] > -1)]). As noted in Wikipedia,
In fully deterministic environments, a learning rate of alpha=1 is optimal
Putting it all together into a function:
q.learn <- function(R, N, alpha, gamma, tgt.state) {
## initialize Q to be zero matrix, same size as R
Q <- matrix(rep(0,length(R)), nrow=nrow(R))
## loop over episodes
for (i in 1:N) {
## for each episode, choose an initial state at random
cs <- sample(1:nrow(R), 1)
## iterate until we get to the tgt.state
while (1) {
## choose next state from possible actions at current state
## Note: if only one possible action, then choose it;
## otherwise, choose one at random
next.states <- which(R[cs,] > -1)
if (length(next.states)==1)
ns <- next.states
else
ns <- sample(next.states,1)
## this is the update
Q[cs,ns] <- Q[cs,ns] + alpha*(R[cs,ns] + gamma*max(Q[ns, which(R[ns,] > -1)]) - Q[cs,ns])
## break out of while loop if target state is reached
## otherwise, set next.state as current.state and repeat
if (ns == tgt.state) break
cs <- ns
}
}
## return resulting Q normalized by max value
return(100*Q/max(Q))
}
where the input parameters are:
R is the rewards matrix as defined in the blog
N is the number of episodes to iterate
alpha is the learning rate
gamma is the discount factor
tgt.state is the target state of the problem.
Using the example in the linked website as a test:
N <- 1000
alpha <- 1
gamma <- 0.8
tgt.state <- 6
R <- matrix(c(-1,-1,-1,-1,0,-1,-1,-1,-1,0,-1,0,-1,-1,-1,0,-1,-1,-1,0,0,-1,0,-1,0,-1,-1,0,-1,0,-1,100,-1,-1,100,100),nrow=6)
print(R)
## [,1] [,2] [,3] [,4] [,5] [,6]
##[1,] -1 -1 -1 -1 0 -1
##[2,] -1 -1 -1 0 -1 100
##[3,] -1 -1 -1 0 -1 -1
##[4,] -1 0 0 -1 0 -1
##[5,] 0 -1 -1 0 -1 100
##[6,] -1 0 -1 -1 0 100
Q <- q.learn(R,iter,alpha,gamma,tgt.state)
print(Q)
## [,1] [,2] [,3] [,4] [,5] [,6]
##[1,] 0 0 0.0 0 80 0.00000
##[2,] 0 0 0.0 64 0 100.00000
##[3,] 0 0 0.0 64 0 0.00000
##[4,] 0 80 51.2 0 80 0.00000
##[5,] 64 0 0.0 64 0 100.00000
##[6,] 0 80 0.0 0 80 99.99994
Suppose I have a matrix like so:
data=matrix(c(1,0,0,0,0,0,1,0,0.6583,0,0,0,1,0,0,0,0.6583,0,1,0,0,0,0,0,1),nrow=5,ncol=5)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0.0000 0 0.0000 0
[2,] 0 1.0000 0 0.6583 0
[3,] 0 0.0000 1 0.0000 0
[4,] 0 0.6583 0 1.0000 0
[5,] 0 0.0000 0 0.0000 1
How do I create another matrix, say "data2", such that it has the same number of off-diagonal nonzero elements as "data" but in another location other than the one in data? The randomly simulated data will be uniform (so runif).
Here is a somewhat clumsy way to do this. It works well for small matrices but would be too slow if you're going to use this for some very high-dimensional problems.
# Current matrix:
data=matrix(c(1,0,0,0,0,0,1,0,0.6583,0,0,0,1,0,0,0,0.6583,0,1,0,0,0,0,0,1),nrow=5,ncol=5)
# Number of nonzero elements in upper triangle:
no.nonzero<-sum(upper.tri(data)*data>0)
# Generate same number of new nonzero correlations:
new.cor<-runif(no.nonzero,-1,1)
# Create new diagonal matrix:
p<-dim(data)[1]
data2<-diag(1,p,p)
### Insert nonzero correlations: ###
# Step 1. Identify the places where the nonzero elements can be placed:
pairs<-(p^2-p)/2 # Number of element in upper triangle
combinations<-matrix(NA,pairs,2) # Matrix containing indices for those elements (i.e. (1,2), (1,3), ... (2,3), ... and so on)
k<-0
for(i in 1:(p-1))
{
for(j in {i+1}:p)
{
k<-k+1
combinations[k,]<-c(i,j)
}
}
# Step 2. Randomly pick indices:
places<-sample(1:k,no.nonzero)
# Step 3. Insert nonzero correlations:
for(i in 1:no.nonzero)
{
data2[combinations[places[i],1],combinations[places[i],2]]<-data2[combinations[places[i],2],combinations[places[i],1]]<-new.cor[i]
}
Not really understood the question. There are two off-diagonal and non-zero elements (0.6583) in the example, right? Is matrix with two elements the result you want in this case?
data=matrix(c(1,0,0,0,0,0,1,0,0.6583,0,0,0,1,0,0,0,0.6583,0,1,0,0,0,0,0,1),nrow=5,ncol=5)
# Convert to vector
data2 <- as.numeric(data)
# Remove diagonal
data2 <- data2[as.logical(upper.tri(data) | lower.tri(data))]
# Remove 0 elements
data2 <- data2[data2 != 0]
data2