packages feed

Emping 0.1 → 0.2

raw patch · 16 files changed

+572/−197 lines, 16 filesbinary-added

Files

Emping.cabal view
@@ -1,5 +1,5 @@ name:                Emping-version:             0.1+version:             0.2 license:             GPL license-file:        LICENSE build-depends:       base, parsec@@ -13,16 +13,17 @@        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.+       that can be read by OO Calc. If there are logical dependencies+       in the set of reduced rules, these are shown in a separate .csv file.       category:            Data Mining extra-source-files:  README        executable:        emping hs-source-dirs:    src main-is:           Main.hs-ghc-options:       -o+ghc-options:       -fglasgow-exts -O other-modules:     CSVParse                    Codec-                   Aux                    Reduce+                   Abduce                    CSVTable
README view
@@ -1,10 +1,13 @@+The compressed archive contains source files in the functional programming language Haskell.+Emping should run on any platform which has the Glasgow Haskell compiler installed.+ The preferred way to install emping is through Cabal, for example:  $ runhaskell Setup.lhs configure --prefix=$HOME $ runhaskell Setup.lhs build $ runhaskell Setup.lhs install -where the commands might need to follow:+where the commands might need to follow the prefix:      /usr/bin/env depending on your settings. @@ -18,6 +21,7 @@  Or, put the the source files in a directory of your choice and compile them with: -ghc --make Main.hs -o emping+ghc -fglasgow-exts --make -O Main.hs -o emping -where ghc is the Haskell compiler and emping is the executable.+where ghc is the Haskell compiler and emping is the executable. +(-fglasgow-exts is a required option and -O (upper case) optimizes the compilation)
+ docs/DPT_Fishing.png view

binary file changed (absent → 62814 bytes)

docs/Emp_UG.html view
@@ -2,11 +2,11 @@ <HTML> <HEAD> <META NAME="generator" CONTENT="http://txt2tags.sf.net">-<TITLE>Emping User Guide</TITLE>+<TITLE>Emping User Guide, Version 0.2 </TITLE> </HEAD><BODY BGCOLOR="white" TEXT="black">-<P ALIGN="center"><CENTER><H1>Emping User Guide</H1>+<P ALIGN="center"><CENTER><H1>Emping User Guide, Version 0.2 </H1> <FONT SIZE="4">-<I>Author: Hans van Thiel, April 2007</I><BR>+<I>Author: Hans van Thiel, May 2007</I><BR> email: hthiel.char@zonnet.nl </FONT></CENTER> @@ -32,11 +32,11 @@ </DL>  <P>-Heuristic rules are purely empirical, with no foundation in a theory or model. Emping automatically derives all such rules from a table of facts. This result is called a <B>reduced normal form</B>. Such a result can be analized and simplified further, but this first version of emping only performs the reduction.+Heuristic rules are purely empirical, with no foundation in a theory or model. The input of Emping is just a table of nominal facts. The user has to select which attribute is to be the consequent. Then Emping derives all shortest rules which, in the table, imply the values of the selected consequent. Each reduced rule is a generalization of one or more original rules, and therefore reduced rules may imply or be equivalant to others. If this is the case, these logical dependencies are also derived.   </P> <H2>1.2. How</H2> <P>-Emping reads a file in a comma seperated format (.csv) as produced by the Open Office Calc spreadsheet, and returns the result as a .csv file that can be read by OO Calc.+Emping reads a file in a comma seperated format (.csv) as produced by the Open Office Calc spreadsheet, and returns the results as  .csv files that can be read by OO Calc. </P> <P> You start the utility from a terminal and provide the file name as a command line parameter. For example:@@ -45,10 +45,10 @@ <CODE>$ ./emping QuinLanFacts.csv</CODE> </P> <P>-Emping then asks you to supply the name of the attribute that is to be the consequent of the rules, and the result is saved as a file with that attribute as its name and the .csv extension.+Emping then asks you to supply the name of the attribute that is to be the consequent of the rules. The reduced normal form is saved in a file with prefix "RNF_" and the name of the attribute. If there are logical dependencies, these will be stored in a file with prefix "DPT_". Finally, original rules may be ambiguous, that is, the same antecedent may imply two or more different values. The reduction algorithm also works if ambiguous rules are present, but Emping informs you which rules are ambiguous in a third file with prefix "AMB_".  </P> <P>-This file can then be loaded into OO Calc.+The reduced normal form file and, if present, the others, can then be loaded into OO Calc. </P> <H2>1.3. More</H2> <P>@@ -79,36 +79,46 @@ <P> Open the terminal and type <CODE>emping</CODE>, followed by the filename of the table (including the path). You may have to precede the command with the directory, which contains the emping executable. For example, if it is in your working directory: </P>-<DL>-<DT>$ ./emping (followed by the file name)</DT><DD>-</DL>-+<P>+$ ./emping (followed by the file name)+</P> <H2>2.4. Step 4</H2> <P>-The program will now ask for the attribute which is to be predicted. This can be any one of the names in the table header.-If you type <CODE>?</CODE> you will see a list of the names.+The program will now ask for the attribute which is to be predicted. This can be any one of the names in the table header.  </P>+<P>+<IMG ALIGN="middle" SRC="./session_ex.png" BORDER="0" ALT="">+</P>+<P>+There are no ambiguous rules for <I>Fishing</I> but the reduced normal form has dependency trees as well as unconnected rules.+</P> <H2>2.5. Step 5</H2> <P>-The program will have saved the result in a file with the attribute name and the <CODE>.csv</CODE> extension. This can then be loaded into OO Calc, as shown in the image.+View the reduced normal form in file <I>RNF_Fishing.csv</I> in OO Calc. </P> <P>-<IMG ALIGN="middle" SRC="./Fishing.png" BORDER="0" ALT="">+<IMG ALIGN="middle" SRC="./RNF_Fishing.png" BORDER="0" ALT=""> </P>-<H1>3. Miscellaneous</H1> <P>-The emping utility is written in Haskell, and has been developed and tested on the Fedora Core 6 Linux platform, using the Haskell tools which are available as FC6 packages.+and all branches of the dependency trees, together with the singletons, in <I>DPT_Fishing.csv</I> </P> <P>-(Potential) users will probably be somewhat wary, in particular if their data is critical. Keep in mind that emping derives the rules, which is the hard part. Checking the results for correctness is easy.+<IMG ALIGN="middle" SRC="./DPT_Fishing.png" BORDER="0" ALT=""> </P> <P>-As stated above, this utility is by no means the end of the story (see the included wp). Work will continue, and I'm very interested in comments, ideas and crits from anyone. Thanks in advance.+Note: For an example with ambiguities and equals (implications both ways) choose <I>Windy</I> as the consequent attribute. </P>+<H1>3. Miscellaneous</H1> <P>+The emping utility is written in Haskell, and has been developed and tested on the Fedora Core 6 Linux platform, using the Haskell tools which are available as FC6 packages. To use it you must compile the package with the Haskell compiler on your platform or build it with Cabal. See the README file for details.+</P>+<P>+(Potential) users will probably be somewhat wary, in particular if their data is critical. Keep in mind that emping derives the rules, which is the hard part. Checking the results for correctness is easy.+</P>+<P> <I>Emping</I> stands for <I>empirical reasoning</I> or the Indonesian snack with that name. </P>  <!-- html code generated by txt2tags 2.3 (http://txt2tags.sf.net) -->-<!-- cmdline: txt2tags -\-target html EmpMan.t2t -->+<!-- cmdline: txt2tags -\-target html Emp_UG.t2t --> </BODY></HTML>
− docs/Fishing.png

