Related
library(lpSolveAPI)
my.lp <- make.lp(nrow = 3, ncol = 2)
set.column(my.lp, 1, c(1, 1, 2))
set.column(my.lp, 2, c(3, 1, 0))
set.objfn(my.lp, c(1, 0))
set.constr.type(my.lp, rep("<=", 3))
set.rhs(my.lp, c(4, 2, 3))
set.bounds(my.lp, lower = c(-Inf, -Inf), upper = c(Inf, Inf))
> my.lp
Model name:
C1 C2
Minimize 1 0
R1 1 3 <= 4
R2 1 1 <= 2
R3 2 0 <= 3
Kind Std Std
Type Real Real
Upper Inf Inf
Lower -Inf -Inf
In my.lp, the objective function is set to minimization. How can I change this to maximization? It's not clear to me by looking at the help page of set.objfn.
Set the sense (minimize/maximize) with lp.control.
lp.control(my.lp, sense="max")
my.lp
#Model name:
# C1 C2
#Maximize 1 0
#R1 1 3 <= 4
#R2 1 1 <= 2
#R3 2 0 <= 3
#Kind Std Std
#Type Real Real
#Upper Inf Inf
#Lower -Inf -Inf
solve(my.lp) # returns 0, success
#[1] 0
get.variables(my.lp)
#[1] 1.5 0.0
get.objective(my.lp)
#[1] 1.5
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
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
Having a data frame like this:
df <- data.frame(a=c(31, 18, 0, 1, 20, 2),
b=c(1, 0, 0, 3, 1, 1),
c=c(12, 0, 9, 8, 10, 3))
> df
a b c
1 31 1 12
2 18 0 0
3 0 0 9
4 1 3 8
5 20 1 10
6 2 1 3
How can I do a random subset so the sum of rows and columns is equal to a value, i.e , 100?
As I understand your question, you're trying to sample a subset of the rows and columns of your matrix so that they sum to a target value.
You can use integer optimization to accomplish this. You'll have a binary decision variable for each row, column, and cell, and constraints to force the cell values to be equal to the product of the row and column values. I'll use the lpSolve package to do this, because it has a convenient mechanism to get multiple optimal solutions. We can then use the sample function to select between them:
library(lpSolve)
get.subset <- function(dat, target) {
nr <- nrow(dat)
nc <- ncol(dat)
nvar <- nr + nc + nr*nc
# Cells upper bounded by row and column variable values (r and c) and lower bounded by r+c-1
mat <- as.matrix(do.call(rbind, apply(expand.grid(seq(nr), seq(nc)), 1, function(x) {
r <- x[1]
c <- x[2]
pos <- nr + nc + (r-1)*nc + c
ltc <- rep(0, nvar)
ltc[nr + c] <- 1
ltc[pos] <- -1
ltr <- rep(0, nvar)
ltr[r] <- 1
ltr[pos] <- -1
gtrc <- rep(0, nvar)
gtrc[nr + c] <- 1
gtrc[r] <- 1
gtrc[pos] <- -1
return(as.data.frame(rbind(ltc, ltr, gtrc)))
})))
dir <- rep(c(">=", ">=", "<="), nr*nc)
rhs <- rep(c(0, 0, 1), nr*nc)
# Sum of selected cells equals target
mat <- rbind(mat, c(rep(0, nr+nc), as.vector(t(dat))))
dir <- c(dir, "=")
rhs <- c(rhs, target)
res <- lp(objective.in=rep(0, nvar), # Feasibility problem
const.mat=mat,
const.dir=dir,
const.rhs=rhs,
all.bin=TRUE,
num.bin.solns=100 # Number of feasible solutions to get
)
if (res$status != 0) {
return(list(rows=NA, cols=NA, subset=NA, num.sol=0))
}
sol.num <- sample(res$num.bin.solns, 1)
vals <- res$solution[seq((sol.num-1)*nvar+1, sol.num*nvar)]
rows <- which(vals[seq(nr)] >= 0.999)
cols <- which(vals[seq(nr+1, nr+nc)] >= 0.999)
return(list(rows=rows, cols=cols, subset=dat[rows,cols], num.sol=res$num.bin.solns))
}
The function returns the number of subset with that sum and returns the randomly selected subset:
set.seed(144)
get.subset(df, 1)
# $rows
# [1] 1
# $cols
# [1] 2
# $subset
# [1] 1
# $num.sol
# [1] 14
get.subset(df, 100)
# $rows
# [1] 1 2 4 5
# $cols
# [1] 1 3
# $subset
# a c
# 1 31 12
# 2 18 0
# 4 1 8
# 5 20 10
# $num.sol
# [1] 2
get.subset(df, 10000)
# $rows
# [1] NA
# $cols
# [1] NA
# $subset
# [1] NA
# $num.sol
# [1] 0
I have a problem where I have a bunch of lengths and want to start at the origin (pretend I'm facing to the positive end of the y axis), I make a right and move positively along the x axis for the distance of length_i. At this time I make another right turn, walk the distance of length_i and repeat n times. I can do this but I think there's a more efficient way to do it and I lack a math background:
## Fake Data
set.seed(11)
dat <- data.frame(id = LETTERS[1:6], lens=sample(2:9, 6),
x1=NA, y1=NA, x2=NA, y2=NA)
## id lens x1 y1 x2 y2
## 1 A 4 NA NA NA NA
## 2 B 2 NA NA NA NA
## 3 C 5 NA NA NA NA
## 4 D 8 NA NA NA NA
## 5 E 6 NA NA NA NA
## 6 F 9 NA NA NA NA
## Add a cycle of 4 column
dat[, "cycle"] <- rep(1:4, ceiling(nrow(dat)/4))[1:nrow(dat)]
##For loop to use the information from cycle column
for(i in 1:nrow(dat)) {
## set x1, y1
if (i == 1) {
dat[1, c("x1", "y1")] <- 0
} else {
dat[i, c("x1", "y1")] <- dat[(i - 1), c("x2", "y2")]
}
col1 <- ifelse(dat[i, "cycle"] %% 2 == 0, "x1", "y1")
col2 <- ifelse(dat[i, "cycle"] %% 2 == 0, "x2", "y2")
dat[i, col2] <- dat[i, col1]
col3 <- ifelse(dat[i, "cycle"] %% 2 != 0, "x2", "y2")
col4 <- ifelse(dat[i, "cycle"] %% 2 != 0, "x1", "y1")
mag <- ifelse(dat[i, "cycle"] %in% c(1, 4), 1, -1)
dat[i, col3] <- dat[i, col4] + (dat[i, "lens"] * mag)
}
This gives the desired result:
> dat
id lens x1 y1 x2 y2 cycle
1 A 4 0 0 4 0 1
2 B 2 4 0 4 -2 2
3 C 5 4 -2 -1 -2 3
4 D 8 -1 -2 -1 6 4
5 E 6 -1 6 5 6 1
6 F 9 5 6 5 -3 2
Here it is as a plot:
library(ggplot2); library(grid)
ggplot(dat, aes(x = x1, y = y1, xend = x2, yend = y2)) +
geom_segment(aes(color=id), size=3, arrow = arrow(length = unit(0.5, "cm"))) +
ylim(c(-10, 10)) + xlim(c(-10, 10))
This seems slow and clunky. I'm guessing there's a better way to do this than the items I do in the for loop. What's a more efficient way to keep making programatic rights?
(As suggested by #DWin) Here is a solution using complex numbers, which is flexible to any kind of turn, not just 90 degrees (-pi/2 radians) right angles. Everything is vectorized:
set.seed(11)
dat <- data.frame(id = LETTERS[1:6], lens = sample(2:9, 6),
turn = -pi/2)
dat <- within(dat, { facing <- pi/2 + cumsum(turn)
move <- lens * exp(1i * facing)
position <- cumsum(move)
x2 <- Re(position)
y2 <- Im(position)
x1 <- c(0, head(x2, -1))
y1 <- c(0, head(y2, -1))
})
dat[c("id", "lens", "x1", "y1", "x2", "y2")]
# id lens x1 y1 x2 y2
# 1 A 4 0 0 4 0
# 2 B 2 4 0 4 -2
# 3 C 5 4 -2 -1 -2
# 4 D 8 -1 -2 -1 6
# 5 E 6 -1 6 5 6
# 6 F 9 5 6 5 -3
The turn variable should really be considered as an input together with lens. Right now all turns are -pi/2 radians but you can set each one of them to whatever you want. All other variables are outputs.
Now having a little fun with it:
trace.path <- function(lens, turn) {
facing <- pi/2 + cumsum(turn)
move <- lens * exp(1i * facing)
position <- cumsum(move)
x <- c(0, Re(position))
y <- c(0, Im(position))
plot.new()
plot.window(range(x), range(y))
lines(x, y)
}
trace.path(lens = seq(0, 1, length.out = 200),
turn = rep(pi/2 * (-1 + 1/200), 200))
(My attempt at replicating the graph here: http://en.wikipedia.org/wiki/Turtle_graphics)
I also let you try these:
trace.path(lens = seq(1, 10, length.out = 1000),
turn = rep(2 * pi / 10, 1000))
trace.path(lens = seq(0, 1, length.out = 500),
turn = seq(0, pi, length.out = 500))
trace.path(lens = seq(0, 1, length.out = 600) * c(1, -1),
turn = seq(0, 8*pi, length.out = 600) * seq(-1, 1, length.out = 200))
Feel free to add yours!
This is yet another method using complex numbers. You can rotate a vector "to the right" in the complex plane by multiplying by -1i. The code below makes the first traversal go in the positive X (the Re()-al axis) and each subsequent traversal would be rotated to the "right"
imVecs <- lengths*c(0-1i)^(0:3)
imVecs
# [1] 9+0i 0-5i -9+0i 0+9i 8+0i 0-5i -8+0i 0+7i 8+0i 0-1i -5+0i 0+3i 4+0i 0-7i -4+0i 0+2i
#[17] 3+0i 0-7i -5+0i 0+8i
cumsum(imVecs)
# [1] 9+0i 9-5i 0-5i 0+4i 8+4i 8-1i 0-1i 0+6i 8+6i 8+5i 3+5i 3+8i 7+8i 7+1i 3+1i 3+3i 6+3i 6-4i 1-4i
#[20] 1+4i
plot(cumsum(imVecs))
lines(cumsum(imVecs))
This is the approach to using complex plane rotations to do 45 degree turns to the right:
> sqrt(-1i)
[1] 0.7071068-0.7071068i
> imVecs <- lengths*sqrt(0-1i)^(0:7)
Warning message:
In lengths * sqrt(0 - (0+1i))^(0:7) :
longer object length is not a multiple of shorter object length
> plot(cumsum(imVecs))
> lines(cumsum(imVecs))
And the plot:
This isn't a pretty plot, but I've included it to show that this 'vectorized' coordinate calculation produces correct results which shouldn't be too hard to adapt to your needs:
xx <- c(1,0,-1,0)
yy <- c(0,-1,0,1)
coords <- suppressWarnings(cbind(x = cumsum(c(0,xx*dat$lens)),
y = cumsum(c(0,yy*dat$lens))))
plot(coords, type="l", xlim=c(-10,10), ylim=c(-10,10))
It might be useful to think about this in terms of distance and bearing. Distance is given by dat$lens, and bearing is the angle of movement relative to some arbitrary reference line (say, the x-axis). Then, at each step,
x.new = x.old + distance * cos(bearing)
y.new = y.old + distance * sin(bearing)
bearing = bearing + increment
Here, since we start at the origin and move in the +x direction, (x,y)=(0,0) and bearing starts at 0 degrees. A right turn is simply a bearing increment of -90 degrees (-pi/2 radians). So in R code, using your definition of dat:
x <-0
y <- 0
bearing <- 0
for (i in 1:nrow(dat)){
dat[i,c(3,4)] <- c(x,y)
length <- dat[i,2]
x <- x + length * cos(bearing)
y <- y + length * sin(bearing)
dat[i,c(5,6)] <- c(x,y)
bearing <- bearing - pi/2
}
This produces what you had and has the advantage that you can update it very simply to make left turns, or 45 degree turns, or whatever. You can even add a bearing.increment column to dat to create a random walk.
Very similar to Josh's solution:
lengths <- sample(1:10, 20, repl=TRUE)
x=cumsum(lengths*c(1,0,-1,0))
y=cumsum(lengths*c(0,1,0,-1))
cbind(x,y)
x y
[1,] 9 0
[2,] 9 5
[3,] 0 5
[4,] 0 -4
[5,] 8 -4
[6,] 8 1
[7,] 0 1
[8,] 0 -6
[9,] 8 -6
[10,] 8 -5
[11,] 3 -5
[12,] 3 -8
[13,] 7 -8
[14,] 7 -1
[15,] 3 -1
[16,] 3 -3
[17,] 6 -3
[18,] 6 4
[19,] 1 4
[20,] 1 -4
Base graphics:
plot(cbind(x,y))
arrows(cbind(x,y)[-20,1],cbind(x,y)[-20,2], cbind(x,y)[-1,1], cbind(x,y)[-1,2] )
This does highlight the fact that both Josh's and my solutions are "turning the wrong way", so you need to change the signs on our "transition matrices". And we probably should have started at (0,0), but You should have not trouble adapting this you your needs.