I am trying to solve an mixed integer problem with CVXR in R. Following code is used to solve it:
n <- 6
beta <- Variable(n, n, integer = TRUE)
epsilon <- 0.1*10^-5
objective <- Minimize(1)
constraints <- list(beta >= 1,
beta <= 9,
abs(diff(beta)) >= epsilon,
abs(diff(t(beta))) >= epsilon)
prob <- Problem(objective, constraints)
CVXR_result <- solve(prob)
This gives the following error:
Error in construct_intermediate_chain(object, candidate_solvers, gp = gp) :
Problem does not follow DCP rules.
When I change the code into following code:
n <- 6
beta <- Variable(n, n, integer = TRUE)
epsilon <- 0.1*10^-5
objective <- Minimize(1)
constraints <- list(beta >= 1,
beta <= 9,
abs(diff(beta)) <= epsilon,
abs(diff(t(beta))) <= epsilon)
prob <- Problem(objective, constraints)
CVXR_result <- solve(prob)
CVXR_result$status
CVXR_result$value
cvxrBeta <- CVXR_result$getValue(beta)
cvxrBeta
It works, but these are not the constraints that I want.
Does anyone know how to solve this?
We can convexivy the problem by introducing a boolean matrix y such that y[i,j] is 1 if the i,jth inequality on diff(beta) is greater-than and 0 otherwise. Similarly yy[i,j] is 1 if the i,jth inequality on diff(t(beta)) is greater-than and 0 otherwise. Thus we have added 2*(n-1)*n boolean variables. Also set M to 9 and to avoid numerical difficulties set epsilon to 0.1. For more information see: https://math.stackexchange.com/questions/37075/how-can-not-equals-be-expressed-as-an-inequality-for-a-linear-programming-model/1517850
library(CVXR)
n <- 6
epsilon <- 0.1
M <- 9
beta <- Variable(n, n, integer = TRUE)
y <- Variable(n-1, n, boolean = TRUE)
yy <- Variable(n-1, n, boolean = TRUE)
objective <- Minimize(1)
constraints <- list(beta >= 1,
beta <= M,
diff(beta) <= -epsilon + 2*M*y,
diff(beta) >= epsilon - (1-y)*2*M,
diff(t(beta)) <= -epsilon + 2*M*yy,
diff(t(beta)) >= epsilon - (1-yy)*2*M)
prob <- Problem(objective, constraints)
CVXR_result <- solve(prob)
CVXR_result$status
## [1] "optimal"
CVXR_result$getValue(beta)
## [,1] [,2] [,3] [,4] [,5] [,6]
## [1,] 1 9 1 9 8 7
## [2,] 9 8 7 6 9 4
## [3,] 3 2 1 9 8 2
## [4,] 7 6 2 1 7 6
## [5,] 3 5 3 2 8 5
## [6,] 5 1 4 3 6 9
Related
Under R, I developed the following script :
X = 1:3
Y = 1:2
Z = 1:4
nlargest <- function(m, n) {
res <- order(m)[seq_len(n)]
pos <- arrayInd(res, dim(m), useNames = TRUE)
values = m[res]
position = pos
list(unique(values),
unique(position))
}
m = do.call(expand.grid, lapply(list(X, Y , Z), unique))
m
ecart=as.matrix(dist(m, method = "euclidean", diag = TRUE, upper = FALSE, p = 2))
alpha=0.8
m=10
proba_matrix=alpha*exp(-ecart)
nlargest(proba_matrix, 10)
The function nlargest that I imported from another similar question doesn't extract the n-largest values of the matrix proba_matrix as expected.
I'm searching for a way to obtain n highest values of any matrix with their associated positions.
Example of expected results :
m <- matrix(seq(1,9,by=1),nrow=3,byrow=TRUE);
diag(m) <- 1;
m
[1] 1 2 3 4 5 6 7 8 9
[,1] [,2] [,3]
[1,] 1 2 3
[2,] 4 1 6
[3,] 7 8 1
# I need to obtain :
nlargest(m,4)
$values
[1] 4 6 7 8
$position
row col
[1,] 2 1
[2,] 2 3
[3,] 3 1
[4,] 3 2
In a 2-D matrix you could do something like this:
library(dplyr)
nlargest <- function(m, n){
df <- as.data.frame(cbind(as.vector(m), expand.grid(1:nrow(m), 1:ncol(m))))
colnames(df) <- c("value", "row", "column")
largest <- dplyr::distinct(df, value, .keep_all = T) %>%
dplyr::slice_max(order_by = value, n = n)
l <- list(values = largest$value,
position = largest[, c("row", "column")])
return(l)
}
m <- matrix(c(9, seq(1,9,by=1)),nrow=2,byrow=TRUE)
nlargest(m, 4)
$values
[1] 9 8 7 6
$position
row column
1 1 1
2 2 4
3 2 3
4 2 2
I have a simulation done with the below function in R:
## Load packages and prepare multicore process
library(forecast)
library(future.apply)
plan(multisession)
library(parallel)
library(foreach)
library(doParallel)
n_cores <- detectCores()
cl <- makeCluster(n_cores)
registerDoParallel(cores = detectCores())
set.seed(1)
bootstrap1 <- function(n, phi){
ts <- arima.sim(n, model = list(ar=phi, order = c(1, 1, 0)), sd = 1)
#ts <- numeric(n)
#ts[1] <- rnorm(1)
#for(i in 2:length(ts))
# ts[i] <- 2 * ts[i - 1] + rnorm(1)
########################################################
## create a vector of block sizes
t <- length(ts) # the length of the time series
lb <- seq(n-2)+1 # vector of block sizes to be 1 < l < n (i.e to be between 1 and n exclusively)
########################################################
## This section create matrix to store block means
BOOTSTRAP <- matrix(nrow = 1, ncol = length(lb))
colnames(BOOTSTRAP) <-lb
#BOOTSTRAP <- list(length(lb))
########################################################
## This section use foreach function to do detail in the brace
BOOTSTRAP <- foreach(b = 1:length(lb), .combine = 'cbind') %dopar%{
l <- lb[b]# block size at each instance
m <- ceiling(t / l) # number of blocks
blk <- split(ts, rep(1:m, each=l, length.out = t)) # divides the series into blocks
######################################################
res<-sample(blk, replace=T, 1000) # resamples the blocks
res.unlist <- unlist(res, use.names = FALSE) # unlist the bootstrap series
train <- head(res.unlist, round(length(res.unlist) - 10)) # Train set
test <- tail(res.unlist, length(res.unlist) - length(train)) # Test set
nfuture <- forecast::forecast(train, model = forecast::auto.arima(train), lambda=0, biasadj=TRUE, h = length(test))$mean # makes the `forecast of test set
RMSE <- Metrics::rmse(test, nfuture) # RETURN RMSE
BOOTSTRAP[b] <- RMSE
}
BOOTSTRAPS <- matrix(BOOTSTRAP, nrow = 1, ncol = length(lb))
colnames(BOOTSTRAPS) <- lb
BOOTSTRAPS
return(list("BOOTSTRAPS" = BOOTSTRAPS))
}
I use for loop to print its result three times.
for (i in 1:3) { set.seed(1)
print(bootstrap1(10, 0.5))
}
I have the below result:
## 2 3 4 5 6 7 8 9
##[1,] 1.207381 1.447382 1.282099 0.9311434 0.8481634 1.006494 0.9829584 1.205194
## 2 3 4 5 6 7 8 9
##[1,] 1.404846 1.262756 1.50738 1.188452 0.8981125 1.001651 1.349721 1.579556
## 2 3 4 5 6 7 8 9
##[1,] 1.265196 1.080703 1.074807 1.430653 0.9166268 1.12537 0.9492137 1.201763
If I have to run this several times I will be getting a different result.
I want the way I can set the seed such that the three-round will be distinct while if I run with the set seed, I will get the same three-distinct result using R.
We could specify the kind in set.seed. If we are doing this inside the loop, it will return the same values
for (i in 1:3) {
set.seed(1, kind = "L'Ecuyer-CMRG")
print(bootstrap1(10, 0.5))
}
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 4.189426 6.428085 3.672116 3.893026 2.685741 3.821201 3.286509 4.062811
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 4.189426 6.428085 3.672116 3.893026 2.685741 3.821201 3.286509 4.062811
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 4.189426 6.428085 3.672116 3.893026 2.685741 3.821201 3.286509 4.062811
If the intention is to return different values for each iteration in for loop and get the same result on subsequent runs, specify the set.seed outside the loop
1) First run
set.seed(1, kind = "L'Ecuyer-CMRG")
for (i in 1:3) {
print(bootstrap1(10, 0.5))
}
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 4.189426 6.428085 3.672116 3.893026 2.685741 3.821201 3.286509 4.062811
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 1.476428 1.806258 2.071091 2.09906 2.014298 1.032776 2.573738 1.831142
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 2.248546 1.838302 2.345557 1.696614 2.06357 1.502569 1.912556 1.906049
2) Second run
set.seed(1, kind = "L'Ecuyer-CMRG")
for (i in 1:3) {
print(bootstrap1(10, 0.5))
}
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 4.189426 6.428085 3.672116 3.893026 2.685741 3.821201 3.286509 4.062811
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 1.476428 1.806258 2.071091 2.09906 2.014298 1.032776 2.573738 1.831142
#$BOOTSTRAPS
# 2 3 4 5 6 7 8 9
#[1,] 2.248546 1.838302 2.345557 1.696614 2.06357 1.502569 1.912556 1.906049
According to ?set.seed
"L'Ecuyer-CMRG": -
A ‘combined multiple-recursive generator’ from L'Ecuyer (1999), each element of which is a feedback multiplicative generator with three integer elements: thus the seed is a (signed) integer vector of length 6. The period is around 2^191. The 6 elements of the seed are internally regarded as 32-bit unsigned integers. Neither the first three nor the last three should be all zero, and they are limited to less than 4294967087 and 4294944443 respectively. This is not particularly interesting of itself, but provides the basis for the multiple streams used in package parallel.
Below is the swapping function which swap values lesser than 10 in a list
swapFun <- function(x, n = 10){
inx <- which(x < n)
x[sample(inx)] <- x[inx]
x
}
For example, the original list is 1, 2, 3, 10, 4, 11.
After swapping by sampling , this list may be 2, 1, 4, 10, 3, 11 or 1, 3, 2, 10, 4, 11.
But I want to swap each value lesser than 10 to a different value lesser than 10.
For example, the first outcome (ie 2, 1, 4, 10, 3, 11) is what I want because each value lesser than 10 has been swapped to a different value lesser than 10.
However the second outcome (ie 1, 3, 2, 10, 4, 11.) is not what I want because 1 and 4 have not been swapped to a different value lesser than 10.
If there are no feasible solution, just print 'no feasible solution'
Any suggestions?
Many thanks.
You are looking for a derangement of the values less than 10. By the theory of derangements, approximately 1/e (37%) of randomly chosen permutations are derangements, so a hit or miss approach is reasonable, with an important caveat.
There might be repetitions among the items less than n. Not all permutations of those items are distinguishable, so not all derangements of the items look like derangements: swapping two 2s with each other (for example) is in some sense a derangement, but it wouldn't look like a derangement. The 1/e heuristic applies to raw permutations of positions, not distinguishable permutations of values. If the number of repetitions is high, it might take longer than 1/e would suggest. If in your use-case the performance isn't satisfactory, you would need to replace sample() in the function definitions by a more sophisticated function that picks random distinguishable permutations.
As far as feasibility goes, there will be a feasible solution so long as the most common element less than n doesn't account for more than 50% of the items less than n
derangement <- function(x){
if(max(table(x)) > length(x)/2) return(NA)
while(TRUE){
y <- sample(x)
if(all(y != x)) return(y)
}
}
swapFun <- function(x, n = 10){
inx <- which(x < n)
y <- derangement(x[inx])
if(length(y) == 1) return(NA)
x[inx] <- y
x
}
For example,
> set.seed(10)
> swapFun(c(1,2,10,4,11,2,12))
[1] 2 4 10 2 11 1 12
> swapFun(c(2,2,10,4,11,2,12))
[1] NA
Note that no valid derangement has length 1, but NA has length 1, so testing the length of y is an effective way to test if it is possible to derange the values. The function returns NA if no derangement of the values less than n exists. You can test for NA and print "No feasible solutions" if you want
This function gives you all the unique permutations for the numbers < m while keeping the positions of numbers >= m the same.
require(combinat)
x <- c(1,2,10,4,11,2,12)
m <- 10
swapFun <- function(x, m){
# determine positions of values to be permutated or fixed
xi <- which(x < m)
xj <- which(x >= m)
# make permuations
xp <- do.call(rbind, permn(x[xi]))
# make matrix with permutated and fixed values
xn <- matrix(nrow = nrow(xp), ncol = length(x))
xn[ ,xi] <- xp
xn[ ,xj] <- sort(rep(x[xj],nrow(xp)))
# delete duplicates
d <- !duplicated(apply(xn, 1, paste, collapse = "_"))
xn <- xn[d,]
return(xn)
}
swapFun(x,m)
> swapFun(x,m)
[,1] [,2] [,3] [,4] [,5] [,6] [,7]
[1,] 1 2 10 4 11 2 12
[2,] 1 2 10 2 11 4 12
[3,] 2 1 10 2 11 4 12
[4,] 2 1 10 4 11 2 12
[5,] 1 4 10 2 11 2 12
[6,] 4 1 10 2 11 2 12
[7,] 4 2 10 1 11 2 12
[8,] 2 4 10 1 11 2 12
[9,] 2 4 10 2 11 1 12
[10,] 4 2 10 2 11 1 12
[11,] 2 2 10 4 11 1 12
[12,] 2 2 10 1 11 4 12
Here is a simple example of one type of iterative calc:
vals <- data.frame( "x"=c( 14, 15, 12, 10, 17 ), "ema"=0 )
vals$ema[1] <- vals$x[1]
K <- 0.90
for( jj in 2:nrow( vals ) )
vals$ema[jj] <- K * vals$ema[jj-1] + (1-K) * vals$x[jj]
vals
x ema
1 14 14.0000
2 15 14.1000
3 12 13.8900
4 10 13.5010
5 17 13.8509
The more involved examples use if...else to determine the next value:
for( jj in 2:nrow( vals ) )
if( K * vals$ema[jj-1] + (1-K) * vals$x[jj] < 5.0 )
vals$ema[jj] <- 5.0
else if( K * vals$ema[jj-1] + (1-K) * vals$x[jj] > 15.0 )
vals$ema[jj] <- 15.0
else
vals$ema[jj] <- K * vals$ema[jj-1] + (1-K) * vals$x[jj]
I am not sure if it would be more involved or not, but the decision can be based on the previous value as well:
K1 <- 0.999
K2 <- 0.95
K3 <- 0.90
for( jj in 2:now( vals ) )
if( vals$ema[jj-1] < 0.0 )
vals$ema[jj] <- K1 * vals$ema[jj-1] + (1-K1) * vals$x[jj]
else if( vals$ema[jj-1] > 100.0 )
vals$ema[jj] <- K3 * vals$ema[jj-1] + (1-K3) * vals$x[jj]
else
vals$ema[jj] <- K2 * vals$ema[jj-1] + (1-K2) * vals$x[jj]
This answer by WaltS to a similar question I had about recursive calculations provides two potential solutions. Adapting one of them to your question:
vals$ema.Reduce <- Reduce(function(myema, x) K * myema + (1-K) * x,
x = tail(vals$x, -1), init = 14, accumulate = TRUE)
vals
# x ema ema.Reduce
#1 14 14.0000 14.0000
#2 15 14.1000 14.1000
#3 12 13.8900 13.8900
#4 10 13.5010 13.5010
#5 17 13.8509 13.8509
Explanation of the function:
Reduce() is calculating ema for the current jj row, and myema is the previous value (jj-1) starting with init. The x vector required by Reduce consists of vals$x for the rows you want to calculate: row 2 to the last row = x = tail(vals$x, -1). The accumulate = TRUE option returns the vector instead of the final value. (Note the x term in Reduce is a generic term and not the same as vals$x in the example data. For calculations that do not require the additional term vals$x, a vector of 0's would work (as in the linked answer)).
Adding if/else conditions to Reduce (note: init is changed in these examples to illustrate the conditional statements):
Reduce(function(myema, x) {
if(myema < 5) {
5
} else if(myema > 15) {
15
} else {
K * myema + (1-K) * x
}
}, x = tail(vals$x, -1), init = 16, accumulate = TRUE)
#[1] 16.000 15.000 14.700 14.230 14.507
Reduce(function(myema, x) {
if(myema < 0) {
K1 * myema + (1-K1) * x
} else if(myema > 100) {
K3 * myema + (1-K3) * x
} else {
K2 * myema + (1-K2) * x
}
}, x = tail(vals$x, -1), init = 110, accumulate = TRUE)
#[1] 110.00000 100.50000 91.65000 87.56750 84.03912
K3*110 + (1-K3)*vals$x[2] #100.5
K3*100.5 + (1-K3)*vals$x[3] #91.65
K2*91.65 + (1-K2)*vals$x[4] #87.5675
K2*87.5675 + (1-K2)*vals$x[5] #84.03912
Seems this succeeds:
vals$ema2 <- c(vals$ema[1], K*vals$ema[1:4] +(1-K)*vals$x[2:5] )
> vals
x ema ema2
1 14 14.0000 14.0000
2 15 14.1000 14.1000
3 12 13.8900 13.8900
4 10 13.5010 13.5010
5 17 13.8509 13.8509
Sometimes it is best to work with the time series and data munging libraries. In this case, lag.zoo from the zoo library handles lagged values for you.
library(dplyr)
library(zoo)
vals <- data.frame( "x"=c( 14, 15, 12, 10, 17 ) )
K <- 0.90
vals %>% mutate(ema = (1-K)*vals$x + K*(lag(vals$x,1)))
For this particular problem, the weights for each value is some function of k and i (as in the ith value). We can write a function for the weights, and vectorize it:
weights <- function(i, k) {
q <- 1-k
qs <- '^'(q, 1:i)
rev(qs) * c(1, rep(k, (i-1)))
}
v_weights <- Vectorize(weights)
An example:
> v_weights(1:3, .1)
[[1]]
[1] 0.9
[[2]]
[1] 0.81 0.09
[[3]]
[1] 0.729 0.081 0.090
where these are the weights of the "preceding" x values. We proceed with some matrix algebra. I write a function to make the weights (above) into a matrix:
weight_matrix <- function(j, k) {
w <- v_weights(1:j, k=k)
Ws <- matrix(0, j+1, j+1)
Ws[row(Ws)+col(Ws)<(j+2)] <- unlist(rev(w))
Ws <- t(Ws)
Ws[row(Ws)+col(Ws)==(j+2)] <- k
Ws[(j+1),1] <- 1
Ws
}
Example:
> weight_matrix(3, .1)
[,1] [,2] [,3] [,4]
[1,] 0.729 0.081 0.09 0.1
[2,] 0.810 0.090 0.10 0.0
[3,] 0.900 0.100 0.00 0.0
[4,] 1.000 0.000 0.00 0.0
Then multiply this with the vector of xs. Function: ema <- function(x, k) rev(weight_matrix(length(x)-1, k) %*% x[1:(length(x))]).
To get the dataframe above (I "flipped" the k so it's 0.1 instead of 0.9):
> x <- c(14, 15, 12, 10, 17)
> k <- .1
> vals <- data.frame("x"=x, "ema"=ema(x, k))
> vals
x ema
1 14 14.0000
2 15 14.1000
3 12 13.8900
4 10 13.5010
5 17 13.8509
#shayaa's answer is 99% correct. dplyr implements lag just fine, and apart from a typo in that answer (one value of x should be ema), extraneous calls to column names, and a missing default value (otherwise it puts NA in the first row) it works perfectly well.
library(dplyr)
vals %>% mutate(ema = K*lag(ema, 1, default=ema[1]) + (1-K)*x)
#> x ema
#> 1 14 14.0000
#> 2 15 14.1000
#> 3 12 13.8900
#> 4 10 13.5010
#> 5 17 13.8509
I'm trying to find how to solve quadratic problem in R with both equality and inequality constraints as well as with upper and lower bounds:
min 0.5*x'*H*x + f'*x
subject to: A*x <= b
Aeq*x = beq
LB <= x <= UB
I've checked 'quadprog' and 'kernlab' packages but ... I must be missing something as I have no idea how specify both 'A' and 'Aeq' for solve.QP() or ipop()
Here's a working example:
library('quadprog')
# min
# -8 x1 -16 x2 + x1^2 + 4 x2^2
#
# s.t.
#
# x1 + 2 x2 == 12 # equalities
# x1 + x2 <= 10 # inequalities (N.B. you need to turn it into "greater-equal" form )
# 1 <= x1 <= 3 # bounds
# 1 <= x2 <= 6 # bounds
H <- rbind(c(2, 0),
c(0, 8))
f <- c(8,16)
# equalities
A.eq <- rbind(c(1,2))
b.eq <- c(12)
# inequalities
A.ge <- rbind(c(-1,-1))
b.ge <- c(-10)
# lower-bounds
A.lbs <- rbind(c( 1, 0),
c( 0, 1))
b.lbs <- c(1, 1)
# upper-bounds on variables
A.ubs <- rbind(c(-1, 0),
c( 0,-1))
b.ubs <- c(-3, -6)
# solve
sol <- solve.QP(Dmat = H,
dvec = f,
Amat = t(rbind(A.eq, A.ge, A.lbs, A.ubs)),
bvec = c(b.eq, b.ge, b.lbs, b.ubs),
meq = 1) # this argument says the first "meq" rows of Amat are equalities
sol
> sol
$solution
[1] 3.0 4.5
$value
[1] -6
$unconstrained.solution
[1] 4 2
$iterations
[1] 3 0
$Lagrangian
[1] 10 0 0 0 12 0
$iact
[1] 1 5