271 lines
11 KiB
Haskell
271 lines
11 KiB
Haskell
module GEval.Core
|
|
( geval,
|
|
gevalCore,
|
|
Metric(..),
|
|
MetricOrdering(..),
|
|
getMetricOrdering,
|
|
MetricValue,
|
|
GEvalSpecification(..),
|
|
GEvalOptions(..),
|
|
GEvalException(..),
|
|
defaultGEvalSpecification,
|
|
defaultOutDirectory,
|
|
defaultTestName,
|
|
defaultOutFile,
|
|
defaultExpectedFile,
|
|
defaultMetric,
|
|
getExpectedDirectory,
|
|
configFileName
|
|
) where
|
|
|
|
import Data.Conduit
|
|
import Data.Conduit.Combinators as CC
|
|
import qualified Data.Conduit.Binary as CB
|
|
import qualified Data.Conduit.Text as CT
|
|
import Control.Monad.Trans.Resource
|
|
import qualified Data.Conduit.List as CL
|
|
import Data.Text
|
|
import Data.Text.Read as TR
|
|
import Control.Applicative
|
|
import Control.Exception
|
|
import Control.Conditional (unlessM, whenM)
|
|
import qualified System.Directory as D
|
|
import System.Posix
|
|
import System.FilePath
|
|
import Data.Maybe
|
|
import qualified Data.List.Split as DLS
|
|
|
|
import Data.Attoparsec.Text (parseOnly)
|
|
|
|
import GEval.BLEU
|
|
import GEval.Common
|
|
import GEval.ClippEU
|
|
import GEval.PrecisionRecall
|
|
|
|
type MetricValue = Double
|
|
|
|
data Metric = RMSE | MSE | BLEU | Accuracy | ClippEU | FMeasure Double
|
|
deriving (Eq)
|
|
|
|
instance Show Metric where
|
|
show RMSE = "RMSE"
|
|
show MSE = "MSE"
|
|
show BLEU = "BLEU"
|
|
show Accuracy = "Accuracy"
|
|
show ClippEU = "ClippEU"
|
|
show (FMeasure beta) = "F" ++ (show beta)
|
|
|
|
instance Read Metric where
|
|
readsPrec _ ('R':'M':'S':'E':theRest) = [(RMSE, theRest)]
|
|
readsPrec _ ('M':'S':'E':theRest) = [(MSE, theRest)]
|
|
readsPrec _ ('B':'L':'E':'U':theRest) = [(BLEU, theRest)]
|
|
readsPrec _ ('A':'c':'c':'u':'r':'a':'c':'y':theRest) = [(Accuracy, theRest)]
|
|
readsPrec _ ('C':'l':'i':'p':'p':'E':'U':theRest) = [(ClippEU, theRest)]
|
|
readsPrec p ('F':theRest) = case readsPrec p theRest of
|
|
[(beta, theRest)] -> [(FMeasure beta, theRest)]
|
|
_ -> []
|
|
|
|
|
|
data MetricOrdering = TheLowerTheBetter | TheHigherTheBetter
|
|
|
|
getMetricOrdering :: Metric -> MetricOrdering
|
|
getMetricOrdering RMSE = TheLowerTheBetter
|
|
getMetricOrdering MSE = TheLowerTheBetter
|
|
getMetricOrdering BLEU = TheHigherTheBetter
|
|
getMetricOrdering Accuracy = TheHigherTheBetter
|
|
getMetricOrdering ClippEU = TheHigherTheBetter
|
|
getMetricOrdering (FMeasure _) = TheHigherTheBetter
|
|
|
|
defaultOutDirectory = "."
|
|
defaultTestName = "test-A"
|
|
defaultOutFile = "out.tsv"
|
|
defaultExpectedFile = "expected.tsv"
|
|
|
|
defaultMetric :: Metric
|
|
defaultMetric = RMSE
|
|
|
|
configFileName :: FilePath
|
|
configFileName = "config.txt"
|
|
|
|
data GEvalSpecification = GEvalSpecification
|
|
{ gesOutDirectory :: FilePath,
|
|
gesExpectedDirectory :: Maybe FilePath,
|
|
gesTestName :: String,
|
|
gesOutFile :: String,
|
|
gesExpectedFile :: String,
|
|
gesMetric :: Metric }
|
|
|
|
getExpectedDirectory :: GEvalSpecification -> FilePath
|
|
getExpectedDirectory spec = fromMaybe outDirectory $ gesExpectedDirectory spec
|
|
where outDirectory = gesOutDirectory spec
|
|
|
|
data GEvalOptions = GEvalOptions
|
|
{ geoInit :: Bool,
|
|
geoPrecision :: Maybe Int,
|
|
geoSpec :: GEvalSpecification }
|
|
|
|
|
|
data GEvalException = NoExpectedFile FilePath
|
|
| NoOutFile FilePath
|
|
| NoExpectedDirectory FilePath
|
|
| NoOutDirectory FilePath
|
|
| NoExpectedTestDirectory FilePath
|
|
| NoOutTestDirectory FilePath
|
|
| FileAlreadyThere FilePath
|
|
| TooFewLines
|
|
| TooManyLines
|
|
| EmptyOutput
|
|
| UnexpectedData String
|
|
deriving (Eq)
|
|
|
|
instance Exception GEvalException
|
|
|
|
instance Show GEvalException where
|
|
show (NoExpectedFile filePath) = somethingWrongWithFilesMessage "No file with the expected results" filePath
|
|
show (NoOutFile filePath) = somethingWrongWithFilesMessage "No file with the test results" filePath
|
|
show (NoExpectedDirectory filePath) = somethingWrongWithFilesMessage "No directory with the expected results" filePath
|
|
show (NoOutDirectory filePath) = somethingWrongWithFilesMessage "No directory with the test results" filePath
|
|
show (NoExpectedTestDirectory filePath) = somethingWrongWithFilesMessage "No test subdirectory with the expected results" filePath
|
|
show (NoOutTestDirectory filePath) = somethingWrongWithFilesMessage "No test subdirectory with the results obtained" filePath
|
|
show (FileAlreadyThere filePath) = somethingWrongWithFilesMessage "File already there" filePath
|
|
show TooFewLines = "Too few lines in the output file"
|
|
show TooManyLines = "Too many lines in the output file"
|
|
show EmptyOutput = "The output file is empty"
|
|
show (UnexpectedData message) = "Unexpected data [" ++ message ++ "]"
|
|
|
|
somethingWrongWithFilesMessage :: String -> FilePath -> String
|
|
somethingWrongWithFilesMessage msg filePath = Prelude.concat
|
|
[ msg, ": `", filePath, "`" ]
|
|
|
|
defaultGEvalSpecification = GEvalSpecification {
|
|
gesOutDirectory = defaultOutDirectory,
|
|
gesExpectedDirectory = Nothing,
|
|
gesTestName = defaultTestName,
|
|
gesOutFile = defaultOutFile,
|
|
gesExpectedFile = defaultExpectedFile,
|
|
gesMetric = defaultMetric }
|
|
|
|
isEmptyFile :: FilePath -> IO (Bool)
|
|
isEmptyFile path = do
|
|
stat <- getFileStatus path
|
|
return ((fileSize stat) == 0)
|
|
|
|
geval :: GEvalSpecification -> IO (MetricValue)
|
|
geval gevalSpec = do
|
|
unlessM (D.doesDirectoryExist outDirectory) $ throwM $ NoOutDirectory outDirectory
|
|
unlessM (D.doesDirectoryExist expectedDirectory) $ throwM $ NoExpectedDirectory expectedDirectory
|
|
unlessM (D.doesDirectoryExist outTestDirectory) $ throwM $ NoOutTestDirectory outTestDirectory
|
|
unlessM (D.doesDirectoryExist expectedTestDirectory) $ throwM $ NoExpectedTestDirectory expectedTestDirectory
|
|
gevalCore metric expectedFilePath outFilePath
|
|
where expectedFilePath = expectedTestDirectory </> (gesExpectedFile gevalSpec)
|
|
outFilePath = outTestDirectory </> (gesOutFile gevalSpec)
|
|
expectedTestDirectory = expectedDirectory </> testName
|
|
outTestDirectory = outDirectory </> testName
|
|
expectedDirectory = getExpectedDirectory gevalSpec
|
|
outDirectory = gesOutDirectory gevalSpec
|
|
testName = gesTestName gevalSpec
|
|
metric = gesMetric gevalSpec
|
|
|
|
gevalCore :: Metric -> String -> String -> IO (MetricValue)
|
|
gevalCore RMSE expectedFilePath outFilePath = do
|
|
mse <- gevalCore MSE expectedFilePath outFilePath
|
|
return $ mse ** 0.5
|
|
|
|
gevalCore metric expectedFilePath outFilePath = do
|
|
unlessM (D.doesFileExist expectedFilePath) $ throwM $ NoExpectedFile expectedFilePath
|
|
unlessM (D.doesFileExist outFilePath) $ throwM $ NoOutFile outFilePath
|
|
whenM (isEmptyFile outFilePath) $ throwM $ EmptyOutput
|
|
gevalCore' metric expectedFilePath outFilePath
|
|
|
|
gevalCore' :: Metric -> String -> String -> IO (MetricValue)
|
|
gevalCore' MSE = gevalCore'' outParser outParser itemError averageC id
|
|
where outParser = getValue . TR.double
|
|
|
|
gevalCore' BLEU = gevalCore'' (Prelude.map Prelude.words . DLS.splitOn "\t" . unpack) (Prelude.words . unpack) bleuCombine bleuAgg bleuFinal
|
|
where bleuFinal (p1, p2, p3, p4, rl, l1, l2, l3, l4) = ((p1 /. l1) * (p2 /. l2) * (p3 /. l3) * (p4 /. l4)) ** 0.25 * (brevityPenalty l1 rl)
|
|
bleuCombine (refs, sen) = bleuStep refs sen
|
|
bleuAgg = CC.foldl bleuFuse (0, 0, 0, 0, 0, 0, 0, 0, 0)
|
|
bleuFuse (a1, a2, a3, a4, a5, a6, a7, a8, a9) (b1, b2, b3, b4, b5, b6, b7, b8, b9) = (a1+b1, a2+b2, a3+b3, a4+b4, a5+b5, a6+b6, a7+b7, a8+b8, a9+b9)
|
|
brevityPenalty c r
|
|
| c >= r = 1.0
|
|
| otherwise = exp (1.0 - (r /. c))
|
|
|
|
gevalCore' Accuracy = gevalCore'' strip strip hitOrMiss averageC id
|
|
where hitOrMiss (x,y) = if x == y then 1.0 else 0.0
|
|
|
|
gevalCore' (FMeasure beta) = gevalCore'' outParser outParser getCount countAgg (fMeasureOnCounts beta)
|
|
where outParser = detected . getValue . TR.double
|
|
expParser = expected . getValue . TR.decimal
|
|
expected 1 = True
|
|
expected 0 = False
|
|
expected _ = throw $ UnexpectedData "expected 0 or 1"
|
|
-- output value could be a probability (for compatibility with other measures)
|
|
detected prob
|
|
| prob >= 0.0 && prob < detectionThreshold = False
|
|
| prob >= detectionThreshold && prob <= 1.0 = True
|
|
| otherwise = throw $ UnexpectedData "expected probability"
|
|
detectionThreshold = 0.5
|
|
getCount (True, True) = (1, 1, 1)
|
|
getCount (True, False) = (0, 1, 0)
|
|
getCount (False, True) = (0, 0, 1)
|
|
getCount (False, False) = (0, 0, 0)
|
|
countAgg = CC.foldl countFolder (0, 0, 0)
|
|
|
|
gevalCore' ClippEU = gevalCore'' parseClippingSpecs parseClippings matchStep clippeuAgg finalStep
|
|
where
|
|
parseClippings = controlledParse lineClippingsParser
|
|
parseClippingSpecs = controlledParse lineClippingSpecsParser
|
|
matchStep (clippingSpecs, clippings) = (maxMatch matchClippingToSpec clippingSpecs clippings,
|
|
Prelude.length clippingSpecs,
|
|
Prelude.length clippings)
|
|
clippeuAgg = CC.foldl countFolder (0, 0, 0)
|
|
finalStep counts = f2MeasureOnCounts counts
|
|
|
|
data SourceItem a = Got a | Done
|
|
|
|
gevalCore'' :: (Text -> a) -> (Text -> b) -> ((a, b) -> c) -> (Sink c (ResourceT IO) d) -> (d -> Double) -> String -> String -> IO (MetricValue)
|
|
gevalCore'' expParser outParser itemStep aggregator finalStep expectedFilePath outFilePath = do
|
|
v <- runResourceT $
|
|
(getZipSource $ (,)
|
|
<$> ZipSource (items expectedFilePath expParser)
|
|
<*> ZipSource (items outFilePath outParser))
|
|
$$ (CL.map (checkStep itemStep)
|
|
=$= CL.catMaybes
|
|
=$ aggregator)
|
|
return $ finalStep v
|
|
|
|
checkStep :: ((a, b) -> c) -> (SourceItem a, SourceItem b) -> Maybe c
|
|
checkStep step (Got expectedItem, Got outItem) = Just $ step (expectedItem, outItem)
|
|
checkStep _ (Got _, Done) = throw TooFewLines
|
|
checkStep _ (Done, Got _) = throw TooManyLines
|
|
checkStep _ (Done, Done) = Nothing
|
|
|
|
|
|
averageC :: MonadResource m => Sink Double m Double
|
|
averageC = getZipSink
|
|
$ (\total count -> total / fromIntegral count)
|
|
<$> ZipSink CC.sum
|
|
<*> ZipSink CC.length
|
|
|
|
items :: MonadResource m => String -> (Text -> a) -> Source m (SourceItem a)
|
|
items filePath parser =
|
|
(CB.sourceFile filePath
|
|
$= (CT.decode CT.utf8
|
|
=$= CT.lines
|
|
=$= CL.map ((\x -> Got x) . parser))) >> yield Done
|
|
|
|
itemError :: (Double, Double) -> Double
|
|
itemError (exp, out) = (exp-out)**2
|
|
|
|
getValue :: Num a => Either String (a, Text) -> a
|
|
getValue (Right (x, reminder)) =
|
|
if Data.Text.null reminder || Data.Text.head reminder == '\t'
|
|
then x
|
|
else throw $ UnexpectedData "number expected"
|
|
getValue (Left s) = throw $ UnexpectedData s
|
|
|
|
controlledParse parser t =
|
|
case parseOnly parser t of
|
|
(Right v) -> v
|
|
(Left _) -> throw $ UnexpectedData "cannot parse line"
|