{-# LANGUAGE RankNTypes #-}
{- | Performance metrics for multiobjective problems.

-}

module Moo.GeneticAlgorithm.Multiobjective.Metrics where


import Data.List (tails, sortBy)
import Data.Function (on)


import Moo.GeneticAlgorithm.Types
import Moo.GeneticAlgorithm.Multiobjective.Types
import Moo.GeneticAlgorithm.Multiobjective.NSGA2


type Point = [Double]


-- | Calculate the hypervolume indicator using WFG algorithm.

--

-- Reference:

-- While, L., Bradstreet, L., & Barone, L. (2012). A fast way of

-- calculating exact hypervolumes. Evolutionary Computation, IEEE

-- Transactions on, 16(1), 86-95.

--

hypervolume :: forall fn a . ObjectiveFunction fn a
            => MultiObjectiveProblem fn   -- ^ multiobjective problem @mop@

            -> [Objective]                -- ^ reference point (the worst point)

            -> [MultiPhenotype a]         -- ^ a set of solutions to evaluate

            -> Double                     -- ^ hypervolume

hypervolume :: forall fn a.
ObjectiveFunction fn a =>
MultiObjectiveProblem fn
-> [Double] -> [MultiPhenotype a] -> Double
hypervolume MultiObjectiveProblem fn
mop [Double]
refPoint [MultiPhenotype a]
solutions =
    let ptypes :: [ProblemType]
ptypes = ((ProblemType, fn) -> ProblemType)
-> MultiObjectiveProblem fn -> [ProblemType]
forall a b. (a -> b) -> [a] -> [b]
map (ProblemType, fn) -> ProblemType
forall a b. (a, b) -> a
fst MultiObjectiveProblem fn
mop :: [ProblemType]
        points :: [[Double]]
points = (MultiPhenotype a -> [Double]) -> [MultiPhenotype a] -> [[Double]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype a -> [Double]
forall a. MultiPhenotype a -> [Double]
takeObjectiveValues [MultiPhenotype a]
solutions
    in  Int -> [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Double]
refPoint [[Double]]
points


-- | Basic (non-optimized) WFG algorithm to calculate hypervolume.

--

-- Reference: While et al. (2012).

wfgHypervolume :: [ProblemType]  -- ^ problem types

               -> Point          -- ^ reference point (the @worst@ point)

               -> [Point]        -- ^ a set of points

               -> Double
wfgHypervolume :: [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume [ProblemType]
ptypes [Double]
worst [[Double]]
pts =
    let ptsAndTails :: [([Double], [[Double]])]
ptsAndTails = [[Double]] -> [[[Double]]] -> [([Double], [[Double]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Double]]
pts (Int -> [[[Double]]] -> [[[Double]]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[Double]] -> [[[Double]]]
forall a. [a] -> [[a]]
tails [[Double]]
pts)) :: [(Point, [Point])]
        exclusiveHvs :: [Double]
exclusiveHvs = (([Double], [[Double]]) -> Double)
-> [([Double], [[Double]])] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map
                       (\([Double]
pt, [[Double]]
rest) -> [ProblemType] -> [Double] -> [Double] -> [[Double]] -> Double
exclusiveHypervolume [ProblemType]
ptypes [Double]
worst [Double]
pt [[Double]]
rest)
                       [([Double], [[Double]])]
ptsAndTails
    in  [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
exclusiveHvs


-- | WFG algorithm to calculate hypervolume with sorting optimization.

wfgHypervolume_sort :: Int            -- ^ index of the objective to sort

                    -> [ProblemType]  -- ^ problem types

                    -> Point          -- ^ reference point (the @worst@ point)

                    -> [Point]        -- ^ a set of points

                    -> Double
wfgHypervolume_sort :: Int -> [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume_sort Int
k [ProblemType]
ptypes [Double]
worst [[Double]]
pts
    | [ProblemType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProblemType]
ptypes Bool -> Bool -> Bool
|| [ProblemType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ProblemType]
ptypes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
k Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 =
        Int -> [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Double]
worst [[Double]]
pts  -- bad input, sort the first objective

    | Bool
otherwise =
        let ptype :: ProblemType
ptype = [ProblemType]
ptypes [ProblemType] -> Int -> ProblemType
forall a. [a] -> Int -> a
!! Int
k
            pts' :: [[Double]]
pts' = ([Double] -> [Double] -> Ordering) -> [[Double]] -> [[Double]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Double -> Ordering)
-> ([Double] -> Double) -> [Double] -> [Double] -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ProblemType -> Int -> [Double] -> Double
get ProblemType
ptype Int
k) [[Double]]
pts
        in  [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume [ProblemType]
ptypes [Double]
worst [[Double]]
pts'
    where
      get :: ProblemType -> Int -> [Double] -> Double
      get :: ProblemType -> Int -> [Double] -> Double
get ProblemType
Minimizing Int
k [Double]
objvals
          | [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Double]
objvals [Double] -> Int -> Double
forall a. [a] -> Int -> a
!! Int
k
          | Bool
otherwise          = Double
inf
      get ProblemType
Maximizing Int
k [Double]
objvals
          | [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Double]
objvals [Double] -> Int -> Double
forall a. [a] -> Int -> a
!! Int
k
          | Bool
otherwise          = - Double
inf
      inf :: Double
      inf :: Double
inf = Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0


-- | Construct a limited set (a step of the WFG algorithm).

--

-- @

--     limitSet(S, p) = { limit(x, p) | x \in S }

--     where limit(<s1, ..., sn>, <p1, ..., pn>) = < worse(s1,p1), ..., worse(sn, pn)>.

-- @

limitSet :: [ProblemType] -- ^ problem types

         -> Point         -- ^ reference point

         -> [Point]       -- ^ original set

         -> [Point]       -- ^ limited set

limitSet :: [ProblemType] -> [Double] -> [[Double]] -> [[Double]]
limitSet [ProblemType]
ptypes [Double]
refPoint =
    ([Double] -> [Double]) -> [[Double]] -> [[Double]]
forall a b. (a -> b) -> [a] -> [b]
map ((ProblemType -> Double -> Double -> Double)
-> [ProblemType] -> [Double] -> [Double] -> [Double]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ProblemType -> Double -> Double -> Double
worst [ProblemType]
ptypes [Double]
refPoint)
  where
    worst :: ProblemType -> Double -> Double -> Double
    worst :: ProblemType -> Double -> Double -> Double
worst ProblemType
Minimizing Double
x Double
y | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
y     = Double
x
                         | Bool
otherwise = Double
y
    worst ProblemType
Maximizing Double
x Double
y | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
y     = Double
x
                         | Bool
otherwise = Double
y


-- | Construct a non-dominated subset (a step of the WFG algorithm).

nondominatedSet :: [ProblemType]  -- ^ problem types

                -> [Point]        -- ^ original set

                -> [Point]        -- ^ a non-dominated subset

nondominatedSet :: [ProblemType] -> [[Double]] -> [[Double]]
nondominatedSet [ProblemType]
ptypes [[Double]]
points =
    let dominates :: DominationCmp a
dominates = [ProblemType] -> DominationCmp a
forall a. [ProblemType] -> DominationCmp a
domination [ProblemType]
ptypes
        dummySolutions :: [MultiPhenotype Double]
dummySolutions = ([Double] -> MultiPhenotype Double)
-> [[Double]] -> [MultiPhenotype Double]
forall a b. (a -> b) -> [a] -> [b]
map (\[Double]
objvals -> ([], [Double]
objvals)) [[Double]]
points :: [MultiPhenotype Double]
        fronts :: [[MultiPhenotype Double]]
fronts = DominationCmp Double
-> [MultiPhenotype Double] -> [[MultiPhenotype Double]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp Double
forall {a}. DominationCmp a
dominates [MultiPhenotype Double]
dummySolutions :: [[MultiPhenotype Double]]
    in  case [[MultiPhenotype Double]]
fronts of
          ([MultiPhenotype Double]
nds:[[MultiPhenotype Double]]
_) -> (MultiPhenotype Double -> [Double])
-> [MultiPhenotype Double] -> [[Double]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype Double -> [Double]
forall a. MultiPhenotype a -> [Double]
takeObjectiveValues [MultiPhenotype Double]
nds
          [[MultiPhenotype Double]]
_       -> []


-- | Calculate inclusive hypervolume of a point @p@ (the size of the

-- part of the objective space dominated by @p@ alone).

inclusiveHypervolume :: [ProblemType]  -- ^ problem types

                     -> Point          -- ^ reference point (the @worst@ point)

                     -> Point          -- ^ a point @p@ to evaluate

                     -> Double         -- ^ inclusive hypervolume

inclusiveHypervolume :: [ProblemType] -> [Double] -> [Double] -> Double
inclusiveHypervolume [ProblemType]
ptypes [Double]
worst [Double]
p =
    [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (ProblemType -> Double -> Double -> Double)
-> [ProblemType] -> [Double] -> [Double] -> [Double]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ProblemType -> Double -> Double -> Double
hyperside [ProblemType]
ptypes [Double]
worst [Double]
p
 where
    hyperside :: ProblemType -> Double -> Double -> Double
    hyperside :: ProblemType -> Double -> Double -> Double
hyperside ProblemType
Minimizing Double
upper Double
x = Double -> Double
pos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
upper Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x
    hyperside ProblemType
Maximizing Double
lower Double
x = Double -> Double
pos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
lower
    -- Positive part: to truncate the hypervolume if an unsuitable

    -- reference point is given (not the worst one possible)

    pos :: Double -> Double
    pos :: Double -> Double
pos Double
x = Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
abs Double
x)


-- | Calculate exclusive hypervolume of a point @p@ relative to the

-- @underlying@ set (the size of the part of the objective space that

-- is dominated by @p@, but is not dominated by any member of the

-- @underlying@ set).

exclusiveHypervolume :: [ProblemType]  -- ^ problem types

                     -> Point          -- ^ reference point (the @worst@ point)

                     -> Point          -- ^ a point @p@ to evaluate

                     -> [Point]        -- ^ an @underlying@ set of points

                     -> Double         -- ^ exclusive hypervolume

exclusiveHypervolume :: [ProblemType] -> [Double] -> [Double] -> [[Double]] -> Double
exclusiveHypervolume [ProblemType]
ptypes [Double]
worst [Double]
p [[Double]]
underlying =
    let inclusiveHv :: Double
inclusiveHv = [ProblemType] -> [Double] -> [Double] -> Double
inclusiveHypervolume [ProblemType]
ptypes [Double]
worst [Double]
p
        nds :: [[Double]]
nds = [ProblemType] -> [[Double]] -> [[Double]]
nondominatedSet [ProblemType]
ptypes ([[Double]] -> [[Double]]) -> [[Double]] -> [[Double]]
forall a b. (a -> b) -> a -> b
$ [ProblemType] -> [Double] -> [[Double]] -> [[Double]]
limitSet [ProblemType]
ptypes [Double]
p [[Double]]
underlying
        underlyingHv :: Double
underlyingHv = [ProblemType] -> [Double] -> [[Double]] -> Double
wfgHypervolume [ProblemType]
ptypes [Double]
worst [[Double]]
nds
    in  Double
inclusiveHv Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
underlyingHv