How can I implement a Generalized Assignment Problem: https://en.wikipedia.org/wiki/Generalized_assignment_problem to be solved with Genetic Algorithms https://cran.r-project.org/web/packages/GA/GA.pdf in R.
I have a working example of the code but its not working:
require(GA)
p <- matrix(c(5, 1, 5, 1, 5, 5, 5, 5, 1), nrow = 3)
t <- c(2, 2, 2)
w <- c(2, 2, 2)
assigment <- function(x) {
f <- sum(x * p)
penalty1 <- sum(w)*(sum(t)-sum(w*x))
penalty2 <- sum(w)*(1-sum(x))
f - penalty1 - penalty2
}
GA <- ga(type = "binary", fitness = assigment, nBits = length(p),
maxiter = 1000, run = 200, popSize = 20)
summary(GA)
It seems there are problems in your definition of the fitness function, i.e. the assigment() function.
x is a binary vector, and not a matrix as in the theory, so sum(x * p) is not doing what you likely expect (note that x has length 9 and p is a 3x3 matrix in your example);
the constrain on the sum of x_{ij} is not correctly taken into account by the penalty2 term;
the penalisations should act differently for penalty1 and penalty2, the first is an inequality (i.e. <=) while the second is a strict equality (i.e. =).
w is defined as a vector, but it should be a matrix of the same size as x
Related
I am running below code to evaluate a function at each value of r.
For each element of r, the function calculates the sum of elements of a matrix product. Before doing this, values of M are adjusted based on a kernel function.
# (1) set-up with toy data
r <- seq(0, 10, 1)
bw <- 25
M <- matrix(data = c(0, 1, 2,
1, 0, 1,
2, 1, 0), nrow = 3, ncol = 3)
X <- matrix(rep(1, 9), 3, 3)
#
# (2) computation
res <- c()
# loop, calculationg sum, Epanechnikov kernel
for(i in seq_along(r)) {
res[i] <- sum(
# Epanechnikov kernel
ifelse(-bw < (M - r[i]) & (M - r[i]) < bw,
3 * (1 - ((M - r[i])^2 / bw^2)) / (4*bw),
0) * X,
na.rm = TRUE
)
}
# result
res
I am looking for recommendations to speed this up using base R. Thank you!
Using outer:
Mr <- outer(c(M), r, "-")
colSums(3*(1 - Mr^2/bw^2)/4/bw*(abs(Mr) < bw)*c(X))
#> [1] 0.269424 0.269760 0.269232 0.267840 0.265584 0.262464 0.258480 0.253632 0.247920 0.241344 0.233904
I'll also note that the original for loop solution can be sped up by pre-allocating res (e.g., res <- numeric(length(r))) prior to the for loop.
I want to solve the optimazation problem to search best weights for groups of vectors. Would you like to give some suggestions about how to solve it by R? Thanks very much.
The problem is as follows.
Given there are N groups, we know their similarity matrix among these N groups. The dimension of S is N*N.
In each group, there are K vectors . There are M elements in each vector which value is 0 or 1. .
we can fit an average vector based on these K vectors. For example, average vector
Based on these avearge vectors in each group, we could calculate the correlation among these avearge vectors.
The object is to minimize the differene between correlation matrix C and known similarity matrix S.
Beacuse you didn't provide any data I will generate random and demonstrate way you can approach your problem.
Similarity matrix:
N <- 6
S <- matrix(runif(N^2, -1, 1), ncol = N, nrow = N)
similarity_matrix <- (S + t(S)) / 2
N is number of groups. Each value of similarity matrix is between -1 and 1 and matrix is symmetric (beacuse you want to compare it to covariance matrix these makes sense).
group vectors:
M <- 10
K <- 8
group_vectors <- replicate(N, replicate(K, sample(c(0, 1), M, TRUE)), FALSE)
M is dimension of vector and K is number of binary vectors in each group.
fitness function
fitness <- function(W, group_vectors, similarity_matrix){
W <- as.data.frame(matrix(W, nrow = K, ncol = N))
SS <- cov(
mapply(function(x,y) rowSums(sweep(x, 2, y, "*")), group_vectors, W)
)
sum(abs(SS - similarity_matrix))
}
fitness for given weights calculates described covariance matrix and its distance from similarity_matrix.
differential evolution approach
res <- DEoptim::DEoptim(
fn = fitness,
lower = rep(-1, K*N),
upper = rep(1, K*N),
group_vectors = group_vectors,
similarity_matrix = similarity_matrix,
control = DEoptim::DEoptim.control(VTR = 0, itermax = 1000, trace = 50, NP = 100)
)
W <- matrix(res$optim$bestmem, nrow = K, ncol = N)
genetic algorithm approach
res <- GA::ga(
type = "real-valued",
fitness = function(W, ...) -fitness(W, ...),
lower = rep(-1, K*N),
upper = rep(1, K*N),
group_vectors = group_vectors,
similarity_matrix = similarity_matrix,
maxiter = 10000,
run = 200
)
W <- matrix(res#solution[1,], nrow = K, ncol = N)
I am struggling with this for so long. I have a logistic growth function where the growth parameter
r is a matrix. The model is constructed in a way that I have as an output two N the N1 and N2.
I would like to be able to change the r parameter over time. When time < 50 I would like
r = r1 where
r1=matrix(c(
2,3),
nrow=1, ncol=2
When time >= 50 I would like r=r2 where
r2=matrix(c(
1,2),
nrow=1, ncol=2
Here is my function. Any help is highly appreciated.
rm(list = ls())
library(deSolve)
model <- function(time, y, params) {
with(as.list(c(y,params)),{
N = y[paste("N",1:2, sep = "")]
dN <- r*N*(1-N/K)
return(list(c(dN)))
})
}
r=matrix(c(
4,5),
nrow=1, ncol=2)
K=100
params <- list(r,K)
y<- c(N1=0.1, N2=0.2)
times <- seq(0,100,1)
out <- ode(y, times, model, params)
plot(out)
I would like ideally something like this but it does not work
model <- function(time, y, params) {
with(as.list(c(y,params)),{
N = y[paste("N",1:2, sep = "")]
r = ifelse(times < 10, matrix(c(1,3),nrow=1, ncol=2),
ifelse(times > 10, matrix(c(1,4),nrow=1, ncol=2), matrix(c(1,2),nrow=1, ncol=2)))
print(r)
dN <- r*N*(1-N/K)
return(list(c(dN)))
})
}
Thank you for your time.
Here a generic approach that uses an extended version of the approx function. Note also some further simplifications of the model function and the additional plot of the parameter values.
Edit changed according to the suggestion of Lewis Carter to make the parameter change at t=3, so that the effect can be seen.
library(simecol) # contains approxTime, a vector version of approx
model <- function(time, N, params) {
r <- approxTime(params$signal, time, rule = 2, f=0, method="constant")[-1]
K <- params$K
dN <- r*N*(1-N/K)
return(list(c(dN), r))
}
signal <- matrix(
# time, r[1, 2],
c( 0, 2, 3,
3, 1, 2,
100, 1, 2), ncol=3, byrow=TRUE
)
## test of the interpolation
approxTime(signal, c(1, 2.9, 3, 100), rule = 2, f=0, method="constant")
params <- list(signal = signal, K = 100)
y <- c(N1=0.1, N2=0.2)
times <- seq(0, 10, 0.1)
out <- ode(y, times, model, params)
plot(out)
For a small number of state variables like in the example, separate signals with approxfun from package stats will look less generic but may be slighlty faster.
As a further improvement, one may consider to replace the "hard" transitions with a more smooth one. This can then directly be formulated as a function without the need of approx, approxfun or approxTime.
Edit 2:
Package simecol imports deSolve, and we need only a small function from it. So instead of loading simecol it is also possible to include the approxTime function explicitly in the code. The conversion from data frame to matrix improves performance, but a matrix is preferred anyway in such cases.
approxTime <- function(x, xout, ...) {
if (is.data.frame(x)) {x <- as.matrix(x); wasdf <- TRUE} else wasdf <- FALSE
if (!is.matrix(x)) stop("x must be a matrix or data frame")
m <- ncol(x)
y <- matrix(0, nrow=length(xout), ncol=m)
y[,1] <- xout
for (i in 2:m) {
y[,i] <- as.vector(approx(x[,1], x[,i], xout, ...)$y)
}
if (wasdf) y <- as.data.frame(y)
names(y) <- dimnames(x)[[2]]
y
}
If you want to pass a matrix parameter you should pass a list of parameters and you can modify it inside the model when your time limit is exceeded (in the example below you don't even have to pass the r matrix to the model function)
library(deSolve)
model <- function(time, y, params) {
with(as.list(c(y,params)),{
if(time < 3) r = matrix(c(2,3), nrow = 1, ncol = 2)
else r = matrix(c(1,3), nrow = 1, ncol = 2)
N = y[paste("N",1:2, sep = "")]
dN <- r*N*(1-N/K)
return(list(c(dN)))
})
}
y <- c(N1=0.1, N2=0.2)
params <- list(r = matrix(c(0,0), nrow = 1, ncol = 2), K=100)
times <- seq(0,10,0.1)
out <- ode(y, times, model, params)
plot(out)
You can see examples of this for instance with Delay Differential Equations ?dede
There is a way to solve matrix algebra in R, like it's possible to do in the site:
https://www.symbolab.com/solver/matrix-calculator
I'm trying to solve this on R:
image with aexample of what i'm trying to solve
I have also tried to use the package ktsolve, but i think it can't do what i want.
Thanks for your time.
Depending on your goals, optimization may be the fastest and easiest alternative like in
calculate <- function(x){
A <- matrix(c(1 ,2 ,x), nrow = 1)
B <- matrix(c(1, 2, 3, 4, 5, 2, 6, 2, 1), nrow = 3)
C <- matrix(c(1, 2, x), nrow = 3)
return(abs(A %*% B %*% C - 1))
}
optimize(calculate, c(-100, 100))
I have a data set dat and two lists x and y. I would like to calculate different combination of x and y with different value of k. I wrote the following code to find the value of function fun for these different combinations. but how can I get the value of k which maximize the function fun for these different combination? since in each iteration I have different lists of x and y and at the end I want to find the k which maximise the function fun.
dat = c(9, 2, 7)
k = seq(0, 1, length = 10)
x =list(a = 1, b = 8, c = 4)
y = list(a = .5, b = 5, c = 5)
matrix = cbind(unlist(x), unlist(y)) %*% rbind(1-k, k)
z = apply(matrix, 2, as.list)
fun = function(dat, vec) sum(vec$a * dat - vec$b * dat + vec$c * dat)
res = rep(0, length(k))
for (i in 1:(length(k))){
v = split(unlist(z[[i]]), sub("\\d+$", "", names(z[[i]])))
res[i] = fun(dat, v)
}
> res
[1] -54 -47 -40 -33 -26 -19 -12 -5 2 9
In this example, k = 10 , but how can I find for every different lists without loop?
I still can't make heads or tails of what you are trying to do, but your code seems to boil down to this:
colSums(matrix(rep(dat,nrow(matrix)),ncol=nrow(matrix)) %*% (matrix*c(1,-1,1)))
That will work for any size of k. It also does not require any of your names.
Some advice: Don't use list when a simple vector will do. You seem to understand how the %*% multiply works, you just need to get your matrices into the right form.