-- SPDX-License-Identifier: MPL-2.0

{- | Dense reference estimators. Every design includes an unpenalized intercept;
rows are observations. Fit diagnostics distinguish budget exhaustion from a
coefficient/residual convergence test. Gaussian-process classification uses
the logistic Laplace approximation, rather than exact Bayesian integration.
-}
module HMath.MachineLearning.Regression (
    Penalty (..),
    LinearModel,
    coefficients,
    fitLinear,
    predictLinear,
    polynomialFeatures,
    fitWeighted,
    fitRobust,
    BayesianLinear,
    fitBayesian,
    bayesianMean,
    bayesianCovariance,
    RecursiveLS,
    recursiveLS,
    updateRecursiveLS,
    recursiveCoefficients,
    GLMFamily (..),
    GLM,
    fitGLM,
    predictGLM,
    MultinomialModel,
    fitMultinomial,
    predictMultinomial,
    Kernel (..),
    kernel,
    SVM,
    fitSVM,
    decisionSVM,
    predictSVM,
    GaussianProcess,
    fitGaussianProcess,
    predictGaussianProcess,
    GPClassifier,
    fitGPClassifier,
    predictGPClassifier,
    BayesFamily (..),
    NaiveBayes,
    fitNaiveBayes,
    predictNaiveBayes,
    Discriminant,
    fitDiscriminant,
    predictDiscriminant,
) where

import Control.Monad (foldM)
import Data.List (nub, sort, sortOn, transpose)
import HMath.Error
import HMath.MachineLearning.Internal

-- | Minimize mean squared error divided by two plus L1 and/or squared L2 coefficient penalties.
data Penalty = Ordinary | Ridge Double | Lasso Double | ElasticNet Double Double deriving (Penalty -> Penalty -> Bool
(Penalty -> Penalty -> Bool)
-> (Penalty -> Penalty -> Bool) -> Eq Penalty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Penalty -> Penalty -> Bool
== :: Penalty -> Penalty -> Bool
$c/= :: Penalty -> Penalty -> Bool
/= :: Penalty -> Penalty -> Bool
Eq, Int -> Penalty -> ShowS
[Penalty] -> ShowS
Penalty -> String
(Int -> Penalty -> ShowS)
-> (Penalty -> String) -> ([Penalty] -> ShowS) -> Show Penalty
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Penalty -> ShowS
showsPrec :: Int -> Penalty -> ShowS
$cshow :: Penalty -> String
show :: Penalty -> String
$cshowList :: [Penalty] -> ShowS
showList :: [Penalty] -> ShowS
Show)

-- | Affine predictor; coefficient zero is the intercept and remaining coefficients follow feature order.
newtype LinearModel = LinearModel [Double] deriving (LinearModel -> LinearModel -> Bool
(LinearModel -> LinearModel -> Bool)
-> (LinearModel -> LinearModel -> Bool) -> Eq LinearModel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LinearModel -> LinearModel -> Bool
== :: LinearModel -> LinearModel -> Bool
$c/= :: LinearModel -> LinearModel -> Bool
/= :: LinearModel -> LinearModel -> Bool
Eq, Int -> LinearModel -> ShowS
[LinearModel] -> ShowS
LinearModel -> String
(Int -> LinearModel -> ShowS)
-> (LinearModel -> String)
-> ([LinearModel] -> ShowS)
-> Show LinearModel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LinearModel -> ShowS
showsPrec :: Int -> LinearModel -> ShowS
$cshow :: LinearModel -> String
show :: LinearModel -> String
$cshowList :: [LinearModel] -> ShowS
showList :: [LinearModel] -> ShowS
Show)

-- | Intercept followed by slopes in input feature order.
coefficients :: LinearModel -> [Double]
coefficients :: LinearModel -> [Double]
coefficients (LinearModel [Double]
b) = [Double]
b

-- | Predict one finite response per query row using the fitted intercept and slopes.
predictLinear :: LinearModel -> Dataset -> Either MathError [Double]
predictLinear :: LinearModel -> Dataset -> Either MathError [Double]
predictLinear (LinearModel [Double]
b) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Dataset
xs
    let ys :: [Double]
ys = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
dot [Double]
b ([Double] -> Double)
-> ([Double] -> [Double]) -> [Double] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:)) Dataset
xs
    [Double] -> Either MathError ()
checked [Double]
ys
    [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right [Double]
ys

penalties :: Penalty -> Either MathError (Double, Double)
penalties :: Penalty -> Either MathError (Double, Double)
penalties Penalty
p = do
    let (Double
l1, Double
l2) = case Penalty
p of Penalty
Ordinary -> (Double
0, Double
0); Ridge Double
x -> (Double
0, Double
x); Lasso Double
x -> (Double
x, Double
0); ElasticNet Double
x Double
y -> (Double
x, Double
y)
    Bool -> String -> Either MathError ()
require ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Double
x -> Double -> Bool
finite Double
x Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) [Double
l1, Double
l2]) String
"penalty must be finite and nonnegative"
    (Double, Double) -> Either MathError (Double, Double)
forall a b. b -> Either a b
Right (Double
l1, Double
l2)

-- | Fit affine least squares or coordinate-descent elastic net. Ordinary/ridge use an SVD minimum-norm solve; iterative residual is coefficient displacement.
fitLinear :: MLConfig -> Penalty -> Dataset -> [Double] -> Either MathError (Fit LinearModel)
fitLinear :: MLConfig
-> Penalty
-> Dataset
-> [Double]
-> Either MathError (Fit LinearModel)
fitLinear MLConfig
c Penalty
penalty Dataset
xs [Double]
ys = do
    MLConfig -> Either MathError ()
config MLConfig
c
    (n, d) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    (l1, l2) <- penalties penalty
    let design = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:) Dataset
xs; cols = Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
design; nf = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    if l1 == 0
        then do
            let augmented = Dataset
design Dataset -> Dataset -> Dataset
forall a. [a] -> [a] -> [a]
++ [[if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Double -> Double
forall a. Floating a => a -> a
sqrt (Double
nf Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
l2) else Double
0 | Int
j <- [Int
0 .. Int
d]] | Int
i <- [Int
1 .. Int
d], Double
l2 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0]
            b <- solveLS augmented (ys ++ replicate (if l2 > 0 then d else 0) 0)
            let residual =
                    [Double] -> Double
norm
                        [ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Dataset
design Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double] -> [Double] -> Double
dot (Dataset
design Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) [Double]
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
nf
                            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Double
l2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
b [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
                        | Int
j <- [Int
0 .. Int
d]
                        ]
            checked [residual]
            Right (Fit (LinearModel b) 1 residual (residual <= max 1e-8 (mlTolerance c)))
        else do
            let soft a
t a
z = a -> a
forall a. Num a => a -> a
signum a
z a -> a -> a
forall a. Num a => a -> a -> a
* a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a -> a
forall a. Num a => a -> a
abs a
z a -> a -> a
forall a. Num a => a -> a -> a
- a
t)
                sweep [Double]
b =
                    ([Double] -> Int -> Either MathError [Double])
-> [Double] -> [Int] -> Either MathError [Double]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
                        ( \[Double]
old Int
j -> do
                            let col :: [Double]
col = Dataset
cols Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                partial :: [Double]
partial = ([Double] -> Double -> Double) -> Dataset -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Double]
r Double
y -> Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> [Double] -> Double
dot [Double]
r [Double]
old Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ([Double]
r [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j) Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double]
old [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)) Dataset
design [Double]
ys
                                rho :: Double
rho = [Double] -> [Double] -> Double
dot [Double]
col [Double]
partial Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
nf
                                denominator :: Double
denominator = [Double] -> [Double] -> Double
dot [Double]
col [Double]
col Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
nf Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Double
l2)
                                bnew :: Double
bnew = if Double
denominator Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0 then Double
0 else (if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
rho else Double -> Double -> Double
forall {a}. (Num a, Ord a) => a -> a -> a
soft Double
l1 Double
rho) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
denominator
                            [Double] -> Either MathError ()
