{-# LANGUAGE RankNTypes #-}
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]
hypervolume :: forall fn a . ObjectiveFunction fn a
=> MultiObjectiveProblem fn
-> [Objective]
-> [MultiPhenotype a]
-> Double
hypervolume mop refPoint solutions =
let ptypes = map fst mop :: [ProblemType]
points = map takeObjectiveValues solutions
in wfgHypervolume_sort 0 ptypes refPoint points
wfgHypervolume :: [ProblemType]
-> Point
-> [Point]
-> Double
wfgHypervolume ptypes worst pts =
let ptsAndTails = zip pts (drop 1 (tails pts)) :: [(Point, [Point])]
exclusiveHvs = map
(\(pt, rest) -> exclusiveHypervolume ptypes worst pt rest)
ptsAndTails
in sum exclusiveHvs
wfgHypervolume_sort :: Int
-> [ProblemType]
-> Point
-> [Point]
-> Double
wfgHypervolume_sort k ptypes worst pts
| null ptypes || length ptypes <= k || k < 0 =
wfgHypervolume_sort 0 ptypes worst pts
| otherwise =
let ptype = ptypes !! k
pts' = sortBy (flip compare `on` get ptype k) pts
in wfgHypervolume ptypes worst pts'
where
get :: ProblemType -> Int -> [Double] -> Double
get Minimizing k objvals
| length objvals > k = objvals !! k
| otherwise = inf
get Maximizing k objvals
| length objvals > k = objvals !! k
| otherwise = - inf
inf :: Double
inf = 1/0
limitSet :: [ProblemType]
-> Point
-> [Point]
-> [Point]
limitSet ptypes refPoint =
map (zipWith3 worst ptypes refPoint)
where
worst :: ProblemType -> Double -> Double -> Double
worst Minimizing x y | x > y = x
| otherwise = y
worst Maximizing x y | x < y = x
| otherwise = y
nondominatedSet :: [ProblemType]
-> [Point]
-> [Point]
nondominatedSet ptypes points =
let dominates = domination ptypes
dummySolutions = map (\objvals -> ([], objvals)) points :: [MultiPhenotype Double]
fronts = nondominatedSort dominates dummySolutions :: [[MultiPhenotype Double]]
in case fronts of
(nds:_) -> map takeObjectiveValues nds
_ -> []
inclusiveHypervolume :: [ProblemType]
-> Point
-> Point
-> Double
inclusiveHypervolume ptypes worst p =
product $ zipWith3 hyperside ptypes worst p
where
hyperside :: ProblemType -> Double -> Double -> Double
hyperside Minimizing upper x = pos $ upper - x
hyperside Maximizing lower x = pos $ x - lower
pos :: Double -> Double
pos x = 0.5 * (x + abs x)
exclusiveHypervolume :: [ProblemType]
-> Point
-> Point
-> [Point]
-> Double
exclusiveHypervolume ptypes worst p underlying =
let inclusiveHv = inclusiveHypervolume ptypes worst p
nds = nondominatedSet ptypes $ limitSet ptypes p underlying
underlyingHv = wfgHypervolume ptypes worst nds
in inclusiveHv - underlyingHv