{-# 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 :: MultiObjectiveProblem fn
-> [Objective] -> [MultiPhenotype a] -> Objective
hypervolume MultiObjectiveProblem fn
mop [Objective]
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 :: [[Objective]]
points = (MultiPhenotype a -> [Objective])
-> [MultiPhenotype a] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype a -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues [MultiPhenotype a]
solutions
    in  Int -> [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Objective]
refPoint [[Objective]]
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] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts =
    let ptsAndTails :: [([Objective], [[Objective]])]
ptsAndTails = [[Objective]] -> [[[Objective]]] -> [([Objective], [[Objective]])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Objective]]
pts (Int -> [[[Objective]]] -> [[[Objective]]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[Objective]] -> [[[Objective]]]
forall a. [a] -> [[a]]
tails [[Objective]]
pts)) :: [(Point, [Point])]
        exclusiveHvs :: [Objective]
exclusiveHvs = (([Objective], [[Objective]]) -> Objective)
-> [([Objective], [[Objective]])] -> [Objective]
forall a b. (a -> b) -> [a] -> [b]
map
                       (\([Objective]
pt, [[Objective]]
rest) -> [ProblemType]
-> [Objective] -> [Objective] -> [[Objective]] -> Objective
exclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
pt [[Objective]]
rest)
                       [([Objective], [[Objective]])]
ptsAndTails
    in  [Objective] -> Objective
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Objective]
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] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
k [ProblemType]
ptypes [Objective]
worst [[Objective]]
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] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume_sort Int
0 [ProblemType]
ptypes [Objective]
worst [[Objective]]
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' :: [[Objective]]
pts' = ([Objective] -> [Objective] -> Ordering)
-> [[Objective]] -> [[Objective]]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Objective -> Objective -> Ordering)
-> Objective -> Objective -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Objective -> Objective -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Objective -> Objective -> Ordering)
-> ([Objective] -> Objective)
-> [Objective]
-> [Objective]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ProblemType -> Int -> [Objective] -> Objective
get ProblemType
ptype Int
k) [[Objective]]
pts
        in  [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
pts'
    where
      get :: ProblemType -> Int -> [Double] -> Double
      get :: ProblemType -> Int -> [Objective] -> Objective
get ProblemType
Minimizing Int
k [Objective]
objvals
          | [Objective] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Objective]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Objective]
objvals [Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
k
          | Bool
otherwise          = Objective
inf
      get ProblemType
Maximizing Int
k [Objective]
objvals
          | [Objective] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Objective]
objvals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
k = [Objective]
objvals [Objective] -> Int -> Objective
forall a. [a] -> Int -> a
!! Int
k
          | Bool
otherwise          = - Objective
inf
      inf :: Double
      inf :: Objective
inf = Objective
1Objective -> Objective -> Objective
forall a. Fractional a => a -> a -> a
/Objective
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] -> [Objective] -> [[Objective]] -> [[Objective]]
limitSet [ProblemType]
ptypes [Objective]
refPoint =
    ([Objective] -> [Objective]) -> [[Objective]] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map ((ProblemType -> Objective -> Objective -> Objective)
-> [ProblemType] -> [Objective] -> [Objective] -> [Objective]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 ProblemType -> Objective -> Objective -> Objective
worst [ProblemType]
ptypes [Objective]
refPoint)
  where
    worst :: ProblemType -> Double -> Double -> Double
    worst :: ProblemType -> Objective -> Objective -> Objective
worst ProblemType
Minimizing Objective
x Objective
y | Objective
x Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
> Objective
y     = Objective
x
                         | Bool
otherwise = Objective
y
    worst ProblemType
Maximizing Objective
x Objective
y | Objective
x Objective -> Objective -> Bool
forall a. Ord a => a -> a -> Bool
< Objective
y     = Objective
x
                         | Bool
otherwise = Objective
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] -> [[Objective]] -> [[Objective]]
nondominatedSet [ProblemType]
ptypes [[Objective]]
points =
    let dominates :: DominationCmp a
dominates = [ProblemType] -> DominationCmp a
forall a. [ProblemType] -> DominationCmp a
domination [ProblemType]
ptypes
        dummySolutions :: [MultiPhenotype Objective]
dummySolutions = ([Objective] -> MultiPhenotype Objective)
-> [[Objective]] -> [MultiPhenotype Objective]
forall a b. (a -> b) -> [a] -> [b]
map (\[Objective]
objvals -> ([], [Objective]
objvals)) [[Objective]]
points :: [MultiPhenotype Double]
        fronts :: [[MultiPhenotype Objective]]
fronts = DominationCmp Objective
-> [MultiPhenotype Objective] -> [[MultiPhenotype Objective]]
forall a.
DominationCmp a -> [MultiPhenotype a] -> [[MultiPhenotype a]]
nondominatedSort DominationCmp Objective
forall a. DominationCmp a
dominates [MultiPhenotype Objective]
dummySolutions :: [[MultiPhenotype Double]]
    in  case [[MultiPhenotype Objective]]
fronts of
          ([MultiPhenotype Objective]
nds:[[MultiPhenotype Objective]]
_) -> (MultiPhenotype Objective -> [Objective])
-> [MultiPhenotype Objective] -> [[Objective]]
forall a b. (a -> b) -> [a] -> [b]
map MultiPhenotype Objective -> [Objective]
forall a. MultiPhenotype a -> [Objective]
takeObjectiveValues [MultiPhenotype Objective]
nds
          [[MultiPhenotype Objective]]
_       -> []


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

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

    pos :: Double -> Double
    pos :: Objective -> Objective
pos Objective
x = Objective
0.5 Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
* (Objective
x Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
+ Objective -> Objective
forall a. Num a => a -> a
abs Objective
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]
-> [Objective] -> [Objective] -> [[Objective]] -> Objective
exclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
p [[Objective]]
underlying =
    let inclusiveHv :: Objective
inclusiveHv = [ProblemType] -> [Objective] -> [Objective] -> Objective
inclusiveHypervolume [ProblemType]
ptypes [Objective]
worst [Objective]
p
        nds :: [[Objective]]
nds = [ProblemType] -> [[Objective]] -> [[Objective]]
nondominatedSet [ProblemType]
ptypes ([[Objective]] -> [[Objective]]) -> [[Objective]] -> [[Objective]]
forall a b. (a -> b) -> a -> b
$ [ProblemType] -> [Objective] -> [[Objective]] -> [[Objective]]
limitSet [ProblemType]
ptypes [Objective]
p [[Objective]]
underlying
        underlyingHv :: Objective
underlyingHv = [ProblemType] -> [Objective] -> [[Objective]] -> Objective
wfgHypervolume [ProblemType]
ptypes [Objective]
worst [[Objective]]
nds
    in  Objective
inclusiveHv Objective -> Objective -> Objective
forall a. Num a => a -> a -> a
- Objective
underlyingHv