-- SPDX-License-Identifier: MPL-2.0

{- | Classification metrics. Empty samples are rejected, zero-denominator
precision/recall/F1 are defined as zero. Confusion matrix rows are truth,
columns prediction. ROC ties count one half; PR AUC uses grouped-threshold
trapezoids from recall=0,precision=1 (distinct from average precision).
-}
module HMath.DeepLearning.Metrics (
    ClassificationMetrics (..),
    confusionMatrix,
    classificationMetrics,
    topKAccuracy,
    rocAUC,
    prAUC,
    perplexity,
    cosineSimilarityMatrix,
    marginRankingLoss,
) where

import qualified Data.Foldable as Foldable (foldl')
import Data.List (groupBy, sortBy)
import HMath.Error
import qualified HMath.Tensor as T

-- | Accuracy and per-class precision,recall,and F1 values ordered by class index.
data ClassificationMetrics = ClassificationMetrics
    { ClassificationMetrics -> Double
accuracy :: Double
    -- ^ Fraction of correctly predicted samples.
    , ClassificationMetrics -> [Double]
precisionByClass :: [Double]
    -- ^ Per-class true positives divided by predicted positives; ordering follows class indices.
    , ClassificationMetrics -> [Double]
recallByClass :: [Double]
    -- ^ Per-class true positives divided by actual positives.
    , ClassificationMetrics -> [Double]
f1ByClass :: [Double]
    -- ^ Per-class harmonic mean of precision and recall, following the metric function's zero-denominator convention.
    }
    deriving (ClassificationMetrics -> ClassificationMetrics -> Bool
(ClassificationMetrics -> ClassificationMetrics -> Bool)
-> (ClassificationMetrics -> ClassificationMetrics -> Bool)
-> Eq ClassificationMetrics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClassificationMetrics -> ClassificationMetrics -> Bool
== :: ClassificationMetrics -> ClassificationMetrics -> Bool
$c/= :: ClassificationMetrics -> ClassificationMetrics -> Bool
/= :: ClassificationMetrics -> ClassificationMetrics -> Bool
Eq, Int -> ClassificationMetrics -> ShowS
[ClassificationMetrics] -> ShowS
ClassificationMetrics -> String
(Int -> ClassificationMetrics -> ShowS)
-> (ClassificationMetrics -> String)
-> ([ClassificationMetrics] -> ShowS)
-> Show ClassificationMetrics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClassificationMetrics -> ShowS
showsPrec :: Int -> ClassificationMetrics -> ShowS
$cshow :: ClassificationMetrics -> String
show :: ClassificationMetrics -> String
$cshowList :: [ClassificationMetrics] -> ShowS
showList :: [ClassificationMetrics] -> ShowS
Show)

finite :: [Double] -> Either MathError ()
finite :: [Double] -> Either MathError ()
finite [Double]
xs = if (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Double
x -> Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x Bool -> Bool -> Bool
|| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
x)) [Double]
xs then () -> Either MathError ()
forall a b. b -> Either a b
Right () else MathError -> Either MathError ()
forall a b. a -> Either a b
Left MathError
NonFiniteResult

-- | Count [trueClass,predictedClass] pairs for a positive explicit class count.
confusionMatrix :: Int -> [Int] -> [Int] -> Either MathError [[Int]]
confusionMatrix :: Int -> [Int] -> [Int] -> Either MathError [[Int]]
confusionMatrix Int
classes [Int]
truth [Int]
prediction
    | Int
classes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
truth
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
truth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
prediction
        Bool -> Bool -> Bool
|| (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Int
i -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
classes) ([Int]
truth [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
prediction) =
        MathError -> Either MathError [[Int]]
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"classification labels/classes/lengths")
    | Bool
otherwise =
        [[Int]] -> Either MathError [[Int]]
