module NLP.Concraft.Morphosyntax.Accuracy
(
Stats (..)
, accuracy
, weakLB
, weakUB
, strongLB
, strongUB
) where
import Prelude hiding (Word)
import Data.List (foldl')
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Tagset.Positional as P
import NLP.Concraft.Morphosyntax
import NLP.Concraft.Morphosyntax.Align
data Stats = Stats
{ good :: Int
, gold :: Int }
(.+.) :: Stats -> Stats -> Stats
Stats x y .+. Stats x' y' = Stats (x + x') (y + y')
accuracy :: Stats -> Double
accuracy s
= fromIntegral (good s)
/ fromIntegral (gold s)
weakLB :: Word w => P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> Stats
weakLB tagset ref other =
foldl' (.+.) (Stats 0 0) . map (uncurry stats) $ align ref other
where
stats [x] [y]
| S.null (xTags `S.intersection` yTags) = Stats 0 1
| otherwise = Stats 1 1
where
xTags = choice tagset x
yTags = choice tagset y
stats xs _ = Stats 0 (length xs)
strongLB :: Word w => P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> Stats
strongLB tagset ref other =
foldl' (.+.) (Stats 0 0) . map (uncurry stats) $ align ref other
where
stats [x] [y]
| xTags == yTags = Stats 1 1
| otherwise = Stats 0 1
where
xTags = choice tagset x
yTags = choice tagset y
stats xs _ = Stats 0 (length xs)
weakUB :: Word w => P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> Stats
weakUB tagset ref other =
foldl' (.+.) (Stats 0 0) . map (uncurry stats) $ align ref other
where
stats [x] [y]
| S.null (xTags `S.intersection` yTags) = Stats 0 1
| otherwise = Stats 1 1
where
xTags = choice tagset x
yTags = choice tagset y
stats xs _ = Stats (length xs) (length xs)
strongUB :: Word w => P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> Stats
strongUB tagset ref other =
foldl' (.+.) (Stats 0 0) . map (uncurry stats) $ align ref other
where
stats [x] [y]
| xTags == yTags = Stats 1 1
| otherwise = Stats 0 1
where
xTags = choice tagset x
yTags = choice tagset y
stats xs _ = Stats (length xs) (length xs)
choice :: P.Tagset -> Seg w P.Tag -> S.Set P.Tag
choice tagset = S.fromList . concatMap (P.expand tagset) . positive
positive :: Seg w t -> [t]
positive seg =
let xs = M.toList . unWMap . tags
in [x | (x, v) <- xs seg, v > 0]