checked [Double
bnew]
                            [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right (Int -> Double -> [Double] -> [Double]
forall a. Int -> a -> [a] -> [a]
replace Int
j Double
bnew [Double]
old)
                        )
                        [Double]
b
                        [Int
0 .. Int
d]
            fit <- iterateFit c sweep (\[Double]
a [Double]
b -> [Double] -> Double
norm ([Double] -> [Double] -> [Double]
sub [Double]
a [Double]
b)) (replicate (d + 1) 0)
            Right fit{fitted = LinearModel (fitted fit)}

-- | Build univariate columns x, x^2, ..., x^degree; the regression intercept supplies the constant.
polynomialFeatures :: Int -> [Double] -> Either MathError Dataset
polynomialFeatures :: Int -> [Double] -> Either MathError Dataset
polynomialFeatures Int
degree [Double]
xs = do
    Bool -> String -> Either MathError ()
require (Int
degree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
degree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10000) String
"polynomial degree must be in [1,10000]"
    [Double] -> Either MathError ()
checked [Double]
xs
    let ys :: Dataset
ys = [[Double
x Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
j | Int
j <- [Int
1 .. Int
degree]] | Double
x <- [Double]
xs]
    [Double] -> Either MathError ()
checked (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
ys)
    Dataset -> Either MathError Dataset
forall a b. b -> Either a b
Right Dataset
ys

-- | Fit affine least squares with nonnegative observation weights. Zero-weight rows contribute no error.
fitWeighted :: Dataset -> [Double] -> [Double] -> Either MathError LinearModel
fitWeighted :: Dataset -> [Double] -> [Double] -> Either MathError LinearModel
fitWeighted Dataset
xs [Double]
ys [Double]
weights = do
    (n, _) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require
        (length weights == n && all (\Double
w -> Double -> Bool
finite Double
w Bool -> Bool -> Bool
&& Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) weights && any (> 0) weights)
        "invalid observation weights"
    b <-
        solveLS
            (zipWith (\Double
w [Double]
r -> Double -> [Double] -> [Double]
scale (Double -> Double
forall a. Floating a => a -> a
sqrt Double
w) (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
r)) weights xs)
            (zipWith (\Double
w Double
y -> Double -> Double
forall a. Floating a => a -> a
sqrt Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y) weights ys)
    Right (LinearModel b)

-- | Huber IRLS with fixed positive residual threshold, including intercept.
fitRobust :: MLConfig -> Double -> Dataset -> [Double] -> Either MathError (Fit LinearModel)
fitRobust :: MLConfig
-> Double
-> Dataset
-> [Double]
-> Either MathError (Fit LinearModel)
fitRobust MLConfig
c Double
delta Dataset
xs [Double]
ys = do
    MLConfig -> Either MathError ()
config MLConfig
c
    Bool -> String -> Either MathError ()
require (Double -> Bool
finite Double
delta Bool -> Bool -> Bool
&& Double
delta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) String
"Huber threshold must be positive"
    _ <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    start <- fitWeighted xs ys (replicate (length ys) 1)
    iterateFit
        c
        ( \LinearModel
model -> do
            p <- LinearModel -> Dataset -> Either MathError [Double]
predictLinear LinearModel
model Dataset
xs
            fitWeighted xs ys [if abs r <= delta then 1 else delta / abs r | r <- sub ys p]
        )
        (\LinearModel
a LinearModel
b -> [Double] -> Double
norm ([Double] -> [Double] -> [Double]
sub (LinearModel -> [Double]
coefficients LinearModel
a) (LinearModel -> [Double]
coefficients LinearModel
b)))
        start

{- | Posterior-mean linear model together with coefficient covariance, returned by Bayesian
regression fitting.
-}
data BayesianLinear = BayesianLinear
    { BayesianLinear -> LinearModel
bayesianMean :: LinearModel
    -- ^ Posterior-mean fitted linear model.
    , BayesianLinear -> Dataset
bayesianCovariance :: Dataset
    -- ^ Posterior covariance matrix of linear coefficients.
    }
    deriving (BayesianLinear -> BayesianLinear -> Bool
(BayesianLinear -> BayesianLinear -> Bool)
-> (BayesianLinear -> BayesianLinear -> Bool) -> Eq BayesianLinear
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BayesianLinear -> BayesianLinear -> Bool
== :: BayesianLinear -> BayesianLinear -> Bool
$c/= :: BayesianLinear -> BayesianLinear -> Bool
/= :: BayesianLinear -> BayesianLinear -> Bool
Eq, Int -> BayesianLinear -> ShowS
[BayesianLinear] -> ShowS
BayesianLinear -> String
(Int -> BayesianLinear -> ShowS)
-> (BayesianLinear -> String)
-> ([BayesianLinear] -> ShowS)
-> Show BayesianLinear
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BayesianLinear -> ShowS
showsPrec :: Int -> BayesianLinear -> ShowS
$cshow :: BayesianLinear -> String
show :: BayesianLinear -> String
$cshowList :: [BayesianLinear] -> ShowS
showList :: [BayesianLinear] -> ShowS
Show)

{- | Isotropic zero-mean Gaussian prior, observation precision beta. Unlike
frequentist ridge the prior also regularizes the intercept.
-}
fitBayesian :: Double -> Double -> Dataset -> [Double] -> Either MathError BayesianLinear
fitBayesian :: Double
-> Double -> Dataset -> [Double] -> Either MathError BayesianLinear
fitBayesian Double
alpha Double
beta Dataset
xs [Double]
ys = do
    (_, d) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require (all (\Double
x -> Double -> Bool
finite Double
x Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) [alpha, beta]) "Bayesian precisions must be positive"
    let x = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:) Dataset
xs
        xt = Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
x
        gram = Dataset -> Dataset -> Dataset
