diff --git a/src/GEval/Clippings.hs b/src/GEval/Clippings.hs index eb7c86a..fcdb5b2 100644 --- a/src/GEval/Clippings.hs +++ b/src/GEval/Clippings.hs @@ -5,14 +5,10 @@ module GEval.Clippings import Data.Attoparsec.Text import Data.Text -import Control.Applicative -import Control.Exception import Data.Char (isSpace) import Data.List (unfoldr) import Data.Maybe (catMaybes) -import Debug.Trace - import GEval.Common import GEval.PrecisionRecall (maxMatch) @@ -49,7 +45,7 @@ lineClippingsParser = sepByWhitespaces clippingParser clippingParser :: Parser Clipping clippingParser = do pageNo <- PageNumber <$> decimal - char '/' + _ <- char '/' rectangle <- rectangleParser return $ Clipping pageNo rectangle @@ -59,9 +55,9 @@ lineClippingSpecsParser = sepByWhitespaces clippingSpecParser clippingSpecParser :: Parser ClippingSpec clippingSpecParser = do pageNo <- PageNumber <$> decimal - char '/' + _ <- char '/' rectangle <- rectangleParser - char '/' + _ <- char '/' margin <- decimal return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle) @@ -73,7 +69,7 @@ labeledClippingParser = clippingWithLabelParser :: Parser LabeledClipping clippingWithLabelParser = do label <- takeWhile1 (\c -> not (isSpace c) && c /= ':') - string ":" + _ <- string ":" clipping <- clippingParser return $ LabeledClipping (Just label) clipping @@ -90,8 +86,7 @@ smallerRectangle margin (Rectangle (Point x0 y0) (Point x1 y1)) = Rectangle (Point (x0 + margin) (y0 + margin)) (Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin)) - - +nonNegativeDiff :: (Ord p, Num p) => p -> p -> p nonNegativeDiff x y | x < y = 0 | otherwise = x - y @@ -99,11 +94,11 @@ nonNegativeDiff x y rectangleParser :: Parser Rectangle rectangleParser = do x0 <- decimal - char ',' + _ <- char ',' y0 <- decimal - char ',' + _ <- char ',' x1 <- decimal - char ',' + _ <- char ',' y1 <- decimal if x1 < x0 || y1 < y0 then fail "wrong coordinates" @@ -128,7 +123,7 @@ coveredBy clippingsA clippingsB = sum step ([], _) = Nothing step (firstA:restA, b) = Just (result, (newA ++ restA, newB)) where (result, newA, newB) = step' firstA b - step' rectA [] = (Nothing, [], []) + step' _ [] = (Nothing, [], []) step' a (firstB:restB) = case partitionClippings a firstB of Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB) Nothing -> let @@ -160,8 +155,9 @@ getLeftovers (Rectangle (Point x0 y0) (Point x1 y1)) Rectangle (Point x0 (y1 + 1)) (Point x1 y1'), Rectangle (Point x0' y0') (Point (x0 - 1) y1'), Rectangle (Point (x1 + 1) y0') (Point x1' y1')] - where validRectangle (Rectangle (Point x0 y0) (Point x1 y1)) = x0 <= x1 && y0 <= y1 + where validRectangle (Rectangle (Point x0'' y0'') (Point x1'' y1'')) = x0'' <= x1'' && y0'' <= y1'' +clippEUMatchStep :: ([ClippingSpec], [Clipping]) -> (Int, Int, Int) clippEUMatchStep (clippingSpecs, clippings) = (maxMatch matchClippingToSpec clippingSpecs clippings, Prelude.length clippingSpecs, Prelude.length clippings) diff --git a/src/GEval/PrecisionRecall.hs b/src/GEval/PrecisionRecall.hs index a4e889e..245de95 100644 --- a/src/GEval/PrecisionRecall.hs +++ b/src/GEval/PrecisionRecall.hs @@ -10,13 +10,10 @@ module GEval.PrecisionRecall(calculateMAPForOneResult, countFragFolder, fMeasureOnSeparatedCounts, f1MeasureOnSeparatedCounts) where -import Debug.Trace - import GEval.Common import GEval.Probability import Data.Graph.Inductive -import Data.Graph.Inductive.Query.MaxFlow import Data.List (find, foldl', nub) @@ -28,10 +25,10 @@ import qualified Data.HashMap.Strict as M calculateMAPForOneResult :: (Eq a) => [a] -> [a] -> Double calculateMAPForOneResult expected got = precisionSum / fromIntegral (length expected) where (_::Int, _, precisionSum) = calculateMAPForOneResultCore expected (nub got) - calculateMAPForOneResultCore expected got = foldl' (oneMAPStep expected) (0, 0, 0.0) got - oneMAPStep expected (gotCount, allCount, precisionSum) gotItem - | gotItem `elem` expected = (newGotCount, newAllCount, precisionSum + (newGotCount /. newAllCount)) - | otherwise = (gotCount, newAllCount, precisionSum) + calculateMAPForOneResultCore expected' got' = foldl' (oneMAPStep expected') (0, 0, 0.0) got' + oneMAPStep expected' (gotCount, allCount, precisionSum') gotItem + | gotItem `elem` expected' = (newGotCount, newAllCount, precisionSum' + (newGotCount /. newAllCount)) + | otherwise = (gotCount, newAllCount, precisionSum') where newGotCount = gotCount + 1 newAllCount = allCount + 1 @@ -53,7 +50,7 @@ fMeasure beta matchingFun expected got = weightedHarmonicMean beta p r weightedHarmonicMean :: Double -> Double -> Double -> Double weightedHarmonicMean beta x y = (1 + betaSquared) * x * y `safeDoubleDiv` (betaSquared * x + y) - where betaSquared = beta ^ 2 + where betaSquared = beta ^ (2 :: Int) f2MeasureOnCounts :: ConvertibleToDouble n => (n, Int, Int) -> Double f2MeasureOnCounts = fMeasureOnCounts 2.0 @@ -127,9 +124,9 @@ maxMatchOnOrdered laterThan expected got = -- counting maximum match with maximum bipartite matching -- (we build an auxiliary graph and do a max-flow on this) maxMatch :: (a -> b -> Bool) -> [a] -> [b] -> Int -maxMatch matchFun expected got = mf +maxMatch matchFun expected got = mfVal where (b, e, g) = buildGraph matchFun expected got - mf = maxFlow g (fst b) (fst e) + mfVal = maxFlow g (fst b) (fst e) buildGraph :: (a -> b -> Bool) -> [a] -> [b] -> (LNode Int, LNode Int, Gr Int Int) buildGraph matchFun expected got = (b, e, g) @@ -138,7 +135,7 @@ buildGraph matchFun expected got = (b, e, g) run empty $ do b <- insMapNodeM 0 e <- insMapNodeM 1 - mapM insMapNodeM [2..1+(length expected)+(length got)] + _ <- mapM insMapNodeM [2..1+(length expected)+(length got)] insMapEdgesM $ map (\n -> (0, n, 1)) expectedIxs insMapEdgesM $ map (\m -> (m, 1, 1)) gotIxs insMapEdgesM $ map (\(n,m) -> (n, m, 1)) @@ -172,7 +169,7 @@ getProbabilisticCounts (expected, got) = (results, (map getProbabilityAsDouble g length expected) where gotMass = sum $ map (\(i, j) -> (matchScore (expected !! (i - 1)) (got !! (j - 1))) * (getProbabilityAsDouble (got !! (j - 1)))) matching results = map findResult [1..(length got)] - findResult j = case find (\(i, j') -> j' == j) $ matching of + findResult j = case find (\(_, j') -> j' == j) $ matching of Just (i, _) -> matchScore (expected !! (i - 1)) (got !! (j - 1)) Nothing -> 0.0 (matching, _) = weightedMaxMatching matchScore expected got