Here is one way to approach the problem, and a possible implementation
in R. It's only a sketch, really; and perhaps a more
constructive method (as indicated by Joseph Wood in the
comments) might give good results as well.
Your dataset, again:
df <- read.table(text = "
Size, A, B, D, E
1, 4, 7, -2, 1
5, -4, -1, 1, 4
10, -2, -3, 1, 9
-3, 1, 0, 0, -3
2, 4, -1, 3, -2
55, 8, -7, 9, 0
-5, 3, -4, -1, -5
2, 0, -2, 1, 8
1, -5, 1, 8, 1
4, -9, 3, 2, -3",
sep = ",", header = TRUE)
I use a plain data frame here. For convenience, I
put 'Size' into a separate variable.
size <- df$Size
df <- df[, -1]
df
## A B D E
## 1 4 7 -2 1
## 2 -4 -1 1 4
## 3 -2 -3 1 9
## 4 1 0 0 -3
## 5 4 -1 3 -2
## 6 8 -7 9 0
## 7 3 -4 -1 -5
## 8 0 -2 1 8
## 9 -5 1 8 1
## 10 -9 3 2 -3
Now, I allow a filter to be a function that takes a
column of df as input, plus possibly a second
argument. Such a filter must evaluate to a logical
vector with as many elements as df has rows. For
instance, a greater-than relation would use the
function >, and the second argument would be the
threshold. I collect all allowed functions in a list
functions. (The first function in effect ignores the
given colum.)
functions <- list(function(x, ...) TRUE,
`<`,
`>`)
A candidate solution x, then, is a list of filters (as many filters as there are columns in df)
and parameters for those filters. The following
solution does not apply any filter, because for any column that is input, it always returns TRUE (i.e. no rows are excluded):
x <- list(functions = list(function(x, ...) TRUE,
function(x, ...) TRUE,
function(x, ...) TRUE,
function(x, ...) TRUE),
parameters = c(0, 0, 0, 0))
A helper function to apply the filters: it returns a
logical vector with as many elements as df has rows.
subs <- function(x, df) {
rows <- !logical(nrow(df))
for (i in seq_len(ncol(df)))
rows <- rows & x$functions[[i]](df[, i], x$parameters[[i]])
rows
}
We can test this function with x. As it should, it
selects all rows of df.
subs(x, df)
## [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
The strategy for a local search is now to gradually
change the elements of x. Whenever such a change
leads to a better solution, we keep it. If it is worse,
we do not accept it. See Optimization Heuristics: A
Tutorial for more details. (Disclosure: I am the author; and I am also the maintainer of the NMOF package that I am going to use below.)
The run such a search, we first need an objective
function. It maps a given subset of rows into an single number, the mean size. Note that the algorithm used later minimises,
so I multiply the objective function's result by -1 (the -ans in the last line). Infeasible solutions (less than 5
rows) get penalised.
mean_size <- function(x, df, size, ...) {
rows <- subs(x, df)
subset.df <- df[rows, ]
size <- size[rows]
ans <- sum(size) / max(1, sum(rows))
if (sum(rows) < 5)
ans <- ans - 1000
-ans ## to minimise, return 'ans'
}
Check: the initial solution selects all rows (but note
the reversed sign).
mean_size(x, df, size)
## [1] -7.2
mean(size)
## [1] 7.2
And now the key part: the neighbourhood. The function
picks either a filter or a parameter, and changes it.
neighbour <- function(x, ...) {
stepsize <- 0.5
rand <- runif(1)
i <- sample(length(x$parameters), size = 1)
if (rand > 0.5) {
x$functions[[i]] <- sample(functions, size = 1)[[1]]
} else {
d <- sample(c(-stepsize, stepsize), size = 1)
x$parameters[i] <- min(max(x$parameters[i] + d, -10), 10)
}
x
}
Now we can run the optimisation. I use a method called
Threshold Accepting, implemented in the function
TAopt. Threshold Accepting is a special type of local
search; it may also accept changes that lead to
worse solutions, so that it can escape from local
minima.
library("NMOF")
sol <- TAopt(mean_size, list(neighbour = neighbour,
x0 = x,
nI = 5000,
printBar = FALSE,
printDetail = FALSE),
df = df, size = size)
sol$OFvalue ## objective function value of best solution
## [1] -14.8
So the best solution found by the algorithm implies a mean size of 14.8.
Since Threshold Accepting is a stochastic method, I run 20 restarts.
restarts <- restartOpt(TAopt, n = 20, mean_size,
list(neighbour = neighbour,
x0 = x,
nI = 3000,
printDetail = FALSE,
printBar = FALSE),
df = df, size = size)
summary(sapply(restarts, `[[`, "OFvalue"))
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -14.80 -14.80 -14.80 -13.18 -10.50 -10.00
With the development version of NMOF
(https://github.com/enricoschumann/NMOF), you can set
an option drop0 to TRUE. (With the CRAN version, this raises
a warning about unknown option, but this is harmless.) This should
improve the reliability of the solution.
restarts <- restartOpt(TAopt, n = 20, mean_size,
list(neighbour = neighbour,
x0 = x,
nI = 3000,
drop0 = TRUE,
printDetail = FALSE,
printBar = FALSE),
df = df, size = size)
summary(sapply(restarts, `[[`, "OFvalue"))
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -14.80 -14.80 -14.80 -14.77 -14.80 -14.60
Still, some solutions are likely better than others. There are
different ways to refine the search, but the easiest
way is to run the method 10 times, say, and to keep the
best solution.
best <- restartOpt(TAopt, n = 10, mean_size,
list(neighbour = neighbour,
x0 = x,
nI = 1000,
printDetail = FALSE,
printBar = FALSE),
df = df, size = size,
best.only = TRUE)
best$OFvalue
## [1] -14.8
So let us look at the actual solution.
best$xbest
## $functions
## $functions[[1]]
## function(x, ...) TRUE
##
## $functions[[2]]
## function (e1, e2) .Primitive("<")
##
## $functions[[3]]
## function (e1, e2) .Primitive(">")
##
## $functions[[4]]
## function(x, ...) TRUE
##
##
## $parameters
## [1] -7.5 0.0 0.5 5.0
So, this translates into the following filter:
i <- df[[2]] < 0 & df[[3]] > 0.5
Looking at the implied mean size:
cbind(size[i], df[i, ])
## size[i] A B D E
## 2 5 -4 -1 1 4
## 3 10 -2 -3 1 9
## 5 2 4 -1 3 -2
## 6 55 8 -7 9 0
## 8 2 0 -2 1 8
mean(size[i])
## [1] 14.8
As I said, only a sketch; but perhaps it gets you started.