matmul Dataset
xt Dataset
x
        precision = [[Double
beta Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Double
alpha else Double
0) | Int
j <- [Int
0 .. Int
d]] | Int
i <- [Int
0 .. Int
d]]
    covariance <- inverse precision
    let b = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` Double -> [Double] -> [Double]
scale Double
beta (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
ys) Dataset
xt)) Dataset
covariance
    checked b
    Right (BayesianLinear (LinearModel b) covariance)

-- | Owned online regression coefficients and inverse information, with fixed forgetting factor.
data RecursiveLS = RLS [Double] Dataset Double deriving (RecursiveLS -> RecursiveLS -> Bool
(RecursiveLS -> RecursiveLS -> Bool)
-> (RecursiveLS -> RecursiveLS -> Bool) -> Eq RecursiveLS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecursiveLS -> RecursiveLS -> Bool
== :: RecursiveLS -> RecursiveLS -> Bool
$c/= :: RecursiveLS -> RecursiveLS -> Bool
/= :: RecursiveLS -> RecursiveLS -> Bool
Eq, Int -> RecursiveLS -> ShowS
[RecursiveLS] -> ShowS
RecursiveLS -> String
(Int -> RecursiveLS -> ShowS)
-> (RecursiveLS -> String)
-> ([RecursiveLS] -> ShowS)
-> Show RecursiveLS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecursiveLS -> ShowS
showsPrec :: Int -> RecursiveLS -> ShowS
$cshow :: RecursiveLS -> String
show :: RecursiveLS -> String
$cshowList :: [RecursiveLS] -> ShowS
showList :: [RecursiveLS] -> ShowS
Show)

-- | Current intercept and slopes; updating creates a new state.
recursiveCoefficients :: RecursiveLS -> [Double]
recursiveCoefficients :: RecursiveLS -> [Double]
recursiveCoefficients (RLS [Double]
b Dataset
_ Double
_) = [Double]
b

{- | Initial inverse information delta I; forgetting factor in (0,1]. Input
dimension excludes the automatically supplied intercept.
-}
recursiveLS :: Int -> Double -> Double -> Either MathError RecursiveLS
recursiveLS :: Int -> Double -> Double -> Either MathError RecursiveLS
recursiveLS Int
d Double
delta Double
forgetting = do
    Bool -> String -> Either MathError ()
require
        ( Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
            Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100000
            Bool -> Bool -> Bool
&& Double -> Bool
finite Double
delta
            Bool -> Bool -> Bool
&& Double
delta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
            Bool -> Bool -> Bool
&& Double -> Bool
finite Double
forgetting
            Bool -> Bool -> Bool
&& Double
forgetting Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
            Bool -> Bool -> Bool
&& Double
forgetting Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1
        )
        String
"invalid recursive least-squares configuration"
    RecursiveLS -> Either MathError RecursiveLS
forall a b. b -> Either a b
Right ([Double] -> Dataset -> Double -> RecursiveLS
RLS (Int -> Double -> [Double]
forall a. Int -> a -> [a]
replicate (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double
0) (([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double -> [Double] -> [Double]
scale Double
delta) (Int -> Dataset
ident (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) Double
forgetting)

-- | Assimilate one feature row/response using the matrix inversion lemma. Reject lost definiteness.
updateRecursiveLS :: RecursiveLS -> [Double] -> Double -> Either MathError RecursiveLS
updateRecursiveLS :: RecursiveLS -> [Double] -> Double -> Either MathError RecursiveLS
updateRecursiveLS (RLS [Double]
b Dataset
p Double
forgetting) [Double]
row Double
y = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [[Double]
row]
    [Double] -> Either MathError ()
checked [Double
y]
    let x :: [Double]
x = Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
row; px :: [Double]
px = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
x) Dataset
p; denom :: Double
denom = Double
forgetting Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> [Double] -> Double
dot [Double]
x [Double]
px
    Bool -> String -> Either MathError ()
require (Double
denom Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double -> Bool
finite Double
denom) String
"recursive information matrix lost definiteness"
    let gain :: [Double]
gain = Double -> [Double] -> [Double]
scale (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
denom) [Double]
px
        b' :: [Double]
b' = [Double] -> [Double] -> [Double]
add [Double]
b (Double -> [Double] -> [Double]
scale (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> [Double] -> Double
dot [Double]
b [Double]
x) [Double]
gain)
        xp :: [Double]
xp = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
dot [Double]
x) (Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
p)
        p' :: Dataset
p' =
            [ [((Dataset
p Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j) Double -> Double -> Double
forall a. Num a => a -> a -> a
- ([Double]
gain [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double]
xp [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forgetting | Int
j <- [Int
0 .. [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
            | Int
i <- [Int
0 .. [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            ]
    [Double] -> Either MathError ()
checked ([Double]
b' [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
p')
    RecursiveLS -> Either MathError RecursiveLS
forall a b. b -> Either a b
Right ([Double] -> Dataset -> Double -> RecursiveLS
RLS [Double]
b' Dataset
p' Double
forgetting)

-- | Bernoulli mean with logistic link, or nonnegative response mean with log link.
data GLMFamily = BinomialLogit | PoissonLog deriving (GLMFamily -> GLMFamily -> Bool
(GLMFamily -> GLMFamily -> Bool)
-> (GLMFamily -> GLMFamily -> Bool) -> Eq GLMFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GLMFamily -> GLMFamily -> Bool
== :: GLMFamily -> GLMFamily -> Bool
$c/= :: GLMFamily -> GLMFamily -> Bool
/= :: GLMFamily -> GLMFamily -> Bool
Eq, Int -> GLMFamily -> ShowS
[GLMFamily] -> ShowS
GLMFamily -> String
(Int -> GLMFamily -> ShowS)
-> (GLMFamily -> String)
-> ([GLMFamily] -> ShowS)
-> Show GLMFamily
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GLMFamily -> ShowS
showsPrec :: Int -> GLMFamily -> ShowS
$cshow :: GLMFamily -> String
show :: GLMFamily -> String
$cshowList :: [GLMFamily] -> ShowS
showList :: [GLMFamily] -> ShowS
Show)

-- | Fitted generalized linear model with intercept and family-specific inverse link.
data GLM = GLM GLMFamily [Double] deriving (GLM -> GLM -> Bool
(GLM -> GLM -> Bool) -> (GLM -> GLM -> Bool) -> Eq GLM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GLM -> GLM -> Bool
== :: GLM -> GLM -> Bool
$c/= :: GLM -> GLM -> Bool
/= :: GLM -> GLM -> Bool
Eq, Int -> GLM -> ShowS
[GLM] -> ShowS
GLM -> String
(Int -> GLM -> ShowS)
-> (GLM -> String) -> ([GLM] -> ShowS) -> Show GLM
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GLM -> ShowS
showsPrec :: Int -> GLM -> ShowS
$cshow :: GLM -> String
show :: GLM -> String
$cshowList :: [GLM] -> ShowS
showList :: [GLM] -> ShowS
Show)

sigmoid :: Double -> Double
sigmoid :: Double -> Double
sigmoid Double
x | Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Floating a => a -> a
exp (-Double
x)) | Bool
otherwise = let e :: Double
e = Double -> Double
forall a. Floating a => a -> a
exp Double
x in Double
e Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
e)

-- | Damped Newton/IRLS with nonnegative slope ridge. Residual is the penalized likelihood gradient norm.
fitGLM :: MLConfig -> GLMFamily -> Double -> Dataset -> [Double] -> Either MathError (Fit GLM)
fitGLM :: MLConfig
-> GLMFamily
-> Double
-> Dataset
-> [Double]
-> Either MathError (Fit GLM)
fitGLM MLConfig
c GLMFamily
family Double
ridge Dataset
xs [Double]
ys = do
    MLConfig -> Either MathError ()
config MLConfig
c
    (_, d) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require (finite ridge && ridge >= 0) "invalid GLM ridge"
    require
        (all (\Double
y -> case GLMFamily
family of GLMFamily
BinomialLogit -> Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1; GLMFamily
PoissonLog -> Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) ys)
        "GLM response outside support"
    let x = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:) Dataset
xs
        n = 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]
ys)
        evaluate [Double]
b = do
            let eta :: [Double]
eta = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
b) Dataset
x
                means :: [Double]
means = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
z -> case GLMFamily
family of GLMFamily
BinomialLogit -> Double -> Double
sigmoid Double
z; GLMFamily
PoissonLog -> Double -> Double
forall a. Floating a => a -> a
exp Double
z) [Double]
eta
                log1exp :: a -> a
log1exp a
z = if a
z a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then a
z a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Floating a => a -> a
log (a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Floating a => a -> a
exp (-a
z)) else a -> a
forall a. Floating a => a -> a
log (a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a. Floating a => a -> a
exp a
z)
                loss :: Double
loss =
                    [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]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                            (\Double
z Double
y -> case GLMFamily
family of GLMFamily
BinomialLogit -> Double -> Double
forall {a}. (Ord a, Floating a) => a -> a
log1exp Double
z Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
z; GLMFamily
PoissonLog -> Double -> Double
forall a. Floating a => a -> a
exp Double
z Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
z)
                            [Double]
eta
                            [Double]
ys
                        )
                        Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n
                        Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ridge Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> [Double] -> Double
dot (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
drop Int
1 [Double]
b) (Int -> [Double] -> [Double]
forall a. Int -> [a] -> [a]
drop Int
1 [Double]
b) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
                grad :: [Double]
grad =
                    [ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Double] -> Double -> Double) -> Dataset -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Double]
r Double
e -> [Double]
r [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
e) Dataset
x ([Double] -> [Double] -> [Double]
sub [Double]
means [Double]
ys)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Double
ridge Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
b [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
                    | Int
j <- [Int
0 .. Int
d]
                    ]
                weights :: [Double]
weights = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
mu -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1e-12 (case GLMFamily
family of GLMFamily
BinomialLogit -> Double
mu Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
mu); GLMFamily
PoissonLog -> Double
mu)) [Double]
means
                h :: Dataset
h =
                    [ [ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([Double] -> Double -> Double) -> Dataset -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Double]
r Double
w -> Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
r [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
r [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j) Dataset
x [Double]
weights) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Double
ridge else Double
0)
                      | Int
j <- [Int
0 .. Int
d]
                      ]
                    | Int
i <- [Int
0 .. Int
d]
                    ]
            [Double] -> Either MathError ()
checked (Double
loss Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
grad [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
h)
            (Double, [Double], Dataset)
-> Either MathError (Double, [Double], Dataset)
forall a b. b -> Either a b
Right (Double
loss, [Double]
grad, Dataset
h)
        go Int
k [Double]
b = do
            (loss, g, h) <- [Double] -> Either MathError (Double, [Double], Dataset)
evaluate [Double]
b
            let residual = [Double] -> Double
norm [Double]
g
            if residual <= mlTolerance c || k >= mlIterations c
                then Right (Fit (GLM family b) k residual (residual <= mlTolerance c))
                else do
                    direction <- solveLS h g
                    let line Int
j Double
step
                            | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
40 = MathError -> Either MathError [Double]
forall a b. a -> Either a b
Left (String -> Int -> MathError
NonConvergence String
"GLM line search" Int
j)
                            | Bool
otherwise = do
                                let trial :: [Double]
trial = [Double] -> [Double] -> [Double]
sub [Double]
b (Double -> [Double] -> [Double]
scale Double
step [Double]
direction)
                                (v, _, _) <- [Double] -> Either MathError (Double, [Double], Dataset)
evaluate [Double]
trial
                                if v <= loss - 1e-4 * step * dot g direction then Right trial else line (j + 1) (step / 2)
                    next <- line (0 :: Int) 1
                    go (k + 1) next
    go 0 (replicate (d + 1) 0)

-- | Return conditional means: probabilities for BinomialLogit, positive rates for PoissonLog.
predictGLM :: GLM -> Dataset -> Either MathError [Double]
predictGLM :: GLM -> Dataset -> Either MathError [Double]
predictGLM (GLM GLMFamily
family [Double]
b) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Dataset
xs
    let answer :: [Double]
answer =
            ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map
                (\[Double]
r -> case GLMFamily
family of GLMFamily
BinomialLogit -> Double -> Double
sigmoid ([Double] -> [Double] -> Double
dot [Double]
b (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
r)); GLMFamily
PoissonLog -> Double -> Double
forall a. Floating a => a -> a
exp ([Double] -> [Double] -> Double
dot [Double]
b (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
r)))
                Dataset
xs
    [Double] -> Either MathError ()
checked [Double]
answer
    [Double] -> Either MathError [Double]
forall a b. b -> Either a b
Right [Double]
answer

-- | Softmax class weights and sorted original integer labels.
data MultinomialModel = MultinomialModel [Int] Dataset deriving (MultinomialModel -> MultinomialModel -> Bool
(MultinomialModel -> MultinomialModel -> Bool)
-> (MultinomialModel -> MultinomialModel -> Bool)
-> Eq MultinomialModel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultinomialModel -> MultinomialModel -> Bool
== :: MultinomialModel -> MultinomialModel -> Bool
$c/= :: MultinomialModel -> MultinomialModel -> Bool
/= :: MultinomialModel -> MultinomialModel -> Bool
Eq, Int -> MultinomialModel -> ShowS
[MultinomialModel] -> ShowS
MultinomialModel -> String
(Int -> MultinomialModel -> ShowS)
-> (MultinomialModel -> String)
-> ([MultinomialModel] -> ShowS)
-> Show MultinomialModel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MultinomialModel -> ShowS
showsPrec :: Int -> MultinomialModel -> ShowS
$cshow :: MultinomialModel -> String
show :: MultinomialModel -> String
$cshowList :: [MultinomialModel] -> ShowS
showList :: [MultinomialModel] -> ShowS
Show)

softmax :: [Double] -> [Double]
softmax :: [Double] -> [Double]
softmax [Double]
xs = let m :: Double
m = [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Double]
xs; ex :: [Double]
ex = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double
forall a. Floating a => a -> a
exp (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Num a => a -> a -> a
subtract Double
m) [Double]
xs; s :: Double
s = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
ex in (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
s) [Double]
ex

-- | Fit all class logits by full-batch gradient descent with slope ridge. Residual is weight displacement.
fitMultinomial :: MLConfig -> Double -> Dataset -> [Int] -> Either MathError (Fit MultinomialModel)
fitMultinomial :: MLConfig
-> Double
-> Dataset
-> [Int]
-> Either MathError (Fit MultinomialModel)
fitMultinomial MLConfig
c Double
ridge Dataset
xs [Int]
labels = do
    MLConfig -> Either MathError ()
config MLConfig
c
    (n, d) <- Dataset -> Either MathError (Int, Int)
dataset Dataset
xs
    require (length labels == n && finite ridge && ridge >= 0) "invalid multinomial responses/ridge"
    let classes = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
labels); k = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
classes; design = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
:) Dataset
xs
    require (k >= 2) "multinomial regression needs two classes"
    let step Dataset
weights = do
            let probs :: Dataset
probs = [[Double] -> [Double]
softmax (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
r) Dataset
weights) | [Double]
r <- Dataset
design]
                grad :: Dataset
grad =
                    [ [ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                            [ (Dataset
probs Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- if [Int]
labels [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
classes [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! Int
j then Double
1 else Double
0) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
design Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
a
                            | Int
i <- [Int
0 .. Int
n 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
n
                            Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (if Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Double
0 else Double
ridge Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
weights Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
a)
                      | Int
a <- [Int
0 .. Int
d]
                      ]
                    | Int
j <- [Int
0 .. Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                    ]
                new :: Dataset
new = ([Double] -> [Double] -> [Double]) -> Dataset -> Dataset -> Dataset
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Double]
w [Double]
g -> [Double] -> [Double] -> [Double]
sub [Double]
w (Double -> [Double] -> [Double]
scale (MLConfig -> Double
mlRate MLConfig
c) [Double]
g)) Dataset
weights Dataset
grad
            [Double] -> Either MathError ()
checked (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
new)
            Dataset -> Either MathError Dataset
forall a b. b -> Either a b
Right Dataset
new
    fit <-
        iterateFit c step (\Dataset
a Dataset
b -> [Double] -> Double
norm (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Double] -> [Double] -> [Double]) -> Dataset -> Dataset -> Dataset
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Double] -> [Double] -> [Double]
sub Dataset
a Dataset
b))) (replicate k (replicate (d + 1) 0))
    Right fit{fitted = MultinomialModel classes (fitted fit)}

-- | Return sorted (original label, probability) pairs for each observation.
predictMultinomial :: MultinomialModel -> Dataset -> Either MathError [[(Int, Double)]]
predictMultinomial :: MultinomialModel -> Dataset -> Either MathError [[(Int, Double)]]
predictMultinomial (MultinomialModel [Int]
classes Dataset
weights) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dataset -> [Double]
forall a. [[a]] -> [a]
firstRow Dataset
weights) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Dataset
xs
    [[(Int, Double)]] -> Either MathError [[(Int, Double)]]
forall a b. b -> Either a b
Right [[Int] -> [Double] -> [(Int, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
classes ([Double] -> [Double]
softmax (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` (Double
1 Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
r)) Dataset
weights)) | [Double]
r <- Dataset
xs]

