packages feed

smartGroup 0.2.1 → 0.3.0

raw patch · 3 files changed

+340/−84 lines, 3 filesdep +template-haskelldep −heap

Dependencies added: template-haskell

Dependencies removed: heap

Files

SmartGroup.hs view
@@ -1,91 +1,54 @@-{-# LANGUAGE TypeSynonymInstances #-}-module SmartGroup (Splittable(wordsOf), groupAll, groupNum, groupLog) where-import Data.Heap as Heap-import Data.Set as Set-import Data.Map as Map-import Data.Monoid+{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, MultiParamTypeClasses, FlexibleInstances #-}+module SmartGroup (Splittable(wordsOf), groupRoot, group1, smartGroup, notStopWord, Result(..)) where+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set) import Data.Char+import Data.List import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.Ord--class Ord a => Splittable a where wordsOf :: a -> [a]-instance Splittable String where wordsOf = Prelude.filter ((>3) . length) . words-instance Splittable L.ByteString where-         wordsOf = Prelude.filter ((>3) . L.length) . L.splitWith isSpace-instance Splittable S.ByteString where-         wordsOf = Prelude.filter ((>3) . S.length) . S.splitWith isSpace--data StringL a = StringL {str :: a, count :: Int} deriving (Eq, Show)-instance Ord a => Ord (StringL a) where compare (StringL i a) (StringL x b) = compare a b `mappend` compare i x-data SizeMap s a = Unsplittable (Set a) | Splittable (Map (StringL s) (Set a)) deriving (Eq, Show)-instance (Ord s, Ord a) => Ord (SizeMap s a) where-         compare (Splittable a) (Splittable b) = compare (Map.size a) (Map.size b)-         compare (Unsplittable a) (Unsplittable b) = compare a b-         compare (Unsplittable _) (Splittable _) = LT-         compare (Splittable _) (Unsplittable _) = GT-type WordAssoc s a = MaxHeap (SizeMap s a)--toSet (Unsplittable x) = x-toSet (Splittable x) = Set.unions (Map.elems x)+import Language.Haskell.TH.Syntax -intLog :: Int -> Int-intLog = truncate . logBase 2 . fromIntegral+data Doc a b = Doc {val :: b, wds :: [a], assoc :: (Map a Int), maxFreq :: Int}+data Result a b = Points (Map a [b]) | Subpoints (Map a (Result a b)) deriving Show -groupWith :: (Ord a, Splittable s) => (Int -> WordAssoc s a -> WordAssoc s a) -> Int -> (a -> s) -> [a] -> [[a]]-groupWith f i c = mkList . f i . mkAssoc . mkMap c+class (Ord b) => Splittable a b where wordsOf :: a -> [b]+instance Splittable String String where wordsOf = filter notStopWord . words+instance Splittable L.ByteString L.ByteString where wordsOf = filter (notStopWord . L.unpack) . L.splitWith isSpace+instance Splittable S.ByteString S.ByteString where wordsOf = filter (notStopWord . S.unpack) . S.splitWith isSpace --- | Divide list into as many groups as possible-groupAll :: (Ord a, Splittable s) => Int -> (a -> s) -> [a] -> [[a]]-groupAll = groupWith $ \i x->-         let cycleSplit n = case splitIt i n of-                  (Just a) -> cycleSplit a-                  Nothing -> n-         in cycleSplit x+-- | Test that the word is important to the document's meaning (not 'the', 'a', 'an', etc)+notStopWord :: String -> Bool+notStopWord = not . flip Set.member (Set.fromList $(runIO (readFile "stopWords") >>= (lift . words))) --- | Divide list into about n different groups-groupNum :: (Ord a, Splittable s) => Int -> Int -> (a -> s) -> [a] -> [[a]]-groupNum i = groupWith $ \x->-         let splitTimes n m =-                if Heap.size m >= n then m else-                   case splitIt x m of-                     (Just a) -> splitTimes n a-                     Nothing -> m-         in splitTimes i+-- | Groups a list of splittable items to a given breadth and depth+smartGroup :: (Splittable a b) => Int -> Int -> [a] -> Result b a+smartGroup _ _ [] = Points Map.empty+smartGroup maxSize maxDepth l = f maxDepth docList where+           docList = flip map l $ \x->+                   let w = wordsOf x+                       ass = foldl (flip $ Map.alter (return . maybe 1 (+1))) Map.empty w+                   in Doc x w ass (Map.fold (\x y-> if x>y then x else y) 0 ass)+           tf w (Doc{assoc = m, maxFreq=mf}) = fromIntegral (Map.findWithDefault 0 w m) / fromIntegral mf+           f mx a = if mx == 1 then Points (Map.map (map val) m) else Subpoints $ Map.map (f (mx-1)) m where+                  m = minGroups a Map.empty+                  docFreqs w = foldl (\x y->x + if Map.member w (assoc y) then 1 else 0) 0 a+                  idf w = let d = docFreqs w+                              len = genericLength a+                          in if d > 0 then logBase 2 $ len / (1 + (abs $ fromIntegral maxSize - (len / d))) else 0+                  getRank i j = tf j i * idf j+                  minGroups [] r = r+                  minGroups (x@(Doc{wds=ws}):ns) r =+                            minGroups ns (Map.alter (return . maybe [x] (x:)) (maximumBy (comparing (getRank x)) ws) r)  -- | Divide list into groups such that the amount of groups---   equals the log of the number of elements-groupLog :: (Ord a, Splittable s) => Int -> (a -> s) -> [a] -> [[a]]-groupLog i f s = groupNum (intLog (length s)) i f s--mkMap :: (Ord a, Splittable s) => (a -> s) -> [a] -> Map s (Set a)-mkMap f = foldl (\m x->-        foldl (\m' i-> Map.alter (Just . maybe (Set.singleton x) (Set.insert x)) i m')-        m (wordsOf $ f x)) Map.empty--mkAssoc :: (Ord a, Splittable s) => Map s (Set a) -> MaxHeap (SizeMap s a)-mkAssoc m = Heap.singleton . Splittable . Map.mapKeys (\k-> StringL k (Set.size (m Map.! k))) $ m--splitIt :: (Ord a, Splittable s) => Int -> WordAssoc s a -> Maybe (WordAssoc s a)-splitIt i s = case Heap.view s of-         Nothing -> Nothing-         (Just ((Unsplittable _),_)) -> Nothing-         (Just ((Splittable x),xs)) -> do-               (as,b) <- Map.maxView x-               x1 <- sizeMap i $ flip Map.mapMaybe b $ \n->-                      let m = Set.difference n as-                      in if Set.null m then Nothing else Just m-               x2 <- sizeMap i $ flip Map.mapMaybe b $ \n->-                      let m = Set.intersection n as-                      in if Set.null m then Nothing else Just m-               let x3 = as Set.\\ (Set.unions (Map.elems b))-               return $ (if Set.null x3 then id else Heap.insert (Unsplittable x3)) $-                   Heap.insert x1 $ Heap.insert x2 xs--sizeMap :: (Ord a, Splittable s) => Int -> (Map (StringL s) (Set a)) -> Maybe (SizeMap s a)-sizeMap i m = if Map.null m then Nothing else Just $ case Map.findMax m of-        (StringL _ c,_) -> if c >= i then Splittable m-                 else Unsplittable (Set.unions (Map.elems m))+--   resembles the square root of the number of elements+groupRoot :: (Splittable a b) => Int -> [a] -> Result b a+groupRoot d s = smartGroup (truncate $ sqrt $ fromIntegral (length s)) d s -mkList :: (Ord a, Splittable s) => WordAssoc s a -> [[a]]-mkList = Prelude.map (Set.toList . toSet) . Heap.toList+-- | Groups to the root of the number of elements using a depth of 1.+--   Elements are automatically extracted from the `Result`+group1 :: (Splittable a b) => [a] -> (Map b [a])+group1 l = let (Points m) = groupRoot 1 l in m
smartGroup.cabal view
@@ -7,10 +7,10 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.2.1+Version:             0.3.0  -- A short (one-line) description of the package.-Synopsis:            group strings by words in common+Synopsis:            group strings or bytestrings by words in common  -- A longer description of the package. Description:         Given a list of strings, smartGroup provides a set of functions@@ -41,7 +41,7 @@  -- Extra files to be distributed with the package, such as examples or -- a README.--- Extra-source-files:  +Extra-source-files:  stopwords  -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.2@@ -52,7 +52,7 @@   Exposed-modules:     SmartGroup      -- Packages needed in order to build this package.-  Build-depends:       base >= 3 && < 5, containers < 1, heap <= 1.1, bytestring < 1+  Build-depends:       base >= 3 && < 5, containers < 1, bytestring < 1, template-haskell < 3      -- Modules not exported by this package.   -- Other-modules:
+ stopwords view
@@ -0,0 +1,293 @@+a+about+above+after+again+against+all+am+an+and+any+are+aren't+as+at+be+because+been+before+being+below+between+both+but+by+can't+cannot+could+couldn't+did+didn't+do+does+doesn't+doing+don't+down+during+each+few+for+from+further+had+hadn't+has+hasn't+have+haven't+having+he+he'd+he'll+he's+her+here+here's+hers+herself+him+himself+his+how+how's+i+i'd+i'll+i'm+i've+if+in+into+is+isn't+it+it's+its+itself+let's+me+more+most+mustn't+my+myself+no+nor+not+of+off+on+once+only+or+other+ought+our+ours+ourselves+out+over+own+same+shan't+she+she'd+she'll+she's+should+shouldn't+so+some+such+than+that+that's+the+their+theirs+them+themselves+then+there+there's+these+they+they'd+they'll+they're+they've+this+those+through+to+too+under+until+up+very+was+wasn't+we+we'd+we'll+we're+we've+were+weren't+what+what's+when+when's+where+where's+which+while+who+who's+whom+why+why's+with+won't+would+wouldn't+you+you'd+you'll+you're+you've+your+yours+yourself+yourselves+a+able+about+across+after+all+almost+also+am+among+an+and+any+are+as+at+be+because+been+but+by+can+cannot+could+dear+did+do+does+either+else+ever+every+for+from+get+got+had+has+have+he+her+hers+him+his+how+however+i+if+in+into+is+it+its+just+least+let+like+likely+may+me+might+most+must+my+neither+no+nor+not+of+off+often+on+only+or+other+our+own+rather+said+say+says+she+should+since+so+some+than+that+the+their+them+then+there+these+they+this+tis+to+too+twas+us+wants+was+we+were+what+when+where+which+while+who+whom+why+will+with+would+yet+you+your