Finding a subset in a large dataset (>100) optimizing a parameter - r

Question

I have a large matrix having this structure :
A B C
A' 9 2 0
B' 2 8 0
C' 0 1 7
The diagonal terms represent the interaction of an individual (A) with his/her brother/sister (A'). Off diagonal elements represent the interaction of an individual with individuals not part of the family.
From a large set of individuals (say a few hundreds), I would like to find subsets (say 10) of individuals having minimal interactions with individuals not part of the family.
I was thinking of using a genetic algorithm (to optimize a parameter that I could calculate from the matrix) but could not find any algorithm that deals with subsets.
Is there a package in R (preferable) doing this ?
Thanks

Answer 1

I'll outline binary genetic algorithm approach using GA package interface that you can use as baseline to create your own implementation. Because you have constraint that you want subset of specific length I will create mutation and crossover operators that will not ruin that specification (otherwise those operators will mostly create infeasible individuals).
mutation
mutation <- function(obj, parent){
vec <- as.vector(obj#population[parent,])
ind1 <- which(vec == 1)
ind2 <- setdiff(seq_along(vec), ind1)
ind1 <- sample(ind1, 1)
ind2 <- sample(ind2, 1)
vec[c(sample(ind1, 1), sample(ind2, 1))] <- c(0, 1)
vec
}
Mutation picks one position with 1 and one position with 0 and change their values to 0 and 1 respectively.
crossover
sizeCrossover <- function(size){
function(obj, parents){
vec1 <- obj#population[parents[1],] == 1
vec2 <- obj#population[parents[2],] == 1
c1 <- vec1 & vec2
c1[sample(which(!c1), size - sum(c1))] <- 1
c2 <- vec1 | vec2
c2[sample(which(c2), sum(c2) - size)] <- 0
list(children = rbind(c1, c2), fitness = c(NA, NA))
}
}
Crossover is variation of arithmetic crossover. In case of & it needs to additionally change some 0 to 1 and in case of | it needs to additionally change some 1 to 0.
initial population
initialPopulation <- function(popSize, N, size){
indices <- do.call(
rbind,
mapply(
function(x, y) cbind(x, y),
seq_len(popSize),
replicate(popSize, sample(seq_len(N), size), simplify = FALSE),
SIMPLIFY = FALSE
)
)
mm <- matrix(0, nrow = popSize, ncol = N)
mm[indices] <- 1
mm
}
If you create completely random initial population most (if not every) individuals will be infeasible. You need to create feasible initial population.
fitness
fitness <- function(vec, m, size){
indices <- which(vec == 1)
-sum(m[indices,indices])
}
GA::ga performas maximization hence the minus sign.
random data and parameters
N <- 200 # matrix dimensions
size <- 10 # subset length
popSize <- 100 # population size for genetic algorithm
m <- matrix(sample(0:10, N^2, TRUE), nrow = N)
diag(m) <- 0
ga
obj <- GA::ga(
type = "binary",
nBits = N,
run = 500,
maxiter = 10000,
popSize = popSize,
fitness = fitness,
m = m,
size = 10,
suggestions = initialPopulation(popSize, N, size),
mutation = mutation,
crossover = sizeCrossover(size)
)
subset <- which(obj#solution[1,] == 1)
note
I'm using sample as modified in Advanced R:
sample <- function(x, size = NULL, replace = FALSE, prob = NULL) {
size <- size %||% length(x)
x[sample.int(length(x), size, replace = replace, prob = prob)]
}

Answer 2

The problem in the question is not fully specified so assume that the problem is as follows. Let v be the vector of column sums of m-diag(diag(m)) and let k be an input specifying the required number of individuals in the subset. Then we wish to find the column names corresponding to the k smallest values in v or in terms of the language of integer linear programming we want to find the 0/1 vector x which minimizes v'x such that sum(x) = k.
We use the inputs and v defined in the Note at the end.
1) sort To minimize this we simply take the column names corresponding to the k smallest values of v.
names(head(sort(v), k))
## [1] "C" "A"
2) knapsack This can also be expressed as a knapsack problem. knapsack maximizes so we use max(v)-v to get the effect of minimization.
library(adagio)
res.knap <- knapsack(rep(1, length(v)), max(v) - v, k)
names(v)[res.knap$indices]
## [1] "A" "C"
3) linear programming We can also use integer linear programming with the following solution.
library(lpSolve)
res.lp <- lp("min", v, t(rep(1, length(v))), "=", k, all.bin = TRUE)
res.lp
## Success: the objective function is 2
names(v)[res.lp$solution == 1]
## [1] "A" "C"
4) genalg We use the rbga.bin genetic algorithm.
library(genalg)
set.seed(13)
f <- function(x) if (sum(x) == k) sum(x * v) else Inf
res.ga <- rbga.bin(size = length(v), evalFunc = f, popSize = 200,
mutation = .01, iters = 400)
cat(summary(res.ga))
## ...snip...
## GA Results
## Best Solution : 1 0 1
Note
The inputs are assumed to be:
k <- 2
m <- structure(c(9L, 2L, 0L, 2L, 8L, 1L, 0L, 0L, 7L), dim = c(3L,
3L), dimnames = list(c("A'", "B'", "C'"), c("A", "B", "C")))
v <- colSums(m - diag(diag(m)))