-- | Positive-semidefinite linear, polynomial, or Gaussian radial basis kernel parameters.
data Kernel = LinearKernel | PolynomialKernel Int Double Double | RBFKernel Double
    deriving (Kernel -> Kernel -> Bool
(Kernel -> Kernel -> Bool)
-> (Kernel -> Kernel -> Bool) -> Eq Kernel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Kernel -> Kernel -> Bool
== :: Kernel -> Kernel -> Bool
$c/= :: Kernel -> Kernel -> Bool
/= :: Kernel -> Kernel -> Bool
Eq, Int -> Kernel -> ShowS
[Kernel] -> ShowS
Kernel -> String
(Int -> Kernel -> ShowS)
-> (Kernel -> String) -> ([Kernel] -> ShowS) -> Show Kernel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Kernel -> ShowS
showsPrec :: Int -> Kernel -> ShowS
$cshow :: Kernel -> String
show :: Kernel -> String
$cshowList :: [Kernel] -> ShowS
showList :: [Kernel] -> ShowS
Show)

-- | Evaluate a checked PSD kernel on equal-length finite feature vectors.
kernel :: Kernel -> [Double] -> [Double] -> Either MathError Double
kernel :: Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x [Double]
y = do
    Bool -> String -> Either MathError ()
require ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
x 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]
y) String
"kernel feature mismatch"
    [Double] -> Either MathError ()