forall a b. b -> Either a b
Right
            [ [[()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Int
t, Int
p) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
truth [Int]
prediction, Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i, Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j] | Int
j <- [Int
0 .. Int
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
            | Int
i <- [Int
0 .. Int
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            ]

-- | Return accuracy and per-class precision, recall, and F1 with zero for undefined class denominators.
classificationMetrics :: Int -> [Int] -> [Int] -> Either MathError ClassificationMetrics
classificationMetrics :: Int -> [Int] -> [Int] -> Either MathError ClassificationMetrics
classificationMetrics Int
classes [Int]
truth [Int]
prediction = do
    matrix <- Int -> [Int] -> [Int] -> Either MathError [[Int]]
confusionMatrix Int
classes [Int]
truth [Int]
prediction
    let divide a
a a
b = if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
0 else a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a a -> a -> a
forall a. Fractional a => a -> a -> a
/ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b
        ps = [Int -> Int -> Double
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
divide (([[Int]]
matrix [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[Int]
row [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | [Int]
row <- [[Int]]
matrix]) | Int
i <- [Int
0 .. Int
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
        rs = [Int -> Int -> Double
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
divide (([[Int]]
matrix [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([[Int]]
matrix [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)) | Int
i <- [Int
0 .. Int
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
        fs = (Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Double
p Double
r -> if Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 then Double
0 else Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
r Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
p Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
r)) [Double]
ps [Double]
rs
        acc = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [([[Int]]
matrix [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
i | Int
i <- [Int
0 .. Int
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
truth)
    Right (ClassificationMetrics acc ps rs fs)

-- | Measure whether truth lies among descending top-k scores; equal scores prefer the smaller class index.
topKAccuracy :: Int -> [Int] -> [[Double]] -> Either MathError Double
topKAccuracy :: Int -> [Int] -> [[Double]] -> Either MathError Double
topKAccuracy Int
k [Int]
truth [[Double]]
scores = do
    [Double] -> Either MathError ()
finite ([[Double]] -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Double]]
scores)
    if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
        Bool -> Bool -> Bool
|| [Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
truth
        Bool -> Bool -> Bool
|| [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
truth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [[Double]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Double]]
scores
        Bool -> Bool -> Bool
|| ((Int, [Double]) -> Bool) -> [(Int, [Double])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
t, [Double]
row) -> [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
row Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
row Bool -> Bool -> Bool
|| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
row) ([Int] -> [[Double]] -> [(Int, [Double])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
truth [[Double]]
scores)
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"top-k labels/scores/k")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let correct :: Int
correct =
            [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
                [ ()
                | (Int
t, [Double]
row) <- [Int] -> [[Double]] -> [(Int, [Double])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
truth [[Double]]
scores
                , Int
t
                    Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Double, Int) -> Int) -> [(Double, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map
                        (Double, Int) -> Int
forall a b. (a, b) -> b
snd
                        ( Int -> [(Double, Int)] -> [(Double, Int)]
forall a. Int -> [a] -> [a]
take
                            Int
k
                            ( ((Double, Int) -> (Double, Int) -> Ordering)
-> [(Double, Int)] -> [(Double, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy
                                (\(Double
x, Int
i) (Double
y, Int
j) -> case Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
y Double
x of Ordering
EQ -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
j; Ordering
order -> Ordering
order)
                                ([Double] -> [Int] -> [(Double, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
row [Int
0 :: Int ..])
                            )
                        )
                ]
    Double -> Either MathError Double
forall a b. b -> Either a b
Right (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
correct Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
truth))

-- | Compute the exact positive/negative rank-pair ROC area; both classes are required and ties count half.
rocAUC :: [Bool] -> [Double] -> Either MathError Double
rocAUC :: [Bool] -> [Double] -> Either MathError Double
rocAUC [Bool]
truth [Double]
scores = do
    [Double] -> Either MathError ()
finite [Double]
scores
    if [Bool] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
truth Bool -> Bool -> Bool
|| [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
truth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
scores
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"ROC sample lengths")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let positive :: [Double]
positive = [Double
s | (Bool
True, Double
s) <- [Bool] -> [Double] -> [(Bool, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
truth [Double]
scores]; negative :: [Double]
negative = [Double
s | (Bool
False, Double
s) <- [Bool] -> [Double] -> [(Bool, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
truth [Double]
scores]
    if [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
positive Bool -> Bool -> Bool
|| [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
negative
        then MathError -> Either MathError Double
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"ROC AUC requires both classes")
        else
            Double -> Either MathError Double
forall a b. b -> Either a b
Right
                ( [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [if Double
p Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
n then Double
1 else if Double
p Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
n then Double
0.5 else Double
0 | Double
p <- [Double]
positive, Double
n <- [Double]
negative]
                    Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
positive Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
negative)
                )

-- | Integrate the precision-recall curve by grouped-score trapezoids, requiring at least one positive example.
prAUC :: [Bool] -> [Double] -> Either MathError Double
prAUC :: [Bool] -> [Double] -> Either MathError Double
prAUC [Bool]
truth [Double]
scores = do
    [Double] -> Either MathError ()
finite [Double]
scores
    if [Bool] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bool]
truth Bool -> Bool -> Bool
|| [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
truth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
scores
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"PR sample lengths")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let positives :: Int
positives = [Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
forall a. a -> a
id [Bool]
truth)
    if Int
positives Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"PR AUC requires positives") else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let groups :: [[(Bool, Double)]]
groups = ((Bool, Double) -> (Bool, Double) -> Bool)
-> [(Bool, Double)] -> [[(Bool, Double)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(Bool, Double)
a (Bool, Double)
b -> (Bool, Double) -> Double
forall a b. (a, b) -> b
snd (Bool, Double)
a Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool, Double) -> Double
forall a b. (a, b) -> b
snd (Bool, Double)
b) (((Bool, Double) -> (Bool, Double) -> Ordering)
-> [(Bool, Double)] -> [(Bool, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Bool, Double)
a (Bool, Double)
b -> Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((Bool, Double) -> Double
forall a b. (a, b) -> b
snd (Bool, Double)
b) ((Bool, Double) -> Double
forall a b. (a, b) -> b
snd (Bool, Double)
a)) ([Bool] -> [Double] -> [(Bool, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
truth [Double]
scores))
        update :: (Int, Int, e, e, e) -> [(Bool, b)] -> (Int, Int, e, e, e)
update (Int
tp, Int
fp, e
oldRecall, e
oldPrecision, e
area) [(Bool, b)]
group =
            let tp' :: Int
tp' = Int
tp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Bool
True, b
_) <- [(Bool, b)]
group]
                fp' :: Int
fp' = Int
fp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Bool
False, b
_) <- [(Bool, b)]
group]
                recall :: e
recall = Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tp' e -> e -> e
forall a. Fractional a => a -> a -> a
/ Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
positives
                precision :: e
precision = Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tp' e -> e -> e
forall a. Fractional a => a -> a -> a
/ Int -> e
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
tp' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fp')
             in (Int
tp', Int
fp', e
recall, e
precision, e
area e -> e -> e
forall a. Num a => a -> a -> a
+ (e
recall e -> e -> e
forall a. Num a => a -> a -> a
- e
oldRecall) e -> e -> e
forall a. Num a => a -> a -> a
* (e
precision e -> e -> e
forall a. Num a => a -> a -> a
+ e
oldPrecision) e -> e -> e
forall a. Fractional a => a -> a -> a
/ e
2)
        (Int
_, Int
_, Double
_, Double
_, Double
auc) = ((Int, Int, Double, Double, Double)
 -> [(Bool, Double)] -> (Int, Int, Double, Double, Double))
-> (Int, Int, Double, Double, Double)
-> [[(Bool, Double)]]
-> (Int, Int, Double, Double, Double)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (Int, Int, Double, Double, Double)
-> [(Bool, Double)] -> (Int, Int, Double, Double, Double)
forall {e} {b}.
Fractional e =>
(Int, Int, e, e, e) -> [(Bool, b)] -> (Int, Int, e, e, e)
update (Int
0 :: Int, Int
0 :: Int, Double
0, Double
1, Double
0) [[(Bool, Double)]]
groups
    Double -> Either MathError Double
forall a b. b -> Either a b
Right Double
auc

-- | Exponentiate the negative mean true-token log probability; empty or positive log probabilities fail.
perplexity :: [Double] -> Either MathError Double
perplexity :: [Double] -> Either MathError Double
perplexity [Double]
logs = do
    [Double] -> Either MathError ()
finite [Double]
logs
    if [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
logs Bool -> Bool -> Bool
|| (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) [Double]
logs
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"perplexity requires nonpositive log probabilities")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let y :: Double
y = Double -> Double
forall a. Floating a => a -> a
exp (-[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
logs)) [Double]
logs))
    [Double] -> Either MathError ()
finite [Double
y]
    Double -> Either MathError Double
forall a b. b -> Either a b
Right Double
y

-- | Compare every [M,D] row with every [N,D] row using scale-safe unit vectors; zero vectors fail.
cosineSimilarityMatrix :: T.Tensor Double -> T.Tensor Double -> Either MathError (T.Tensor Double)
cosineSimilarityMatrix :: Tensor Double -> Tensor Double -> Either MathError (Tensor Double)
cosineSimilarityMatrix Tensor Double
a Tensor Double
b = do
    [Double] -> Either MathError ()
finite (Tensor Double -> [Double]
forall a. Tensor a -> [a]
T.tensorValues Tensor Double
a [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ Tensor Double -> [Double]
forall a. Tensor a -> [a]
T.tensorValues Tensor Double
b)
    case (Tensor Double -> [Int]
forall a. Tensor a -> [Int]
T.tensorShape Tensor Double
a, Tensor Double -> [Int]
forall a. Tensor a -> [Int]
T.tensorShape Tensor Double
b) of
        ([Int
m, Int
d], [Int
n, Int
e]) | Int
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
e Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
            let row :: Tensor a -> Int -> [a]
row Tensor a
t Int
i = [Tensor a -> [a]
forall a. Tensor a -> [a]
T.tensorValues Tensor a
t [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j) | Int
j <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
                normalize :: [b] -> Either MathError [b]
normalize [b]
xs =
                    let scale :: b
scale = [b] -> b
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map b -> b
forall a. Num a => a -> a
abs [b]
xs); unit :: [b]
unit = (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
scale) [b]
xs; norm :: b
norm = b -> b
forall a. Floating a => a -> a
sqrt ([b] -> b
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (\b
x -> b
x b -> b -> b
forall a. Num a => a -> a -> a
* b
x) [b]
unit))
                     in if b
scale b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== b
0 then MathError -> Either MathError [b]
forall a b. a -> Either a b
Left (String -> MathError
DomainError String
"cosine similarity zero vector") else [b] -> Either MathError [b]
forall a b. b -> Either a b
Right ((b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
norm) [b]
unit)
            ar <- (Int -> Either MathError [Double])
-> [Int] -> Either MathError [[Double]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([Double] -> Either MathError [Double]
forall {b}. (Ord b, Floating b) => [b] -> Either MathError [b]
normalize ([Double] -> Either MathError [Double])
-> (Int -> [Double]) -> Int -> Either MathError [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tensor Double -> Int -> [Double]
forall {a}. Tensor a -> Int -> [a]
row Tensor Double
a) [Int
0 .. Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            br <- mapM (normalize . row b) [0 .. n - 1]
            T.tensor [m, n] [sum (zipWith (*) x y) | x <- ar, y <- br]
        ([Int], [Int])
_ -> MathError -> Either MathError (Tensor Double)
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"cosine matrix expects [M,D],[N,D]")

-- | Mean hinge on signed (+/-1) pair ordering with a nonnegative finite margin.
marginRankingLoss :: Double -> [Double] -> [Double] -> [Double] -> Either MathError Double
marginRankingLoss :: Double
-> [Double] -> [Double] -> [Double] -> Either MathError Double
marginRankingLoss Double
margin [Double]
labels [Double]
left [Double]
right = do
    [Double] -> Either MathError ()
finite (Double
margin Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
labels [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double]
left [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double]
right)
    if Double
margin Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0
        Bool -> Bool -> Bool
|| [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
labels
        Bool -> Bool -> Bool
|| [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
labels Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
left
        Bool -> Bool -> Bool
|| [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
labels Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
right
        Bool -> Bool -> Bool
|| (Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Double
y -> Double -> Double
forall a. Num a => a -> a
abs Double
y Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
1) [Double]
labels
        then MathError -> Either MathError ()
forall a b. a -> Either a b
Left (String -> MathError
InvalidArgument String
"margin ranking labels/shapes/margin")
        else () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let value :: Double
value =
            [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Double -> Double -> Double -> Double)
-> [Double] -> [Double] -> [Double] -> [Double]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (\Double
y Double
a Double
b -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
margin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
a Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b))) [Double]
labels [Double]
left [Double]
right)
                Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
labels)
    [Double] -> Either MathError ()
finite [Double
value]
    Double -> Either MathError Double
forall a b. b -> Either a b
Right Double
value