binary file changed (58079 → absent bytes)

+ docs/RNF_Fishing.png view

binary file changed (absent → 51962 bytes)

+ docs/session_ex.png view

binary file changed (absent → 35511 bytes)

+ src/Abduce.hs view
@@ -0,0 +1,186 @@+module Abduce ( abdAll, treehasED, cntEDAtt ) where++-- (c) 2007 Hans van Thiel+-- Version 0.2 License GPL++-- module: get partial order, if any, of RNF rules++import Reduce (isSub )+import Data.List ( findIndices, nubBy, partition )+import Data.Tree ( Tree(..), Forest )++-- general purpose functions++-- tree map (fmap not accessible from Data.Tree (???)++treeMap :: (a -> b) -> Tree a -> Tree b+treeMap f (Node x ts) = Node (f x) (map (treeMap f) ts)+++---------------------------------------------------++-- define a Poset (WITHOUT EQUALS)++data Porder = HI | LW | NT deriving (Eq)++class (Eq a) => Poset a where+    pcompare :: a -> a -> Porder++-- put a poset in a tree, each branch is an ordered chain+-- unordered elements are in the same subforest++ins2Tree :: Poset a => a -> Tree a -> Tree a+ins2Tree x t = + case pcompare x (rootLabel t) of+    LW -> Node (rootLabel t) (ins2Forest x (subForest t))+    HI -> Node x (t:[])+    NT -> t++ins2Forest :: Poset a => a -> Forest a -> Forest a+ins2Forest x [] = (Node x []):[]+ins2Forest x for +  | new == for = (Node x []):for+  | otherwise = new+    where new = map (ins2Tree x) for   ++-- put a list of partially ordered elements in forest++isRoot :: Poset a => [a] -> a -> Bool+isRoot ls x = and $ map ((LW /=) . (x `pcompare`)) ls ++initRoots :: Poset a => [a] -> Forest a+initRoots ls = map ((flip Node) []) ls++lsinFor :: Poset a => [a] -> Forest a -> Forest a+lsinFor [] for = for+lsinFor (x:xs) for = ins2Forest x (lsinFor xs for)++list2Forest :: Poset a => [a] -> Forest a+list2Forest ls = lsinFor res for where+                     (x,res) = partition (isRoot ls) ls +                     for = initRoots x  +-----------------------------------------------------+-----------------------------------------------------++-- A: match indices of reduced rules with indices of +-- the original(s) denoted by a reduced rule++-- indices of original rule(s) denoted by reduced+-- rule. Note: consequent included, for simplicity++redOrgs :: (Eq a, Eq b) => [[(a,b)]] -> [(a,b)] -> [Int]+redOrgs rules red = findIndices (red `isSub`) rules++-- tuples of the indices of  originals and the reduced+-- rule index for orgs and reds with same av consequent++redOPrs :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> [([Int],Int)]+redOPrs rules reds = zip orixls [0..] where+           orixls = map (redOrgs rules) reds++-- get all reds denoting the same original (ONE)+-- Note: first denote originals, second reduced equals++getEquals :: [([Int],Int)] -> ([Int],Int) -> ([Int],[Int])+getEquals  y  (ols,_)=+      (ols, [snd x | x <- y, fst x == ols ])++-- group original-red pairs into original-equals paire+-- remove doubles of origs, maybe same, different order++toEquals :: [([Int],Int)] -> [([Int],[Int])]+toEquals orpl = nubBy eqOrg ls where+     ls = map (getEquals orpl) orpl+     eqOrg (x1,y1) (x2,y2) = isSub x1 x2 && isSub x2 x1+-------------------------------------------------------++-- first orig indices, second red indices matched+-- from rules to reds with same consequent av++redOrgs2Eqs :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> [([Int],[Int])]+redOrgs2Eqs rules reds = toEquals (redOPrs rules reds)+------------------------------------------------------++-- B: show partial order, according to sublists of origs+-- the reds are in implication chain of orig sublists++-- define type RuRe as a poset++type RuRe = ([Int],[Int])++-- first in orig is high, low or not ordered++instance Poset RuRe where+     pcompare (x1,y1) (x2,y2)+              | isSub x2 x1 = HI+              | isSub x1 x2 = LW+              | otherwise = NT+---------------------------------------------------+++-- convert rules and reds for same consequent into+-- a poset forest++redOrgs2Forest :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> Forest RuRe+redOrgs2Forest rules reds = +          list2Forest (redOrgs2Eqs rules reds)++-- order is determined, original indices no longer needed++remOrgs :: Forest RuRe -> Forest [Int]+remOrgs for =  map (treeMap snd) for++-- produces the partial order of reduceds, with+-- indices of equals in one list (rules WITH cons)++reds2EqsFor :: (Eq a, Eq b)=> [[(a,b)]] -> [[(a,b)]] -> Forest [Int]+reds2EqsFor rules reds = +              remOrgs (redOrgs2Forest rules reds)++-- replace indices list with rule list (of equals)++eqix2reds :: (Eq a, Eq b) => [[(a,b)]] -> [Int] -> [[(a,b)]]+eqix2reds reds exls = map (reds !!) exls++-- from a list of original rules and their reductions+-- get the partial order of the reductions (with conseq)++abd1Val :: (Eq a, Eq b) => [[(a,b)]] -> [[(a,b)]] -> Forest [[(a,b)]]+abd1Val rules reds = map trmf for where+               trmf = treeMap (eqix2reds reds)+               for = reds2EqsFor rules reds+------------------------------------------------------++-- abduce all reductions for a selected attribute++abdAll :: (Eq a, Eq b) => [[[(a,b)]]] -> [[[(a,b)]]] -> [ Forest [[(a,b)]] ]+abdAll rulegrp redsgrp = zipWith abd1Val rulegrp redsgrp++-------------------------------------------------------++-- check if a tree contains a branch and/or equals++treehasED :: (Eq a, Eq b) => Tree [[(a,b)]] -> Bool+treehasED t | length (rootLabel t) == 1 +              && subForest t == [] = False+            | otherwise = True++-- count branches and/or equals in forest, +-- fst is number of chains, snd number of singles++cntEDVal :: (Eq a, Eq b) => Forest [[(a,b)]] -> (Int,Int)+cntEDVal for = (dep, sin) where +       dep = sum $ fst (unzip temp) +       sin = sum $ snd (unzip temp) +       temp = map (mark . treehasED) for  +       mark x | x == True = (1,0)+              | x == False = (0,1) ++-- count branches and/or equals in attribute abduction+-- fst is chain count, snd is number of unconnected rules++cntEDAtt :: (Eq a, Eq b) => [Forest [[(a,b)]] ] -> (Int,Int)+cntEDAtt forls = (dep, sin) where+             dep = sum $ fst (unzip temp)+             sin = sum $ snd (unzip temp) +             temp = map cntEDVal forls
− src/Aux.hs 
@@ -1,45 +0,0 @@-module Aux (redAtt, selavN, gtAtec ) where---- (c) 2007 Hans van Thiel--- Version 0.1 License GPL--import Reduce ( redCons )-import Data.Array-import Data.List ( delete )---- module: auxiliary functions for Main---- reduction for a consequent attribute, coded by Codec---- execute the reduction on all attribute-value pairs--- the result matches each reduction with its consequent--redAtt :: [(Int,Int)] -> [[(Int,Int)]] -> [([[(Int,Int)]], (Int,Int))]-redAtt avls src = zip (map ((flip redCons) src) avls) avls------------------------------------------------------------------ get the index of an attribute string--selAtt :: String -> Array Int [String] -> Int-selAtt att attvarr  = slAtt att (indices attvarr) attvarr where-                            slAtt at [] arr = error "Attribute not found..."-                            slAtt at (x:xs) arr | att == (head (arr ! x)) = x-                                                | otherwise = slAtt at xs arr---- get the coded attribute-value pairs from the attribute index--selAV :: Int -> Array Int [String] -> [(Int,Int)]-selAV ai attvarr = let avstr = attvarr ! ai-                       vais = [1..(length avstr)-1]-                   in  [(ai, x) | x <- vais ]---- get the coded attribute-value pairs from the attribute name--selavN :: String -> Array Int [String] -> [(Int,Int)]-selavN atn attvarr = selAV ai attvarr where ai = selAtt atn attvarr---- get antecedent and consequent attribute indices from consequent index--gtAtec :: Int -> Array Int [String] -> ([Int],Int)-gtAtec cns attvarr = ((delete cns ils),cns) where-                                 ils = indices attvarr              ------------------------------------------------------
src/CSVParse.hs view
@@ -1,8 +1,5 @@ module CSVParse ( getTable ) where --- (c) 2007 Hans van Thiel--- Version 0.1 License GPL- import Text.ParserCombinators.Parsec {- module: parse a table in Open Office Calc csv-format    empty lines are skipped@@ -35,9 +32,10 @@                     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 view
@@ -1,16 +1,17 @@-module CSVTable ( red2Table ) where+module CSVTable (rule2Attls,res2CSVTb,abd2CSVTb,amb2CSVTb ) where  -- (c) 2007 Hans van Thiel--- Version 0.1 License GPL+-- Version 0.2 License GPL --- module: convert reduction result to CSV +-- module: convert reduction result to a CSV  -- format that can be read by Open Office Calc  import Data.Char (isDigit ) import Data.List ( delete ) import Data.Array+import Data.Tree ( Tree(..), Forest ) ----------- some auxiliary functions ----------------+-- auxiliary functions   -- check whether a string is a number or text @@ -25,75 +26,203 @@ toCalc x | allDigit x = x          | otherwise = "\"" ++ x ++ "\"" --- get the value string of an attribute-value tuple--strVal :: Array Int [String] -> (Int,Int) ->  String-strVal attvarr x  =   -     toCalc $ (attvarr ! (fst x)) !! (snd x)---- get the attribute string from an index -strAtt :: Array Int [String] -> Int -> String-strAtt attvarr ix = head (attvarr ! ix)- -- insert a separator s between two strings  inSep :: String -> String -> String -> String inSep s x y = x ++ s ++ y----------------------------------------------- --- show the value of the attribute index or a blank+-- value string of an attribute-value tuple -indStr :: Array Int [String] -> [(Int,Int)] ->  Int-> String-indStr attvarr []  x = " "-indStr attvarr (y:ys) x | x == fst y = strVal  attvarr y-                        | otherwise = indStr attvarr ys x +av2ValStr :: Array Int [String] -> (Int,Int) ->  String+av2ValStr attvarr (x,y)  =   +     toCalc ((attvarr ! x) !! y) +-- get attribute string from index to array --- turn antecedent into CSV string +a2AttStr :: Array Int [String] -> Int -> String+a2AttStr attvarr ix = head (attvarr ! ix) -ant2Str :: Array Int [String] -> [Int]-> [(Int,Int)]-> String-ant2Str attvarr indls redlin =  -           foldl1 (inSep ",") y where-                   y = map (indStr attvarr redlin ) indls+-- lookup an av pair from an attribute +lkp :: Int -> [(Int,Int)] -> Maybe (Int,Int)+lkp att [] = Nothing+lkp att (x:xs) | att == fst x = Just x+               | otherwise = lkp att xs  --- get consequent value string and newline-cns2Str :: Array Int [String] -> (Int,Int) ->  String-cns2Str attvarr cons = -           ",\" is \"," ++ (strVal attvarr cons) ++ "\n"+-- order a reduced rule to att list and fill in the blanks --- get the table antecedent header-ahd2Str :: Array Int [String] -> [Int] ->  String-ahd2Str attvarr indls  = foldl1 (inSep ",") y where-                   y = [ strAtt attvarr z | z <- indls ]+formatRed :: [Int] -> [(Int,Int)] -> [Maybe (Int,Int)]+formatRed [] red = []+formatRed (x:xs) red = (lkp x red): (formatRed xs red) --- get consequent attribute string and newline-chd2Str ::  Array Int [String] -> Int -> String-chd2Str attvarr ati = -     ", ," ++  (toCalc (head (attvarr ! ati))) ++ "\n"+-- transform a maybe av pair to a OO Calc string --- show the table header in csv format-hd2csv :: Array Int [String] -> ([Int], Int) -> String-hd2csv attvarr hdp = -     (ahd2Str attvarr (fst hdp)) ++ (chd2Str attvarr (snd hdp))----------------------------------------------------+mbAV2Calc :: Array Int [String] -> Maybe (Int,Int) -> String+mbAV2Calc attvarr avp = +   case avp of +        Just x -> av2ValStr attvarr x+        Nothing -> " " --- show a reduction for a consequent value in csv+-- transform a reduced rule to a list of OOCalc strings -red2csv :: Array Int [String] -> [Int] -> ([[(Int,Int)]], (Int,Int)) -> [String]-red2csv attvarr indls rstp = -          map ( ++ cns2Str attvarr (snd rstp)) redstr where -                    redstr =  map (ant2Str attvarr indls) (fst rstp)+red2CalStr :: Array Int [String] -> [Int] -> [(Int,Int)] -> [String]+red2CalStr attvarr attls red = +          map (mbAV2Calc attvarr) frmred where+                        frmred = formatRed attls red --- show the reduction results for an attribute in csv+-- convert a reduced rule to a .csv table row -all2csv :: Array Int [String] -> [Int] -> [([[(Int,Int)]], (Int,Int))] -> String-all2csv attvarr indls redres = concat $ concatMap (red2csv attvarr indls) redres+red2CSV :: Array Int [String] -> [Int] -> [(Int,Int)] -> String+red2CSV attvarr attls red =+    (foldr1 (inSep ",") (init calcs)) ++ +    ",\" is \"," ++ (last calcs) ++ "\n" where+          calcs = red2CalStr attvarr attls red+-------------------------------------------------- --- output a csv table from the array of attribute-value names,--- the antecedent attributes and consequent, and the --- zip of the reduction results and the consequent values+-- get the attributes from a rule (ORIGINAL RULE) -red2Table :: Array Int [String] -> ([Int],Int)-> [([[(Int,Int)]], (Int,Int))] -> String-red2Table attvarr indls redres = -  (hd2csv attvarr indls) ++ (all2csv attvarr (fst indls) redres)+rule2Attls :: [(Int,Int)] -> [Int]+rule2Attls rule = map fst rule+----------------------------------------------------++-- convert header to .csv table row++hdr2CSV :: Array Int [String] -> [Int] -> String+hdr2CSV attvarr attls = +     (foldr1 (inSep ",") (init calcs)) ++ +     ", ," ++ (last calcs) ++  "\n"  where +              strls = map (a2AttStr attvarr) attls+              calcs = map toCalc strls            +--------------------------------------------------++-- convert a reduction for the same av consequent to .csv++sameCons2CSV :: Array Int [String] -> [Int] -> [[(Int,Int)]] -> String+sameCons2CSV attvarr attls redsame =+     concatMap (red2CSV attvarr attls) redsame++-- convert a reductions for an attribute to .csv++allReds2CSV :: Array Int [String] -> [Int] -> [[[(Int,Int)]]] -> String+allReds2CSV attvarr attls redgrp =+     concatMap (sameCons2CSV attvarr attls) redgrp+--------------------------------------------------++-- convert all reductions for an attribute to .csv table++res2CSVTb :: Array Int [String] -> [Int] -> [[[(Int,Int)]]] -> String+res2CSVTb attvarr attls redgrp =+     (hdr2CSV attvarr attls) ++ +     allReds2CSV attvarr attls redgrp+----------------------------------------------------+----------------------------------------------------++-- section for .csv output of abductions++-- get the branches of a tree ++brTree :: Tree a -> [[a]]+brTree (Node x []) = [[x]]+brTree (Node x for) = map (x:) brls where+                          brls = concatMap brTree for++-- show the antecedent as a .csv string+-- analogous to red2CSV, but on init, without consequent++ant2CSV :: Array Int [String] -> [Int] -> [(Int,Int)] -> String+ant2CSV attvarr attls red = +   foldr1 (inSep ",") calcs where +       calcs =  red2CalStr attvarr (init attls) (init red)++-- show a list of equals in .csv format++eqs2CSV :: Array Int [String] -> [Int] -> [[(Int,Int)]] -> 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 ++-- show a chain of equals in .csv format++chain2CSV :: Array Int [String] -> [Int] -> [[[(Int,Int)]]] -> String+chain2CSV attvarr attls chain+ | length chain == 1 = eqs2CSV attvarr attls (head chain)+ | otherwise = foldr1 (inSep ",\"implies\"\n") strls where+                 strls = map (eqs2CSV attvarr attls) chain++ruleChain2CSV :: Array Int [String] -> [Int] -> String -> [[[(Int,Int)]]] ->  String+ruleChain2CSV attvarr attls cons chain  =+    (chain2CSV attvarr attls chain) ++ +    ",\" is \"," ++ cons ++ "\n\n"+-------------------------------------------------------++-- get the consequent value string from a tree++consfrTree :: Array Int [String] -> Tree [[(Int,Int)]] -> String+consfrTree attvarr t = +   av2ValStr attvarr cns where+        cns = last (head (rootLabel t))++-- list of chains from a tree +-- Note: reverse all branches++chainsfrTree :: Tree [[(Int,Int)]] -> [[[[(Int,Int)]]]]+chainsfrTree t = map reverse (brTree t)++-- show a tree in .csv format++tree2CSV :: Array Int [String] -> [Int] -> Tree [[(Int,Int)]] -> String+tree2CSV attvarr attls t = +     concatMap (ruleChain2CSV attvarr attls cons) chains where+                            chains = chainsfrTree t+                            cons = consfrTree attvarr t+---------------------------------------------------------+-- a forest of abduction trees to .csv format++forest2CSV :: Array Int [String] -> [Int] -> Forest [[(Int,Int)]] -> String+forest2CSV attvarr attls for = +    concatMap (tree2CSV attvarr attls) for+-----------------------------------------------------+-- abduction result to .csv format++allAbds2CSV :: Array Int [String] -> [Int] -> [Forest [[(Int,Int)]] ]-> String+allAbds2CSV attvarr attls abdgrp =+    concatMap (forest2CSV attvarr attls) abdgrp+----------------------------------------------------+-- abduction result to .csv table++abd2CSVTb :: Array Int [String] -> [Int] -> [Forest [[(Int,Int)]] ] -> String+abd2CSVTb attvarr attls abdgrp =+     (hdr2CSV attvarr attls) ++ +     allAbds2CSV attvarr attls abdgrp+-----------------------------------------------------+-----------------------------------------------------++-- show ambiguous original rules in .csv format+-- Note: original rules do not need intermediate Maybe's++org2CSV :: Array Int [String] -> [(Int,Int)] -> String+org2CSV attvarr orule = +   antstr ++ ",\" is \"," ++ constr ++ "\n" where+        antstr = foldr1 (inSep ",") antstrls+        antstrls = init rulestrls        +        constr = last rulestrls+        rulestrls = map (av2ValStr attvarr) orule++-- ambiguous rules to .csv (always more than one)++ambs2CSV :: Array Int [String] -> [[(Int,Int)]] -> String+ambs2CSV attvarr ambrls = +     (concatMap (org2CSV attvarr) ambrls) ++ "\n"++ambgrp2CSV :: Array Int [String] -> [[[(Int,Int)]]] -> String+ambgrp2CSV attvarr ambgrp +    | length ambgrp == 1 = ambs2CSV attvarr (head ambgrp)+    | otherwise = concatMap (ambs2CSV attvarr) ambgrp++amb2CSVTb :: Array Int [String] -> [Int] -> [[[(Int,Int)]]] -> String+amb2CSVTb attvarr attls ambgrp =+   hdr2CSV attvarr attls ++ ambstr where+         ambstr = ambgrp2CSV attvarr ambgrp
src/Codec.hs view
@@ -1,17 +1,25 @@ module Codec ( avCod, avArr )where  -- (c) 2007 Hans van Thiel--- Version 0.1 License GPL+-- Version 0.2 License GPL --- Note: extended Haskell because of dependent parameters- -{- module: code a table of strings into:-    attribute-value lists, with the attributes in the heads-    lists of tuples, fst indexing att, snd indexing val -        attribute indexes av-list of lists, start 0-        value indexes value in av-list, start 1-   string table has: attribute names in first line-                     attribute values in following lines+{- module: code a table of attributes and values++Note: extended Haskell because of dependent parameters++first row of table: attribute names (must be unique)+following rows of table: attribute values++avArr produces an array of string lists+head of each list, with index 0, is an attribute name+tail of each list, starting with index 1, has value names++avCod produces a list of lists of attribute-value tuples +first of each tuple codes an attribute as an Int index+into the attribute-value array+second of each tuble codes a value as an index into the+list indexed by its attribute (0 is the attribute name,+and 1 is the first value in the list) -}  import Data.List (transpose, elemIndex)@@ -60,5 +68,3 @@ avArr :: [[String]] -> Array Int [String] avArr tb = listArray (0, (length attvals) -1) attvals where       attvals = avLs tb--
src/Main.hs view
@@ -1,41 +1,79 @@-module Main where+module Main ( main ) where  -- (c) 2007 Hans van Thiel--- Version 0.1 License GPL+-- Version 0.2 License GPL +-- module: reduce a table of facts in .csv format+-- output the reduction to a .csv table for OO Calc+ import System.Environment (getArgs )+import Data.Array import CSVParse (getTable ) import Codec (avArr, avCod )-import Aux (redAtt, selavN, gtAtec )-import CSVTable ( red2Table )-import Data.Array+import Reduce ( f2Grp, redAll, ambOrg )+import CSVTable (rule2Attls ,res2CSVTb,abd2CSVTb,amb2CSVTb )+import Abduce (abdAll, cntEDAtt )  main = do  [fname] <- getArgs            tb <- getTable fname            let  attvarr = avArr tb-           consN <- getConsAtt attvarr-           let  src = avCod tb-                cons = selavN consN attvarr-                redres = redAtt cons src-                indls = gtAtec (fst (head cons)) attvarr-                outTable = red2Table attvarr indls redres-           writeFile (consN ++ ".csv") outTable+                facts = avCod tb+           (consNm, cons) <- getConsAtt attvarr+           let  rulegrp = f2Grp cons facts+                redres = redAll rulegrp+                ambgrp = ambOrg rulegrp+                attls = rule2Attls ((head . head) rulegrp)+                outTable = res2CSVTb attvarr attls redres+                abdres = abdAll rulegrp redres+                (dep, sin) = cntEDAtt abdres+                abdTable= abd2CSVTb attvarr attls abdres+                ambigTable = amb2CSVTb attvarr attls ambgrp+           writeFile ("RNF_" ++ consNm ++ ".csv") outTable+           putStrLn ("Ambiguous Rules:   " ++ show (length ambgrp))+           if ambgrp == [] then return ()+                           else writeFile ("AMB_" ++ consNm ++ ".csv") ambigTable+           putStrLn ("Dependency Trees:  " ++ (show dep))+           putStrLn ("Unconnected Rules: " ++ (show sin))+           if dep == 0 then return()+                       else writeFile ("DPT_" ++ consNm ++ ".csv") abdTable+---------------------------------------------------+-- auxiliary functions for getConsAtt --------------------------------------------- print the list of attribute names+-- show list of attribute names for getConsN and getCons  shAtts :: Array Int [String] -> IO ()-shAtts attvar = print als where-               als = [ head x | x <- elems attvar ]   +shAtts attvarr = print als where+               als = [ head x | x <- elems attvarr ]   +-- get the index of an attribute string++usrAtt :: String -> Array Int [String] -> Maybe Int+usrAtt att attvarr  = +  slAtt att (indices attvarr) attvarr where+    slAtt at [] arr = Nothing +    slAtt at (x:xs) arr | att == (head (arr ! x)) = Just x+                        | otherwise = slAtt at xs arr+  -- get the consequent attribute from the user+-- (allow for typing errors of attribute name) -getConsAtt :: Array Int [String] -> IO String-getConsAtt attvarr = do { putStrLn "Select the consequent attribute /n ( ? to see all)" ;+getConsN :: Array Int [String] -> IO String+getConsN attvarr = do { putStrLn "Select the consequent attribute ( ? to see all)" ;                   answ <- getLine ;                   if answ == "?"                       then do { shAtts attvarr;-                                           getConsAtt attvarr }-                     else return answ +                               getConsN attvarr }+                     else return answ                          }--------------------------------------------++-- returns name and value of selected attribute + +getConsAtt :: Array Int [String] -> IO (String, Int)+getConsAtt attvarr = do { nm <- getConsN attvarr ;+                        case usrAtt nm attvarr of+                            Just x -> return (nm, x)+                            Nothing -> do { putStrLn "Unknown Attribute.." ;+                           getConsAtt attvarr }+                     }++
src/Reduce.hs view
@@ -1,13 +1,25 @@-module Reduce ( redCons ) where+module Reduce (isSub,f2Grp, redAll, ambOrg ) where  -- (c) 2007 Hans van Thiel--- Version 0.1 License GPL+-- Version 0.2 License GPL --- module: get the reduced normal form of a rule model--- some general purpose functions+{- module: get the reduced normal form of a rule model -import Data.List (nub, (\\), nubBy, partition )+a fact is a list of attribute value pairs+a rule is a the same list of av pairs, interpreted with+init as antecedent and last as consequent (of course+reshuffled according to consequent attribute selection) +the reduction algorithm is implemented by redPos p n+redAll implements this on a group of rules, partitioned+by their consequent attribute. So redAll follows f2Grp!++-}++import Data.List (nub, (\\), nubBy, partition, delete )++-- some general purpose functions+ isSub, isSuper :: Eq a => [a] -> [a] -> Bool isSub [] y = True isSub (x:xs) y | not (x `elem` y) = False@@ -24,6 +36,15 @@ minLs x y | x `isSub` y = x           | otherwise = y +-- partitions a list according to an equivalence relation++partitionBy :: (a -> a -> Bool) -> [a] -> [[a]]+partitionBy eq [] = []+partitionBy eq ls = x:(partitionBy eq y)  where+                   (x,y) = partition ((head ls) `eq`) ls ++-- A,B and C: the reduction algorithm in its three steps+ -- A: formulate hypothesis from original rules (positive)  hypot :: Eq a => [[a]] -> [a]@@ -85,23 +106,49 @@                     isIn y ls = or (map (isSub y) ls)  -- A, B and C: reduce a list of positive original rules +-- Note: redPos takes antecedents only!  redPos :: (Eq a,Eq b) => [[(a,b)]] -> [[(a,b)]] -> [[(a,b)]] redPos p n = verify (trAndOr (match (hypot p) n)) p+------------------------------------------------------- --- reduce a list of attribute-value pairs by selecting the--- consequent. The consequent attribute is removed from p and n+-- facts to rules by putting consequent attribute last --- remove the consequent attributes+shuf :: (Eq a, Eq b) => a -> [(a,b)] -> [(a,b)]+shuf at avls = (fst z) ++ (snd z) where+                  z = partition ((at /=) . fst) avls -rmAtt :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[(a,b)]]-rmAtt at rws =  map rm rws where -                    rm  ls = [y | y <- ls, at /= fst y ]+f2rules :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[(a,b)]]+f2rules at facls =  map (shuf at) facls --- reduce the list of attribute- value pairs (no consequent)+-- group according to consequent attribute-values -redCons :: (Eq a, Eq b) => (a,b) -> [[(a,b)]] -> [[(a,b)]]-redCons x y = redPos p n where-                    z= partition (x `elem`) y -                    p = rmAtt (fst x) (fst z)-                    n = rmAtt (fst x) (snd z)+f2Grp :: (Eq a, Eq b) => a -> [[(a,b)]] -> [[[(a,b)]]] +f2Grp at facls = +    partitionBy (\x y -> (last x) == (last y)) ruls where+                    ruls = f2rules at facls+                 +-- reduce one of a group of rules. Consequent is last in+-- each rule list..++redOne :: (Eq a, Eq b) => [[[(a,b)]]] -> [[(a,b)]] -> [[(a,b)]]+redOne grp rls  = map (++ [cns]) (redPos p n)  where+           p = map init rls+           n = map init (concat $ (delete rls grp))+           cns = (last . head) rls++-- reduce a rule model for all attribute-value pairs +-- the consequents will be last in each AV-list+-- Note: facts are converted to grouped rules by f2rGrp!++redAll :: (Eq a,Eq b)=> [[[(a,b)]]] ->  [[[(a,b)]]]+redAll rlgrp = map (redOne rlgrp) rlgrp+--------------------------------------------------------++-- find ambiguities in rule group+-- Note: == works because rows have same av order++ambOrg :: (Eq a, Eq b) => [[[(a,b)]]] -> [[[(a,b)]]]+ambOrg grp = filter (\x -> (length x) > 1) anteqs where+   anteqs = partitionBy (\x y -> (init x) == (init y)) ols+   ols = concat grp
− test_data/Fishing.csv 
@@ -1,15 +0,0 @@-Weather,Temperature,Humidity,Windy, ,"Fishing"-"sunny","hot", , ," is ","bad"-"sunny", ,"high", ," is ","bad"- ,"hot", ,"yes"," is ","bad"-"sunny","mild", ,"no"," is ","bad"-"rain", , ,"yes"," is ","bad"-"cloudy", , , ," is ","good"- ,"cool", ,"no"," is ","good"- , ,"normal","no"," is ","good"- ,"mild","normal", ," is ","good"- ,"hot","normal", ," is ","good"-"rain", , ,"no"," is ","good"-"sunny", ,"normal", ," is ","good"-"sunny","mild", ,"yes"," is ","good"-"sunny","cool", , ," is ","good"
+ test_data/NumQuinFacts.csv view
@@ -0,0 +1,16 @@+"Number","Weather","Temperature","Humidity","Windy","Fishing"+,,,,,+1,"sunny","hot","high","no","bad"+2,"sunny","hot","high","yes","bad"+3,"cloudy","hot","high","no","good"+4,"rain","mild","high","no","good"+5,"rain","cool","normal","no","good"+6,"rain","cool","normal","yes","bad"+7,"cloudy","cool","normal","yes","good"+8,"sunny","mild","high","no","bad"+9,"sunny","cool","normal","no","good"+10,"rain","mild","normal","no","good"+11,"sunny","mild","normal","yes","good"+12,"cloudy","mild","high","yes","good"+13,"cloudy","hot","normal","no","good"+14,"rain","mild","high","yes","bad"