checked ([Double]
x [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [Double]
y)
    case Kernel
kind of
        RBFKernel Double
gamma -> Bool -> String -> Either MathError ()
require (Double -> Bool
finite Double
gamma Bool -> Bool -> Bool
&& Double
gamma Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) String
"RBF gamma must be positive"
        PolynomialKernel Int
degree Double
gamma Double
offset ->
            Bool -> String -> Either MathError ()
require
                (Int
degree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
degree Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1000 Bool -> Bool -> Bool
&& Double -> Bool
finite Double
gamma Bool -> Bool -> Bool
&& Double
gamma Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double -> Bool
finite Double
offset Bool -> Bool -> Bool
&& Double
offset Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0)
                String
"invalid PSD polynomial kernel"
        Kernel
_ -> () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let value :: Double
value = case Kernel
kind of
            Kernel
LinearKernel -> [Double] -> [Double] -> Double
dot [Double]
x [Double]
y
            RBFKernel Double
gamma -> Double -> Double
forall a. Floating a => a -> a
exp (-Double
gamma Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> [Double] -> Double
dist2 [Double]
x [Double]
y)
            PolynomialKernel Int
degree Double
gamma Double
offset -> (Double
gamma Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> [Double] -> Double
dot [Double]
x [Double]
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
offset) Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
degree
    [Double] -> Either MathError ()
checked [Double
value]
    Double -> Either MathError Double
forall a b. b -> Either a b
Right Double
value

-- | Binary kernel decision state, retaining original training observations and signed dual weights.
data SVM = SVM Kernel Dataset [Double] Double deriving (SVM -> SVM -> Bool
(SVM -> SVM -> Bool) -> (SVM -> SVM -> Bool) -> Eq SVM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SVM -> SVM -> Bool
== :: SVM -> SVM -> Bool
$c/= :: SVM -> SVM -> Bool
/= :: SVM -> SVM -> Bool
Eq, Int -> SVM -> ShowS
[SVM] -> ShowS
SVM -> String
(Int -> SVM -> ShowS)
-> (SVM -> String) -> ([SVM] -> ShowS) -> Show SVM
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SVM -> ShowS
showsPrec :: Int -> SVM -> ShowS
$cshow :: SVM -> String
show :: SVM -> String
$cshowList :: [SVM] -> ShowS
showList :: [SVM] -> ShowS
Show)

{- | Deterministic two-coordinate SMO for binary labels -1/+1. The reported
residual is the largest box-constrained dual KKT violation.
-}
fitSVM :: MLConfig -> Kernel -> Double -> Dataset -> [Double] -> Either MathError (Fit SVM)
fitSVM :: MLConfig
-> Kernel
-> Double
-> Dataset
-> [Double]
-> Either MathError (Fit SVM)
fitSVM MLConfig
c Kernel
kind Double
cost Dataset
xs [Double]
ys = do
    MLConfig -> Either MathError ()
config MLConfig
c
    (n, _) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require
        (n >= 2 && all (`elem` [-1, 1]) ys && (-1) `elem` ys && 1 `elem` ys && finite cost && cost > 0)
        "SVM needs both binary classes and positive C"
    gram <- traverse (\[Double]
x -> ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x) Dataset
xs) xs
    let decision [Double]
as Double
bias Int
i = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bias
        dual [Double]
as =
            [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
as
                Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.5
                    Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
        pair ([Double]
as, Double
bias) Int
i =
            let ei :: Double
ei = [Double] -> Double -> Int -> Double
decision [Double]
as Double
bias Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                violates :: Bool
violates =
                    ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ei Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< -MLConfig -> Double
mlTolerance MLConfig
c Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cost) Bool -> Bool -> Bool
|| ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ei Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> MLConfig -> Double
mlTolerance MLConfig
c Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0)
                candidates :: [Int]
candidates = (Int -> Double) -> [Int] -> [Int]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\Int
j -> Double -> Double
forall a. Num a => a -> a
negate (Double -> Double
forall a. Num a => a -> a
abs (Double
ei Double -> Double -> Double
forall a. Num a => a -> a -> a
- ([Double] -> Double -> Int -> Double
decision [Double]
as Double
bias Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)))) [Int
j | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i]
                -- A maximal-error candidate can be blocked by its box bounds.
                -- Continue through the remaining coordinates instead of stalling.
                attempt :: [Int] -> Either MathError ([Double], Double)
attempt [] = ([Double], Double) -> Either MathError ([Double], Double)
forall a b. b -> Either a b
Right ([Double]
as, Double
bias)
                attempt (Int
j : [Int]
rest) = do
                    let ej :: Double
ej = [Double] -> Double -> Int -> Double
decision [Double]
as Double
bias Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                        ai :: Double
ai = [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                        aj :: Double
aj = [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                        (Double
lo, Double
hi) =
                            if [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                then (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ai), Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
cost (Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ai))
                                else (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
ai Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
cost), Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
cost (Double
ai Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
aj))
                        eta :: Double
eta = Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                        withValue :: Double -> [Double]
withValue Double
value = Int -> Double -> [Double] -> [Double]
forall a. Int -> a -> [a] -> [a]
replace Int
i (Double
ai Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
value)) (Int -> Double -> [Double] -> [Double]
forall a. Int -> a -> [a] -> [a]
replace Int
j Double
value [Double]
as)
                        -- Coincident rows have zero curvature. Their dual is
                        -- linear along this feasible pair, so compare endpoints.
                        endpoint :: Double
endpoint = if [Double] -> Double
dual (Double -> [Double]
withValue Double
lo) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> [Double] -> Double
dual (Double -> [Double]
withValue Double
hi) then Double
lo else Double
hi
                        aj' :: Double
aj' = if Double
eta Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< -Double
1e-14 then Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
lo (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
hi (Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
ei Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ej) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
eta)) else Double
endpoint
                        ai' :: Double
ai' = Double
ai Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
aj Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aj')
                    if Double
lo Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
hi Bool -> Bool -> Bool
|| Double -> Double
forall a. Num a => a -> a
abs (Double
aj' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aj) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-14 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double -> Double
forall a. Num a => a -> a
abs Double
aj)
                        then [Int] -> Either MathError ([Double], Double)
attempt [Int]
rest
                        else do
                            let b1 :: Double
b1 = Double
bias Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ei Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
ai' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ai) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
aj' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aj) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                b2 :: Double
b2 = Double
bias Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ej Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
ai' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
ai) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
aj' Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aj) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Dataset
gram Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j
                                bias' :: Double
bias' = if Double
ai' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
ai' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cost then Double
b1 else if Double
aj' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&& Double
aj' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cost then Double
b2 else (Double
b1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b2) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
                                next :: [Double]
next = Double -> [Double]
withValue Double
aj'
                            [Double] -> Either MathError ()
checked (Double
bias' Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
next)
                            ([Double], Double) -> Either MathError ([Double], Double)
