Remove some warnings

This commit is contained in:
Filip Gralinski 2022-01-22 16:42:52 +01:00
parent dbe4783d3c
commit a7e731a0f8
2 changed files with 20 additions and 27 deletions

View File

@ -5,14 +5,10 @@ module GEval.Clippings
import Data.Attoparsec.Text import Data.Attoparsec.Text
import Data.Text import Data.Text
import Control.Applicative
import Control.Exception
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.List (unfoldr) import Data.List (unfoldr)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Debug.Trace
import GEval.Common import GEval.Common
import GEval.PrecisionRecall (maxMatch) import GEval.PrecisionRecall (maxMatch)
@ -49,7 +45,7 @@ lineClippingsParser = sepByWhitespaces clippingParser
clippingParser :: Parser Clipping clippingParser :: Parser Clipping
clippingParser = do clippingParser = do
pageNo <- PageNumber <$> decimal pageNo <- PageNumber <$> decimal
char '/' _ <- char '/'
rectangle <- rectangleParser rectangle <- rectangleParser
return $ Clipping pageNo rectangle return $ Clipping pageNo rectangle
@ -59,9 +55,9 @@ lineClippingSpecsParser = sepByWhitespaces clippingSpecParser
clippingSpecParser :: Parser ClippingSpec clippingSpecParser :: Parser ClippingSpec
clippingSpecParser = do clippingSpecParser = do
pageNo <- PageNumber <$> decimal pageNo <- PageNumber <$> decimal
char '/' _ <- char '/'
rectangle <- rectangleParser rectangle <- rectangleParser
char '/' _ <- char '/'
margin <- decimal margin <- decimal
return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle) return $ ClippingSpec pageNo (smallerRectangle margin rectangle) (extendedRectangle margin rectangle)
@ -73,7 +69,7 @@ labeledClippingParser =
clippingWithLabelParser :: Parser LabeledClipping clippingWithLabelParser :: Parser LabeledClipping
clippingWithLabelParser = do clippingWithLabelParser = do
label <- takeWhile1 (\c -> not (isSpace c) && c /= ':') label <- takeWhile1 (\c -> not (isSpace c) && c /= ':')
string ":" _ <- string ":"
clipping <- clippingParser clipping <- clippingParser
return $ LabeledClipping (Just label) clipping return $ LabeledClipping (Just label) clipping
@ -90,8 +86,7 @@ smallerRectangle margin (Rectangle (Point x0 y0) (Point x1 y1)) =
Rectangle (Point (x0 + margin) (y0 + margin)) Rectangle (Point (x0 + margin) (y0 + margin))
(Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin)) (Point (x1 `nonNegativeDiff` margin) (y1 `nonNegativeDiff` margin))
nonNegativeDiff :: (Ord p, Num p) => p -> p -> p
nonNegativeDiff x y nonNegativeDiff x y
| x < y = 0 | x < y = 0
| otherwise = x - y | otherwise = x - y
@ -99,11 +94,11 @@ nonNegativeDiff x y
rectangleParser :: Parser Rectangle rectangleParser :: Parser Rectangle
rectangleParser = do rectangleParser = do
x0 <- decimal x0 <- decimal
char ',' _ <- char ','
y0 <- decimal y0 <- decimal
char ',' _ <- char ','
x1 <- decimal x1 <- decimal
char ',' _ <- char ','
y1 <- decimal y1 <- decimal
if x1 < x0 || y1 < y0 if x1 < x0 || y1 < y0
then fail "wrong coordinates" then fail "wrong coordinates"
@ -128,7 +123,7 @@ coveredBy clippingsA clippingsB = sum
step ([], _) = Nothing step ([], _) = Nothing
step (firstA:restA, b) = Just (result, (newA ++ restA, newB)) step (firstA:restA, b) = Just (result, (newA ++ restA, newB))
where (result, newA, newB) = step' firstA b where (result, newA, newB) = step' firstA b
step' rectA [] = (Nothing, [], []) step' _ [] = (Nothing, [], [])
step' a (firstB:restB) = case partitionClippings a firstB of step' a (firstB:restB) = case partitionClippings a firstB of
Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB) Just (commonRect, leftoversA, leftoversB) -> (Just commonRect, leftoversA, leftoversB ++ restB)
Nothing -> let 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 (y1 + 1)) (Point x1 y1'),
Rectangle (Point x0' y0') (Point (x0 - 1) y1'), Rectangle (Point x0' y0') (Point (x0 - 1) y1'),
Rectangle (Point (x1 + 1) y0') (Point x1' 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, clippEUMatchStep (clippingSpecs, clippings) = (maxMatch matchClippingToSpec clippingSpecs clippings,
Prelude.length clippingSpecs, Prelude.length clippingSpecs,
Prelude.length clippings) Prelude.length clippings)

View File

@ -10,13 +10,10 @@ module GEval.PrecisionRecall(calculateMAPForOneResult,
countFragFolder, fMeasureOnSeparatedCounts, f1MeasureOnSeparatedCounts) countFragFolder, fMeasureOnSeparatedCounts, f1MeasureOnSeparatedCounts)
where where
import Debug.Trace
import GEval.Common import GEval.Common
import GEval.Probability import GEval.Probability
import Data.Graph.Inductive import Data.Graph.Inductive
import Data.Graph.Inductive.Query.MaxFlow
import Data.List (find, foldl', nub) import Data.List (find, foldl', nub)
@ -28,10 +25,10 @@ import qualified Data.HashMap.Strict as M
calculateMAPForOneResult :: (Eq a) => [a] -> [a] -> Double calculateMAPForOneResult :: (Eq a) => [a] -> [a] -> Double
calculateMAPForOneResult expected got = precisionSum / fromIntegral (length expected) calculateMAPForOneResult expected got = precisionSum / fromIntegral (length expected)
where (_::Int, _, precisionSum) = calculateMAPForOneResultCore expected (nub got) where (_::Int, _, precisionSum) = calculateMAPForOneResultCore expected (nub got)
calculateMAPForOneResultCore expected got = foldl' (oneMAPStep expected) (0, 0, 0.0) got calculateMAPForOneResultCore expected' got' = foldl' (oneMAPStep expected') (0, 0, 0.0) got'
oneMAPStep expected (gotCount, allCount, precisionSum) gotItem oneMAPStep expected' (gotCount, allCount, precisionSum') gotItem
| gotItem `elem` expected = (newGotCount, newAllCount, precisionSum + (newGotCount /. newAllCount)) | gotItem `elem` expected' = (newGotCount, newAllCount, precisionSum' + (newGotCount /. newAllCount))
| otherwise = (gotCount, newAllCount, precisionSum) | otherwise = (gotCount, newAllCount, precisionSum')
where newGotCount = gotCount + 1 where newGotCount = gotCount + 1
newAllCount = allCount + 1 newAllCount = allCount + 1
@ -53,7 +50,7 @@ fMeasure beta matchingFun expected got = weightedHarmonicMean beta p r
weightedHarmonicMean :: Double -> Double -> Double -> Double weightedHarmonicMean :: Double -> Double -> Double -> Double
weightedHarmonicMean beta x y = weightedHarmonicMean beta x y =
(1 + betaSquared) * x * y `safeDoubleDiv` (betaSquared * 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 :: ConvertibleToDouble n => (n, Int, Int) -> Double
f2MeasureOnCounts = fMeasureOnCounts 2.0 f2MeasureOnCounts = fMeasureOnCounts 2.0
@ -127,9 +124,9 @@ maxMatchOnOrdered laterThan expected got =
-- counting maximum match with maximum bipartite matching -- counting maximum match with maximum bipartite matching
-- (we build an auxiliary graph and do a max-flow on this) -- (we build an auxiliary graph and do a max-flow on this)
maxMatch :: (a -> b -> Bool) -> [a] -> [b] -> Int 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 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 :: (a -> b -> Bool) -> [a] -> [b] -> (LNode Int, LNode Int, Gr Int Int)
buildGraph matchFun expected got = (b, e, g) buildGraph matchFun expected got = (b, e, g)
@ -138,7 +135,7 @@ buildGraph matchFun expected got = (b, e, g)
run empty $ run empty $
do b <- insMapNodeM 0 do b <- insMapNodeM 0
e <- insMapNodeM 1 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 (\n -> (0, n, 1)) expectedIxs
insMapEdgesM $ map (\m -> (m, 1, 1)) gotIxs insMapEdgesM $ map (\m -> (m, 1, 1)) gotIxs
insMapEdgesM $ map (\(n,m) -> (n, m, 1)) insMapEdgesM $ map (\(n,m) -> (n, m, 1))
@ -172,7 +169,7 @@ getProbabilisticCounts (expected, got) = (results, (map getProbabilityAsDouble g
length expected) length expected)
where gotMass = sum $ map (\(i, j) -> (matchScore (expected !! (i - 1)) (got !! (j - 1))) * (getProbabilityAsDouble (got !! (j - 1)))) matching where gotMass = sum $ map (\(i, j) -> (matchScore (expected !! (i - 1)) (got !! (j - 1))) * (getProbabilityAsDouble (got !! (j - 1)))) matching
results = map findResult [1..(length got)] 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)) Just (i, _) -> matchScore (expected !! (i - 1)) (got !! (j - 1))
Nothing -> 0.0 Nothing -> 0.0
(matching, _) = weightedMaxMatching matchScore expected got (matching, _) = weightedMaxMatching matchScore expected got