I have a list of locations and their weights (calculated distances apart) in a matrix.
I would like the optimal solution for each location having 3 connections, minimizing total distance.
costs6 <- matrix(c(0,399671,1525211,990914,1689886,1536081,399671,0,1802419,1128519,1964930,1603803,1525211,1802419,0,814942,164677,943489,990914,1128519.4,814942.7,0,953202,565712,1689886,1964930,164677,953202,0, 1004916,1536081,1603803,943489,565712,1004916,0),ncol=6,byrow=TRUE)
plantcap <- rep(3,6)
citydemand <- rep(3,6)
plant.signs <- rep("=",6)
city.signs <- rep("=",6)
lptrans <- lp.transport(costs6,"min",plant.signs,plantcap,city.signs,citydemand)
lptrans$solution
lptrans
This LP solver returns
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 3 0 0 0 0 0
[2,] 0 3 0 0 0 0
[3,] 0 0 3 0 0 0
[4,] 0 0 0 3 0 0
[5,] 0 0 0 0 3 0
[6,] 0 0 0 0 0 3
I am wondering if there is a way to max out any Xij at 1, so that the solver will give me three ones in each column/row, rather than one 3 in each column/row? If not, is there another solver I can use to find the solution?
Something like this, setting it up as an LP problem (assuming a symmetric solution matrix)?
library(lpSolve)
costs6 <- matrix(c(0,399671,1525211,990914,1689886,1536081,
399671,0,1802419,1128519,1964930,1603803,
1525211,1802419,0,814942,164677,943489,
990914,1128519.4,814942.7,0,953202,565712,
1689886,1964930,164677,953202,0, 1004916,
1536081,1603803,943489,565712,1004916,0),ncol=6,byrow=TRUE)
nLoc <- nrow(costs6)
nParams <- sum(1:(nLoc - 1L))
# set up the constraint matrix
# columns are parameters corresponding to the lower triangular of costs6 (by column)
# the first six constraints are for the row/column sums
# the last 15 constraints are for the maximum number of times each path can be used (1)
nConst <- sum(1:nLoc)
mConst <- matrix(0L, nConst, nParams)
mConst[matrix(c(c(combn(1:nLoc, 2)), rep(1:nParams, each = 2)), ncol = 2)] <- 1L
mConst[(nLoc + 1L):nConst,] <- diag(nParams)
lpSol <- lp(
direction = "min",
objective.in = unlist(costs6[lower.tri(costs6)]),
const.mat = mConst,
const.dir = c(rep("=", nLoc), rep("<=", nParams)),
const.rhs = c(rep(3L, nLoc), rep(1L, nParams)),
all.int = TRUE
)
lpSol
#> Success: the objective function is 8688039
# convert the solution to a transport matrix
mSol <- matrix(0, nLoc, nLoc)
mSol[lower.tri(mSol)] <- lpSol$solution
mSol[upper.tri(mSol)] <- t(mSol)[upper.tri(mSol)]
mSol
#> [,1] [,2] [,3] [,4] [,5] [,6]
#> [1,] 0 1 1 1 0 0
#> [2,] 1 0 0 1 1 0
#> [3,] 1 0 0 0 1 1
#> [4,] 1 1 0 0 0 1
#> [5,] 0 1 1 0 0 1
#> [6,] 0 0 1 1 1 0
Related
I need to generate a list of all permutations of a 3x3 matrix following these conditions in R:
-The only possible values in the first row are c(0,1,2).
-The only possible values in the second row are c(0,1).
-The only possible value in the last row is 0.
Here's a couple examples:
0 0 1
0 0 0
0 0 0
1 0 2
0 1 0
0 0 0
2 2 1
1 1 0
0 0 0
So I have to generate all the existing matrices satisfying these conditions. I think there are 216 permutations, if I'm not wrong.
library(plyr)
library(magrittr)
res <-
expand.grid(
0:2, 0:2, 0:2,
0:1, 0:1, 0:1,
0, 0, 0
) %>%
as.matrix() %>%
alply(1, matrix, nrow = 3, byrow = TRUE)
# remove redundant plyr attributes
res <- res[1:length(res)]
res
#> $`1`
#> [,1] [,2] [,3]
#> [1,] 0 0 0
#> [2,] 0 0 0
#> [3,] 0 0 0
#>
#> $`2`
#> [,1] [,2] [,3]
#> [1,] 1 0 0
#> [2,] 0 0 0
#> [3,] 0 0 0
#>
#> $`3`
#> [,1] [,2] [,3]
#> [1,] 2 0 0
#> [2,] 0 0 0
#> [3,] 0 0 0
...
expand.grid creates a data.frame of all combinations of 9 numbers where first three numbers can be from 0 to 2, second three are either 0 or 1, and last three are always 0. So basically it's our needed matrices written in rows. There are indeed 216 of them. Now we just need to turn the rows into 3x3 matrices.
The best approach I was able to find is to convert the dataframe into matrix and then use plyr::alply.
I cannot figure out how to do this in functional programming way, but here's the for loop approach.
library(gtools)
x <- permutations(3,3, c(0,1,2),repeats.allowed = TRUE)
y <- permutations(2,3,c(0,1), repeats.allowed = TRUE)
z = list()
length = 1
for(i in 1:nrow(x)){
for(j in 1:nrow(y)){
z[[length]] <- (matrix(c(x[i,],y[j,],0,0,0), nrow = 3, byrow = TRUE))
length = length + 1
}
}
> length(z)
[1] 216
I have a unknown vector X with length=50, and a known vector Y (length 50) of constants.
I wish to find X, such that for X_i>=0, sum(X_i) is minimized, with the constraint:
X_n + X_{n-1} >= Y_n
I am not sure where to start with R.
I guess you can try CVXR to solve the optimization problem.
First of all, let's define a matrix M like below
M <- matrix(0,nrow = 10,ncol = 11)
for (i in 1:nrow(M)) {
for (j in 1:ncol(M)) {
if (j %in% (i+(0:1))) M[i,j] <- 1
}
}
which looks like
> M
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
[1,] 1 1 0 0 0 0 0 0 0 0 0
[2,] 0 1 1 0 0 0 0 0 0 0 0
[3,] 0 0 1 1 0 0 0 0 0 0 0
[4,] 0 0 0 1 1 0 0 0 0 0 0
[5,] 0 0 0 0 1 1 0 0 0 0 0
[6,] 0 0 0 0 0 1 1 0 0 0 0
[7,] 0 0 0 0 0 0 1 1 0 0 0
[8,] 0 0 0 0 0 0 0 1 1 0 0
[9,] 0 0 0 0 0 0 0 0 1 1 0
[10,] 0 0 0 0 0 0 0 0 0 1 1
Then, we construct the objective function as well as the constraints
library(CVXR)
X <- Variable(11)
objective <- Minimize(sum(X))
constraints <- list( X>=0, M%*%X >= Y)
problem <- Problem(objective,constraints)
res <- solve(problem)
Finally, we can see values of X via res$getValue(X)
Example
Given Y as below
set.seed(1)
Y <- runif(10)
we can get
Xopt <- res$getValue(X)
> Xopt
[,1]
[1,] 1.667850e-07
[2,] 3.072356e-01
[3,] 6.488860e-02
[4,] 6.214644e-01
[5,] 2.867441e-01
[6,] 1.486883e-02
[7,] 8.835218e-01
[8,] 7.476340e-02
[9,] 5.860353e-01
[10,] 5.264372e-02
[11,] 9.142897e-03
Another possible option might be pracma::fmincon, e.g.,
pracma:: fmincon(rep(0, 11),
function(x) sum(x),
A = -M,
b = -Y,
lb = 0,
)
This can be expressed as a linear program
min 1'x
s.t. Ax >= y
x >= 0
We can use the lpSolve package to solve this. Let n be the length of x and k be the number of x's in each constraint. The constraints defined in the body of the question corresponds to k=2 but the subject of the question defines the constraints differently and corresponds to k=3. There will be n-k+1 constraints.
embed(1:n,k) creates an n-k+1 by k matrix each row of which is the column indexes of the ones in the corresonding row of A. For example, for k=2 the first row of embed(...) is 1:2 since elements 1 and 2 of the first row of A are ones and the rest of the row of A is zeros. The second row of embed output is 2:3, the third row is 3:4, etc. We then apply replace over the rows to replace an n-vector of zeros, numeric(n), with ones in those positions. The way apply works is that it gives the transpose of what we want so we transpose it back to get A.
Finally we run the linear program. We can use str(out) to examine the output components that are returned. In particular we display the solution as out$solution.
library(lpSolve)
# inputs - replace these three with your inputs
n <- 5 # no of x variables
k <- 2 # no of x's in each constraint
Y <- seq_len(n - k + 1)
A <- t(apply(embed(1:n, k), 1, replace, x = numeric(n), values = 1))
out <- lp("min", rep(1, n), A, ">=", Y)
out
## Success: the objective function is 6
out$solution
## [1] 0 2 0 4 0
I have a few vectors that I would like to arrange into square matrices of the same dimensions for future multiplication. Some vectors are shorters than others so I would like to add zeros to the shorters ones so that all the resulting matrices are of the same dimension.
I tried to add 0 to the tail of the shorter vectors but I haven't been able to generate the reducible matrices that I want. Below are some pseudo data. Thank you for your time!
seq_a <- rep(1,4)
seq_b <- rep(1,3)
matA <- diag(seq_a)
matB <- matrix(c(diag(seq_b),0),nrow=4,ncol = 4)
[,1] [,2] [,3] [,4]
[1,] 1 1 1 0
[2,] 0 0 0 0
[3,] 0 0 1 1
[4,] 0 0 0 0
Warning message:
In matrix(c(diag(seq_c), 0), nrow = 4, ncol = 4) :
data length [10] is not a sub-multiple or multiple of the number of rows [4]
The desired matB should be
[,1] [,2] [,3] [,4]
[1,] 1 0 0 0
[2,] 0 1 0 0
[3,] 0 0 1 0
[4,] 0 0 0 0
That is just a typo: you should first pad the vector, and then convert it to a diagonal matrix.
matB <- diag( c(seq_b,0) )
I have a list of matrices (some hundred thousands). I want to create a single matrix where the cells correspond to e.g. the 95%. With that I mean this: if e.g. cell mat[1,2] is positive (i.e. >0) in 95% of the matrices it is scored a 1, and if e.g. cell mat[2,1] is negative (i.e. <0) in 95% of the matrices it is scored a -1. If they fall below this threshold they are scored a 0.
#Dummy data
listX <- list()
for(i in 1:10){listX[[i]]<-matrix(rnorm(n = 25, mean = 0.5, sd = 1),5,5)}
listX2 <- listX
for(i in 1:10) { listX2[[i]] <- ifelse(listX[[i]] >0, 1, -1) }
For the sake of the dummy data, the 95% can be changed to say 60%, such that the cells that keep their sign in 6 out of 10 matrices are kept and scored either 1 or -1 and the rest 0.
I'm stuck on this, hence cannot provide any more code.
I would do:
listX <- list()
set.seed(20)
# I set seed for reproducability, and changed your mean so you could see the negatives
for(i in 1:10){listX[[i]]<-matrix(rnorm(n = 25, mean = 0, sd = 1),5,5)}
threshold <- 0.7
(Reduce('+',lapply(listX,function(x){x > 0}))/length(listX) >= threshold) - (Reduce('+',lapply(listX,function(x){x < 0}))/length(listX) >= threshold)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 -1 1
[2,] -1 1 -1 -1 1
[3,] 0 0 0 1 1
[4,] 0 1 0 0 0
[5,] 0 0 0 0 0
This basically checks both conditions, and adds the two checks together. To break down one of the conditions (Reduce('+',lapply(listX,function(x){x > 0}))/length(listX) > threshold)
lapply(listX,function(x){x > 0}) loops through each matrix and converts it to a a matrix of true/false for every value that is above zero.
Reduce('+',lapply(listX,function(x){x > 0}))/length(listX) then adds these all together (Reduce), and divides by the number of obeservations. If the proportion is greater than our threshold, we set that value to one, and if not it is zero.
We then subtract the same matrix with x < 0 as the test, which gives -1 in each case where enough sub-values are negative.
You can change the list to an array and then take the mean over the dimensions.
arr <- simplify2array(listX)
grzero = rowMeans(arr > 0, dims = 2)
lezero = rowMeans(arr < 0, dims = 2)
prop = 0.6
1* (grzero >= prop) + -1* (lezero >= prop)
Test case showing which answers work so far! (edit)
Below you'll find my original answer. It ended up producing comparable results to the other answers on test cases involving randomly seeded data. To triple check, I created a small test data set with a known answer. It turns out that only answer by #Chris passes right now (though #user20650 should be ok if using >= on this example as indicated in comments). Here it is in case anyone else wants to use it:
listX <- list(
matrix(c(1,0,-1,1), nrow = 2),
matrix(c(1,0,-1,1), nrow = 2),
matrix(c(1,0, 1,0), nrow = 2)
)
# With any threshold < .67,
# result should be...
matrix(c(1, 0, -1, 1), nrow = 2)
#> [,1] [,2]
#> [1,] 1 -1
#> [2,] 0 1
# Otherwise...
matrix(c(1, 0, 0, 0), nrow = 2)
#> [,1] [,2]
#> [1,] 1 0
#> [2,] 0 0
# #Chris answer passes
threshold <- 0.5
(Reduce('+',lapply(listX,function(x){x > 0}))/length(listX) >= threshold) - (Reduce('+',lapply(listX,function(x){x < 0}))/length(listX) >= threshold)
#> [,1] [,2]
#> [1,] 1 -1
#> [2,] 0 1
threshold <- 1.0
(Reduce('+',lapply(listX,function(x){x > 0}))/length(listX) >= threshold) - (Reduce('+',lapply(listX,function(x){x < 0}))/length(listX) >= threshold)
#> [,1] [,2]
#> [1,] 1 0
#> [2,] 0 0
# My function fails...
prob_matrix(listX, .5)
#> [,1] [,2]
#> [1,] 1 -1
#> [2,] 0 1
prob_matrix(listX, 1)
#> [,1] [,2]
#> [1,] 1 0
#> [2,] 0 1
# #user20650 answer fails...
arr <- simplify2array(listX)
grzero = rowSums(arr > 0, dims = 2) / length(listX)
lezero = rowSums(arr < 0, dims = 2) / length(listX)
prop = 0.5
1* (grzero > prop) + -1* (lezero > prop)
#> [,1] [,2]
#> [1,] 1 -1
#> [2,] 0 1
arr <- simplify2array(listX)
grzero = rowSums(arr > 0, dims = 2) / length(listX)
lezero = rowSums(arr < 0, dims = 2) / length(listX)
prop = 1.0
1* (grzero > prop) + -1* (lezero > prop)
#> [,1] [,2]
#> [1,] 0 0
#> [2,] 0 0
Original answer
Here's one approach...
Combine sign and Reduce to do a cumulative sum of the signs of values in each cell, returning a single matrix.
Any cells where this value is less than the threshold number (your probability * number of matrices in the list) is converted to 0.
Return the sign() of all cells.
Below is an example with a wrapper function:
Toy data...
set.seed(12)
listX <- list()
for(i in 1:10){listX[[i]]<-matrix(rnorm(n = 25, mean = 0, sd = 1), 5, 5)}
Function...
prob_matrix <- function(matrix_list, prob) {
# Sum the signs of values in each cell
matrix_list <- lapply(matrix_list, sign)
x <- Reduce(`+`, matrix_list)
# Convert cells below prob to 0, others to relevant sign
x[abs(x) < (prob * length(matrix_list)) / 2] <- 0
sign(x)
}
Example cases...
prob_matrix(listX, .2)
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] -1 1 0 1 0
#> [2,] -1 0 -1 -1 0
#> [3,] 1 -1 1 1 1
#> [4,] 0 -1 1 1 -1
#> [5,] -1 0 -1 0 -1
prob_matrix(listX, .4)
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] -1 1 0 1 0
#> [2,] -1 0 -1 -1 0
#> [3,] 1 -1 1 1 1
#> [4,] 0 -1 1 1 -1
#> [5,] -1 0 -1 0 -1
prob_matrix(listX, .6)
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] 0 1 0 1 0
#> [2,] -1 0 0 -1 0
#> [3,] 1 -1 0 1 1
#> [4,] 0 0 0 1 -1
#> [5,] -1 0 0 0 -1
prob_matrix(listX, .8)
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] 0 1 0 1 0
#> [2,] -1 0 0 -1 0
#> [3,] 1 -1 0 1 1
#> [4,] 0 0 0 1 -1
#> [5,] -1 0 0 0 -1
I was wondering if is it possible to stringsplit each integer in a set of numbers and transform it into a transition matrix, e.g
data<-c(11,123,142,1423,1234,12)
What i would like to do is to split each integer in the data (considering only the first two elements in the dataset),first element will be 1,1 second element will be 1,2,3....and convert it into matrix e,g 1,1 will be 1 to 1, 1,2 will be 1 to 2 and 2,3 will be 2 to 3. generating the following matrix
1 2 3 4 5
1 1 1 0 0 0
2 0 0 1 0 0
3 0 0 0 0 0
4 0 0 0 0 0
5 0 0 0 0 0
My matrix will never go past 5x5. Below is what i have done which works but it's really really tedious.
data2<-as.matrix(as.character(data))
for(i in 1:nrow(data2)) {
values<-strsplit(data2,"")
}
values2<-t(sapply(values, '[', 1:max(sapply(values, length))))
values2[is.na(values2)]<-0
values3<-apply(values2,2,as.numeric)
from1to1<-0
from1to2<-0
from1to3<-0
from1to4<-0
from1to5<-0
from2to1<-0
from2to2<-0
from2to3<-0
from2to4<-0
...
from5to4<-0
from5to5<-0
for(i in 1:nrow(values3)){
for(j in 1:(ncol(values3)-1))
if (((values3[i,j]==1)&(values3[i,j+1]==1))){
from1to1<-from1to1 + 1
}else{
if (((values3[i,j]==1)&(values3[i,j+1]==2))){
from1to2<-from1to2 + 1
}else{
if (((values3[i,j]==1)&(values3[i,j+1]==3))){
from1to3<-from1to3 + 1
}else{
if (((values3[i,j]==1)&(values3[i,j+1]==4))){
from1to4<-from1to4 + 1
}else{
if (((values3[i,j]==1)&(values3[i,j+1]==5))){
from1to5<-from1to5 + 1
}else{
if (((values3[i,j]==1)&(values3[i,j+1]==1))){
from1to1<-from1to1 + 1
}else{.....continues through all other from2to1...from5to5``
I then place every single number into a 5x5 matrix.
This is obviously tedious and long and ridiculous. Is there anyway to shorten this? Any suggestions is appreciated.
Here's an option, presented here piped so as to be easy to follow:
library(magrittr) # for the pipe
# initialize a matrix of zeros
mat <- matrix(0, 5, 5)
# split each element into individual digits
strsplit(as.character(data), '') %>%
# turn list elements back to integers
lapply(as.integer) %>%
# make a 2 column matrix of each digit paired with the previous digit
lapply(function(x){matrix(c(x[-length(x)], x[-1]), ncol = 2)}) %>%
# reduce list to a single 2-column matrix
do.call(rbind, .) %>%
# for each row, add 1 to the element of mat they subset
apply(1, function(x){mat[x[1], x[2]] <<- mat[x[1], x[2]] + 1; x})
# output is the transpose of the matrix; the real results are stored in mat
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
## [1,] 1 1 2 1 4 1 4 2 1 2 3 1
## [2,] 1 2 3 4 2 4 2 3 2 3 4 2
mat
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1 3 0 2 0
## [2,] 0 0 3 0 0
## [3,] 0 0 0 1 0
## [4,] 0 2 0 0 0
## [5,] 0 0 0 0 0
Alternately, if you'd like xtabs as suggested by alexis_laz, replace the last line with xtabs(formula = ~ .[,1] + .[,2]) instead of using mat.
You might also check out the permutations package, which from what I can tell seems to be for working with this kind of data, though it's somewhat high-level.