forall a b. b -> Either a b
Right ([Double]
next, Double
bias')
             in if Bool
violates then [Int] -> Either MathError ([Double], Double)
attempt [Int]
candidates else ([Double], Double) -> Either MathError ([Double], Double)
forall a b. b -> Either a b
Right ([Double]
as, Double
bias)
        recalibrate [Double]
as Double
oldBias =
            let raw :: Int -> Double
raw Int
i = [Double] -> Double -> Int -> Double
decision [Double]
as Double
0 Int
i
                free :: [Double]
free = [[Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
raw Int
i | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1], [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1e-10, [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-10]
                lower :: [Double]
lower =
                    [ [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
raw Int
i
                    | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                    , ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1 Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-10) Bool -> Bool -> Bool
|| ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== -Double
1 Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-10)
                    ]
                upper :: [Double]
upper =
                    [ [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- Int -> Double
raw Int
i
                    | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                    , ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== -Double
1 Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-10) Bool -> Bool -> Bool
|| ([Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
1 Bool -> Bool -> Bool
&& [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-10)
                    ]
             in if Bool -> Bool
not ([Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
free)
                    then [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
free 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]
free)
                    else
                        if [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
lower Bool -> Bool -> Bool
|| [Double] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
upper then Double
oldBias else [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Double]
lower Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Double]
upper Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
        residual [Double]
as Double
bias =
            [Double] -> Double
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum
                [ let margin :: Double
margin = [Double]
ys [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* [Double] -> Double -> Int -> Double
decision [Double]
as Double
bias Int
i
                   in if [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
1e-12
                        then Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
margin)
                        else if [Double]
as [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
cost Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1e-12 then 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
1) else Double -> Double
forall a. Num a => a -> a
abs (Double
margin Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1)
                | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                ]
        go Int
k [Double]
as Double
bias = do
            let r :: Double
r = [Double] -> Double -> Double
residual [Double]
as Double
bias
            if Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= MLConfig -> Double
mlTolerance MLConfig
c Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= MLConfig -> Int
mlIterations MLConfig
c
                then Fit SVM -> Either MathError (Fit SVM)
forall a b. b -> Either a b
Right (SVM -> Int -> Double -> Bool -> Fit SVM
forall a. a -> Int -> Double -> Bool -> Fit a
Fit (Kernel -> Dataset -> [Double] -> Double -> SVM
SVM Kernel
kind Dataset
xs ((Double -> Double -> Double) -> [Double] -> [Double] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) [Double]
as [Double]
ys) Double
bias) Int
k Double
r (Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= MLConfig -> Double
mlTolerance MLConfig
c))
                else do
                    (next, b) <- (([Double], Double) -> Int -> Either MathError ([Double], Double))
-> ([Double], Double)
-> [Int]
-> Either MathError ([Double], Double)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([Double], Double) -> Int -> Either MathError ([Double], Double)
pair ([Double]
as, Double
bias) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                    go (k + 1) next (recalibrate next b)
    go 0 (replicate n 0) 0

-- | Return signed kernel margins; zero is the fitted decision boundary.
decisionSVM :: SVM -> Dataset -> Either MathError [Double]
decisionSVM :: SVM -> Dataset -> Either MathError [Double]
decisionSVM (SVM Kernel
kind Dataset
train [Double]
weights Double
bias) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dataset -> [Double]
forall a. [[a]] -> [a]
firstRow Dataset
train)) Dataset
xs
    ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ( \[Double]
x -> do
            vals <- ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x) Dataset
train
            let v = [Double] -> [Double] -> Double
dot [Double]
weights [Double]
vals Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
bias
            checked [v]
            Right v
        )
        Dataset
xs

-- | Classify margins as -1 or +1, with zero assigned +1.
predictSVM :: SVM -> Dataset -> Either MathError [Double]
predictSVM :: SVM -> Dataset -> Either MathError [Double]
predictSVM SVM
model Dataset
xs = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
x -> if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 then Double
1 else -Double
1) ([Double] -> [Double])
-> Either MathError [Double] -> Either MathError [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SVM -> Dataset -> Either MathError [Double]
decisionSVM SVM
model Dataset
xs

-- | Zero-mean Gaussian-process regression posterior with retained training covariance solve.
data GaussianProcess = GP Kernel Dataset [Double] Dataset deriving (GaussianProcess -> GaussianProcess -> Bool
(GaussianProcess -> GaussianProcess -> Bool)
-> (GaussianProcess -> GaussianProcess -> Bool)
-> Eq GaussianProcess
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GaussianProcess -> GaussianProcess -> Bool
== :: GaussianProcess -> GaussianProcess -> Bool
$c/= :: GaussianProcess -> GaussianProcess -> Bool
/= :: GaussianProcess -> GaussianProcess -> Bool
Eq, Int -> GaussianProcess -> ShowS
[GaussianProcess] -> ShowS
GaussianProcess -> String
(Int -> GaussianProcess -> ShowS)
-> (GaussianProcess -> String)
-> ([GaussianProcess] -> ShowS)
-> Show GaussianProcess
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GaussianProcess -> ShowS
showsPrec :: Int -> GaussianProcess -> ShowS
$cshow :: GaussianProcess -> String
show :: GaussianProcess -> String
$cshowList :: [GaussianProcess] -> ShowS
showList :: [GaussianProcess] -> ShowS
Show)

-- | Fit a GP with strictly positive observation-noise variance and a checked PSD kernel.
fitGaussianProcess :: Kernel -> Double -> Dataset -> [Double] -> Either MathError GaussianProcess
fitGaussianProcess :: Kernel
-> Double
-> Dataset
-> [Double]
-> Either MathError GaussianProcess
fitGaussianProcess Kernel
kind Double
noise Dataset
xs [Double]
ys = do
    (n, _) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require (finite noise && noise > 0) "GP observation variance must be positive"
    k <- traverse (\[Double]
x -> ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x) Dataset
xs) xs
    inv <- inverse [[k !! i !! j + if i == j then noise else 0 | j <- [0 .. n - 1]] | i <- [0 .. n - 1]]
    let alpha = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
ys) Dataset
inv
    checked alpha
    Right (GP kind xs alpha inv)

-- | Return posterior latent-function (mean, variance), excluding observation noise.
predictGaussianProcess :: GaussianProcess -> Dataset -> Either MathError [(Double, Double)]
predictGaussianProcess :: GaussianProcess -> Dataset -> Either MathError [(Double, Double)]
predictGaussianProcess (GP Kernel
kind Dataset
train [Double]
alpha Dataset
inv) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dataset -> [Double]
forall a. [[a]] -> [a]
firstRow Dataset
train)) Dataset
xs
    ([Double] -> Either MathError (Double, Double))
-> Dataset -> Either MathError [(Double, Double)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ( \[Double]
x -> do
            kv <- ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x) Dataset
train
            kxx <- kernel kind x x
            let mu = [Double] -> [Double] -> Double
dot [Double]
kv [Double]
alpha; variance = Double
kxx Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> [Double] -> Double
dot [Double]
kv (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
kv) Dataset
inv)
            checked [mu, variance]
            require (variance >= -1e-7 * max 1 kxx) "GP negative posterior variance"
            Right (mu, max 0 variance)
        )
        Dataset
xs

-- | Logistic Gaussian-process classifier fitted with a Laplace Gaussian posterior approximation.
data GPClassifier = GPC Kernel Dataset [Double] Dataset deriving (GPClassifier -> GPClassifier -> Bool
(GPClassifier -> GPClassifier -> Bool)
-> (GPClassifier -> GPClassifier -> Bool) -> Eq GPClassifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GPClassifier -> GPClassifier -> Bool
== :: GPClassifier -> GPClassifier -> Bool
$c/= :: GPClassifier -> GPClassifier -> Bool
/= :: GPClassifier -> GPClassifier -> Bool
Eq, Int -> GPClassifier -> ShowS
[GPClassifier] -> ShowS
GPClassifier -> String
(Int -> GPClassifier -> ShowS)
-> (GPClassifier -> String)
-> ([GPClassifier] -> ShowS)
-> Show GPClassifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GPClassifier -> ShowS
showsPrec :: Int -> GPClassifier -> ShowS
$cshow :: GPClassifier -> String
show :: GPClassifier -> String
$cshowList :: [GPClassifier] -> ShowS
showList :: [GPClassifier] -> ShowS
Show)

-- | Newton mode fitting for 0/1 labels. A 1e-10 diagonal jitter stabilizes the prior covariance.
fitGPClassifier :: MLConfig -> Kernel -> Dataset -> [Double] -> Either MathError (Fit GPClassifier)
fitGPClassifier :: MLConfig
-> Kernel
-> Dataset
-> [Double]
-> Either MathError (Fit GPClassifier)
fitGPClassifier MLConfig
c Kernel
kind Dataset
xs [Double]
ys = do
    MLConfig -> Either MathError ()
config MLConfig
c
    (n, _) <- Dataset -> [Double] -> Either MathError (Int, Int)
