Emping 0.5.1 → 0.6
raw patch · 29 files changed
+1255/−1152 lines, 29 filesbinary-added
Files
- Emping.cabal +16/−19
- HaskellM.png binary
- README +0/−28
- src/Abduce.hs +151/−157
- src/Aux.hs +0/−62
- src/CSVParse.hs +0/−74
- src/CSVTable.hs +0/−249
- src/Codec.hs +27/−60
- src/CsvParse.hs +73/−0
- src/CsvTable.hs +197/−0
- src/DefRules.hs +112/−0
- src/Main.hs +357/−330
- src/Reduce.hs +148/−173
- user_guide/default.css +104/−0
- user_guide/empug.html +70/−0
- user_guide/ugimg/abduce_bad.png binary
- user_guide/ugimg/abduce_bad_gr.png binary
- user_guide/ugimg/abduce_good.png binary
- user_guide/ugimg/abduce_good_gr.png binary
- user_guide/ugimg/ambig_temperature.png binary
- user_guide/ugimg/emping_end.png binary
- user_guide/ugimg/emping_start.png binary
- user_guide/ugimg/logo7000.png binary
- user_guide/ugimg/lsg_abduce_good.png binary
- user_guide/ugimg/msg_abduce_good.png binary
- user_guide/ugimg/msg_temperature_mild.png binary
- user_guide/ugimg/reduce_fishing.png binary
- user_guide/ugimg/reduce_temperature.png binary
- user_guide/ugimg/source.png binary
Emping.cabal view
@@ -1,34 +1,31 @@ name: Emping-version: 0.5.1+version: 0.6 license: GPL license-file: LICENSE build-depends: base, parsec, fgl, mtl, array, gtk-copyright: Hans van Thiel 2006 - 2008+copyright: Hans van Thiel 2006 - 2009 author: Hans van Thiel maintainer: hthiel.char@zonnet.nl build-depends: containers build-type: Simple stability: experimental-homepage: http://home.telfort.nl/sp969709/+homepage: http://www.muitovar.com synopsis: derives heuristic rules from nominal data-description: utility that reads a table in a csv (comma separated) format that can be generated from- Open Office Calc (spreadsheet), derives all shortest rules for a selected attribute,- and writes them to a .csv file that can be read by OO Calc. The shortest rules may be- partially ordered by implication (entailment) and equivalence (equality) and this partial- order is shown in Graphviz readable .dot files. Emping has a Gtk2Hs based GUI.+description: interactive (prototype) tool for discovery and analysis of predictive relations in nominal data+ reads tables in Open Office Calc .csv format, saves results in .csv and .dot (GraphViz) category: Data Mining-extra-source-files: README+extra-source-files: HaskellM.png -executable: emping-hs-source-dirs: src-main-is: Main.hs+executable: emping+hs-source-dirs: src+main-is: Main.hs -ghc-options: -O2 -Wall -other-modules: CSVParse- Codec- Reduce- Abduce- CSVTable- Aux+ghc-options: -Wall +other-modules: CsvParse+ Codec+ DefRules+ Reduce+ Abduce+ CsvTable
+ HaskellM.png view
binary file changed (absent → 12983 bytes)
− README
@@ -1,28 +0,0 @@-The compressed archive contains source files in the functional programming language Haskell.--Emping should compile on any platform which has the Glorious Haskell Compiler version 6.8 installed,-and a Gtk2Hs library 0.9.12 or higher. --One way to install Emping is through Cabal, for example:--$ runhaskell Setup configure --prefix=$HOME-$ runhaskell Setup build-$ runhaskell Setup install--where the commands might need to follow the prefix:- /usr/bin/env-depending on your settings.--You might want to look at: http://www.haskell.org/haskellwiki/How_to_write_a_Haskell_program--and/or the cabal documentation at: http://www.haskell.org/ghc/docs/latest/html/Cabal/index.html--for more information.-----------------------------------------------Or, put the source files in a directory of your choice and compile them with:--ghc --make -O2 -Wall Main.hs -o emping--where 'ghc' is the Haskell compiler, Main.hs is the source file of that name, and emping is the executable.
src/Abduce.hs view
@@ -1,196 +1,190 @@-{- | Emping 0.5 (provisional)--Module Abduce produces a graph of implications (equivalences in one node), between reduced antecedents with the same consequent.--Fri 04 Apr 2008 07:19:00 PM CEST --}-module Abduce (abduceTopAll, hasDependencies, orgReg2Ndg, nodeLegend, implicGraphOne, implicGraphAll, RuRe ) where-import Aux-import Data.List ( findIndices, nubBy, nub, (\\) )-import Data.Graph.Inductive-import Control.Monad.State+{- | Emping 0.6 (provisional) ------------------------------------------------------------------------------------ Match indices of reduced rules with indices of the original(s) which include a reduced rule+Tue 19 May 2009 05:53:47 PM CEST --- | indices of original rule(s) denoted by the same reduced rule. The antecedents of the original are supersets of the reduced antecedent.-redOrgs :: [Rule] -> Rule -> [Int]-redOrgs rules red = findIndices (\x -> (fst red) `isSub` (fst x)) rules+Module Abduce contains functions to find implications of reduced rules with+the same consequent. Each reduced rule stands for one or more originals.+Rule red1 implies red2 if the originals of red1 are a subset of the originals of red2.+Reduced rules, which imply the same original rule, form an equivalence class.+So the reduced rules for the same consequent are in a poset of equivalence classes.+The function abduceReds gets the graph of this poset from the lists of reduced and original rules. --- | tuples of the indices of originals and of the reduced rules for orgs and reds with same av consequent. First the originals, second the reduced rule.-redOPrs :: [Rule] -> [Rule] -> [([Int], Int)]-redOPrs rules reds = zip orixls [0..] where- orixls = map (redOrgs rules) reds+Sun 24 May 2009 07:10:00 PM CEST --- | define a type synonym for rule indices and reduced rule indices. First the rule indices, then the reduced indices.-type RuRe = ([Int], [Int])--- ^ Second is a node in the graph (of equals), first determines the order.+-} +module Abduce ( abduceReds, graphHasImps,graphMLGen ) where --- | get all reduced rules denoting the same original (ONE). First is originals, second is reduced equals.-getEquals :: [([Int],Int)] -> ([Int],Int) -> RuRe-getEquals y (ols,_)=- (ols, [snd x | x <- y, fst x == ols ])+import Data.Set (Set)+import qualified Data.Set as Abduce+import Data.List ( findIndices )+import Control.Monad.State+import Data.Maybe (isJust, fromJust)+import Data.Graph.Inductive+import DefRules (Rule) --- | group original-red pairs into original-equals pairs, remove doubles of original indices (maybe same but in different order)-toEquals :: [([Int],Int)] -> [RuRe]-toEquals orpl = nubBy eqOrg ls where- ls = map (getEquals orpl) orpl- eqOrg (x1,_) (x2,_) = isSub x1 x2 && isSub x2 x1+---------------------- redefined set functions -----------------------+isSub :: Ord a => Set a -> Set a -> Bool+isSub = Abduce.isSubsetOf --- | first original indices, second reduced rule indices, matched from original rules to reductions with the same consequent av-redOrgs2Eqs :: [Rule] -> [Rule] -> [RuRe]-redOrgs2Eqs rules reds = toEquals (redOPrs rules reds)+set_fromList :: Ord a => [a] -> Set a+set_fromList = Abduce.fromList+---------------------------------------------------------------------- ----------------------------------------------------------------------------------- Get the implications (partially ordered through the originals they denote)+-- find indices of original rule(s) denoted by the same reduced rule +-- antecedents of reduction are subsets (including equal) of the original+redIOrgsOne :: Rule -> [Rule] -> Set Int+redIOrgsOne red rules = + set_fromList $ findIndices (\x -> (fst red) `isSub` (fst x)) rules --- | define a partial order (WITHOUT EQUALS)-data Porder = HI | LW | NT deriving (Eq)+-- tuples of the indices of originals for each reduced rule+-- first in tuple is the reduced rule index, second the indices of originals+redIOrgsAll :: [Rule] -> [Rule] -> [(Int, Set Int)]+redIOrgsAll reds rules = zip [0..] orixls where+ orixls = map (flip redIOrgsOne rules) reds --- | define a comparison function for the partial order of an original rules - equal reductions (indices) pair-pcompare :: RuRe -> RuRe -> Porder-pcompare (x1, _) (x2, _)- | isSub x2 x1 = HI- | isSub x1 x2 = LW- | otherwise = NT+-- reduced rules may denote the same original rule (equivalence)+-- fst in the result is a list of equals, snd is the indices of originals+getEqualsOne :: (Int,Set Int) -> [(Int,Set Int)] -> ([Int], Set Int)+getEqualsOne (_, orig) ls = (eqls, orig ) where+ eqls = [ fst x | x <- ls , snd x == orig ] ----------------- Top Level Equals (no graph involved)----------------------+-- if a reduction is already in some equals list, ignore, otherwise get a new one+-- now every reduction is in one equivalence list, no duplicate lists+getEqsOneSt :: [(Int, Set Int)] -> (Int,Set Int) ->+ State [Int] (Maybe ([Int], Set Int) )+getEqsOneSt ls r = + State (\s -> let res = getEqualsOne r ls+ in if (fst r) `elem` s + then (Nothing, s)+ else (Just res, (fst res) ++ s) ) --- | get the top of a RuRe pair in a list-getTp :: [RuRe] -> RuRe -> RuRe-getTp ls x = foldr cmpmax x ls where - cmpmax u v | pcompare u v == HI = u- | otherwise = v+-- group all reduced rules, with originals, to equals with originals+groupEquals :: [(Int, Set Int)] -> [([Int], Set Int)]+groupEquals ls = [ fromJust x | x <- mbeqls, isJust x ] where+ mbeqls = evalState (mapM (getEqsOneSt ls) ls) [] --- | get all tops from a RuRe list-getTops :: [RuRe] -> [RuRe]-getTops ls = nub $ map (getTp ls) ls+type ReRu = ([Int], Set Int) --- | get the indices of the tops-eqixTops :: [Rule] -> [Rule] -> [[Int]]-eqixTops rules reds = map snd (getTops $ redOrgs2Eqs rules reds)+-- | from the list of reductions and the list of rules (all same consequent) +-- get equivalent reductions with their original rule indices)+eqivRedRulS :: [Rule] -> [Rule] -> [ReRu]+eqivRedRulS reds ruls = groupEquals $ redIOrgsAll reds ruls --- | replace indices of equals list with actual rule list (of reduced rules) and sort by length-srteqix2reds :: [Rule] -> [Int] -> [Rule]-srteqix2reds reds exls = sortByValNum $ map (reds !!) exls+-------------------------------------------------------------------------------+{- get implications between equivalence classes of reduced rules+ the partial order (of the implication relation) is found through the originals+ red1 implies red2 if origs set of red1 is a subset of origs set of red2 + the rule which implies less originals, implies the rule which implies more -} --- | get the top level for the reductions of a consequent av-abduceTopOne :: [Rule] -> [Rule] -> [[Rule]]-abduceTopOne rules reds = map (srteqix2reds reds) (eqixTops rules reds)+reruToNode :: [ReRu] -> [LNode ReRu]+reruToNode reruls = zip [1..] reruls -srtabduceTopOne :: [Rule] -> [Rule] -> [[Rule]]-srtabduceTopOne rules = sortListEqs . (abduceTopOne rules)+-- partial order (no equals, these are caught inthe equivalence lists)+-- HI = high, LW = low, NT = not ordered+data Porder = HI | LW | NT deriving (Eq) --- | check if the top level differs in length from the reduced list. No dependencies if not.-hasEDOne :: [[Rule]] -> [Rule] -> Bool-hasEDOne tops reds | (length tops) == (length reds) = False- | otherwise = True+-- poset comparison: the smaller (LW) implies the larger (HI)+-- isSubsetOf from from Data.Set (could also use isProperSubsetOf)+pcomp :: LNode ReRu -> LNode ReRu -> Porder+pcomp (_,(_, x1)) (_,(_,x2)) | isSub x1 x2 = LW+ | isSub x2 x1 = HI+ | otherwise = NT --- | get the top levels for the reductions of all values of the consequent attribute-abduceTopAll :: [[Rule]] -> [[Rule]] -> [[[Rule]]]-abduceTopAll rulegrp redsgrp = zipWith srtabduceTopOne rulegrp redsgrp+--------------- get a graph of the poset by implication ------------------------ --- | check the top levels for all consequent values for equals and dependencies-hasDependencies :: [[[Rule]]] -> [[Rule]] -> Bool-hasDependencies topsgrp redsgrp = or $ zipWith hasEDOne topsgrp redsgrp+{- add a possible node to an adjacency list. If it is a superset of any in+ the list, then ignore. If it is unconnected to all others , add it.+ If it is a subset of some members, replace those with it. -}+newLub :: LNode ReRu -> [LNode ReRu] -> [LNode ReRu]+newLub mb lubs | any (\x -> (pcomp x mb) == LW) lubs = lubs+ | all (\x -> (pcomp x mb) == NT) lubs = mb:lubs+ | otherwise = mb:newlubs+ where newlubs = filter (\x -> (pcomp x mb) /= HI) lubs ------------------------------------------------------------------------------------------------------------------------------------------------------- Build a directed graph of the implications (top down, each edge an entailment).---- | get nodes from a list of original rules-reductions pairs (start = 1) for an av-myGetNodes :: [RuRe] -> [LNode RuRe]-myGetNodes rurls = zip [1..] rurls---- | update nodes to get a linear sequence (of nodes)-myUpdateNodes :: [LNode RuRe] -> State Node [LNode RuRe]-myUpdateNodes ndrurls = - State (\n -> ( map (plusprior n) ndrurls , n + length ndrurls )) where- plusprior x (nd, rur) = (nd + x, rur)---- | update all the nodes for an attribute, so they range from 1 to the total number.-contNodes :: [[LNode RuRe]] -> [[LNode RuRe]]-contNodes ndgrls = evalState (mapM myUpdateNodes ndgrls) 0+-- if a ReRu implies another, it is a possible member of the adjacency list+addLub :: LNode ReRu -> LNode ReRu -> State [LNode ReRu] (LNode ReRu)+addLub nod mb = State (\s -> if (pcomp nod mb) == LW+ then (nod , newLub mb s)+ else (nod, s) ) --- | get labeled nodes from original rules and reductions-rr2Nds :: [Rule] -> [Rule] -> [LNode RuRe]-rr2Nds rules reds = myGetNodes $ redOrgs2Eqs rules reds +-- N.B nod must NOT be a member of mbls! This is batch , starts from []+getAdj :: LNode ReRu -> [LNode ReRu] -> [LNode ReRu]+getAdj nod mbls = execState (mapM (addLub nod) mbls) [] --------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | get labeled nodes from rulegroup and reduction group. THIS is the BASE for all graphs.-orgReg2Ndg :: [[Rule]] -> [[Rule]] -> [[LNode RuRe]]-orgReg2Ndg rulegrp redgrp = contNodes (zipWith rr2Nds rulegrp redgrp)------------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- get a node with its nearest implications+getAdjPair :: LNode ReRu -> [LNode ReRu] -> (LNode ReRu,[LNode ReRu])+getAdjPair nod nodls = (nod, adj) where+ adj = getAdj nod src+ src = filter (/= nod) nodls --- | nodes with reduced reduction equivalences (reds are the reductions for an av)-nodesWRls :: [Rule] -> [LNode RuRe] -> [LNode [Rule]]-nodesWRls reds rurls = map getrule rurls where - getrule (nod, (_,re)) = (nod, srteqix2reds reds re)+-- get the (node, adjacency list) tuples for all elements of a LNode ReRu list+getAdjPairAll :: [LNode ReRu] -> [(LNode ReRu,[LNode ReRu])]+getAdjPairAll reruls = map ((flip getAdjPair) reruls) reruls --- | get nodes with the indices of the reduction equivalences-nodeLegend :: [[Rule]] -> [[LNode RuRe]] -> [LNode [Rule]]-nodeLegend redsgrp nodegrp = concat $ zipWith nodesWRls redsgrp nodegrp+-- type synonym for just the indices of reductions+type Re = [Int] -------------------- get the edges from a list of LNode RuRe --------------+-- in a node with its closest implications, we don't need the originals any more+remOrigsFromNodes :: [(LNode ReRu, [LNode ReRu])] -> [(LNode Re, [LNode Re])]+remOrigsFromNodes napls = map redsonly napls where + redsonly (nd, adj) = (remfn nd, map remfn adj)+ remfn (x,(r, _)) = (x,r)+ +-- get the list of nodes to build the graph (all types)+-- if the adjacency list is empty, the node is unconnected, but still in the graph+nodesFromNodeAdjList :: [(LNode a, [LNode a])] -> [LNode a]+nodesFromNodeAdjList ndals = map fst ndals --- | just like getTp, but with nodes (functor here?)-getNdTp :: [LNode RuRe] -> LNode RuRe -> LNode RuRe-getNdTp nodls nod = - foldr ndcmpmax nod nodls where - ndcmpmax (nd1,x) (nd2,y) | pcompare x y == HI = (nd1,x)- | otherwise = (nd2,y)+-- get the list of edges from a node adjacency list (all types of Eq (?))+-- if the adjacency list is empty, there are no edges for that node+edgesFromNodeAdj :: Eq a => (LNode a, [LNode a]) -> [UEdge]+edgesFromNodeAdj (nd, adj) | adj == [] = []+ | otherwise = zip3 src tgt typ + where tgt = map fst adj+ n = length tgt+ src = replicate n (fst nd) + typ = replicate n () --- | get the top level from a node list (just like getTops)-getNodeTops :: [LNode RuRe] -> [LNode RuRe]-getNodeTops ndls = nub $ map (getNdTp ndls) ndls+-- get the list of edges to build the graph (all types of Eq (?) )+-- N.B. concat takes care of any empty edge lists+edgesFromNodeAdjList :: Eq a => [(LNode a,[LNode a])] -> [UEdge]+edgesFromNodeAdjList = concatMap edgesFromNodeAdj --- | split a RuRe list into levels, each level the top of the next lower.-getNodeLevels :: [LNode RuRe] -> [[LNode RuRe]]-getNodeLevels [] = []-getNodeLevels nodls = (getNodeTops nodls):(getNodeLevels $ (nodls \\ (getNodeTops nodls)))+-- get the reduced rules themselves from a node+reToRed :: [Rule] -> LNode Re -> LNode [Rule]+reToRed reds (nd,ils) = (nd, map (reds !!) ils) --- | get the edges from a top node to the next lower level-myGtUEdge :: [LNode RuRe] -> LNode RuRe-> [UEdge]-myGtUEdge lvs tn = zip3 src trgt etyp where- src = replicate (length lvs) (fst tn)- trgt = map fst rurls- etyp = replicate (length lvs) ()- rurls = filter (nodecompare tn) lvs- nodecompare (_,x) (_,y) = (pcompare x y) == HI+-- change all indices in a node list to the rules themselves+reToRedAll :: [Rule] -> [LNode Re] -> [LNode [Rule]]+reToRedAll reds ndls = map (reToRed reds) ndls --- | get the edges from a top level to a lower level (the next)-topUEdges :: [LNode RuRe] -> [LNode RuRe] -> [UEdge]-topUEdges lv1 lv2 = concatMap (myGtUEdge lv2) lv1+-- from reductions and their originals, get a graph of reduced rules+-- each edge represents an implication, the first implies the second+abduceReds :: [Rule] -> [Rule] -> Gr [Rule] ()+abduceReds reds ruls = mkGraph nds eds where + nds = reToRedAll reds (nodesFromNodeAdjList nda)+ eds = edgesFromNodeAdjList nda + nda = (remOrigsFromNodes + . getAdjPairAll + . reruToNode + . (eqivRedRulS reds)) ruls +-------------------------------------------------------------------- +----------------------------- graph analysis ----------------------- --- | get all edges from a level list. Case of only one level returns []-allLevelUEdges :: [[LNode RuRe]] -> [UEdge]-allLevelUEdges [] = error "Abduce allLevelUEdges: list is empty"-allLevelUEdges (_:[]) = []-allLevelUEdges (x:y:ys) = (topUEdges x y) ++ (allLevelUEdges (y:ys))+-- | check if a graph has any rule implications at all+graphHasImps :: Gr [Rule] () -> Bool+graphHasImps gr | edges gr == [] = False+ | otherwise = True --- | from a list of nodes, get the corresponding edges-myGetUEdges :: [LNode RuRe] -> [UEdge]-myGetUEdges = allLevelUEdges . getNodeLevels+-- workaround gsel to get tops and bottoms of a graph+lnodesMLGen :: Bool -> Gr [Rule] () -> [LNode [Rule]]+lnodesMLGen msg ag = [ (n,l) | (n,l) <- labNodes ag, mldeg ag n == 0 ]+ where mldeg = if msg then outdeg else indeg --- | replace the RuRe with the length of the equivalence list-disrure :: [LNode RuRe] -> [LNode (Int,Int)]-disrure nodls = map rur2ln nodls where- rur2ln (nd, (_ , redidls)) = (nd, (nd, (length redidls))) +graphMLGen :: Bool -> Gr [Rule] () -> Gr [Rule] ()+graphMLGen msg ag = mkGraph nds [] where nds = lnodesMLGen msg ag --- | make a graph of a node list-implicGraphOne :: [LNode RuRe] -> Gr (Int,Int) ()-implicGraphOne nodelist = mkGraph nds edgs where- nds = disrure nodelist- edgs = myGetUEdges nodelist- --- | make a graph of the group of node lists-implicGraphAll :: [[LNode RuRe]] -> Gr (Int,Int) ()-implicGraphAll nodegroup = mkGraph nds edgs where- nds = disrure $ concat nodegroup- edgs = concatMap myGetUEdges nodegroup
− src/Aux.hs
@@ -1,62 +0,0 @@-{- | Emping 0.5 (provisional)--Module Aux provides some general purpose functions, which are used by other modules.--Fri 04 Apr 2008 07:20:22 PM CEST --}-module Aux where--import Data.List ( partition, sortBy )---- | AVp is the type of an attribute-value tuple.-type AVp = (Int, Int)--{- | Ant is the type of the Antedent in a rule. --Warning: A fact is also a list of Int tuples, and so is a disjunction of attribute-value pairs. Use only when it really reprecents an Antedent of a rule.--}-type Ant = [AVp]---- | Rule is the type of a rule, a tuple of an Ant and a AVp-type Rule = (Ant,AVp)---- | checks whether the elements of the first list are all in the second list--isSub :: Eq a => [a] -> [a] -> Bool-isSub [] _ = True-isSub (x:xs) y | not (x `elem` y) = False- | otherwise = isSub xs y---- | checks whether two lists are equal as sets (regardless of order)-isEq :: Eq a => [a] -> [a] -> Bool-isEq x y = isSub x y && isSub y x---- | returns x if it's elements are all in y, otherwise y-minLs :: Eq a => [a] -> [a] -> [a]-minLs x y | x `isSub` y = x- | otherwise = y---- | partitions a list according to an equivalence relation-partitionBy :: (a -> a -> Bool) -> [a] -> [[a]]-partitionBy _ [] = []-partitionBy eq ls = x:(partitionBy eq y) where- (x,y) = partition ((head ls) `eq`) ls ---- | sort a list of (reduced) rules according to antecedent length, shortest antecedents first-sortByValNum :: [Rule] -> [Rule]-sortByValNum (x:[]) = [x] -- only one rule in list (usually equivalence list)-sortByValNum rls = sortBy lengthcmp rls where - lengthcmp (x,_) (y,_) | (length x) > (length y) = GT- | (length x) == (length y) = EQ- | otherwise = LT---- | sort a list of SORTED equivalence classes. Then head is always shortest. -sortListEqs :: [[Rule]] -> [[Rule]]-sortListEqs equivls = sortBy eqvcmp equivls where- eqvcmp x y | (myln x) > (myln y) = GT- | (myln x) == (myln y) = EQ- | otherwise = LT- myln = length . fst . head---
− src/CSVParse.hs
@@ -1,74 +0,0 @@-{- | Emping 0.4, 0.5 (provisional)--Module CSVParse converts a table in Open Office Calc .csv format into a list of lists of Haskell Strings.The first row in the table must consist of the attribute names. It is recommended that all attributes have unique names, but blanks and doubles are allowed. Each attribute will be identified by its column number.--The rows after the first must be attribute values. Values in different columns may have the same names or be blank. Values in the same column with the same names are considered to be equal. Emping will generate a list of values for each column.--Warning: if you use blank fields in the table, be sure they are correctly seperated by comma's and that each row is correctly terminated by a newline.--Fri 04 Apr 2008 07:17:12 PM CEST --}-module CSVParse ( getTable , blankId ) where--import Text.ParserCombinators.Parsec--{- |-a text field starts with \" and ends with \"--a numerical field consists of digits only --an empty field is zero or more spaces separated by comma's, returns \"NA\"--}--comma:: GenParser Char a Char-comma = char ','---- | textField returns any String between double quotes (the OO Calc format)-txtField :: GenParser Char a String-txtField = do char '\"' - txt <- many (noneOf "\"") - char '\"'; return txt ---- | numField returns a string of digits as a string. This is the OO Calc format for numbers.-numField :: GenParser Char a String -numField = many1 digit---- | blankId is the String returned from parsing a blank field. Currently this is: \"NA\", which stands for 'not applicable'.-blankId :: String-blankId = "NA"---- | noField parses a blank field-noField :: GenParser Char a String-noField = do { many (char ' '); return blankId }---- | getField parses a text field, a numeric field, or a blank field-getField :: GenParser Char a String-getField = do {txtField <|> numField <|> noField }---- | csvLine parses a row-csvLine :: GenParser Char a [String]-csvLine = do fields <- (sepBy getField comma)- newline - return fields---- | csvTable parses the table-csvTable :: GenParser Char a [[String]]-csvTable = many csvLine---- | getTable reads the table from a file path and returns a list of row representations, each itself a list of strings-getTable :: String -> IO [[String]]-getTable fname = do pares <- parseFromFile csvTable fname- let res = case pares of - Right x -> x- Left err -> error (show err)- return (res) --{---- test the table in csv format for parse errors--test = do putStrLn "Enter CSV file:"- name <- getLine- res <- parseFromFile csvTable name- case res of Left err -> print err- Right xs -> print xs--}
− src/CSVTable.hs
@@ -1,249 +0,0 @@-{- | Emping 0.5 (provisional)--Module CSVTable converts results to a CSV format that can be read by Open Office Calc -and a rule graph to .dot format that can be read by a Graphviz viewer.--Fri 04 Apr 2008 07:19:30 PM CEST --}-module CSVTable ( allDup2CSVTb , allAmb2CSVTb, rnf2CSVTb, allTops2CSVTb, allNodes2CSVTb, graph2DOT ) where--import Data.Char (isDigit )-import Data.Array-import Data.Graph.Inductive-import Aux (AVp, Ant, Rule)-import CSVParse (blankId)---- | check whether a string is a number or text-allDigit :: String -> Bool-allDigit [] = True-allDigit (x:xs) | isDigit x = allDigit xs- | otherwise = False---- | convert string or number to OO Calc format-toCalc :: String -> String-toCalc x | allDigit x = x- | otherwise = "\"" ++ x ++ "\""--{- | get an OO Calc value String (-1 is \" \") from an attribute-value pair-Warning: for the time being all values of -1 are written as an NA field, not as blanks.--}-showValue :: Array Int (String, [String]) -> AVp -> String-showValue attvarr (att, val)- | val == -1 = toCalc "NA" -- blank field- | otherwise = toCalc ((snd (attvarr ! att)) !! val)---- | get an OO Calc value string from a Maybe AVp (Nothing is \" \")-showMaybeValue :: Array Int (String, [String]) -> Maybe AVp -> String-showMaybeValue attvarr mbav = - case mbav of - Just x -> showValue attvarr x- Nothing -> " "---- | get an OO Calc attribute string from an attribute index (blankId is \" \")-showAttribute :: Array Int (String, [String]) -> Int -> String-showAttribute attvarr att - | attstr == blankId = " "- | otherwise = toCalc attstr- where attstr = fst (attvarr ! att)---- | insert a separator s between two strings-inSep :: String -> String -> String -> String-inSep s x y = x ++ s ++ y---- | from an ORIGINAL rule, get the display sequence (fst is the antecedent)-displayGuide :: Rule -> ([Int], Int)-displayGuide (ant, cons) = (map fst ant, fst cons)---- | lookup an attribute-value pair for an attribute in a reduced antecedent-lkp :: Int -> Ant -> Maybe AVp-lkp _ [] = Nothing-lkp att (x:xs) | att == fst x = Just x- | otherwise = lkp att xs ---- | order a reduced antecedent according to a display guide first, including Nothing-formatAnt :: [Int] -> Ant-> [Maybe AVp]-formatAnt [] _ = []-formatAnt (x:xs) antec = (lkp x antec): (formatAnt xs antec)---- | get a list of OO Calc value strings from an antecedent-ant2CalStr :: Array Int (String, [String]) -> [Int] -> Ant -> [String]-ant2CalStr attvarr attls antec = - map (showMaybeValue attvarr) frmant where- frmant = formatAnt attls antec---- | convert a reduced rule to a .csv table row (with \\n)-red2CSV :: Array Int (String,[String]) -> ([Int],Int) -> Rule -> String-red2CSV attvarr (attls, _ ) (ant,cons) =- (foldr1 (inSep ",") calstr) - ++ ",\" is \"," - ++ (showValue attvarr cons) - ++ "\n" - where calstr = ant2CalStr attvarr attls ant---- | convert the table header to a .csv row--hdr2CSV :: Array Int (String, [String]) -> ([Int], Int) -> String-hdr2CSV attvarr (attls, consatt) = - (foldr1 (inSep ",") calstr) - ++ ", ," - ++ (showAttribute attvarr consatt)- ++ "\n" - where calstr = map (showAttribute attvarr) attls- ------------------------------------------------------- | convert a list of reductions with the same consequent to .csv-sameCons2CSV :: Array Int (String,[String]) -> ([Int], Int) -> [Rule] -> String-sameCons2CSV attvarr dispg redcons =- concatMap (red2CSV attvarr dispg) redcons---- | convert the reductions for all values of an attribute to .csv-allReds2CSV :: Array Int (String,[String]) -> ([Int], Int) -> [[Rule]] -> String-allReds2CSV attvarr dispg redgrp =- concatMap (sameCons2CSV attvarr dispg) redgrp----------------------------------------------------{- | convert a reduced normal form to .csv table with a header. --Warning: Get the display guide from the original rules--}-rnf2CSVTb :: Array Int (String,[String]) -> [[Rule]] -> [[Rule]] -> String-rnf2CSVTb attvarr origs redgrp =- (hdr2CSV attvarr dispg) ++ (allReds2CSV attvarr dispg redgrp) where- dispg = displayGuide (head (head origs))------------------------- .csv output of equals ------------------- | convert a duplicate and its occurrence count into a .csv String -dup2CSV :: Array Int (String, [String]) -> ([AVp], Int) -> String-dup2CSV attvarr (fct, cnt) = - (foldr1 (inSep ",") strls) ++ "," ++ ((toCalc . show) cnt) ++ "\n" where- strls = map (showValue attvarr) fct---- | get a header from a duplicate and convert it .csv String WITHOUT newline-dup2HdrCSV :: Array Int (String, [String]) -> ([AVp],Int) -> String-dup2HdrCSV attvarr (fct, _) = - (foldr1 (inSep ",") strls) ++ "," ++ (toCalc "Number") ++ "\n" where- strls = map ((showAttribute attvarr) . fst) fct---- | transform a list of representatives of duplicate and their counts to a .csv String-allDup2CSVTb :: Array Int (String,[String]) -> [([AVp],Int)] -> String-allDup2CSVTb attvarr dbls = (dup2HdrCSV attvarr (head dbls)) ++- concatMap (dup2CSV attvarr) dbls--------------------------------------------------------{- | show ambiguous original rules in .csv format--Note: original rules do not need intermediate Maybe's, like reduced rules--}-org2CSV :: Array Int (String, [String]) -> Rule -> String-org2CSV attvarr orule = - antstr ++ ",\" is \"," ++ constr ++ "\n" where- antstr = foldr1 (inSep ",") antstrls- antstrls = map (showValue attvarr) (fst orule) - constr = showValue attvarr (snd orule)---- | ambiguous rules to .csv (always more than one) with extra newline--ambs2CSV :: Array Int (String,[String]) -> [Rule] -> String-ambs2CSV attvarr ambrls = - (concatMap (org2CSV attvarr) ambrls) ++ "\n"---- | a group of ambiguous rules, with different consequents, to .csv-ambgrp2CSV :: Array Int (String,[String]) -> [[Rule]] -> String-ambgrp2CSV attvarr ambgrp - | length ambgrp == 1 = ambs2CSV attvarr (head ambgrp)- | otherwise = concatMap (ambs2CSV attvarr) ambgrp---- | display ambiguous rules in a .csv table. The guide for the header is obtained from the first rule.-allAmb2CSVTb :: Array Int (String,[String]) -> [[Rule]] -> String-allAmb2CSVTb attvarr ambgrp =- (hdr2CSV attvarr (antatt,consatt)) ++ ambstr where- (antatt, consatt) = ((map fst ant), (fst cons))- (ant, cons) = head (head ambgrp)- ambstr = ambgrp2CSV attvarr ambgrp--------------------------------------------------------------- ------------------------------------ The .csv output of top level abductions ------------------------- | show the antecedent as a .csv string. Analogous to red2CSV, but without extras for the consequent-ant2CSV :: Array Int (String,[String]) -> [Int] -> Rule -> String-ant2CSV attvarr attls red = - foldr1 (inSep ",") calcs where - calcs = ant2CalStr attvarr attls (fst red)---- | show a list of equal antecedents in .csv format. Warning: as before, the guide is the first of a display guide, NO consequent yet.-eqs2CSV :: Array Int (String,[String]) -> [Int] -> [Rule] -> String-eqs2CSV attvarr attls eqls - | length eqls == 1 = - ant2CSV attvarr attls (head eqls)- | otherwise = - foldr1 (inSep ",\"equals\"\n") strls where- strls = map (ant2CSV attvarr attls) eqls ---- | append the consequent value, 2 newlines for readability.-eqsWCons2CSV :: Array Int (String, [String]) -> [Int] -> [Rule] -> String-eqsWCons2CSV attvarr attls eqls = (eqs2CSV attvarr attls eqls)- ++ ",\" is \","- ++ (showValue attvarr ( snd (head eqls)))- ++ "\n\n"---- convert all rule equivalences in a top level for a consequent-tops2CSV :: Array Int (String, [String]) -> [Int] -> [[Rule]] -> String-tops2CSV attvarr attls abdtops = concatMap (eqsWCons2CSV attvarr attls) abdtops---- convert all rule equivalences to .csv for all the top level abductions-allTops2CSV :: Array Int (String, [String]) -> [Int] -> [[[Rule]]] -> String-allTops2CSV attvarr attls topsgrp = concatMap (tops2CSV attvarr attls) topsgrp------------------------------------------------------------------ | transform the abduction result to .csv table with header-allTops2CSVTb :: Array Int (String,[String]) -> [[Rule]] -> [[[Rule]]] -> String-allTops2CSVTb attvarr origs topsgrp = - (hdr2CSV attvarr guide) ++ allTops2CSV attvarr (fst guide) topsgrp where guide = displayGuide (head (head origs))------------------------------ Graph Legend to .csv ---------------------------- | display a list of equals in .csv, but allow for the first column to be empty, for any antecedent AFTER the first-nods2CSV :: Array Int (String,[String]) -> [Int] -> [Rule] -> String-nods2CSV attvarr attls eqls - | length eqls == 1 = fstline - | otherwise = foldr1 (inSep ",\"equals\"\n") strls- where fstline = ant2CSV attvarr attls (head eqls)- strls = fstline:(map foline (tail eqls))- foline x = ',': (ant2CSV attvarr attls x)---- | exactly like eqsWCons2CSV-nodsWCons2CSV :: Array Int (String, [String]) -> [Int] -> [Rule] -> String-nodsWCons2CSV attvarr attls eqls = (nods2CSV attvarr attls eqls)- ++ ",\" is \","- ++ (showValue attvarr ( snd (head eqls)))- ++ "\n\n"---- | put the node in front of the equals with cons-lnode2CSV :: Array Int (String,[String]) -> [Int] -> LNode [Rule] -> String-lnode2CSV attvarr attls (nd,eqls) = - ((toCalc .show) nd) ++ "," ++ (nodsWCons2CSV attvarr attls eqls)---- | get all nodes from a graph legend-allNodes2CSV :: Array Int (String,[String]) -> [Int] -> [LNode [Rule]] -> String-allNodes2CSV attvarr attls legend = concatMap (lnode2CSV attvarr attls) legend---- | prepend the header with Node in the first column-allNodes2CSVTb :: Array Int (String,[String]) -> [[Rule]] -> [LNode [Rule]] -> String-allNodes2CSVTb attvarr origs legend = - (toCalc "Node") - ++ ","- ++ (hdr2CSV attvarr guide)- ++ (allNodes2CSV attvarr (fst guide) legend ) where guide = displayGuide (head (head origs))-------------------------- transform a graph to .dot format -------------------------------------- | use the graphviz function with defaults. Page matrix is sqrt of number of nodes. --- Page is smallest of A4 and US Letter. Specific graph type used, not class.-graph2DOT :: Gr (Int,Int) () -> String -> String-graph2DOT graph name = - graphviz graph name (8.3,11.0) (pgn,pgn) Portrait where- pgn = 1 + (round . sqrt . (/ nodpp) . fromIntegral) (noNodes graph)- nodpp = 50.0 :: Double--
src/Codec.hs view
@@ -1,89 +1,56 @@-{- | Emping 0.4, 0.5 (provisional)+{- | Emping 0.6 (provisional) -Module Codec transforms a list of lists of String attributes and values into a list of lists of Int tuples. The first list of Strings must be the attribute names (may contain blankId), the following lists must contain attribute values or blankId. +Tue 19 May 2009 05:51:44 PM CEST -The module also provides an Array to display the names of coded attributes and values, and functions to deal with table rows that are equal (duplicates). +Module Codec transforms a list of lists of String attributes and values into a list of lists of Int tuples. The first argument of Strings (row) must contain the attribute names (may be blankId), the following argument lists (rows) must contain value names or blankId. The module also provides an Array function to display the names of AVp coded attributes and values -} -Fri 04 Apr 2008 07:17:45 PM CEST --}-module Codec (tableCode, tableToArray, partDups, checkNoDups, factsDups, factsUniques ) where+module Codec (tableCode, tableToArray, AVp ) where -import Data.List (transpose, elemIndex) import Control.Monad.State+import Data.List (transpose, elemIndex) import Data.Array-import Aux ( AVp, partitionBy )-import CSVParse ( blankId )+-- import CsvParse ( blankId ) (just a reminder) --- | check whether a value string is in a list, add it if not, and return its index. A blankId returns an index of -1 and leaves the value list unchanged.+-- | AVp is the type synonym of an attribute-value tuple.+type AVp = (Int, Int)++-- check whether a value is in a list, append it, with its index, if not+-- blankId is treated like any other value (or attribute) repl1 :: String -> State [String] Int-repl1 x - | x == blankId = State (\col -> (-1, col))- | otherwise = State (\col -> case elemIndex x col of+repl1 x = State (\col -> case elemIndex x col of Nothing -> ((length col), col ++ [x]) Just i -> (i, col)) --- | replace value strings with indices to a unique list of value strings. Note: the blankId is represented by -1-getInds :: [String] -> [Int]-getInds strcol = evalState (mapM repl1 strcol) []---- | get the list of values itself. Note: the blankId is not represented in this list.+-- gets a list of unique values from a column of values getVals :: [String] -> [String] getVals strcol = execState (mapM repl1 strcol) [] --- | get all unique value lists from the original table+-- constructs an index for each unique value in column of values+getInds :: [String] -> [Int]+getInds strcol = evalState (mapM repl1 strcol) []++-- get all unique values of each attribute from the original table avLs :: [[String]] -> [[String]]-avLs [] = error "Codec avLs: empty String list"-avLs (_:[]) = error "Codec avLs : only one element in String list"+-- avLs [] = error "Codec avLs: table is empty" (checked in tableToArray)+-- avLs (_:[]) = error "Codec avLs: table has 1 row" (see above) avLs tb = ((map getVals) . transpose . tail) tb -{- |-tableCode produces a list of lists of attribute-value tuples, coded as Int. A list of tuples represents a conjunction of attribute values, also called a fact list.- -first of each tuple indexes into the attribute-value array (and the first element of that tuple, the attribute name)+{- | tableCode produces a list of lists of attribute-value tuples, coded as Int. A list of tuples represents a conjunction (and) of attribute values. -second of each tuble indexes into the second element of an array tuple, the list of value names +The first Int of each AVp pair indexes into an array of Strings. The first element of each array element is the attribute name. The second Int of an AVp pair indexes into the second element of that array element, which is the list of value names of that attribute. See: tableToArray -} -tableCode represents blankId as -1, which is not in the string array.--} tableCode :: [[String]] -> [[AVp]]-tableCode [] = error "Codec tableCode: empty String list"-tableCode (_:[]) = error "Codec tableCode : only one element in String list"+tableCode [] = error "Codec tableCode: table is empty"+tableCode (_:[]) = error "Codec tableCode : table has 1 row" tableCode tb = map (zip [0..]) (values (tail tb)) where values = transpose . (map getInds) . transpose --{- |-tableToArray returns an array of attribute value-lists. The first element of a tuple is an attribute name, the second the list of its unique values.--An attribute coding must be an index to the array (and the String)--A value coding must be an index to the list of Strings.+{- | tableToArray constructs an array of tuples of an attribute name and a list of its value names. The format for each element is (attribute name, list of value names). -} -Note: blankId is not represented in the Array.--} tableToArray :: [[String]] -> Array Int (String, [String])+tableToArray [] = error "Codec tableToArray: table is empty"+tableToArray (_:[]) = error "Codec tableToArray: table has 1 row" tableToArray tb = listArray (0, (length (head tb)) -1) atplusvals where atplusvals = zip (head tb) (avLs tb)----- | partDups partitions a fact list into a list of duplicates and their counts. This is a data check, duplicates do not effect the reduction, but should be removed initially.--partDups :: [[AVp]] -> [([[AVp]], Int)]-partDups origs = [(x, length x) | x <- parts ] where- parts = partitionBy (\x y -> x == y ) origs---- | check the partition of possible Dups for any Dups (True if no Dups)-checkNoDups :: [([[AVp]], Int)] -> Bool-checkNoDups parts | (filter (\x -> (snd x) > 1) parts) == [] = True- | otherwise = False---- | get a representative of each double in the facts with its occurrence count-factsDups :: [([[AVp]],Int)] -> [([AVp],Int)]-factsDups dupfacs = [ ((head . fst) x, snd x) | x <- dbls ] where - dbls = [ x | x <- dupfacs, (snd x) > 1 ]---- | factsUniques returns the head of each partition of a Dups (including singles)list. This function removes any double data entries, if they exist.-factsUniques :: [([[AVp]], Int)] -> [[AVp]]-factsUniques dupfacs = map (head . fst) dupfacs
+ src/CsvParse.hs view
@@ -0,0 +1,73 @@+{- | Emping 0.6 (provisional)++Module CsvParse converts a table in Open Office Calc .csv format into a list of lists of Haskell Strings.The first row in the table must consist of the attribute names. It is recommended that all attributes have unique names, but blanks and doubles are allowed. Each attribute will be identified by its column number.++The rows after the first must be attribute values. Values in different columns may have the same names or be blank. Values in the same column with the same names are considered to be equal. Emping will generate a list of values for each column.++Tue 19 May 2009 05:50:37 PM CEST +-}+module CsvParse ( getTable , blankId ) where++import Text.ParserCombinators.Parsec++{- |+a text field starts with \" and ends with \" any other character is allowed+a numerical field consists of digits only +an empty field is zero or more spaces separated by comma's, returns \"NA\" +-}++-- | blankId is the String returned from parsing a blank field +-- currently this is: \"NA\", which stands for 'not applicable' +blankId :: String+blankId = "NA"++comma:: Parser Char+comma = char ','++-- textField returns any String between double quotes (the OO Calc format)+txtField :: Parser String+txtField = do char '\"' + txt <- many (noneOf "\"") + char '\"' + return txt ++-- numField returns a string of digits as a string +-- this is the OO Calc format for numbers+numField :: Parser String +numField = many1 digit ++-- noField parses a blank field+noField :: Parser String+noField = do { many (char ' '); return blankId }++-- getField parses a text field, a numeric field, or a blank field+getField :: Parser String+getField = do {txtField <|> numField <|> noField } ++-- csvLine parses a row+csvLine :: Parser [String]+csvLine = do fields <- (sepBy getField comma)+ newline + return fields++-- csvTable parses the table+csvTable :: Parser [[String]]+csvTable = many csvLine++-- | getTable reads the table from a file path +-- it returns a list of rows, where each row is a list of strings+getTable :: String -> IO [[String]]+getTable fname = do pares <- parseFromFile csvTable fname+ let res = case pares of + Right x -> x+ Left err -> error ("parse error at: " ++ (show err))+ return res +-------------------------------------------------------------------------+-- test the table in csv format for parse errors+{-+test = do putStrLn "Enter CSV file:"+ name <- getLine+ res <- parseFromFile csvTable name+ case res of Left err -> error ("parse error at: " ++ (show err))+ Right xs -> print xs+-}
+ src/CsvTable.hs view
@@ -0,0 +1,197 @@+{- | Emping 0.6 (provisional)++Tue 19 May 2009 05:54:20 PM CEST ++Module CsvTable converts results to a .csv format that can be read by Open Office+Calc and .dot format that can be read by a Graphviz viewer. -}+ +module CsvTable (redTbShow, dupTbShow, ambigTbShow, + eqivGraphShow, legendGrTbShow ) where++import Data.Char (isDigit )+import Data.Array+import Data.List (delete, intersperse, sortBy)+import Data.Ord (comparing) +import Data.Set (Set)+import qualified Data.Set as CsvTable+import Data.Graph.Inductive+--import Aux (AVp, Ant, Rule)+import CsvParse (blankId)+import Codec (AVp)+import DefRules (Rule)++----------------------- rename set functions ------------------+set_elems :: Set a -> [a]+set_elems = CsvTable.elems++set_size :: Set a -> Int+set_size = CsvTable.size+---------------------------------------------------------------+-- version of intercalate, which won't import+concatSperse :: [a] -> [[a]] -> [a]+concatSperse xs xss = concat (intersperse xs xss)+---------------------------------------------------------------+-- type synonym for the array of attribute and value names+type NameArray = Array Int (String,[String])++-- convert string or number to OO Calc format (three cases)+toCalc :: String -> String+toCalc x | x == blankId = "\"\""+ | all isDigit x = x+ | otherwise = "\"" ++ x ++ "\""++-- convert a value in an AVp to OO Calc format (with or without ")+valueShow :: AVp -> NameArray -> String+valueShow (a,v) attvarr = toCalc (vstrls !! v) where+ vstrls = snd (attvarr ! a)+-- convert an attribute in an AVp to OO Calc format (with or without ")+attribShow :: Int -> Array Int (String, [String]) -> String+attribShow ai attvarr = toCalc astr where+ astr = fst (attvarr ! ai)+++-- get the string of attribute names with consequent last (table head) +ruleTbHead :: Rule -> NameArray -> String+ruleTbHead (_,(ca,_)) attvarr = + aastr ++ ",," ++ castr where+ castr = attribShow ca attvarr+ aastr = concatSperse "," aastrls+ aastrls = map (flip attribShow attvarr) aarow+ aarow = delete ca (indices attvarr)++-- if there is no AVp in the antecedent for that attribute, show a blank+-- otherwise, show the value+valueOrBlank :: [AVp] -> NameArray -> Int -> String+valueOrBlank antls attvarr ps + | av == [] = "\"\""+ | otherwise = valueShow (head av) attvarr + where av = filter (\x -> fst x == ps) antls++-- show an antecedent as a csv string+antecTbRow :: Rule -> NameArray -> String+antecTbRow (antec, con) attvarr = concatSperse "," antvls+ where antvls = map (valueOrBlank antls attvarr) antpos+ antpos = delete (fst con) (indices attvarr) + antls = set_elems antec++-- show one rule as a row in a OO Calc .csv table+ruleTbRowOne :: Rule -> NameArray -> String+ruleTbRowOne rul attvarr = astr ++ ",\"implies\"," ++ cstr + where astr = antecTbRow rul attvarr+ cstr = valueShow (snd rul) attvarr++-- sort a list of reduced rules by the number of antecedent elements +sortRdsByLength :: [Rule] -> [Rule]+sortRdsByLength = sortBy $ comparing (set_size . fst)++-- show all the rules, sorted by length, for the same consequent value (in .csv)+ruleTbForCons :: [Rule] -> NameArray -> String+ruleTbForCons reds attvarr = concatSperse "\n" rulstrls where+ rulstrls = map (flip ruleTbRowOne attvarr) srtred+ srtred = sortRdsByLength reds++----------------------------- output of rule reduction ----------------------+-- | get the OO Calc .csv table for all reductions of some attribute+-- this is the complete output of a reduction with an OO Calc .csv table as input+redTbShow :: [[Rule]] -> NameArray -> String+redTbShow redall attvarr = concatSperse "\n" (h:rows) where+ rows = map (flip ruleTbForCons attvarr) redall+ h = ruleTbHead rfc attvarr+ rfc = head (head redall)++------------------ duplicates in the input able --------------------------++-- show a duplicate row from the input table, with its frequency+-- works on the output of DefRules.getDups (frequency in last column)+dupShow :: ([AVp],Int) -> NameArray -> String+dupShow (facls,n) attvarr = vstr ++ "," ++ nstr where+ vstr = concatSperse "," valstrls+ nstr = toCalc (show n)+ valstrls = map (flip valueShow attvarr) facls+++-- | show the table of duplicate facts, with the counts in last columb+-- N.B. factlists are in original order, so use skels to get attributes+dupTbShow :: [([AVp],Int)] -> NameArray -> String+dupTbShow dupls attvarr = concatSperse "\n" (h:vstrls) where+ vstrls = map (flip dupShow attvarr) dupls+ h = attstr ++ ",\"count\""+ attstr = concatSperse "," attstrls+ attstrls = map (flip attribShow attvarr) skels+ skels = indices attvarr++-----------------------------------------------------------------------------+------------------------------- ambiguous rules -----------------------------++-- show one ambiguous rule !(almost, but not quite, like the others)!+oneAmbigShow :: ([AVp], AVp) -> NameArray -> String+oneAmbigShow (antls, con) attvarr = astr ++ ",\"implies\"," ++ cstr + where astr = concatSperse "," astrls + astrls = map (flip valueShow attvarr) antls + cstr = valueShow con attvarr++-- show a group of ambiguities, same antecedent, different consequent!+groupAmbigShow :: [([AVp], AVp)] -> NameArray -> String+groupAmbigShow ambigs attvarr = + concatSperse "\n" ambstrls where+ ambstrls = map (flip oneAmbigShow attvarr) ambigs +++-- get the head of a table with ambiguities +ambigTbHead :: ([AVp],AVp) -> NameArray -> String+ambigTbHead (_,con) attvarr = csvstr ++ ",," ++ castr where+ castr = attribShow ca attvarr+ csvstr = concatSperse "," antstrls+ antstrls = map (flip attribShow attvarr) antrow+ antrow = delete ca (indices attvarr)+ ca = fst con+++-- | show all ambiguous rules in an OO Calc .csv table+ambigTbShow :: [[([AVp], AVp)]] -> NameArray -> String+ambigTbShow allamb attvarr = concatSperse "\n\n" (h:ambstrls)+ where h = ambigTbHead one attvarr+ ambstrls = map (flip groupAmbigShow attvarr) allamb + one = head (head allamb) +------------------------------------------------------------------------------+----------------------------- abduction graph ---------------------------++-- transform a graph of equivalent rules to one of +-- the node numbers (legend) and the number of rules in the equals group+graphDisp :: Gr [Rule] () -> Gr (Int,Int) ()+graphDisp agr = gmap t agr + where t (p,nd,rls,s) = (p,nd, (nd,length rls),s) ++-- standard fgl function with defaults. Page matrix is sqrt of number of nodes. +-- Page is smallest of A4 and US Letter. Specific graph type used, not class.+graphToDot :: Gr (Int,Int) () -> String -> String+graphToDot graph name = + graphviz graph name (8.3,11.0) (pgn,pgn) Portrait + where pgn = 1 + (round . sqrt . (/ nodpp) . fromIntegral) (noNodes graph)+ nodpp = 50.0 :: Double++-- | show a graph of the abductions for a selected consequent value+-- watch the name, the GraphViz program does not accept all characters!+eqivGraphShow :: Gr [Rule] () -> String -> String+eqivGraphShow graph name = graphToDot (graphDisp graph) name ++-- show a sorted list of equivalent antecedents, with their common consequent+-- N.B starts with a legend, after each newline an empty field+eqivShow :: LNode [Rule] -> NameArray -> String+eqivShow (nd,eqivs) attvarr = leg ++ "," ++ antstr ++ ",\"implies\"," ++ cvstr+ where leg = (toCalc . show) nd+ antstr = concatSperse ",\"equals\"\n," antstrls+ antstrls = map (flip antecTbRow attvarr) srtls+ srtls = sortRdsByLength eqivs+ cvstr = valueShow ((snd . head) eqivs) attvarr++-- | get a legend table for the abduction graph (for ONE consequent value)+-- N.B. table head must move one to the right+legendGrTbShow :: Gr [Rule] () -> NameArray -> String+legendGrTbShow rg attvarr = concatSperse "\n\n" (h:eqivstrls)+ where h = ',':(ruleTbHead ex attvarr) + eqivstrls = map (flip eqivShow attvarr) ndls+ ex = (head . snd . head) ndls+ ndls = labNodes rg+------------------------------------------------------------------------------+
+ src/DefRules.hs view
@@ -0,0 +1,112 @@+{- | Emping 0.6 (provisional)++Tue 19 May 2009 05:52:26 PM CEST ++Module DefRules contains functions to transform a coded table of attribute value rows into nominal rules of the form: antecedent implies consequent. +The consequent is a value of a (user selected) attribute, and the antecedent is a conjunction of values of (other) attributes++A coded fact list can be checked for duplicates, though duplicate rows in a table do not affect the results. +Rules are called ambiguous, if they have the same antecedent but a different consequent. Ambiguous rules do have an effect. Any sub set of the duplicate antecedent would be a contradiction, and is therefore excluded as a reduction.++If the table is not fully normalized, ALL rules for some consequent value may be+ambiguous. Then there are no reduced rules for that consequent! -}++module DefRules (getDups, cleanFacts, getAmbiguousRules,factsToPartition,+ factsTo_NB_Partition, hasBlankValues, Antec, Rule, partitionToSets ) where++import Data.List (partition, elemIndex )+import Data.Array (Array, (!), elems ) +import Data.Set (Set, fromList )+import Codec (AVp )+import CsvParse ( blankId )++-- partDups partitions an list of AVp lists into duplicates and their counts. +partDups :: [[AVp]] -> [([[AVp]], Int)]+partDups tb = [(x, length x) | x <- parts ] where+ parts = partitionBy (\x y -> x == y ) tb++-- | get a representative of each duplicate AVp list, with its frequency, or []+getDups :: [[AVp]] -> [([AVp],Int)]+getDups tb | dbls == [] = []+ | otherwise = [ ((head . fst) x, snd x) | x <- dbls ] + where + dbls = [ x | x <- dupfacs, (snd x) > 1 ]+ dupfacs = partDups tb++-- removes all duplicates from list of AVp lists, also works if there are none+remDups :: [[AVp]] -> [[AVp]]+remDups tb = map (head . fst) dupfacs + where dupfacs = partDups tb++-- split an AVP list into an antecedent consequent pair+-- works because only one value of an attribute can be in a conjunction+f2r :: Int -> [AVp] -> ([AVp],AVp)+f2r att fact = (ant, cons) where + (ant, [cons]) = partition (\u -> (fst u) /= att) fact++-- split all rows in the coded table in antecedent consequent pairs+factsToRules :: Int -> [[AVp]] -> [([AVp],AVp)]+factsToRules att fls = map (f2r att) fls++-- remove rules with a blank consequent value+remBlankConseq :: Array Int (String, [String]) -> [([AVp],AVp)] -> [([AVp],AVp)]+remBlankConseq namearr ruls = + case blankix of+ Nothing -> ruls+ Just blank -> filter (\u -> (snd $ snd u) /= blank) ruls + where att = (fst .snd . head) ruls+ blankix = elemIndex blankId (snd (namearr ! att))++-- partitions list of antecedent consequent pairs to consequents +partitionRules :: [([AVp],AVp)] -> [[([AVp], AVp)]]+partitionRules ruls = partitionBy (\x y -> (snd x) == (snd y)) ruls ++-- | get all ambiguous rules and fact duplicates (!!!!) in a rule partition +getAmbiguousRules :: [[([AVp], AVp)]] -> [[([AVp], AVp)]]+getAmbiguousRules grp = filter (\x -> (length x) > 1) anteqs + where anteqs = partitionBy eq (concat grp)+ eq (a1, _) (a2,_) = a1 == a2++-- | if the user decides to check, duplicates are removed+cleanFacts :: Bool -> [[AVp]] -> [[AVp]]+cleanFacts clean tb | clean = remDups tb+ | otherwise = tb++-- | gets rules (from clean facts or not) and partitions them+factsToPartition :: Int -> [[AVp]] -> [[([AVp],AVp)]]+factsToPartition att tb = partitionRules $ factsToRules att tb++factsTo_NB_Partition :: Array Int (String, [String]) -> Int -> [[AVp]] -> [[([AVp],AVp)]]+factsTo_NB_Partition namearr att tb = + partitionRules $ remBlankConseq namearr $ factsToRules att tb++-- | checks for any blank values in data, attributes are not checked+hasBlankValues :: Array Int (String, [String]) -> Bool+hasBlankValues namearr = any hasbl values + where values = (snd . unzip . elems) namearr+ hasbl ls = case elemIndex blankId ls of+ Nothing -> False+ _ -> True++-- | type synonym for an antecedent as a set of attribute-value pairs+type Antec = Set AVp+-- | type synonym for a rule with an antecedent as a set+type Rule = (Antec, AVp)++-- transform the antecedent of a rule into a Set+r2set :: ([AVp], AVp) -> Rule+r2set (a,c) = (fromList a, c)++-- | transform the antecedents of all rules to Sets+partitionToSets :: [[([AVp],AVp)]] -> [[Rule]]+partitionToSets prt = map (map r2set) prt+ +--------------- general helper function -------------------------------+-- partitions a list according to an equivalence relation+partitionBy :: (a -> a -> Bool) -> [a] -> [[a]]+partitionBy _ [] = []+partitionBy eq ls = x:(partitionBy eq y) where+ (x,y) = partition ((head ls) `eq`) ls +------------------------------------------------------------------------++
src/Main.hs view
@@ -1,33 +1,27 @@ {- | Module Main -Emping 0.5 (provisional)--Module Main performs the GUI and I\/O tasks for the reduction of heuristic rules. The input consists of facts -in a comma separated file (.csv) format as produced by the Open Office Calc spreadsheet. The rule output is in the same-format and can be read by OO Calc. Dependencies between reduced rules may be shown as a graph in .dot format, which can-be viewed with a GraphViz viewer like dotty or gzviewer.+Emping 0.6 (provisional) -The user can open a .csv file, select an attribute which is to be the consequent, and Emping will find all shortest rules-which predict the values of the selected attribute. +Module Main performs the GUI and I\/O tasks for the reduction and abduction of heuristic rules. The input is a table in a comma separated file (.csv) format as produced by the Open Office Calc spreadsheet. The reduction output is in the same format and can be read by OO Calc. Dependencies between reduced rules are shown as a graph in .dot format, which can be viewed with a GraphViz viewer like dotty or gzviewer. -The user can set whether the facts will be checked for duplicates, and for ambiguous rules (those with the same -antecedent but a different consequent). Graph may be displayed as entailments (top down) or implications (the reversed graph).+The user can open a .csv file, select an attribute which is to be the consequent, and Emping will find all shortest rules which predict the values of the selected attribute.+For the same attribute, the user can select a value, and Emping will find implications (entailments) between the reduced rules. -See the white paper \"Deriving Heuristic Rules from Facts\" (January 2007) for more on the foundation and algorithm.+For example, in a table containing the name of a disease, and 'yes' and 'no' in its column, with a list of symptoms and values like 'yes', 'no', or 'absent', 'mild', 'severe', and so on, in the table rows, Emping will find the smallest sets of symptoms that predict that disease, and also those that predict its absence. +Selecting 'yes' will then produce a graph of all relationships between the groups of symptoms that predict the disease. Selecting 'no' will find the relationships between the syptom sets that disprove that disease. -Wed 16 Apr 2008 01:14:12 PM CEST +See the white paper \"Deriving Heuristic Rules from Facts\" (January 2007) for more on the foundation and algorithm. --}+Tue 26 May 2009 05:23:44 PM CEST -} module Main (main) where import Graphics.UI.Gtk import Control.Concurrent-import Data.IORef+import Data.Maybe (fromJust) import Data.Array-import Data.Graph.Inductive-import Aux-import CSVParse+import CsvParse import Codec-import CSVTable+import DefRules+import CsvTable import Reduce import Abduce @@ -36,381 +30,414 @@ initGUI timeoutAddFull (yield >> return True) priorityDefaultIdle 50 window <- windowNew- set window [windowTitle := "Emping", windowDefaultWidth := 400,- windowDefaultHeight := 100]+ set window [windowTitle := "Emping", windowDefaultWidth := 470,+ windowDefaultHeight := 140] vbox1 <- vBoxNew False 0 containerAdd window vbox1 - opensrc <- actionNew "OpenSrc" "Open" (Just "Open a source .csv file") (Just stockOpen)- options <- actionNew "OptionMenu" "Options" (Just "Check for duplicates and ambiguities") (Just stockProperties)- selcons <- actionNew "SelCons" "Consequent" (Just "Select the attribute which will be the rule consequent") (Just stockNew)- reduact <- actionNew "ReduAct" "Reduce" (Just "Get the reduced normal form of the rules") (Just stockConvert)- abdutop <- actionNew "AbduTop" "Top" (Just "Get only the top level of all implications") (Just stockGotoTop)- filemen <- actionNew "FileMenu" "File" (Just "Open and exit") (Just stockFile)- quitact <- actionNew "QuitAct" "Quit" Nothing (Just stockQuit)- grphmen <- actionNew "GrphMen" "Rule Graphs" (Just "Display rule graphs or legend") (Just stockGotoBottom)- attgrph <- actionNew "AttGrph" "Attribute" (Just "Get the graph of implications for the attribute") (Just stockZoom100)- valgrph <- actionNew "ValGrph" "Per Value" (Just "Get the graph of implications for an attribute value") (Just stockZoomIn)- glegend <- actionNew "GleGend" "Legend" (Just "Legend of all nodes in the implication graph") (Just stockUnderline)+ file <- actionNew "FileMenu" "File" (Just "Open and exit") (Just stockFile)+ newsrc <- actionNew "NewSrc" "New Table" (Just "Get a new source (.csv) file") (Just stockNew)+ open <- actionNew "OpenSrc" "Open" (Just "Open a source (.csv) file") (Just stockOpen)+ dupchk <- toggleActionNew "DupChck" "Table Check" (Just "Check table for duplicate rows") Nothing+ quit <- actionNew "QuitAct" "Quit" Nothing (Just stockQuit) - duptogg <- toggleActionNew "DupCheck" "Check Data" (Just "Check facts for duplicates") Nothing- ambtogg <- toggleActionNew "AmbCheck" "Check Rules" (Just "Check rules for ambiguity") Nothing- revtogg <- toggleActionNew "RevGraph" "Reverse" (Just "Get the graphs in reverse direction") Nothing+ rule <- actionNew "RuleMenu" "Rule" (Just "Construct a rule") (Just stockNew)+ newatt <- actionNew "NewAtt" "New Rules" (Just "Define a new consequent attribute") (Just stockNew)+ cons <- actionNew "SelCons" "Select" (Just "Select the attribute which is to be the consequent") (Just stockProperties)+ ambchk <- toggleActionNew "AmbChck" "Rule Check" (Just "Check whether some rules are ambiguous") Nothing - toggleActionSetActive duptogg True - toggleActionSetActive ambtogg True+ rdmenu <- actionNew "RedMenu" "Reduction" (Just "Reduced normal form of all the rules") (Just stockConvert)+ reduce <- actionNew "Reduce" "Reduce All" (Just "Reduce all rules to shortest") (Just stockExecute) - actgrp <- actionGroupNew "ActGrp"- mapM_ (actionGroupAddAction actgrp) [opensrc,options,selcons,reduact,abdutop,filemen,quitact,grphmen,attgrph,valgrph,glegend]- mapM_ (actionGroupAddAction actgrp) [duptogg,ambtogg,revtogg]+ abmenu <- actionNew "AbduMenu" "Abduction" (Just "Entailments of rules with the same consequent") (Just stockSortDescending)+ abdsel <- actionNew "SelAbd" "Choose" (Just "Select consequent value for rule abduction") (Just stockProperties)+ abduce <- actionNew "Abduce" "Abduce" (Just "Show rule entailments for selected consequent") (Just stockZoom100)+ abdgsl <- toggleActionNew "AbdGsl" "Most General" (Just "Checked is most, unchecked is least general") Nothing+ abdmlg <- actionNew "AbdMgn" "M/L General" (Just "Show most/least general rules for selected consequent") (Just stockGotoBottom) + infmenu <- actionNew "InfMenu" "About" (Just "Summary Information") Nothing+ about <- actionNew "About" "About" (Just "Summary Information") (Just stockAbout)++ actgrp <- actionGroupNew "ActGrp" + mapM_ (actionGroupAddAction actgrp) [file,newsrc,open,quit,rule,newatt, cons,rdmenu,reduce,abmenu,abdsel,abduce, abdmlg,infmenu,about]+ mapM_ (flip actionSetSensitive False) [newsrc,cons,newatt,reduce,abdsel,abduce,abdmlg]+ mapM_ (actionGroupAddAction actgrp) [dupchk,ambchk,abdgsl]+ toggleActionSetActive dupchk False + toggleActionSetActive ambchk True+ toggleActionSetActive abdgsl True+ manager <- uiManagerNew uiManagerAddUiFromString manager uiDecl uiManagerInsertActionGroup manager actgrp 0 mbMenubar <- uiManagerGetWidget manager "ui/menubar"- let menubar = case mbMenubar of- Just x -> x- Nothing -> error "Main: Cannot get menubar from String"- boxPackStart vbox1 menubar PackNatural 0- mbToolbar <- uiManagerGetWidget manager "ui/toolbar"- let toolbar = case mbToolbar of- Just x -> x- Nothing -> error "Main: Cannot get toolbar from String"- boxPackStart vbox1 toolbar PackNatural 0 + boxPackStart vbox1 (fromJust mbMenubar) PackNatural 0 - status <- statusbarNew- boxPackStart vbox1 status PackNatural 0- gencontext <- statusbarGetContextId status "General" + stbar <- statusbarNew+ boxPackEnd vbox1 stbar PackNatural 0+ stcx <- statusbarGetContextId stbar "General" + mbToolbar <- uiManagerGetWidget manager "ui/toolbar"+ boxPackEnd vbox1 (fromJust mbToolbar) PackNatural 0 + filesrc <- fileChooserDialogNew (Just "Source File in CSV") (Just window) FileChooserActionOpen [("Cancel", ResponseCancel), ("Open", ResponseAccept)]- filesave <- fileChooserDialogNew (Just "Save File") (Just window)- FileChooserActionSave- [("Cancel", ResponseCancel), ("Save", ResponseAccept)]- fileChooserSetDoOverwriteConfirmation filesave True- csvfilt <- fileFilterNew fileFilterAddPattern csvfilt "*.csv" fileFilterSetName csvfilt "CSV Source" fileChooserAddFilter filesrc csvfilt - attpopman <- uiManagerNew - attpopgrp <- actionGroupNew "Popup Att Select"+ filesave <- fileChooserDialogNew (Just "Save File") (Just window)+ FileChooserActionSave+ [("Cancel", ResponseCancel), ("Save", ResponseAccept)]+ fileChooserSetDoOverwriteConfirmation filesave True - valpopman <- uiManagerNew- valpopgr <- actionGroupNew "Popup Value Select"+ apop <- windowNewPopup+ set apop [ windowDefaultWidth := 100, windowDefaultHeight := 100, + windowTypeHint := WindowTypeHintCombo, windowWindowPosition := WinPosMouse] + apbox <- vBoxNew False 0+ containerAdd apop apbox+ asb <- comboBoxNewText+ set asb [comboBoxHasFrame := True]+ boxPackStart apbox asb PackGrow 0 - mapM_ ((flip actionSetSensitive) False) [selcons, reduact,abdutop,attgrph,valgrph,glegend]+ vpop <- windowNewPopup+ set vpop [ windowDefaultWidth := 100, windowDefaultHeight := 100, + windowTypeHint := WindowTypeHintCombo, windowWindowPosition := WinPosMouse] + vpbox <- vBoxNew False 0+ containerAdd vpop vpbox+ vsb <- comboBoxNewText+ set vsb [comboBoxHasFrame := True]+ boxPackStart vpbox vsb PackGrow 0 - mvrNameArray <- newEmptyMVar- mvrSingleFacts <- newEmptyMVar- mvrSelCons <- newEmptyMVar- mvrRules <- newEmptyMVar- mvrReductions <- newEmptyMVar- mvrNodeGroup <- newEmptyMVar- mvrValPopup <- newEmptyMVar+ globNameArray <- newEmptyMVar + globTableCode <- newEmptyMVar + globRulesPartition <- newEmptyMVar+ globAttIndex <- newEmptyMVar + globAllReds <- newEmptyMVar + globAbduReds <- newEmptyMVar + globAbduOrigs <- newEmptyMVar+ globAbdGraph <- newEmptyMVar + globAttLength <- newEmptyMVar+ globValLength <- newEmptyMVar - hasValPopup <- newIORef False + abop <- windowNewPopup+ set abop [windowDefaultWidth := 100, windowDefaultHeight := 100, + windowTypeHint := WindowTypeHintNotification]+ abovb <- vBoxNew False 0+ containerAdd abop abovb + abclose <- buttonNewFromStock stockClose+ boxPackStart abovb abclose PackNatural 0+ frame <- frameNew+ boxPackStart abovb frame PackNatural 0+ label <- labelNew (Just "\n\n Emping: version 0.6\n (c) 2006-2009 Hans van Thiel \n Licence: GPL\n www.muitovar.com\n\n")+ containerAdd frame label+ frameSetShadowType frame ShadowOut+ widgetModifyBg abop StateNormal (Color 0 0 35000)+ widgetModifyFg label StateNormal (Color 65535 65535 65535 )+ image <- imageNewFromFile "./HaskellM.png"+ boxPackStart abovb image PackNatural 0 - onActionActivate opensrc $ do - mbf1 <- mygetFileName filesrc- case mbf1 of- Nothing -> return () - Just fpath1 -> do { statusbarPush status gencontext "Reading and parsing source..."- ;forkIO $ do { - ;strl <- getTable fpath1 - ;let stfacts = tableCode strl- stnamearray = tableToArray strl - ;stsinglefacts <- getNoDuplicates duptogg filesave status gencontext stnamearray stfacts - ;putMVar mvrNameArray stnamearray- ;putMVar mvrSingleFacts stsinglefacts - ;actionSetSensitive selcons True - } - ;actionSetSensitive opensrc False-- } - - onActionActivate selcons $ do {- slnamearray <- readMVar mvrNameArray- ;singlefacts <- readMVar mvrSingleFacts+ onActionActivate newsrc $ do { -- reset everything+ mapM_ (flip actionSetSensitive False) [open,cons,reduce,abdsel,abduce,abdmlg]+ ;tryTakeMVar globNameArray + ;tryTakeMVar globTableCode+ ;tryTakeMVar globRulesPartition + ;tryTakeMVar globAttIndex + ;tryTakeMVar globAllReds + ;tryTakeMVar globAbduReds + ;tryTakeMVar globAbduOrigs+ ;tryTakeMVar globAbdGraph+ ;attln1 <- takeMVar globAttLength -- at reset, there's always a combo initialised+ ;clearCombo asb attln1+ ;mbvalln1 <- tryTakeMVar globValLength+ ;case mbvalln1 of+ Nothing -> return ()+ Just valln1 -> clearCombo vsb valln1 + ;statusbarPush stbar stcx "Open another source file..."+ ;actionSetSensitive open True+ } -- end newsrc - ;let choice = map (\ind -> (RadioActionEntry (show ind) (fst (slnamearray ! ind)) Nothing Nothing Nothing ind)) (indices slnamearray)--- dummy because of radioActionGetCurrentValue and RadioActionEntry. Selection of already selected does nothing.- dummy = [RadioActionEntry (show lst) "None" Nothing Nothing Nothing lst] where lst = length (indices slnamearray)- dumchoice = concat [choice,dummy]- popmstr = "<ui><popup>" ++ (concatMap itstr dumchoice) ++ "</popup></ui>"- itstr x = "<menuitem action=\"" ++ (radioActionName x) ++ "\" />" - myChange ra = do { cons <- radioActionGetCurrentValue ra- ;let consname = (fst (slnamearray ! cons))- ;statusbarPush status gencontext ("The consequent attribute is: " ++ consname)- ;let rules = facts2Rules cons singlefacts- ;noamb <- noAmbiguities ambtogg filesave status gencontext slnamearray cons rules- ;if noamb then do { putMVar mvrSelCons cons- ;putMVar mvrRules rules+ onActionActivate open $ do + mbf1 <- empFileName filesrc+ case mbf1 of+ Nothing -> return () + Just fpath1 -> do + { statusbarPush stbar stcx "Reading and parsing .csv table..." + ;dp <- get dupchk toggleActionActive+ ;forkIO $ do { + ;tbstr <- getTable fpath1 + ;let attvarr1 = tableToArray tbstr+ tbcod1 = tableCode tbstr+ ;if dp then postGUIAsync $ saveDups filesave stbar stcx attvarr1 tbcod1+ else return ()+ ;let als = (fst . unzip) (elems attvarr1) + ;postGUIAsync $ mapM_ (comboBoxAppendText asb) als + ;putMVar globAttLength (length als) -- initialize new attribute list+ ;putMVar globNameArray attvarr1 -- should be empty if reset by action new+ ;putMVar globTableCode (cleanFacts dp tbcod1) -- only no dupplicates guaranteed if user checked the box! + ;postGUIAsync $ actionSetSensitive newsrc True+ ;postGUIAsync $ actionSetSensitive cons True + ;postGUIAsync $ statusbarPush stbar stcx ".csv table read and parsed.." >> return () + } -- end fork + ;actionSetSensitive open False+ } -- end Just - ;actionSetSensitive selcons False- ;actionSetSensitive reduact True- }- else return ()- } - ;uiManagerInsertActionGroup attpopman attpopgrp 0 - ;actionGroupAddRadioActions attpopgrp dumchoice ((length dumchoice) -1) myChange - ;uiManagerAddUiFromString attpopman popmstr+ onActionActivate newatt $ do { -- just like newsrc, except for the source table and its name array and the attribute length ??+ mapM_ (flip actionSetSensitive False) [reduce,abdsel,abduce,abdmlg]+ ;tryTakeMVar globRulesPartition + ;tryTakeMVar globAttIndex + ;tryTakeMVar globAllReds + ;tryTakeMVar globAbduReds + ;tryTakeMVar globAbduOrigs + ;tryTakeMVar globAbdGraph + ;mbvalln2 <- tryTakeMVar globValLength+ ;case mbvalln2 of+ Nothing -> return ()+ Just valln2 -> clearCombo vsb valln2 + ;comboBoxSetActive asb (-1)+ ;actionSetSensitive cons True+ ;statusbarPush stbar stcx "Define rules with another consequent attribute..." + ;return ()+ } - ;mbpopup <- uiManagerGetWidget attpopman "/ui/popup"- ;let attpopup = case mbpopup of- Nothing -> error "Main: no popup menu for consequent attribute selection"- Just x -> x - ;menuPopup (castToMenu attpopup) Nothing + onActionActivate cons $ do widgetShowAll apop+ + onChanged asb $ do { + mbasix1 <- comboBoxGetActive asb + ;ambp <- get ambchk toggleActionActive + ;if ambp then statusbarPush stbar stcx "Building rules and checking for ambiguities..."+ else statusbarPush stbar stcx "Building rules..."+ ;case mbasix1 of + Nothing -> return ()+ Just asix1 -> do {+ forkIO $ do {+ ;tbcod2 <- readMVar globTableCode + ;attvarr2 <- readMVar globNameArray+ ;let rlspart = factsToPartition asix1 tbcod2+ rsp = partitionToSets rlspart + ;if ambp + then postGUIAsync $ saveAmbs filesave stbar stcx attvarr2 rlspart+ else postGUIAsync $ (statusbarPush stbar stcx "Not checked for ambiguous rules...") >> return () + ;putMVar globRulesPartition rsp -- write rules + ;putMVar globAttIndex asix1 -- write which attribute+ ;postGUIAsync $ actionSetSensitive reduce True+ ;postGUIAsync $ actionSetSensitive newatt True+ } -- end forkIO+ ;actionSetSensitive cons False+ } -- end Just+ ;widgetHideAll apop+ } -- end onChange + onActionActivate reduce $ do {+ statusbarPush stbar stcx "Reducing all rules, this may take a while..."+ ;forkIO $ do { + asix2 <- readMVar globAttIndex+ ;attvarr3 <- readMVar globNameArray+ ;let attname = fst (attvarr3 ! asix2) + ;allorigs1 <- readMVar globRulesPartition + ;let allreds1 = reduceAll allorigs1+ ;mbf1 <- empFileName filesave + ;case mbf1 of + Nothing -> postGUIAsync $ statusbarPush stbar stcx ("Save of reduced rules for " ++ attname ++ " cancelled") >> return ()+ Just fpath -> do writeFile (fpath ++ ".csv") (redTbShow allreds1 attvarr3)+ postGUIAsync $ statusbarPush stbar stcx ("Finished reduction for " ++ attname ) >> return ()+ ;putMVar globAllReds allreds1 + ;mbvalln3 <- tryTakeMVar globValLength + ;case mbvalln3 of+ Nothing -> return ()+ Just valln3 -> postGUIAsync $ clearCombo vsb valln3 -- remove any previous value strings+ ;let vls = snd (attvarr3 ! asix2) + ;postGUIAsync $ mapM_ (comboBoxAppendText vsb) vls + ;putMVar globValLength (length vls) -- initialize value selection for abduction + ;actionSetSensitive abdsel True+ } -- end forkIO + ;actionSetSensitive abduce False+ ;actionSetSensitive abdmlg False+ ;actionSetSensitive reduce False ;return ()- } + } -- end reduce - onActionActivate reduact $ do - mbf2 <- mygetFileName filesave- case mbf2 of- Nothing -> return () - Just fpath2 -> do { statusbarPush status gencontext "Reducing rules, this may take a while..."- ;forkIO $ do { + onActionActivate abdsel $ widgetShowAll vpop - rdnamearray <- readMVar mvrNameArray- ;rdrules <- readMVar mvrRules - ;rdcons <- readMVar mvrSelCons - - ;let rdconsname = (fst (rdnamearray ! rdcons))- reductions = reduceAll rdrules- - ;writeFile fpath2 (rnf2CSVTb rdnamearray rdrules reductions)- ;statusbarPush status gencontext ("Finished reduction for " ++ rdconsname)+ onChanged vsb $ do { + mbvsix <- comboBoxGetActive vsb+ ;mbvnam1 <- comboBoxGetActiveText vsb+ ;if mbvsix == Nothing || mbvnam1 == Nothing + then return ()+ else do {+ let vsix = fromJust mbvsix+ vnam1 = fromJust mbvnam1+ ;forkIO $ do {+ ;allreds2 <- readMVar globAllReds -- selection can be called more times+ ;allorigs2 <- readMVar globRulesPartition+ ;let abdr1 = filter (\r -> snd (snd r) == vsix) (concat allreds2) -- all reduced rules for that value+ orig1 =filter (\r -> snd (snd r) == vsix) (concat allorigs2) -- all original rules for that value + ;if abdr1 == [] + then postGUIAsync $ statusbarPush stbar stcx ("No rules found, for " ++ vnam1 ++ " ,possibly because of ambiguity") >> return ()+ else do { + tryTakeMVar globAbduReds -- user can select another without doing abduction on the prior one+ ;putMVar globAbduReds abdr1+ ;tryTakeMVar globAbduOrigs+ ;putMVar globAbduOrigs orig1+ ;postGUIAsync $ actionSetSensitive abduce True+ } -- end else+ } -- end forkIO+ ;return ()+ } -- end else+ ;actionSetSensitive abdsel False+ ;widgetHideAll vpop+ } -- end onChanged - ;putMVar mvrReductions reductions+ onActionActivate abduce $ do {+ statusbarPush stbar stcx "Searching for rule entailments"+ ;(Just vnam2) <- comboBoxGetActiveText vsb+ ;forkIO $ do {+ abdr2 <- readMVar globAbduReds + ;orig2 <- readMVar globAbduOrigs+ ;attvarr4 <- readMVar globNameArray+ ;asix3 <- readMVar globAttIndex+ ;let abg1 = abduceReds abdr2 orig2+ anam = fst (attvarr4 ! asix3 )+ ;tryTakeMVar globAbdGraph+ ;putMVar globAbdGraph abg1+ ;if graphHasImps abg1 == False + then postGUIAsync $ statusbarPush stbar stcx ("No entailments in " ++ anam ++ " : " ++ vnam2 ++ " rules") >> return ()+ else do {+ mbf2 <- empFileName filesave + ;case mbf2 of + Nothing -> postGUIAsync $ statusbarPush stbar stcx ("Save of entailment results for " ++ anam ++ " : " ++ vnam2 ++ " cancelled") >> return ()+ Just fpath -> do writeFile (fpath ++ ".dot") (eqivGraphShow abg1 "emping")+ writeFile (fpath ++ ".csv") (legendGrTbShow abg1 attvarr4) + postGUIAsync $ statusbarPush stbar stcx ("Saved rule entailments for " ++ anam ++ " : " ++ vnam2 ) >> return ()+ actionSetSensitive abdsel True+ } -- end else+ } -- end forkIO+ ;actionSetSensitive abduce False+ ;actionSetSensitive abdsel False+ ;actionSetSensitive abdmlg True+ } -- end abduce - ;actionSetSensitive abdutop True- ;actionSetSensitive glegend True- } - ;actionSetSensitive reduact False - } + onActionActivate abdmlg $ do {+ mstg <- get abdgsl toggleActionActive+ ;let cs = if mstg then " most " else " least "+ ;statusbarPush stbar stcx ("Getting" ++ cs ++ "general rules")+ ;forkIO $ do {+ attvarr5 <- readMVar globNameArray+ ;abg2 <- readMVar globAbdGraph+ ;let mgg = graphMLGen mstg abg2+ ;mbf3 <- empFileName filesave+ ;case mbf3 of + Nothing -> postGUIAsync $ statusbarPush stbar stcx ("Save of" ++ cs ++ "general rules cancelled") >> return ()+ Just fpath -> do writeFile (fpath ++ ".csv") (legendGrTbShow mgg attvarr5) + postGUIAsync $ statusbarPush stbar stcx ("Saved" ++ cs ++ "general rules") >> return () + } -- end fork+ ; return ()+ } -- end activate - onActionActivate abdutop $ do - mbf3 <- mygetFileName filesave- case mbf3 of - Nothing -> return ()- Just fpath3 -> do { statusbarPush status gencontext "Checking for rule dependencies.."- ;forkIO $ do {- abnamearray <- readMVar mvrNameArray- ;abrules <- readMVar mvrRules - ;abcons <- readMVar mvrSelCons- ;abreductions <- readMVar mvrReductions - - ;let abconsname = (fst (abnamearray ! abcons)) - topsgroup = abduceTopAll abrules abreductions - ;if not (hasDependencies topsgroup abreductions) then do - { statusbarPush status gencontext ("There are no dependencies in reductions for " ++ abconsname)- ;actionSetSensitive abdutop False- } - else do { - writeFile fpath3 (allTops2CSVTb abnamearray abrules topsgroup)- ;statusbarPush status gencontext ("Saved most general reductions for " ++ abconsname) - ;return () - }- }- ;actionSetSensitive abdutop False- } - - onActionActivate glegend $ do - mbf4 <- mygetFileName filesave- ;case mbf4 of - Nothing -> return ()- Just fpath4 -> do { forkIO $ do {- glnamearray <- readMVar mvrNameArray- ;glcons <- readMVar mvrSelCons- ;glrules <- readMVar mvrRules - ;glreductions <- readMVar mvrReductions - ;let glconsname = (fst (glnamearray ! glcons)) - nodegroup = orgReg2Ndg glrules glreductions - ;statusbarPush status gencontext "Getting graph legend, this may take a while..."- ;let graphlegend = nodeLegend glreductions nodegroup- ;writeFile fpath4 (allNodes2CSVTb glnamearray glrules graphlegend)- ;statusbarPush status gencontext ("Saved graph legend for " ++ glconsname)-- ;putMVar mvrNodeGroup nodegroup- }- ;actionSetSensitive attgrph True - ;actionSetSensitive valgrph True- ;actionSetSensitive glegend False - } -- onActionActivate attgrph $ do - mbf5 <- mygetFileName filesave- case mbf5 of- Nothing -> return () - Just fpath5 -> do { statusbarPush status gencontext "Building rule dependency graph..."- ;forkIO $ do {- agnamearray <- readMVar mvrNameArray- ;agcons <- readMVar mvrSelCons- ;agnodegroup <- readMVar mvrNodeGroup-- ;let agconsname = (fst (agnamearray ! agcons)) - ;revset <- get revtogg toggleActionActive- ;let fullgraph = implicGraphAll agnodegroup - displaygraph | revset = grev fullgraph- | otherwise = fullgraph- ;writeFile fpath5 (graph2DOT displaygraph agconsname)- ;statusbarPush status gencontext ("Saved rule dependency graph for " ++ agconsname)- ;return ()- }- ;return () - } -- onActionActivate valgrph $ do { ppres <- readIORef hasValPopup- ;if ppres then return ()- else do {- vgnamearray <- readMVar mvrNameArray- ;vgcons <- readMVar mvrSelCons- ;vgnodegroup <- readMVar mvrNodeGroup-- ;let grphvalues = snd (vgnamearray ! vgcons) -- define the value menu for valgrph here- valindices = [0..((length grphvalues)-1)]- valchoice = map (\ind -> (RadioActionEntry (show ind) (grphvalues !! ind) Nothing Nothing Nothing ind)) valindices--- dummy value, as with selcons- valdummy = [RadioActionEntry (show lst) "None" Nothing Nothing Nothing lst] where lst = length valindices- valdumchoice = concat [valchoice,valdummy]- valpopmstr = "<ui><popup>" ++ (concatMap vitstr valdumchoice) ++ "</popup></ui>" -- itstr defined above- vitstr x = "<menuitem action=\"" ++ (radioActionName x) ++ "\" />" - ;actionGroupAddRadioActions valpopgr valdumchoice ((length valdumchoice) -1) - (myValChange vgnodegroup filesave status gencontext vgnamearray vgcons revtogg)- ;uiManagerAddUiFromString valpopman valpopmstr- ;uiManagerInsertActionGroup valpopman valpopgr 0-- ;mbvalpopup <- uiManagerGetWidget valpopman "/ui/popup"- ;let valpopup = case mbvalpopup of- Nothing -> error "Main: no popup menu for value selection of graph"- Just x -> x+ onActionActivate about $ widgetShowAll abop - ;putMVar mvrValPopup valpopup- ;writeIORef hasValPopup True- } -- end else- ;vgvalpopup <- readMVar mvrValPopup- ;menuPopup (castToMenu vgvalpopup) Nothing - ;return ()- } + onClicked abclose $ widgetHideAll abop widgetShowAll window-- onActionActivate quitact (widgetDestroy window)-+ onActionActivate quit $ do {+ widgetDestroy window + ;widgetDestroy apop + ;widgetDestroy vpop+ ;widgetDestroy abop+ } onDestroy window mainQuit mainGUI -- uiDecl :: String uiDecl = "<ui>\ \ <menubar>\ \ <menu action=\"FileMenu\">\+\ <menuitem action=\"NewSrc\" />\ \ <menuitem action=\"OpenSrc\" />\+\ <menuitem action=\"DupChck\" />\ \ <menuitem action=\"QuitAct\" />\ \ </menu>\-\ <menu action=\"OptionMenu\">\-\ <menuitem action=\"DupCheck\" />\-\ <menuitem action=\"AmbCheck\" />\+\ <menu action=\"RuleMenu\">\+\ <menuitem action=\"NewAtt\" />\+\ <menuitem action=\"SelCons\" />\+\ <menuitem action=\"AmbChck\" />\+\ </menu>\+\ <menu action=\"RedMenu\">\+\ <menuitem action=\"Reduce\" />\ \ </menu>\-\ <menu action=\"GrphMen\">\-\ <menuitem action=\"RevGraph\" />\-\ <menuitem action=\"AttGrph\" />\-\ <menuitem action=\"ValGrph\" />\-\ <menuitem action=\"GleGend\" />\+\ <menu action=\"AbduMenu\">\+\ <menuitem action=\"SelAbd\" />\+\ <menuitem action=\"Abduce\" />\+\ <menuitem action=\"AbdGsl\" />\+\ <menuitem action=\"AbdMgn\" />\ \ </menu>\+\ <menu action=\"InfMenu\">\+\ <menuitem action=\"About\" />\+\ </menu>\ \ </menubar>\ \ <toolbar>\ \ <toolitem action=\"OpenSrc\" />\ \ <toolitem action=\"SelCons\" />\-\ <toolitem action=\"ReduAct\" />\-\ <toolitem action=\"AbduTop\" />\+\ <toolitem action=\"Reduce\" />\+\ <toolitem action=\"SelAbd\" />\+\ <toolitem action=\"Abduce\" />\ \ </toolbar>\ \ </ui>" --- | test for duplicates if the user wants, let the user save a .csv file of duplicates with frequencies, finally remove duplicates from facts-getNoDuplicates :: ToggleAction -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[AVp]] -> IO [[AVp]]-getNoDuplicates check fs status dupcontext attvarr rawfcts = do- { duptrue <- get check toggleActionActive- ; if duptrue then do {- ;statusbarPush status dupcontext "Checking for duplicates..."- ; let prt = partDups rawfcts- ;if checkNoDups prt then do { - statusbarPush status dupcontext "No duplicates found in the facts"- ;return () } - else do { mbf <- mygetFileName fs - ;case mbf of - Just fpath -> writeFile fpath (((allDup2CSVTb attvarr) . factsDups) prt)- Nothing -> return () - ;statusbarPush status dupcontext "Duplicates have been removed from the fact list" - ;return () - } - ;return (factsUniques prt)- } - else do { statusbarPush status dupcontext "Source file read and parsed"- ;return rawfcts- }- } --- returns True if there are NO ambiguous rules for the selected consequent attribute (and if the test was skipped)-noAmbiguities :: ToggleAction -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String]) -> Int -> [[Rule]] -> IO Bool-noAmbiguities check fs status ambcontext attvarr consatt rules = do {- let cnsnm = (fst (attvarr ! consatt)) - ;ambtest <- get check toggleActionActive- ; if ambtest then do {- let ambs = getAmbiguous rules- ; if ambs == [] then do { statusbarPush status ambcontext ("No ambiguous rules for " ++ (fst (attvarr ! consatt)))- ;return True- }- else do { statusbarPush status ambcontext ( "Ambiguities: " ++ (show (length ambs)) ++ " for " ++ (fst (attvarr ! consatt)))- ;mbf <- mygetFileName fs- ;case mbf of - Nothing -> return () - Just fpath -> writeFile fpath (allAmb2CSVTb attvarr ambs) - ;return False - } - } - else do { statusbarPush status ambcontext ("No ambiguities check. The consequent attribute is: " ++ cnsnm)- ;return True- }- }+-- helper function to get file path+empFileName :: FileChooserDialog -> IO (Maybe FilePath)+empFileName fs = + do resp <- dialogRun fs + widgetHide fs + case resp of + ResponseAccept -> fileChooserGetFilename fs + (_) -> return Nothing -mygetFileName :: FileChooserDialog -> IO (Maybe FilePath)-mygetFileName fs = do resp <- dialogRun fs - widgetHide fs - case resp of - ResponseAccept -> fileChooserGetFilename fs - (_) -> return Nothing+-- let the user save a .csv file of duplicate table rows with counts+saveDups :: FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[AVp]] -> IO ()+saveDups fs dupstat dupcontext attvarr cfac = do {+ statusbarPush dupstat dupcontext "Checking for duplicates..."+ ;let dups = getDups cfac+ ;if dups == [] + then statusbarPush dupstat dupcontext "No duplicate rows found in the table" >> return ()+ else do {mbf <- empFileName fs + ;case mbf of + Nothing -> statusbarPush dupstat dupcontext "Save of row duplicates cancelled" >> return ()+ Just fpath -> do + { writeFile (fpath ++ ".csv") (dupTbShow dups attvarr) + ;statusbarPush dupstat dupcontext ("Duplicate rows written to " ++ fpath ++ ".csv")+ ;return ()+ } -- end Just + } -- end else+ } -- end saveDups -myValChange :: [[LNode RuRe]] -> FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> Int -> ToggleAction -> RadioAction -> IO ()-myValChange ndgrp fs status valcontext attvarr cns check ra = do { - statusbarPush status valcontext "Building value rule graph.."- ;valind <- radioActionGetCurrentValue ra- ;revset <- get check toggleActionActive- ;let valuegraph = implicGraphOne (ndgrp !! valind)- displaygraph | revset = grev valuegraph- | otherwise = valuegraph- ;mbf <- mygetFileName fs- ;case mbf of - Nothing -> do { statusbarPush status valcontext "Cancelled"- ;return () - }- Just fpath -> do { forkIO $ do { - let consname = (fst (attvarr ! cns))- valname = (snd (attvarr ! cns)) !! valind- ;writeFile fpath (graph2DOT displaygraph "ValueGraph")- ;statusbarPush status valcontext (consname ++ " : " ++ valname ++ " rule graph saved")- ;return ()- }- ;return ()- }- }- +-- let the user save ambiguous rules in .csv format+saveAmbs :: FileChooserDialog -> Statusbar -> ContextId -> Array Int (String,[String])-> [[([AVp], AVp)]] -> IO ()+saveAmbs fs ambstat ambcontext attvarr rpart = do {+ let allambs = getAmbiguousRules rpart+ ;if allambs == [] + then statusbarPush ambstat ambcontext "No ambiguous rules found" >> return ()+ else do { mbf <- empFileName fs + ;case mbf of + Nothing -> statusbarPush ambstat ambcontext "Save of ambiguous rules cancelled" >> return ()+ Just fpath -> do {+ writeFile (fpath ++ ".csv") (ambigTbShow allambs attvarr)+ ;statusbarPush ambstat ambcontext ("Ambiguous rules written to " ++ fpath ++ ".csv")+ ;return ()+ } -- end Just + } -- end else+ } -- end saveAmbs++-- helper function to clear combo box+clearCombo :: ComboBoxClass self => self -> Int -> IO ()+clearCombo cb ln = mapM_ (comboBoxRemoveText cb) (reverse [0..(ln-1)])+++
src/Reduce.hs view
@@ -1,132 +1,134 @@-{- | Emping 0.5 (provisional)+{- | Emping 0.6 (provisional) -Module Reduce transforms a list of facts into a partition of rules for each value of a selected attribute, and returns all shortest rules (reduced normal form).+Tue 19 May 2009 05:53:08 PM CEST -The reduction takes a coded fact list, which may have been checked for doubles (see module Codec). The original rules can be checked first for ambiguities. Ambiguous rules have the same antecedent, but a different consequent.+Module Reduce implements the three stage algorithm to derive all shortest rules from a (coded) table of nominal rules. +A rule is a tuple of an antecedent and a consequent (type synonym Rule). +A consequent is an attribute value tuple (type synonym AVp). +An antecedent is a Set of AVp pairs (type synonym Antec). -Fri 04 Apr 2008 07:18:23 PM CEST --}+Rules may be ambiguous (same antecedent, different consequent).+If all rules for some consequent are ambiguous, the antecedent list is empty. -} -module Reduce ( getAmbiguous, facts2Rules, reduceAll )where-import Data.List ( nub, (\\), partition, nubBy, delete )-import Aux+module Reduce ( reduceAll ) where+import Data.Set (Set)+import qualified Data.Set as Reduce+import Data.List (partition, delete, nub )+import Codec (AVp)+import DefRules (Antec, Rule ) --- A,B and C: the reduction algorithm in its three steps --- A: formulate hypothesis from original antecedents of a consequent+-------------- usage of Data.Set functions ---------------+-- strict foldl1' for union of sets in a list+-- GHC Set docs say that (big `union` small) is best+set_unions :: Ord a => [Set a] -> Set a+set_unions = Reduce.unions -- foldl1' Reduce.union better ???? --- | returns a disjunction of all antecedent av's-hypot :: [Ant] -> [AVp]-hypot = nub . concat+set_diff :: Ord a => Set a -> Set a -> Set a+set_diff = Reduce.difference --- B: falsify the hypothesis+set_member :: Ord a => a -> Set a -> Bool+set_member = Reduce.member --- B1. match with all the antecedents of other than the consequent+set_map :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b+set_map = Reduce.map --- | the reduction as a conjunction of disjunctions-fsfmatch :: [AVp] -> [[AVp]] -> [[AVp]]-fsfmatch h = map (h \\) +set_findMax :: Set a -> a+set_findMax = Reduce.findMax --- B2. transform conjunction of disjunctions into disjunction of conjunctions+set_delete :: Ord a => a -> Set a -> Set a+set_delete = Reduce.delete --- | count the occurrences in a list and return the list without it (if it is present)-delCount :: AVp -> [AVp] -> (Int, [AVp])-delCount _ [] = (0,[])-delCount x (y:ys) - | x == y = (fst(delCount x ys) + 1,snd (delCount x ys))- | otherwise = (fst(delCount x ys), y:snd(delCount x ys))+set_null :: Ord a => Set a -> Bool+set_null = Reduce.null --- | return the elements of a list with their counts-elWCnt :: [AVp] -> [(AVp, Int)]-elWCnt [] = []-elWCnt (x:xs) = (x, cnt) : elWCnt res where- cnt = fst (delCount x (x:xs))- res = snd (delCount x (x:xs))+set_filter :: Ord a => (a -> Bool) -> Set a -> Set a+set_filter = Reduce.filter --- | sort the frequency list, most occurring first-freqSort :: [(AVp,Int)] -> [(AVp,Int)]-freqSort [] = []-freqSort [x] = [x]-freqSort (x:xs) = - (freqSort high) ++ [x] ++ (freqSort low) where- high = [h | h <- xs, (snd h) >= (snd x)]- low = [l | l <- xs, (snd l) < (snd x)]+set_singleton :: Ord a => a -> Set a+set_singleton = Reduce.singleton --- | make the list from which the roots and root children are built. -mkavRtLs :: [[AVp]] -> [AVp]-mkavRtLs = fst . unzip . freqSort . elWCnt . concat+set_insert :: Ord a => a -> Set a -> Set a+set_insert = Reduce.insert --- | delete an element with a property, if it is there, and report its presence. Lists without that element unchanged.+set_isSubsetOf :: Ord a => Set a -> Set a -> Bool+set_isSubsetOf = Reduce.isSubsetOf -findDel :: (AVp -> Bool) -> [AVp] -> Bool -> ([AVp],Bool)-findDel _ [] s = ([],s)-findDel p (y:ys) s - | p y = (fst $ findDel p ys s, True)- | otherwise = (y:(fst $ findDel p ys s), snd $ findDel p ys s)+----------------------------------------------------------- -{- | fst: list without element that satisfies p (may be [])-snd: True if there was such an element, else False--}-findDelPred :: (AVp -> Bool) -> [AVp] -> ([AVp],Bool)-findDelPred p ls = findDel p ls False+-- A,B and C: the reduction algorithm in its three steps -{- | from an av and an or-list, get the children or-list -and the or-list for the next av. There are 4 possibilities.--}+-- A: formulate hypothesis from the antecedents of rules for a consequent --- | test a possible child or-list-chldsrc :: Int -> [([AVp],Bool)] -> Maybe [[AVp]]-chldsrc att porls2 - | porls2 == [] = Just [] -- will be leaf- | otherwise = - let porls3 = map fst porls2- chorls = map (findDelPred (\x -> att == fst x)) porls3 in- if ([],True) `elem` chorls -- or-list contradiction- then Nothing- else Just (map fst chorls) +-- returns a disjunction of AVp pairs, not an antecedent+hypot :: [Antec] -> Set AVp+hypot pa = set_unions pa --- | test a possible next in a forest -tnextsrc :: [([AVp],Bool)] -> Maybe [[AVp]]-tnextsrc porls1 | porls1 == [] = Nothing- | otherwise = if ([],True) `elem` porls1 - then Nothing -- contradiction- else Just (map fst porls1)+-- B: falsify the hypothesis --- | split an original or-list into children (fst) and next (snd)-splitOrls :: AVp-> [[AVp]] -> (Maybe [[AVp]],Maybe [[AVp]])-splitOrls av orls = (x,y) where - x = chldsrc (fst av) v- y = if (tnextsrc u) == Nothing - then Nothing- else Just (map fst imls)- (u,v) = partition snd imls- imls = map (findDelPred (av ==)) orls+-- B1. match with all the antecedents of other than the consequent --- | make root list with children from sorted possibles -rootLs :: [AVp]->[[AVp]]->[Maybe (AVp,[[AVp]])]-rootLs _ [] = []-rootLs [] _ = error "Reduce rootLs: root source is []"-rootLs (x:xs) orls = tsrc:rootLs xs next where- tsrc = case pchld of - Nothing -> Nothing- Just chld -> Just (x,chld)- next = case pnext of- Nothing -> []- Just nxt -> nxt- (pchld, pnext) = splitOrls x orls- --- | make root list with childsource from or list-makeRtChldLs :: [[AVp]] -> [Maybe (AVp,[[AVp]])]-makeRtChldLs [] = error "Reduce makeRtChldLs: list is []" -makeRtChldLs orls = rootLs (mkavRtLs orls) orls+-- the reduction result as a (conjunctive) list of AVp disjunctions+fsfmatch :: Set AVp -> [Antec] -> [Set AVp]+fsfmatch hyp na = map (set_diff hyp) na --- | define a rose tree that can have empty branches+-- B2. transform conjunction of disjunctions into disjunction of conjunctions++-- count the occurrence of an element in a list of OR_sets and return it, with its count+countInOrs :: AVp -> [Set AVp] -> (Int,AVp)+countInOrs x orls = (n,x) where+ n = length $ filter (set_member x) orls++-- for all elements present in a list of OR-sets, return them with their counts+countAllInOrs :: [Set AVp] -> Set (Int,AVp)+countAllInOrs orls = set_map (flip countInOrs orls) (set_unions orls)+ ++-- the root of the (sub) tree is the most occurring AVp+-- depends on the default ordering of tuples!!+-- N.B. for each new OR_set list, the most occurring AVp must be recalculated!!+getRoot :: [Set AVp] -> AVp+getRoot orls = snd $ set_findMax (countAllInOrs orls)++-- growing to the right, with the OR_lists which do not contain the root, and+-- the OR_lists, which do contain the root, with that root removed+-- except if that rest is empty +restRight :: AVp -> [Set AVp] -> [Set AVp]+restRight rt orls | orls == [] || any set_null dlrt = []+ | otherwise = dlrt ++ nort+ where (ysrt, nort) = partition (set_member rt) orls+ dlrt = map (set_delete rt) ysrt++-- growing down from the root, OR_lists with the root are represented by the root itself +-- any elements with the same attribute as the root must be removed from the porls (possible or set lists)+rootDown :: AVp -> [Set AVp] -> Maybe (AVp,[Set AVp])+rootDown rt orls | porls == [] = Just (rt,[])+ | any set_null porls = Nothing+ | otherwise = Just (rt, porls)+ where nort = filter (\s -> not (set_member rt s)) orls+ porls = map (remWithAtt (fst rt)) nort+ remWithAtt a s = set_filter (\e -> (fst e) /= a) s ++-- construct a level of possible roots and OR_set lists+rootLevel :: [Set AVp] -> [Maybe (AVp,[Set AVp])]+rootLevel [] = []+rootLevel orls = rtwch:(rootLevel next) + where rt = getRoot orls+ rtwch = rootDown rt orls+ next = restRight rt orls++-- define a rose tree that can have empty branches data Maytree a = Niets | Wel {avLabel::a, avChils :: Mayfor a} deriving Eq type Mayfor a = [Maytree a] --- | make a tree and forest from Maybe roots and source children-mkAVMTree :: Maybe (AVp,[[AVp]]) -> Maytree AVp+-- construct a Mayfor from a list of OR_sets+mkAVMFor:: [Set AVp] -> Mayfor AVp+mkAVMFor suborls = map mkAVMTree rtchls where+ rtchls = rootLevel suborls++-- construct a MayTree from Maybe roots and source children+mkAVMTree :: Maybe (AVp,[Set AVp]) -> Maytree AVp mkAVMTree rtchls = case rtchls of Nothing -> Niets@@ -134,93 +136,66 @@ Just (x, suborls) -> Wel {avLabel = x, avChils = mkAVMFor suborls } -mkAVMFor:: [[AVp]] -> Mayfor AVp-mkAVMFor suborls = map mkAVMTree rtchls where- rtchls = makeRtChldLs suborls---- | get the branches of a Maytree. The empty lists are lost because of concatMap-brMayTree :: Maytree AVp -> [[AVp]]+-- get the branches of a Maytree. The empty lists are lost because of concatMap+brMayTree :: Maytree AVp -> [Antec] brMayTree t = case t of Niets -> []- (Wel x []) -> [[x]]- (Wel x for) -> map (x:) brls where+ (Wel x []) -> [set_singleton x]+ (Wel x for) -> map (set_insert x) brls where brls = concatMap brMayTree for --- | extract the smallest sublists from the orlist of andlists-extrMin :: [[AVp]] -> [[AVp]]-extrMin ls = nubBy isEq [ getMinin x ls | x <-ls ] - where getMinin x y = foldr minLs x y---- | final transformation of a conjunction of disjunctions to a disjunction of conjunctions-trAndOr :: [[AVp]] -> [Ant]-trAndOr orls = - extrMin (concatMap brMayTree for) where for = mkAVMFor orls----- C: Verify the falsification result with the original positive antecedents+-- returns x if it's elements are all in y, otherwise y+minSet :: Ord a => Set a -> Set a -> Set a+minSet x y | x `set_isSubsetOf` y = x+ | otherwise = y --- | erify the falsification result with the original positive antecedents-verify :: [Ant] -> [Ant] -> [Ant]-verify flsd orig = [x | x <- flsd , x `isIn` orig ] where- isIn y ls = or (map (isSub y) ls)+-- extract the smallest sublists from the orlist of andlists+extrMin :: [Antec] -> [Antec]+extrMin ls = nub [ getMinin x ls | x <-ls ] + where getMinin x y = foldr minSet x y --- A, B and C: reduce a list of positive original antecedents---- | the implementation of the rule reduction (for one consequent attribute-value-redPos :: [Ant] -> [Ant] -> [Ant]-redPos p n = verify (trAndOr (fsfmatch (hypot p) n)) p--------------------------------------------------------+-- the function to transform (ANDs of ORs) to (ORs of ANDs)+transOrToAnd :: [Set AVp] -> [Antec]+transOrToAnd = extrMin . (concatMap brMayTree) . mkAVMFor + +---------------------------------------------------------------------------------------------- --- Functions on the list of facts +-- C: Verify the falsification result with the original positive antecedents --- | f2r works because only one value of an attribute can be in a fact.--- and there is always one (possibly value -1 as defined by Codec)-f2r :: Int -> [AVp] -> (Ant,AVp)-f2r att fact = (ant, cons) where - (ant, [cons]) = partition (\u -> (fst u) /= att) fact+-- test whether an unfalsified antec is a subset of an original rule+verifOne :: Antec -> [Antec] -> Bool+verifOne nf ruls = any (\s -> nf `set_isSubsetOf` s) ruls --- | remove all rules with blank consequent value. -f2rules :: Int -> [[AVp]] -> [Rule]-f2rules att facls = filter (\u -> (snd $ snd u) /= -1) raw where- raw = map (f2r att) facls+verify :: [Antec] -> [Antec] -> [Antec]+verify allnf ruls = filter (flip verifOne ruls) allnf -{- | partition a fact list according to the attribute-values of the consequent+------------------- not used for now -------------------------------+--potential :: [Antec] -> [Antec] -> [Antec]+--potential allnf ruls = filter (not . (flip verifOne ruls)) allnf -Important: all rules with blank consequent values should have been removed by f2rules.--}-facts2Rules :: Int -> [[AVp]] -> [[Rule]]-facts2Rules at facls = - partitionBy (\x y -> (snd x) == (snd y)) ruls where- ruls = f2rules at facls +-- transform lists of antecedents to rules+antecsToRules :: [Antec] -> AVp -> [Rule]+antecsToRules antecs av = zip antecs avls where+ avls = replicate (length antecs) av --- | the reduction algorithm for each consequent is implemented by redPos p n-redOne :: [[Rule]] -> [Rule] -> [Rule]-redOne grp rls = map addcons (redPos p n) where- p = map fst rls- n = map fst (concat $ (delete rls grp))- addcons x = (x,cons)- cons= (snd . head) rls+-- A, B and C: reduce a partition of rules --- | add a sort by length to reduction of one consequent value-sortedRedOne :: [[Rule]] -> [Rule] -> [Rule]-sortedRedOne grp rls = sortByValNum $ redOne grp rls+-- | reduce list of rules with the same consequent in a partition of rules+reduceOne :: [Rule] -> [[Rule]] -> [Rule]+reduceOne rls allrls | antecs == [] = []+ | otherwise = antecsToRules ver cons + where rulants = (map fst rls)+ cons = (snd . head) rls+ h = hypot rulants+ others = delete rls allrls+ ors = fsfmatch h (map fst (concat others))+ antecs = transOrToAnd ors+ ver = verify antecs rulants --- | reduce a rule model for all consequent attribute-value pairs +-- | reduce all rules in a rule partition and remove any empty rules reduceAll :: [[Rule]] -> [[Rule]]-reduceAll rlgrp = map (sortedRedOne rlgrp) rlgrp--------------------------------------------------------------------------------{- | find ambiguities in a rule group. A rule group partitions rules according to the consequent values.--Equal facts must have been removed, otherwise they will show up too.--Warning: only works if the Antedent rows have the same attribute order. --}-getAmbiguous :: [[Rule]] -> [[Rule]]-getAmbiguous grp = filter (\x -> (length x) > 1) anteqs where- anteqs = partitionBy (\x y -> (fst x) == (fst y)) ols- ols = concat grp+reduceAll allrules = filter (/= []) result where+ result = map ((flip reduceOne) allrules) allrules -----------------------------------------------------------------------------------------------------
+ user_guide/default.css view
@@ -0,0 +1,104 @@+html {+ background-color: #a52a2a+}++body {+ background-color: silver+}++#header { + display: block; + width: auto; + height: 36px; + background-color: teal; + padding-bottom: 7px; + border-bottom: 7px ridge #a52a2a+}++#footer { + display: block; + width: auto;+ height: 36px; + background-color: teal; + padding-top: 7px; + border-top: 7px ridge #a52a2a +}++.nav-contact{+ display: inline;+ float: left +}++.nav-up{+ display: inline;+ float: right+}++.nav-left {+ display: inline;+ float: left+}+.nav-right {+ display: inline;+ float: right+}++h1 {+ text-align: center+}++li {+ display: list-item; + margin-bottom: 0.17in; + line-height: 0.18in+}++p,h3 { + padding-left: 10px;+ padding-right: 10px+}++p.summary {+ display: block;+ position: relative; + margin-left:20%;+ margin-bottom:30px; + background-color: inherit;+ font-style: italic;+ width: 60%+}++#date-stamp {+ text-align: center+}+++table {+ display: table;+ border: 5px ridge #a52a2a;+ margin-left: auto;+ margin-right: auto+}++td,th {+ background-color:#e5e5e5; + text-align: center;+ border: 2px ridge #a52a2a;+ padding-left: 5px;+ padding-right: 5px +}++th {+ padding-bottom: 10px;+ padding-top: 10px+}++img { display:block;+ margin-left: auto;+ margin-right: auto+ +}++input,textarea {+ background-color: #e5e5e5;+}
+ user_guide/empug.html view
@@ -0,0 +1,70 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">+<head>+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+ <meta name="author" content="Hans van Thiel"/>+ <meta name="decription" content="user guide of data mining tool emping 0.6" /> + <title>Emping 0.6 User Guide</title>+ <link rel="stylesheet" type="text/css" media="screen" href="./default.css"/>++</head>++<body>+<div id="header">+<span class="nav-up"><a href="http://www.muitovar.com">web site</a></span>+</div> +<h1>Emping 0.6 User Guide</h1>++<p>Emping 0.6 is a tool (prototype) for the discovery and analysis of predictive relations in nominal data. Its usage is best explained by example.</p>++<p>The source of the example is the well known data set from J.R. Quinlan, as shown in the screenshot from an Open Office Calc spreadsheet. All data and all results in Emping, except for the graphs, are in the .csv (comma seperated file) format which can be read and saved by OO Calc.</p>+<p><img src="./ugimg/source.png" alt="source table" /></p>+<p>When Emping is started (for installation see the end) you can load a table like the one above with 'Open'. The first row should contain the attribute names, and each column should contain the possible values for the attribute at the top. You can use numbers, but they will be treated like any other name. So, type 1 will be no different from type A, and so on. Emping will automatically load the names in the table into its menu.</p>+<p><img src="./ugimg/emping_start.png" alt="emping start" /></p>+<p>The next steps to take are shown by the greyed out items in the tool bar. When the table has been loaded, the 'Select' function becomes active, and you can select one of the attributes as consequent of the rules. In this case we select 'Fishing'.</p>+<p>Once this is done the function "Reduce All' becomes active. You can now save a file with the result. (A .csv extension is appended automatically to your file name.) The reduction for this example looks like this in OO Calc.</p>+<p><img src="./ugimg/reduce_fishing.png" alt="reduce fishing" /></p>+<p>The result of the reduction is a list of shortest rules which predict the values of the selected consequent. These reduced rules are partially ordered through entailment. When the reduction has been completed, the 'Choose' function becomes active. You can now choose one of the values of the attribute, in this case 'good' or 'bad'. When this has been done 'Abduce' becomes active.</p>+<p>'Abduce' produces two files, a directed graph of all the entailments in .dot format and a legend in .csv format. (The extensions are again appended automatically.) The .dot files can be viewed with dotty or another GraphViz viewer, as shown next. (The screenshot has been zoomed out and resized.)</p>+<p><img src="./ugimg/abduce_good_gr.png" alt="abduce good graph" /></p>+<p>This shows all entailments for the rules that imply good fishing. The first number is the node number, as shown in the legend below, the second is the number of equivalents, here one for all cases. If x implies y and y also implies x then the rules are equivalent (or equal for short).</p>+<p>Note that the direction of graphs is from least general to most general, and from top to bottom. The menu icons also indicate this direction.</p>+<p><img src="./ugimg/abduce_good.png" alt="abduce good" /></p>+<p>You might be especially interested in the most general rules, which do not imply any others, or the least general, which are not implied by any others. You can extract those through the 'M/L General' menu item in the 'Abduce' menu. Which of the two is determined by the 'Most General' checkbox (checked by default).</p>+<p>The most general for good fishing are</p>+<p><img src="./ugimg/msg_abduce_good.png" alt="most general good fishing" /></p>+<p>and the least general</p>+<p><img src="./ugimg/lsg_abduce_good.png" alt="least general good fishing" /></p>+<p>Note that rule number 8, the unconnected one in the graph, appears twice. It is both most and least general.</p>+<p>You can also get the relations between the rules for Fishing : bad, of course, by choosing that particular attribute value.</p>+<p><img src="./ugimg/abduce_bad_gr.png" alt="abduce bad graph" /></p>+<p><img src="./ugimg/abduce_bad.png" alt="abduce bad" /></p>+<p>The choice of 'Fishing' as the consequent attribute is natural for a human but, purely technical, any attribute can be selected as the consequent.</p>+<p>The 'New Rules' item in the 'Rule' menu lets you reset the selection and then select another attribute, for example, 'Temperature'. The 'Rule' menu has a check box 'Check Rule', which is active by default, and its purpose is demonstrated here</p>+<p><img src="./ugimg/ambig_temperature.png" alt="ambiguous for temperature" /></p>+<p>It appears that for this consequent attribute there are ambiguous rules, rules which have the same antecedent but a different consequent. These cancel each other, and if all are ambiguous, there will be no reductions for that particular value. For temperature, however, there are several remaining shortest rules for each of the three predicates.</p>+<p><img src="./ugimg/reduce_temperature.png" alt="reduce temperature" /></p>+<p>You can do an abduction for any of the three attribute values 'hot', 'mild' and 'cool'. It appears there are no entailments for 'mild', and therefore there is no graph.</p>+<p><img src="./ugimg/emping_end.png" alt="emping end" /></p>+<p>There may still be equivalencies, however, and this appears to be the case here, as shown by applying "M/L General' in the 'Abduce' menu.</p>+<p><img src="./ugimg/msg_temperature_mild.png" alt="most general temperature mild" /></p>+<p>The 5 rules from the reduced table can be grouped into 3 clusters of equivalent rules.</p>+<p>You can load a new data source with 'New Table' from the 'File' menu. This menu also has a 'Table Check' box, which is off by default. It lets you check the data source for duplicate rows, which don't change the results, but do slow things down. If checked, duplicates are automatically removed from the data (but not from your source file). You can also save any duplicates, with their frequencies of occurrence, in a separate file.</p>+<p> </p>+<p>The above example runs in a few seconds, but depending on the number of rows and in particular the number of values of the consequent attribute, calculations can take minutes and even more time. You cannot skip any of the described steps if you just want the abduction for one attribute value only, but you can cancel saving results.+Because Haskell, the language which Emping was written in, only evaluates results when needed, calculations for other values, which are not needed, are automatically skipped. So, not saving what you don't want will generally speed up things. The messaging to the user is, however, not as sophisticated and, before the appropriate tool item becomes active again, it might seem that the program hangs.</p>++<h3>Requirements and Installation</h3>+<p>Emping 0.6 is written in Haskell with GHC 6.8 and Gtk2Hs 0.9.13 on Fedora Core 8 Linux. The compiled program might just run on any Gnome Linux system. It may be compiled from the source modules (unpacked from a tar.gz file) on the command line with ghc --make -O -Main.hs -o yourfilename. Emping is a standalone application and not a library, but it could also be installed from a Cabal package, which is the Haskell standard.</p>++<p>To handle the comma separated files you need the Open Office Calc spreadsheet or something else that can read the .csv format. Anything in Emping is just a text string, but OO Calc writes labels between quotes, and numbers as they are. To see the .dot graphs you need dotty or another GraphViz viewer, for example, ZRGViewer.</p>++<h3>Differences with previous versions</h3>+<p>Emping Version 0.6 has been completely reviewed and optimized in many ways. The most important difference is the implementation of rule antecedents as Haskell sets instead of lists. This did not have much effect on the reductions, but did speed up the abductions considerably.</p>+<p>Built on experience with previous versions, Emping 0.6 has been redesigned to be a usable tool. Its purpose is to help discover and analyse predictive relationships, in real nominal data, in a practical and timely manner. However, it is still experimental and relatively untested, as its version number of less than one indicates.</p>+<h3>Usage and Rights</h3>+<p>Emping is open source and licensed under the General Public Licence (GPL). The Haskell libraries it uses are licensed by their respective authors as listed in the GHC documentation.</p>+<p>© 2006-2009 Hans van Thiel</p>+<p><img src="./ugimg/logo7000.png" alt="Haskell logo" /></p>+</body>+</html>
+ user_guide/ugimg/abduce_bad.png view
binary file changed (absent → 45597 bytes)
+ user_guide/ugimg/abduce_bad_gr.png view
binary file changed (absent → 5435 bytes)
+ user_guide/ugimg/abduce_good.png view
binary file changed (absent → 52192 bytes)
+ user_guide/ugimg/abduce_good_gr.png view
binary file changed (absent → 6048 bytes)
+ user_guide/ugimg/ambig_temperature.png view
binary file changed (absent → 42711 bytes)
+ user_guide/ugimg/emping_end.png view
binary file changed (absent → 14675 bytes)
+ user_guide/ugimg/emping_start.png view
binary file changed (absent → 13437 bytes)
+ user_guide/ugimg/logo7000.png view
binary file changed (absent → 8971 bytes)
+ user_guide/ugimg/lsg_abduce_good.png view
binary file changed (absent → 44156 bytes)
+ user_guide/ugimg/msg_abduce_good.png view
binary file changed (absent → 45816 bytes)
+ user_guide/ugimg/msg_temperature_mild.png view
binary file changed (absent → 43588 bytes)
+ user_guide/ugimg/reduce_fishing.png view
binary file changed (absent → 43687 bytes)
+ user_guide/ugimg/reduce_temperature.png view
binary file changed (absent → 43861 bytes)
+ user_guide/ugimg/source.png view
binary file changed (absent → 45969 bytes)