Here is an example where the Nelder-Mead derivative-free optimziation algorithm is used. The problem is that I want a solution for integer-valued parameters. Does anybody know a way to do that in R?
library(dfoptim)
fn <- function(x) {
f1 <- x[1] + 6*x[2]
f2 <- 3*(10-x[1]) + 5*(10-x[2])
max(f1, f2)
}
par0 <- c(1, 1)
nmkb(par0, fn, lower = 0, upper = 10)
Following up on my comment, your problem can be rewritten as as Mixed-Integer Linear Programming:
Minimize z (A)
Subject to
z >= x + 6y (B)
z >= 80 - 3x - 5y (C)
x >= 0 (D)
x <= 10 (E)
y >= 0 (F)
y <= 10 (G)
x, y are integer (H)
MILP are solved using a branch-and-bound algorithm that should be faster than a non-linear solver. One such free solver is lpSolve:
library(lpSolve)
res <- lp(direction = "min",
objective.in = c(1, 0, 0), # (A) (weights for {z, x, y})
const.mat = rbind(c(1, -1, -6), # (B)
c(1, +3, +5), # (C)
c(0, 1, 0), # (D)
c(0, 1, 0), # (E)
c(0, 0, 1), # (F)
c(0, 0, 1)), # (G)
const.dir = c(">=", ">=", ">=", "<=", ">=", "<="), # (B through G)
const.rhs = c( 0, 80, 0, 10, 0, 10), # (B through G)
int.vec = c(2, 3)) # (H)
res$solution # optimal values for z, x, y respectively
# [1] 33 9 4
I hope this helps. If not, maybe some will find it interesting nonetheless.
Related
Suppose I have the following system of inequalities:
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
I want to find multiple tuples of (x, y) that satisfy the above inequalities.
library(Rglpk)
obj <- numeric(2)
mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3)
dir <- c("<=", "<=", ">=")
rhs <- c(-3, 2.5, -3)
Rglpk_solve_LP(obj = obj, mat = mat, dir = dir, rhs = rhs)
Using the above code only seems to return 1 possible solution tuple (1.5, 0). Is possible to return other solution tuples?
Edit: Based on the comments, I would be interested to learn if there are any functions that could help me find the corner points.
Actually to understand the possible answers for the given question we can try to solve the system of inequalities graphically.
There was a nice answer concerning plotting of inequations in R at stackowerflow. Using the given aproach we can plot the following graph:
library(ggplot2)
fun1 <- function(x) 2*x - 3 # this is the same as -2x + y <= -3
fun2 <- function(x) -1.25*x + 2.5 # 1.25x + y <= 2.5
fun3 <- function(x) -3 # y >= -3
x1 = seq(-1,5, by = 1/16)
mydf = data.frame(x1, y1=fun1(x1), y2=fun2(x1),y3= fun3(x1))
mydf <- transform(mydf, z = pmax(y3,pmin(y1,y2)))
ggplot(mydf, aes(x = x1)) +
geom_line(aes(y = y1), colour = 'blue') +
geom_line(aes(y = y2), colour = 'green') +
geom_line(aes(y = y3), colour = 'red') +
geom_ribbon(aes(ymin=y3,ymax = z), fill = 'gray60')
All the possible (infinite by number) tuples lie inside the gray triangle.
The vertexes can be found using the following code.
obj <- numeric(2)
mat <- matrix(c(-2, 1.25, 1, 1), nrow = 2)
rhs <- matrix(c(-3, 2.5), nrow = 2)
aPoint <- solve(mat, rhs)
mat <- matrix(c(-2, 0, 1, 1), nrow = 2)
rhs <- matrix(c(-3, -3), nrow = 2)
bPoint <- solve(mat, rhs)
mat <- matrix(c(1.25, 0, 1, 1), nrow = 2)
rhs <- matrix(c(2.5, -3), nrow = 2)
cPoint <- solve(mat, rhs)
Note the order of arguments of matrices.
And you get the coordinates:
> aPoint
[,1]
[1,] 1.6923077
[2,] 0.3846154
> bPoint
[,1]
[1,] 0
[2,] -3
> cPoint
[,1]
[1,] 4.4
[2,] -3.0
All the codes below are with base R only (no need library(Rglpk))
1. Corner Points
If you want to get all the corner points, here is one option
A <- matrix(c(-2, 1.25, 0, 1, 1, -1), nrow = 3)
b <- c(-3, 2.5, 3)
# we use `det` to check if the coefficient matrix is singular. If so, we return `Inf`.
xh <-
combn(nrow(A), 2, function(k) {
if (det(A[k, ]) == 0) {
rep(NA, length(k))
} else {
solve(A[k, ], b[k])
}
})
# We filter out the points that satisfy the constraint
corner_points <- t(xh[, colSums(A %*% xh <= b, na.rm = TRUE) == length(b)])
such that
> corner_points
[,1] [,2]
[1,] 1.692308 0.3846154
[2,] 0.000000 -3.0000000
[3,] 4.400000 -3.0000000
2. Possible Tuples
If you want to have multiple tuples, e.g., n=10, we can use Monte Carlo simulation (based on the obtained corner_points in the previous step) to select the tuples under the constraints:
xrange <- range(corner_points[, 1])
yrange <- range(corner_points[, 2])
n <- 10
res <- list()
while (length(res) < n) {
px <- runif(1, xrange[1], xrange[2])
py <- runif(1, yrange[1], yrange[2])
if (all(A %*% c(px, py) <= b)) {
res[length(res) + 1] <- list(c(px, py))
}
}
and you will see n possible tuples in a list like below
> res
[[1]]
[1] 3.643167 -2.425809
[[2]]
[1] 2.039007 -2.174171
[[3]]
[1] 0.4990635 -2.3363637
[[4]]
[1] 0.6168402 -2.6736421
[[5]]
[1] 3.687389 -2.661733
[[6]]
[1] 3.852258 -2.704395
[[7]]
[1] 1.7571062 0.1067597
[[8]]
[1] 3.668024 -2.771307
[[9]]
[1] 2.108187 -1.365349
[[10]]
[1] 2.106528 -2.134310
First of all, the matrix representing the three equations needs a small correction, because R fills matrices column by column :
-2x + y <= -3
1.25x + y <= 2.5
y >= -3
mat <- matrix(c(-2, 1.25, 0, 1, 1, 1), nrow = 3
# and not : mat <- matrix(c(-2, 1, 1.25, 1, 0, 1), nrow = 3)
To get different tuples, you could modify the objective function :
obj <- numeric(2) results in an objective function 0 * x + 0 * y which is always equal to 0 and can't be maximized : the first valid x,y will be selected.
Optimization on x is achieved by using obj <- c(1,0), resulting in maximization / minimization of 1 * x + 0 * y.
Optimization on y is achieved by using obj <- c(0,1).
#setting the bounds is necessary, otherwise optimization occurs only for x>=0 and y>=0
bounds <- list(lower = list(ind = c(1L, 2L), val = c(-Inf, -Inf)),
upper = list(ind = c(1L, 2L), val = c(Inf, Inf)))
# finding maximum x: obj = c(1,0), max = T
Rglpk_solve_LP(obj = c(10,0), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = T)$solution
# [1] 4.4 -3.0
# finding minimum x: obj = c(1,0), max = F
Rglpk_solve_LP(obj = c(10,0), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = F)$solution
#[1] 0 -3
# finding maximum y: obj = c(0,1), max = T
Rglpk_solve_LP(obj = c(0,1), mat = mat, dir = dir, rhs = rhs,bound=bounds, max = T)$solution
#[1] 1.6923077 0.3846154
I have the below codes for a bivariate normal distribution:
library(mnormt)
x <- seq(-5, 5, 0.25)
y <- seq(-5, 5, 0.25)
mu <- c(0, 0)
sigma <- matrix(c(2, -1, -1, 2), nrow = 2)
f <- function(x, y) dmnorm(cbind(x, y), mu, sigma)
z <- outer(x, y, f)
a) I would like to know what the algebraic expression z=f(x,y) is based on the above codes (please write the algebraic expression explicitly). b) Indeed, numbers 2, -1, -1 and 2 in matrix(c(2, -1, -1, 2), nrow = 2) are which parameters in the algebraic expression z=f(x,y)?
If you want to see the source code, you may go to see there there.
I comment the code for you :
dmnorm <- function(x, mean=rep(0,d), varcov, log=FALSE)
{
# number of variable
d <- if(is.matrix(varcov)) ncol(varcov) else 1
if(d==1) return(dnorm(x, mean, sqrt(varcov), log=log))
x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x)
if(ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'")
if(is.matrix(mean)) {
if ((nrow(x) != nrow(mean)) || (ncol(mean) != d))
stop("mismatch of dimensions of 'x' and 'mean'") }
if(is.vector(mean)) mean <- outer(rep(1, nrow(x)), as.vector(matrix(mean,d)))
# center
X <- t(x - mean)
# compute the inverse of sigma
conc <- pd.solve(varcov, log.det=TRUE)
# Q is the exponential part
Q <- colSums((conc %*% X)* X)
# compute the log determinant
log.det <- attr(conc, "log.det")
# log likelihood
logPDF <- as.vector(Q + d*logb(2*pi) + log.det)/(-2)
if(log) logPDF else exp(logPDF)
}
It is a strick application of this equation :
Which come from this website.
Have a problem with data generating and I have no idea how to solve this. All information provided in photo: Problem.
I think that X_i(t) in both cases should be 200 x 100 if we say that t is from 0 to 1 (length = 100). Furthermore, coefficients for polynomial should contain 200 x 4 and coefficients for fourier should contain 200 x 5. Bu I have no idea how to start to solve this problem.
Here is some code. So, I have already defined my beta's, but I can't defeat generating of X_i(t).
t <- seq(0, 1, length = 100)
beta_1t <- rep(0, 100)
plot(t, beta_1t, type = "l")
beta_2t <- (t >= 0 & t < 0.342) * ((t - 0.5)^2 - 0.025) +
(t >= 0.342 & t <= 0.658) * 0 +
(t > 0.658 & t <= 1) * (-(t - 0.5)^2 + 0.025)
plot(t, beta_2t, type = "l")
beta_3t <- t^3 - 1.6 * t^2 + 0.76 * t + 1
plot(t, beta_3t, type = "l")
poly_c <- matrix(rnorm(n = 800, mean = 0, sd = 1), ncol = 4)
four_c <- matrix(rnorm(n = 1000, mean = 0, sd = 1), ncol = 5)
As I mentioned before, there should be (X_i(t), Y_i(t)) samples. Here i = 1, 2, ..., 200; t from [0, 1] (length = 100).
Given two vectors of integers:
X <- c(0, 201, 0, 0, 160, 0, 0, 0, 15, 80)
Y <- c(0, 0, 0, 0, 1, 4, 42, 10, 19, 0)
I want to calculate the probability p1 = P(X10 > X11), where X10 is a variable with a conditional distribution of X given that Y = 0, and X11 is a variable with a conditional distribution of X given that Y > 0. (This problem is motivated by a desire to implement equation 8 from RS Pimentel et al. 2015, Stat Prob Lett 96:61-67.)
For two pairs of vectors, I can simply calculate:
N <- length(X)
X10 <- X
X10[Y > 0] <- 0
X11 <- X
X11[Y == 0] <- 0
p1 <- sum(X10 > X11) / N
However, I now want to calculate p1 for all pairs of columns in an integer matrix:
Z <- c(0, 0, 0, 0, 0, 1, 0, 1, 8, 0)
matrix(c(X, Y, Z), ncol = 3)
I am not interested in the diagonal.
The desired output is therefore:
[,1] [,2] [,3]
[1,] 0.2 0.3
[2,] 0.2
[3,]
How can I write a function that will calculate p1 for all pairs of columns in the matrix?
You can create a custom function to compute your probability, then apply it to each combination of columns:
p1 <- function(x, y) {
x10 <- x
x10[y > 0] <- 0
x11 <- x
x11[y == 0] <- 0
mean(x10 > x11)
}
combinations <- t(combn(ncol(M), 2))
# create a matrix of NAs, fill the appropriate values
result <- matrix(NA, nrow = ncol(M), ncol = ncol(M))
result[combinations] <- apply(combinations, 1, function(r) p1(M[, r[1]], M[, r[2]]))
I have the following code:
beta <- c(1, 2, 3)
X1 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1,
0, 0, 1, 1),
nrow = 4,
ncol = 3)
Z1 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1),
nrow = 4,
ncol = 2)
Z2 <- matrix(c(1, 1, 1, 1,
0, 1, 0, 1),
nrow = 4,
ncol = 2)
library(MASS)
S1 <- mvrnorm(70, mu = c(0,0), Sigma = matrix(c(10, 3, 3, 2), ncol = 2))
S2 <- mvrnorm(40, mu = c(0,0), Sigma = matrix(c(10, 4, 4, 2), ncol = 2))
z <- list()
y <- list()
for(j in 1:dim(S1)[1]){
for(i in 1:dim(S2)[1]){
z[[i]] <- X1 %*% beta+Z1 %*% S1[j,]+Z2 %*% S2[i,]+matrix(rnorm(4, mean = 0 , sd = 0.27), nrow = 4)
Z <- unname(do.call(rbind, z))
}
y[[j]] <- Z
Y <- unname(do.call(rbind, y))
}
X1 is a 4x3, Z1 and Z2 are 4x2 matrices. So everytime X1 %*% beta+X2 %*% S1[j,]+X2 %*% S2[i,]+matrix(rnorm(4, mean = 0 , sd = sigma), nrow = 4) is called it outputs a 4x1 matrix. So far I store all these values in the inner and outer loop in two lists and then call rbind() to transform them into a matrix. Is there a way to directly store them in matrices?
You can avoid using lists if you rely on the apply functions and on vector recycling. I broke down your equation into its parts. (I hope I interpreted it accurately!)
Mb <- as.vector(X1 %*% beta)
M1 <- apply(S1,1,function(x) Z1 %*% x )
M2 <- apply(S2,1,function(x) Z2 %*% x ) + Mb
Mout <- apply(M1,2,function(x) M2 + as.vector(x))
as.vector(Mout) + rnorm(length(Mout), mean = 0 , sd = 0.27)
because the random numbers are added after the matrix multiplication (ie are not involved in any calculation), you can just put them in on the end.
Also note that you can't add a smaller matrix to a larger one, but if you make it a vector first then R will recycle it as necessary. So when Mb (a vector of length 4) is added to a matrix with 4 rows and n columns, it is recycled n times.