responses Dataset
xs [Double]
ys
    require (all (`elem` [0, 1]) ys) "GP classification labels must be 0/1"
    gram <- traverse (\[Double]
x -> ([Double] -> Either MathError Double)
-> Dataset -> Either MathError [Double]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Kernel -> [Double] -> [Double] -> Either MathError Double
kernel Kernel
kind [Double]
x) Dataset
xs) xs
    ki <-
        inverse [[gram !! i !! j + if i == j then 1e-10 else 0 | j <- [0 .. n - 1]] | i <- [0 .. n - 1]]
    let step [Double]
f = do
            let p :: [Double]
p = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
sigmoid [Double]
f
                w :: [Double]
w = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
z -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1e-12 (Double
z Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
z))) [Double]
p
                h :: Dataset
h = [[Dataset
ki Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
+ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then [Double]
w [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i else Double
0 | Int
j <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
                g :: [Double]
g = [Double] -> [Double] -> [Double]
add (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
f) Dataset
ki) ([Double] -> [Double] -> [Double]
sub [Double]
p [Double]
ys)
            delta <- Dataset -> [Double] -> Either MathError [Double]
solveLS Dataset
h [Double]
g
            let new = [Double] -> [Double] -> [Double]
sub [Double]
f [Double]
delta
            checked new
            Right new
    fit <- iterateFit c step (\[Double]
a [Double]
b -> [Double] -> Double
norm ([Double] -> [Double] -> [Double]
sub [Double]
a [Double]
b)) (replicate n 0)
    let f = Fit [Double] -> [Double]
forall a. Fit a -> a
fitted Fit [Double]
fit; p = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
sigmoid [Double]
f; w = (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Double
z -> Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1e-12 (Double
z Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
z))) [Double]
p
    correction <-
        inverse
            [[gram !! i !! j + if i == j then 1 / (w !! i) else 0 | j <- [0 .. n - 1]] | i <- [0 .. n - 1]]
    Right fit{fitted = GPC kind xs (sub ys p) correction}

-- | Approximate class-one probabilities using the logistic Gaussian variance correction.
predictGPClassifier :: GPClassifier -> Dataset -> Either MathError [Double]
predictGPClassifier :: GPClassifier -> Dataset -> Either MathError [Double]
predictGPClassifier (GPC Kernel
kind Dataset
xs [Double]
alpha Dataset
correction) Dataset
queries' = do
    predictions <- GaussianProcess -> Dataset -> Either MathError [(Double, Double)]
predictGaussianProcess (Kernel -> Dataset -> [Double] -> Dataset -> GaussianProcess
GP Kernel
kind Dataset
xs [Double]
alpha Dataset
correction) Dataset
queries'
    Right [sigmoid (mu / sqrt (1 + pi * v / 8)) | (mu, v) <- predictions]

-- | Gaussian features, nonnegative multinomial counts, or binary Bernoulli features.
data BayesFamily = GaussianBayes | MultinomialBayes | BernoulliBayes deriving (BayesFamily -> BayesFamily -> Bool
(BayesFamily -> BayesFamily -> Bool)
-> (BayesFamily -> BayesFamily -> Bool) -> Eq BayesFamily
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BayesFamily -> BayesFamily -> Bool
== :: BayesFamily -> BayesFamily -> Bool
$c/= :: BayesFamily -> BayesFamily -> Bool
/= :: BayesFamily -> BayesFamily -> Bool
Eq, Int -> BayesFamily -> ShowS
[BayesFamily] -> ShowS
BayesFamily -> String
(Int -> BayesFamily -> ShowS)
-> (BayesFamily -> String)
-> ([BayesFamily] -> ShowS)
-> Show BayesFamily
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BayesFamily -> ShowS
showsPrec :: Int -> BayesFamily -> ShowS
$cshow :: BayesFamily -> String
show :: BayesFamily -> String
$cshowList :: [BayesFamily] -> ShowS
showList :: [BayesFamily] -> ShowS
Show)

-- | Fitted class priors and family-specific independent feature likelihoods.
data NaiveBayes = NB BayesFamily [Int] [Double] Dataset Dataset deriving (NaiveBayes -> NaiveBayes -> Bool
(NaiveBayes -> NaiveBayes -> Bool)
-> (NaiveBayes -> NaiveBayes -> Bool) -> Eq NaiveBayes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NaiveBayes -> NaiveBayes -> Bool
== :: NaiveBayes -> NaiveBayes -> Bool
$c/= :: NaiveBayes -> NaiveBayes -> Bool
/= :: NaiveBayes -> NaiveBayes -> Bool
Eq, Int -> NaiveBayes -> ShowS
[NaiveBayes] -> ShowS
NaiveBayes -> String
(Int -> NaiveBayes -> ShowS)
-> (NaiveBayes -> String)
-> ([NaiveBayes] -> ShowS)
-> Show NaiveBayes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NaiveBayes -> ShowS
showsPrec :: Int -> NaiveBayes -> ShowS
$cshow :: NaiveBayes -> String
show :: NaiveBayes -> String
$cshowList :: [NaiveBayes] -> ShowS
showList :: [NaiveBayes] -> ShowS
Show)

-- | Fit class likelihoods. Smoothing is a variance floor for Gaussian and a pseudocount otherwise.
fitNaiveBayes :: BayesFamily -> Double -> Dataset -> [Int] -> Either MathError NaiveBayes
fitNaiveBayes :: BayesFamily
-> Double -> Dataset -> [Int] -> Either MathError NaiveBayes
fitNaiveBayes BayesFamily
family Double
smoothing Dataset
xs [Int]
labels = do
    (n, _) <- Dataset -> Either MathError (Int, Int)
dataset Dataset
xs
    require
        (length labels == n && finite smoothing && smoothing > 0)
        "invalid naive Bayes responses/smoothing"
    case family of
        BayesFamily
MultinomialBayes -> Bool -> String -> Either MathError ()
require ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
xs)) String
"multinomial features must be nonnegative"
        BayesFamily
BernoulliBayes -> Bool -> String -> Either MathError ()
require ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> [Double] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Double
0, Double
1]) (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
xs)) String
"Bernoulli features must be binary"
        BayesFamily
_ -> () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let classes = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
labels)
        groups = [[[Double]
x | ([Double]
x, Int
y) <- Dataset -> [Int] -> [([Double], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip Dataset
xs [Int]
labels, Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c] | Int
c <- [Int]
classes]
        priors = (Dataset -> Double) -> [Dataset] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\Dataset
g -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dataset -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Dataset
g) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) [Dataset]
groups
        means = (Dataset -> [Double]) -> [Dataset] -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map Dataset -> [Double]
meanV [Dataset]
groups
        variances =
            [ ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map
                ( \[Double]
col ->
                    Double -> Double -> Double
forall a. Ord a => a -> a -> a
max
                        Double
smoothing
                        ([Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [(Double
v Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
col 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]
col)) Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
2 :: Int) | Double
v <- [Double]
col] 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]
col))
                )
                (Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
g)
            | Dataset
g <- [Dataset]
groups
            ]
        probs = case BayesFamily
family of
            BayesFamily
GaussianBayes -> Dataset
means
            BayesFamily
MultinomialBayes ->
                [ let counts :: [Double]
counts = ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
smoothing) (Double -> Double) -> ([Double] -> Double) -> [Double] -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum) (Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
g) in Double -> [Double] -> [Double]
scale (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
counts) [Double]
counts | Dataset
g <- [Dataset]
groups
                ]
            BayesFamily
BernoulliBayes ->
                [ ([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (\[Double]
col -> ([Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
col Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
smoothing) 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]
col) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
smoothing)) (Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
g)
                | Dataset
g <- [Dataset]
groups
                ]
    checked (priors ++ concat probs ++ concat variances)
    Right (NB family classes priors probs variances)

-- | Select the class with greatest log posterior; preserve the original integer labels.
predictNaiveBayes :: NaiveBayes -> Dataset -> Either MathError [Int]
predictNaiveBayes :: NaiveBayes -> Dataset -> Either MathError [Int]
predictNaiveBayes (NB BayesFamily
family [Int]
classes [Double]
priors Dataset
params Dataset
variances) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dataset -> [Double]
forall a. [[a]] -> [a]
firstRow Dataset
params)) Dataset
xs
    case BayesFamily
