Emping-0.6: src/CsvTable.hs
{- | 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
------------------------------------------------------------------------------