family of
        BayesFamily
MultinomialBayes -> Bool -> String -> Either MathError ()
require ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0) (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
xs)) String
"multinomial query must be nonnegative"
        BayesFamily
BernoulliBayes -> Bool -> String -> Either MathError ()
require ((Double -> Bool) -> [Double] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Double -> [Double] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Double
0, Double
1]) (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
xs)) String
"Bernoulli query must be binary"
        BayesFamily
_ -> () -> Either MathError ()
forall a b. b -> Either a b
Right ()
    let scores :: [Double] -> [Double]
scores [Double]
row =
            [ Double -> Double
forall a. Floating a => a -> a
log ([Double]
priors [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
                Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                    [ case BayesFamily
family of
                        BayesFamily
GaussianBayes ->
                            -Double
0.5
                                Double -> Double -> Double
forall a. Num a => a -> a -> a
* ( Double -> Double
forall a. Floating a => a -> a
log (Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
forall a. Floating a => a
pi Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Dataset
variances Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))
                                        Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ([Double]
row [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dataset
params Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
2 :: Int) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Dataset
variances Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
                                  )
                        BayesFamily
MultinomialBayes -> [Double]
row [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Dataset
params Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
                        BayesFamily
BernoulliBayes -> [Double]
row [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Dataset
params Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- [Double]
row [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Dataset
params Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
i)
                    | Int
i <- [Int
0 .. [Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
row Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
                    ]
            | Int
j <- [Int
0 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            ]
    let allScores :: Dataset
allScores = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map [Double] -> [Double]
scores Dataset
xs
    [Double] -> Either MathError ()
checked (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
allScores)
    [Int] -> Either MathError [Int]
forall a b. b -> Either a b
Right [[Int]
classes [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! [Double] -> Int
forall a. Ord a => [a] -> Int
argmax [Double]
s | [Double]
s <- Dataset
allScores]

-- | Class priors, means, and regularized inverse covariance/log-determinant state.
data Discriminant = Discriminant [Int] [Double] Dataset [Dataset] [Double] deriving (Discriminant -> Discriminant -> Bool
(Discriminant -> Discriminant -> Bool)
-> (Discriminant -> Discriminant -> Bool) -> Eq Discriminant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Discriminant -> Discriminant -> Bool
== :: Discriminant -> Discriminant -> Bool
$c/= :: Discriminant -> Discriminant -> Bool
/= :: Discriminant -> Discriminant -> Bool
Eq, Int -> Discriminant -> ShowS
[Discriminant] -> ShowS
Discriminant -> String
(Int -> Discriminant -> ShowS)
-> (Discriminant -> String)
-> ([Discriminant] -> ShowS)
-> Show Discriminant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Discriminant -> ShowS
showsPrec :: Int -> Discriminant -> ShowS
$cshow :: Discriminant -> String
show :: Discriminant -> String
$cshowList :: [Discriminant] -> ShowS
showList :: [Discriminant] -> ShowS
Show)

{- | False = pooled covariance LDA; True = class covariance QDA. A positive
diagonal ridge makes singular/constant-feature data explicitly regularized.
-}
fitDiscriminant :: Bool -> Double -> Dataset -> [Int] -> Either MathError Discriminant
fitDiscriminant :: Bool -> Double -> Dataset -> [Int] -> Either MathError Discriminant
fitDiscriminant Bool
quadratic Double
ridge Dataset
xs [Int]
labels = do
    (n, d) <- Dataset -> Either MathError (Int, Int)
dataset Dataset
xs
    require
        (n == length labels && finite ridge && ridge > 0)
        "discriminant needs labels/positive covariance ridge"
    let classes = [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort ([Int] -> [Int]
forall a. Eq a => [a] -> [a]
nub [Int]
labels)
        groups = [[[Double]
x | ([Double]
x, Int
y) <- Dataset -> [Int] -> [([Double], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip Dataset
xs [Int]
labels, Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c] | Int
c <- [Int]
classes]
        means = (Dataset -> [Double]) -> [Dataset] -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map Dataset -> [Double]
meanV [Dataset]
groups
        scatters =
            [ let centered :: Dataset
centered = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> [Double]
`sub` [Double]
mu) Dataset
g in Dataset -> Dataset -> Dataset
matmul (Dataset -> Dataset
forall a. [[a]] -> [[a]]
transpose Dataset
centered) Dataset
centered
            | (Dataset
g, [Double]
mu) <- [Dataset] -> Dataset -> [(Dataset, [Double])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Dataset]
groups Dataset
means
            ]
        pooled = [[[Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Dataset
s Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j | Dataset
s <- [Dataset]
scatters] Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n | Int
j <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] | Int
i <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
        covs =
            if Bool
quadratic
                then (Dataset -> Dataset -> Dataset)
-> [Dataset] -> [Dataset] -> [Dataset]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Dataset
g Dataset
s -> ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map (Double -> [Double] -> [Double]
scale (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dataset -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Dataset
g))) Dataset
s) [Dataset]
groups [Dataset]
scatters
                else Int -> Dataset -> [Dataset]
forall a. Int -> a -> [a]
replicate ([Dataset] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Dataset]
groups) Dataset
pooled
        regularized =
            [ [[Dataset
cov Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
i [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
+ if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j then Double
ridge else Double
0 | Int
j <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]] | Int
i <- [Int
0 .. Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
            | Dataset
cov <- [Dataset]
covs
            ]
    inverses <- traverse inverse regularized
    eigs <- traverse symmetricEigen regularized
    let logdets = (([Double], Dataset) -> Double)
-> [([Double], Dataset)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double)
-> (([Double], Dataset) -> [Double])
-> ([Double], Dataset)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Double
forall a. Floating a => a -> a
log ([Double] -> [Double])
-> (([Double], Dataset) -> [Double])
-> ([Double], Dataset)
-> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Double], Dataset) -> [Double]
forall a b. (a, b) -> a
fst) [([Double], Dataset)]
eigs
    checked logdets
    Right
        ( Discriminant
            classes
            (map (\Dataset
g -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dataset -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Dataset
g) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) groups)
            means
            inverses
            logdets
        )

-- | Classify with Gaussian discriminant log likelihoods using training covariance state.
predictDiscriminant :: Discriminant -> Dataset -> Either MathError [Int]
predictDiscriminant :: Discriminant -> Dataset -> Either MathError [Int]
predictDiscriminant (Discriminant [Int]
classes [Double]
priors Dataset
means [Dataset]
inverses [Double]
logdets) Dataset
xs = do
    Int -> Dataset -> Either MathError ()
queries ([Double] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Dataset -> [Double]
forall a. [[a]] -> [a]
firstRow Dataset
means)) Dataset
xs
    let scores :: [Double] -> [Double]
scores [Double]
row =
            [ let delta :: [Double]
delta = [Double] -> [Double] -> [Double]
sub [Double]
row (Dataset
means Dataset -> Int -> [Double]
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
               in Double -> Double
forall a. Floating a => a -> a
log ([Double]
priors [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j) Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* ([Double]
logdets [Double] -> Int -> Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
j Double -> Double -> Double
forall a. Num a => a -> a -> a
+ [Double] -> [Double] -> Double
dot [Double]
delta (([Double] -> Double) -> Dataset -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map ([Double] -> [Double] -> Double
`dot` [Double]
delta) ([Dataset]
inverses [Dataset] -> Int -> Dataset
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)))
            | Int
j <- [Int
0 .. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
classes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
            ]
        allScores :: Dataset
allScores = ([Double] -> [Double]) -> Dataset -> Dataset
forall a b. (a -> b) -> [a] -> [b]
map [Double] -> [Double]
scores Dataset
xs
    [Double] -> Either MathError ()
checked (Dataset -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Dataset
allScores)
    [Int] -> Either MathError [Int]
forall a b. b -> Either a b
Right [[Int]
classes [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! [Double] -> Int
forall a. Ord a => [a] -> Int
argmax [Double]
s | [Double]
s <- Dataset
allScores]