--------------------------------------------------------------------------------------------------- -- -- EftExperiment.hs - Embedded Figures Test Results Analyzer -- -- Experimental program to compare with EftExperiment.cpp -- -- Copyright (C) 2008 Alan G. Carter -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. -- --------------------------------------------------------------------------------------------------- module Main where import Graphics.UI.WX import Graphics.UI.WXCore import Control.Monad import Data.List import Data.Char import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S --------------------------------------------------------------------------------------------------- -- -- Tokens and Lookup Tables -- -- RangeQuestion : Tokens to to use as keys to store responses with range [ -2, -1, 1, 2] in a Map -- -- DrugType : Tokens indicating use of drugs, stored in a Set -- drugLookup : Table relating text drug names with tokens -- colourDrugs : A collection of 9 colours for displaying drug users' frequency distributions -- -- ActivityType : Tokens indicating activities, stored in a Set -- activityLookup : Table relating text activity names with tokens -- -- geekLookup : Substrings of Occupation implying geekly interests -- --------------------------------------------------------------------------------------------------- data RangeQuestion = IEnjoyMyJob | MyJobIsWellDefined | MyCoworkersAreCooperative | MyWorkplaceIsStressful | MyJobIsStressful | MoraleIsGoodWhereIWork | IGetFrustratedAtWork deriving (Eq, Ord, Show) data DrugType = DrugSsri | DrugBenzo | DrugRitalin | DrugAlcohol | DrugTobacco | DrugMarijuana | DrugCocaine | DrugMdma | DrugCaffeine deriving (Eq, Ord, Show) drugLookup = [("SSRIs", DrugSsri) ,("Benzodiazepines", DrugBenzo) ,("Ritalin", DrugRitalin) ,("Alcohol", DrugAlcohol) ,("Tobacco", DrugTobacco) ,("Marijuana", DrugMarijuana) ,("Cocaine", DrugCocaine) ,("MDMA", DrugMdma) ,("caff", DrugCaffeine)] colourSsri = rgb 0 0 255 colourBenzo = rgb 0 255 0 colourRitalin = rgb 255 0 0 colourAlcohol = rgb 255 255 0 colourTobacco = rgb 255 0 255 colourMarijuana = rgb 0 255 255 colourCocaine = rgb 0 0 127 colourMdma = rgb 0 127 0 colourCaffeine = rgb 127 0 0 data ActivityType = EveningWalks | CulturalActivities | ImaginaryFriend | History | Cooking | Meditation | ChangeRoutes | ChangeJob | MoveHome | FallInLove | BreakUp | NewCar | Vacation | SeeOldFriends | GetMoreSleep | Disaster deriving (Eq, Ord, Show) activityLookup = [("Evening Walks", EveningWalks) ,("Cultural Activities", CulturalActivities) ,("Imaginary Friend", ImaginaryFriend) ,("History", History) ,("Cooking", Cooking) ,("Meditation", Meditation) ,("Change Routes", ChangeRoutes) ,("Change Job", ChangeJob) ,("Move Home", MoveHome) ,("Fall In Love", FallInLove) ,("Break Up", BreakUp) ,("New Car", NewCar) ,("Vacation", Vacation) ,("See Old Friends", SeeOldFriends) ,("Get More Sleep", GetMoreSleep) ,("Disaster", Disaster)] geekLookup = [ "software" , "programm" , "system" , "sysadmin" , "sysadm" , "devel" , "engr" , "sd" , "engineer" , "computer" , "mathemat" , "comp-sci" , "csstudent" , "dba" , "web" ] --------------------------------------------------------------------------------------------------- -- -- Entry and HardEntry -- -- An Entry record contains one person's results. It is constructed from many partial Entry, each -- representing one line of the input file. These are then combined (based on the record ID) to -- make the complete entries as they put into a Map. To enable partial Entry, everything in the -- definition which isn't a Map or a Set is a Maybe. We have a combine function which favours a -- Just over a Nothing, and merges the Map of ranges and Sets of drugs and activities. We also have -- an emptyEntry which contains Nothing, an empty Map or empty Sets as appropriate. -- -- Unfortunately it's a bit awkward dealing with the Maybes once the Entrys have been combined. We -- therefore define a HardEntry which is an Entry without the Maybes, and a function hardenEntry -- which takes an Entry and returns a HardEntry, putting in defaults where necessary. The field -- names in the HardEntry all have "h" in front of them. -- --------------------------------------------------------------------------------------------------- data Entry = Entry { isMale :: Maybe Bool , ageGroup :: Maybe Int , occupation :: Maybe String , isGeek :: Maybe Bool , ranges :: M.Map RangeQuestion Int , activities :: S.Set ActivityType , drugs :: S.Set DrugType , isNauseous :: Maybe Bool , otherMeds :: Maybe String , otherDrugs :: Maybe String , before :: Maybe Int , after :: Maybe Int } deriving (Eq, Ord, Show) combine :: Entry -> Entry -> Entry combine (Entry a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12) (Entry b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12) = Entry (a01 `mplus` b01) (a02 `mplus` b02) (a03 `mplus` b03) (a04 `mplus` b04) (a05 `M.union` b05) (a06 `S.union` b06) (a07 `S.union` b07) (a08 `mplus` b08) (a09 `mplus` b09) (a10 `mplus` b10) (a11 `mplus` b11) (a12 `mplus` b12) emptyEntry = Entry { isMale = Nothing , ageGroup = Nothing , occupation = Nothing , isGeek = Nothing , ranges = (M.empty) , activities = (S.empty) , drugs = (S.empty) , isNauseous = Nothing , otherMeds = Nothing , otherDrugs = Nothing , before = Nothing , after = Nothing } data HardEntry = HardEntry { hIsMale :: Bool , hAgeGroup :: Int , hOccupation :: String , hIsGeek :: Bool , hRanges :: M.Map RangeQuestion Int , hActivities :: S.Set ActivityType , hDrugs :: S.Set DrugType , hIsNauseous :: Bool , hOtherMeds :: String , hOtherDrugs :: String , hBefore :: Int , hAfter :: Int } deriving (Eq, Ord, Show) hardenEntry e = HardEntry { hIsMale = fromMaybe False (isMale e) , hAgeGroup = fromMaybe 0 (ageGroup e) , hOccupation = fromMaybe "" (occupation e) , hIsGeek = fromMaybe False (isGeek e) , hRanges = (ranges e) , hActivities = (activities e) , hDrugs = (drugs e) , hIsNauseous = fromMaybe False (isNauseous e) , hOtherMeds = fromMaybe "" (otherMeds e) , hOtherDrugs = fromMaybe "" (otherDrugs e) , hBefore = fromMaybe 0 (before e) , hAfter = fromMaybe 0 (after e) } --------------------------------------------------------------------------------------------------- -- -- Input File Parsing Utility Functions -- -- split tokenizes a String into a list, delimited by a given character. The data file lines are -- all tab delimited. -- -- validateInteger takes a String and returns Just an Int if it parses, Nothing otherwise. -- -- encodeRange takes a String and returns an Int score. -- -- doRange takes a record ID, a token for a range response, a text response and a multiplier. -- Returns a tuple containing an Int key and an Entry. The Entry's ranges Map contains the token as -- the key, and the encodeRange numeric encoding of the response times the multiplier as the value. -- The multiplier is used to make normalized positive responses to negatively worded questions. -- The tuple is ready to be combined into the final Map of keys to Entrys. -- -- registerActivity is a tricky worker function given to a foldl. Takes a tuple of a string holding -- all the reporter's activities and a Set of ActivityType. This first tuple is the "initial value" -- of a map. Also takes a tuple relating an activity's text name and token. This second tuple is an -- element of the activityLookup table (see above), also given to the foldl. Returns a tuple -- containing the reporter's activities and either the input Set if the text name is *not* -- contained in the reporter's activities, or the input Set with the token added if the text name -- *is* in the reporter's activities. -- -- doActivities is the driver for registerActivity. Takes a reporter's activities. Gives it to -- foldl with an empty Set and the activityLookup table. Out pops a String and Set tuple, and we -- select the Set with snd. This Set then contains the appropriate token for each activity names in -- the report. -- -- registerDrug is similar to registerActivity. -- -- doDrugs is similar to doActivities. -- -- doGeeky takes a String which will the the reporter's occupation. Looks for the geekiness -- implying substrings in geekLookup, and logically ORs the results. If the occupation contains one -- or more geek implying substrings doGeeky will retun True. -- -- cutUp takes the input file in a String. The file consists of lines of tab delimited fields. The -- function breaks the text into a list of lines, then maps that into a list of lists of fields. -- The list of lists is then filtered to ensure all elements have 4 elements, and the top row is -- thrown away (because it contains the column headings). -- -- checkScores is a little utility which returns True if the before and after scores given to it -- are within acceptable limits. -- --------------------------------------------------------------------------------------------------- split :: String -> Char -> [String] split [] delim = [""] split (c:cs) delim | c == delim = "" : rest | otherwise = (c : head rest) : tail rest where rest = split cs delim validateInteger s = case reads s :: [(Int, String)] of [(x, "")] -> (Just x) _ -> Nothing encodeRange "Strongly Agree" = 2 encodeRange "Agree" = 1 encodeRange "Disagree" = -1 encodeRange "Strongly Disagree" = -2 encodeRange _ = 0 doRange k f v s = (read k, emptyEntry { ranges = M.singleton f ((encodeRange v) * s)}) registerActivity (chatter, actSet) (option, act) = if (isInfixOf option chatter) then (chatter, (S.insert act actSet)) else (chatter, actSet) doActivities v = snd (foldl registerActivity (v, S.empty) activityLookup) registerDrug (chatter, drugSet) (option, drug) = if (isInfixOf option chatter) then (chatter, (S.insert drug drugSet)) else (chatter, drugSet) doDrugs v = snd (foldl registerDrug (v, S.empty) drugLookup) doGeeky v = foldl (||) False (map (\t -> (isInfixOf t (map toLower v))) geekLookup) cutUp contents = tail (filter (\fields -> (length fields) == 4) (map (\x -> split x '\t') (lines contents))) checkScores b a = (b > 100) && (b < 10000) && (a > -1) && (a < 10000) --------------------------------------------------------------------------------------------------- -- -- readRow -- -- The input files contains many lines. Each line contains 4 fields: -- -- Line ID (not used). -- Record ID -- Property Name -- Value -- -- These lines can be assembled into records. The job of readRow is to take a list of 4 values from -- such a line and in each case return a tuple of the record ID and a partial Entry filled is as -- indicated by the line. The Entrys will then be combined by their associated keys to make the -- complete records. -- -- The correct version of readRow is selected by the arguments, and each version does something -- slightly different. -- -- Gender : We only notice a male to avoid redundancy here. The False alternative will be -- explicitly put in place where necessary when we use hardenEntry to create a -- HardEntry -- Age : Textual age bands are converted to numbers 0 to 10. -- Occupation : The occupation is stored, and the isGeek flag is set if doGeeky finds any geek -- implying substrings. -- New Activities : The argument is a comma separated list of activity names. doActivities converts -- this into a Set of tokens. -- Ranges : doRange (see above) does all the work, the only work in readRow (except calling -- doRange) is passing the correct token and multiplier (for turning negatively -- worded questions into positive values) to doRange. The Nausea question offers a -- range, but we just convert it into a Bool. -- Drugs : The questions distinguish between prescription and non-prescription drugs, but -- they go into the same Set. The user text is a comma seperated list like New -- Activities. We also pick up the string "caff" in the free text Other Drugs. -- Scores : We call validateInteger which will return Nothing if the score fails to parse -- as a number, or Just the parsed Int. -- --------------------------------------------------------------------------------------------------- readRow :: [String] -> (Int, Entry) readRow [n, k, "Gender", "Male"] = (read k, emptyEntry { isMale = Just True }) readRow [n, k, "Age", "0 - 9"] = (read k, emptyEntry { ageGroup = Just 0 }) readRow [n, k, "Age", "10 - 19"] = (read k, emptyEntry { ageGroup = Just 1 }) readRow [n, k, "Age", "20 - 29"] = (read k, emptyEntry { ageGroup = Just 2 }) readRow [n, k, "Age", "30 - 39"] = (read k, emptyEntry { ageGroup = Just 3 }) readRow [n, k, "Age", "40 - 49"] = (read k, emptyEntry { ageGroup = Just 4 }) readRow [n, k, "Age", "50 - 59"] = (read k, emptyEntry { ageGroup = Just 5 }) readRow [n, k, "Age", "60 - 69"] = (read k, emptyEntry { ageGroup = Just 6 }) readRow [n, k, "Age", "70 - 79"] = (read k, emptyEntry { ageGroup = Just 7 }) readRow [n, k, "Age", "80 - 89"] = (read k, emptyEntry { ageGroup = Just 8 }) readRow [n, k, "Age", "90 - 99"] = (read k, emptyEntry { ageGroup = Just 9 }) readRow [n, k, "Age", "100+"] = (read k, emptyEntry { ageGroup = Just 10 }) readRow [n, k, "Occupation", v] = (read k, emptyEntry { occupation = Just v, isGeek = Just (doGeeky v) }) readRow [n, k, "New Activities", v] = (read k, emptyEntry { activities = (doActivities v)}) readRow [n, k, "I Enjoy My Job", v] = doRange k IEnjoyMyJob v 1 readRow [n, k, "My Job Is Well Defined", v] = doRange k MyJobIsWellDefined v 1 readRow [n, k, "My Co-workers Are Co-operative", v] = doRange k MyCoworkersAreCooperative v 1 readRow [n, k, "My Workplace Is Stressful", v] = doRange k MyWorkplaceIsStressful v (-1) readRow [n, k, "My Job Is Stressful", v] = doRange k MyJobIsStressful v (-1) readRow [n, k, "Morale Is Good Where I Work", v] = doRange k MoraleIsGoodWhereIWork v 1 readRow [n, k, "I Get Frustrated At Work", v] = doRange k IGetFrustratedAtWork v (-1) readRow [n, k, "I Feel Nauseous When Very Bored", v] = (read k, emptyEntry { isNauseous = Just ((encodeRange v) > 0)}) readRow [n, k, "Prescription Meds", v] = (read k, emptyEntry { drugs = (doDrugs v)}) readRow [n, k, "Non-Prescription Drugs", v] = (read k, emptyEntry { drugs = (doDrugs v)}) readRow [n, k, "Other Meds", v] = (read k, emptyEntry { otherMeds = Just v }) readRow [n, k, "Other Drugs", v] = (read k, emptyEntry { otherDrugs = Just v, drugs = (doDrugs (map toLower v)) }) readRow [n, k, "Before", v] = (read k, emptyEntry { before = validateInteger v }) readRow [n, k, "After", v] = (read k, emptyEntry { after = validateInteger v }) readRow [n, k, f, v] = (read k, emptyEntry) --------------------------------------------------------------------------------------------------- -- -- Statistical Processing -- -- mkDouble converts an Int to a Double. There doesn't seem to be a direct way to do this. -- -- intDiv does a C style truncating divide of two Ints. -- -- mean calculates the arithmetic mean of its inputs as a Double. -- -- stdDev calculates the standard deviation of its inputs as a Double. -- -- makeDistribColumns takes a list of HardEntrys and a list of one second score band numbers as -- found in the hBefore field of the HardEntrys. It produces a list of tuples, containing the score -- band number (useful for debugging but not otherwise) and a list of the hBefore scores found in -- the HardEntrys in the score band. We don't actually use the scores again - we just count the -- number of score - but this retains commonality with the similar calculations described below. -- -- makeDistribStats takes the output of makeDistribColumns and returns a list of tuples containing -- the score band, and the number of scores in each band. These can then be used to plot a -- histogram showing the number of Entrys in each one second score band. -- -- makeAgeColumns is similar to makeDistribColumns, but produces lists of hBefore scores in age -- bands as found in the hAgeGroup field. -- -- makeAgeStats takes the output of makeAgeColumns and returns a list of tuples containing the age -- band, the mean and the standard deviation, rounded to Ints. -- -- sumRanges adds the scores between -2 and +2 held in a map of ActivityType to Int. -- -- makeStressColumns is similar to makeDistribColumns, but organises the Entrys into bands between -- -14 and +14, as found by summing the scores in the Map of ActivityType to Int, which is called -- hRanges. -- -- makeStressStats is similar to makeAgeStats. -- -- makeActColumns is similar to makeAgeColumns, but just takes the number of activities in the Set -- called hActivities, and extracts the hBefore and hAfter scores.. -- -- makeActStats is similar to makeAgeStats, but calculates the mean and standard deviation of the -- before and after scores. -- --------------------------------------------------------------------------------------------------- mkDouble :: Int -> Double mkDouble x = fromInteger (toInteger x) :: Double intDiv :: Int -> Int -> Int intDiv a b = floor ((mkDouble a) / (mkDouble b)) mean :: [Int] -> Double mean x = (mkDouble (sum x)) / (mkDouble (length x)) stdDev :: [Int] -> Double stdDev x = sqrt ((sum (map (\d -> (((mkDouble d) - (mean x))^2)) x)) / (mkDouble (length x))) makeDistribColumns :: [HardEntry] -> [Int] -> [(Int, [Int])] makeDistribColumns entries columns = map makeDistribColumn columns where makeDistribColumn column = (column, map (\h -> hBefore h) (filter (\d -> (intDiv (hBefore d) 1000) == column) entries)) makeDistribStats :: [(Int, [Int])] -> [(Int, Int)] makeDistribStats l = map (\(a, s) -> (a, length s)) l makeAgeColumns :: [HardEntry] -> [Int] -> [(Int, [Int])] makeAgeColumns entries columns = map makeAgeColumn columns where makeAgeColumn column = (column, map (\h -> hBefore h) (filter (\d -> (hAgeGroup d) == column) entries)) makeAgeStats :: [(Int, [Int])] -> [(Int, Int, Int)] makeAgeStats l = map (\(a, s) -> (a, round (mean s), round (stdDev s))) l sumRanges e = M.fold (+) 0 e makeStressColumns :: [HardEntry] -> [Int] -> [(Int, [Int])] makeStressColumns entries columns = map makeStressColumn columns where makeStressColumn column = (column, map (\h -> hBefore h) (filter (\d -> (sumRanges(hRanges d)) == column) entries)) makeStressStats :: [(Int, [Int])] -> [(Int, Int, Int)] makeStressStats l = map (\(a, s) -> (a, round (mean s), round (stdDev s))) l makeActColumns :: [HardEntry] -> [Int] -> [(Int, [Int], [Int])] makeActColumns entries columns = map makeActColumn columns where makeActColumn column = (column, map (\h -> hBefore h) (filter (\d -> (S.size(hActivities d)) == column) entries), map (\h -> hAfter h) (filter (\d -> (S.size(hActivities d)) == column) entries)) makeActStats :: [(Int, [Int], [Int])] -> [(Int, Int, Int, Int, Int)] makeActStats l = map (\(e, b, a) -> (e, round (mean b), round (stdDev b), round (mean a), round (stdDev a))) l --------------------------------------------------------------------------------------------------- -- -- The Luggage -- -- The status frame contains lots of text controls for reporting the number of Entrys in various -- groups. The statistical processing creates lists of numbers for plotting histograms, means and -- standard deviations. To make these collections of controls and values easy to pass around we -- collect them into tuples, and define some accessors for picking out the ones we want. -- --------------------------------------------------------------------------------------------------- getdTotal (x, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdValid (_, x, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdSingle (_, _, x, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdPaired (_, _, _, x, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdGeeks (_, _, _, _, x, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdNonGeeks (_, _, _, _, _, x, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getdMale (_, _, _, _, _, _, x, _, _, _, _, _, _, _, _, _, _, _, _) = x getdFemale (_, _, _, _, _, _, _, x, _, _, _, _, _, _, _, _, _, _, _) = x getdNauseators (_, _, _, _, _, _, _, _, x, _, _, _, _, _, _, _, _, _, _) = x getdNonNauseators (_, _, _, _, _, _, _, _, _, x, _, _, _, _, _, _, _, _, _) = x getdSsri (_, _, _, _, _, _, _, _, _, _, x, _, _, _, _, _, _, _, _) = x getdBenzo (_, _, _, _, _, _, _, _, _, _, _, x, _, _, _, _, _, _, _) = x getdRitalin (_, _, _, _, _, _, _, _, _, _, _, _, x, _, _, _, _, _, _) = x getdAlcohol (_, _, _, _, _, _, _, _, _, _, _, _, _, x, _, _, _, _, _) = x getdTobacco (_, _, _, _, _, _, _, _, _, _, _, _, _, _, x, _, _, _, _) = x getdMarijuana (_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, x, _, _, _) = x getdCocaine (_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, x, _, _) = x getdMdma (_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, x, _) = x getdCaffeine (_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, x) = x getvAgeStats (x, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getvDistribStatsAll (_, x, _, _, _, _, _, _, _, _, _, _, _, _, _) = x getvDistribStatsNauseous (_, _, x, _, _, _, _, _, _, _, _, _, _, _, _) = x getvDistribStatsNonNauseous (_, _, _, x, _, _, _, _, _, _, _, _, _, _, _) = x getvStressStats (_, _, _, _, x, _, _, _, _, _, _, _, _, _, _) = x getvActStats (_, _, _, _, _, x, _, _, _, _, _, _, _, _, _) = x getvDistribStatsSsri (_, _, _, _, _, _, x, _, _, _, _, _, _, _, _) = x getvDistribStatsBenzo (_, _, _, _, _, _, _, x, _, _, _, _, _, _, _) = x getvDistribStatsRitalin (_, _, _, _, _, _, _, _, x, _, _, _, _, _, _) = x getvDistribStatsAlcohol (_, _, _, _, _, _, _, _, _, x, _, _, _, _, _) = x getvDistribStatsTobacco (_, _, _, _, _, _, _, _, _, _, x, _, _, _, _) = x getvDistribStatsMarijuana (_, _, _, _, _, _, _, _, _, _, _, x, _, _, _) = x getvDistribStatsCocaine (_, _, _, _, _, _, _, _, _, _, _, _, x, _, _) = x getvDistribStatsMdma (_, _, _, _, _, _, _, _, _, _, _, _, _, x, _) = x getvDistribStatsCaffeine (_, _, _, _, _, _, _, _, _, _, _, _, _, _, x) = x --------------------------------------------------------------------------------------------------- -- -- GUI Utility Functions -- -- scalingTable is a list of Y axis scale sizes and spacing between calibration marks that make -- aesthetically pleasing layouts. If the scale size required is bigger than the greatest available -- then 10 calibration marks are selected, to contain the requirement. -- -- intDivUp performs a rounded up Int division. -- -- maxOfHistogram finds the maximum value in a list of (column, value) tuples. It's used in finding -- how big the Y axis of the frequency distribution graphs must be. -- -- pickScale takes a Y scale requirement and returns a tuple from the scalingTable. If the scale -- size required is bigger than the greatest available in the scalingTable then a tuple containing -- 10 calibration marks are selected, to contain the requirement. -- -- chooseColoursDrawAxes draws the X and Y axes in black. -- -- drawScoreScaleY places calibration marks 0 - 9 on the Y axis, and adds a legend indictating -- either Before or Before and After scores, depending on the "both" argument. -- --------------------------------------------------------------------------------------------------- scalingTable = [(500, 50) ,(250, 25) ,(200, 20) ,(100, 10) ,( 50, 5) ,( 30, 3) ,( 25, 5) ,( 20, 2) ,( 10, 1) ,( 5, 1)] intDivUp :: Int -> Int -> Int intDivUp a b = ceiling ((mkDouble a) / (mkDouble b)) maxOfHistogram stats = snd (foldl (\(cA, vA) (cB, vB) -> if (vA > vB) then (cA, vA) else (cB, vB)) (0, 0) stats) pickScale :: Int -> (Int, Int) pickScale fsd = if (fsd > (fst (head scalingTable))) then let step = (intDivUp fsd 10) in (step * 10, step) else (foldl checkScale (0, 0) scalingTable) where checkScale (sA, dA) (sB, dB) | (sA < sB) && (sA >= fsd) = (sA, dA) | (sB < sA) && (sB >= fsd) = (sB, dB) | (sA > sB) = (sA, dA) | otherwise = (sB, dB) chooseColoursDrawAxes dc = do set dc[penColor := black, brushColor := grey, textColor := black] dcDrawLine dc (pt 100 500) (pt 600 500) dcDrawLine dc (pt 100 0) (pt 100 500) drawScoreScaleY dc both = do mapM_ (\n -> do let s = show n drawText dc s (pt 60 (500 - (n * 50)))[]) (take 10 [0..]) if (both) then do sz <- getTextExtent dc "Red: Before Green: After (s)" let offset = intDiv (500 - (sizeW sz)) 2 rotatedText dc "Red: Before Green: After (s)" (pt 30 (500 - offset)) 90 [] else do sz <- getTextExtent dc "Before (s)" let offset = intDiv (500 - (sizeW sz)) 2 rotatedText dc "Before (s)" (pt 30 (500 - offset)) 90 [] --------------------------------------------------------------------------------------------------- -- -- GUI Setup and Callbacks -- --------------------------------------------------------------------------------------------------- setUp = do -- create some mutable variables that the file opening routine can fill in and the various -- frames can access as needed. Collect them into a tuple vA <- varCreate [] vB <- varCreate [] vC <- varCreate [] vD <- varCreate [] vE <- varCreate [] vF <- varCreate [] vG <- varCreate [] vH <- varCreate [] vI <- varCreate [] vJ <- varCreate [] vK <- varCreate [] vL <- varCreate [] vM <- varCreate [] vN <- varCreate [] vO <- varCreate [] let v = (vA, vB, vC, vD, vE, vF, vG, vH, vI, vJ, vK, vL, vM, vN, vO) -- a mutable variable to store the list of active frames, to we avoid trying to repaint a graph -- that the user has dismissed by closing the frame. vKnownFrames <- varCreate [] -- create the status frame and graph frames. statusFrame <- frame [text := "EFT Analyzer", fullRepaintOnResize := False] -- frequency distribution graph distribFrame <- frame [ text := "Frequency Distribution" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] distribPanel <- panel distribFrame [ clientSize := (sz 600 600) , position := (pt 0 0)] set distribPanel [ on paint := onDistribPanelPaint (getvDistribStatsAll v) ] -- frequency distribution graph nauseators distribFrameNauseators <- frame [ text := "Frequency Distribution (Nauseators)" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] distribPanelNauseators <- panel distribFrameNauseators [ clientSize := (sz 600 600) , position := (pt 0 0)] set distribPanelNauseators [on paint := onDistribPanelPaint (getvDistribStatsNauseous v)] -- frequency distribution graph non-nauseators distribFrameNonNauseators <- frame [ text := "Frequency Distribution (Non-Nauseators)" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] distribPanelNonNauseators <- panel distribFrameNonNauseators [ clientSize := (sz 600 600) , position := (pt 0 0)] set distribPanelNonNauseators [on paint := onDistribPanelPaint (getvDistribStatsNonNauseous v)] -- frequency distribution graph drugs - note in this case we give the paint callback the whole -- tuple rather than a single list of stats. distribFrameDrugs <- frame [ text := "Frequency Distribution Per Drug" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] distribPanelDrugs <- panel distribFrameDrugs [ clientSize := (sz 600 600) , position := (pt 0 0)] set distribPanelDrugs [on paint := onDistribPanelDrugsPaint v] -- stressors by average score graph stressFrame <- frame [ text := "Stressors By Average Score" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] stressPanel <- panel stressFrame [ clientSize := (sz 600 600) , position := (pt 0 0)] set stressPanel [ on paint := onStressPanelPaint (getvStressStats v) ] -- exercises by average score graph actFrame <- frame [ text := "Exercises By Average Score" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] actPanel <- panel actFrame [ clientSize := (sz 600 600) , position := (pt 0 0)] set actPanel [ on paint := onActPanelPaint (getvActStats v) ] -- age by average score graph ageFrame <- frame [ text := "Age By Average Score" , clientSize := (sz 600 600) , bgcolor := white , fullRepaintOnResize := False ] agePanel <- panel ageFrame [ clientSize := (sz 600 600) , position := (pt 0 0)] set agePanel [ on paint := onAgePanelPaint (getvAgeStats v) ] -- create the file menu file <- menuPane [text := "File"] open <- menuItem file [text := "Open..."] quit <- menuQuit file [] -- create a bunch of text controls for displaying the number of Entrys in various groups, collect -- them into a tuple. dA <- textEntry statusFrame [text := "0", alignment := AlignRight] dB <- textEntry statusFrame [text := "0", alignment := AlignRight] dC <- textEntry statusFrame [text := "0", alignment := AlignRight] dD <- textEntry statusFrame [text := "0", alignment := AlignRight] dE <- textEntry statusFrame [text := "0", alignment := AlignRight] dF <- textEntry statusFrame [text := "0", alignment := AlignRight] dG <- textEntry statusFrame [text := "0", alignment := AlignRight] dH <- textEntry statusFrame [text := "0", alignment := AlignRight] dI <- textEntry statusFrame [text := "0", alignment := AlignRight] dJ <- textEntry statusFrame [text := "0", alignment := AlignRight] dK <- textEntry statusFrame [text := "0", alignment := AlignRight] dL <- textEntry statusFrame [text := "0", alignment := AlignRight] dM <- textEntry statusFrame [text := "0", alignment := AlignRight] dN <- textEntry statusFrame [text := "0", alignment := AlignRight] dO <- textEntry statusFrame [text := "0", alignment := AlignRight] dP <- textEntry statusFrame [text := "0", alignment := AlignRight] dQ <- textEntry statusFrame [text := "0", alignment := AlignRight] dR <- textEntry statusFrame [text := "0", alignment := AlignRight] dS <- textEntry statusFrame [text := "0", alignment := AlignRight] let d = (dA, dB, dC, dD, dE, dF, dG, dH, dI, dJ, dK, dL, dM, dN, dO, dP, dQ, dR, dS) -- put the text controls and the menu bar into the stats frame. set statusFrame [layout := grid 2 0 [[label "Total Entries", widget (getdTotal d)] ,[label "Valid Entries", widget (getdValid d)] ,[label "Single Values", widget (getdSingle d)] ,[label "Paired Values", widget (getdPaired d)] ,[label "Geeks", widget (getdGeeks d)] ,[label "Non Geeks", widget (getdNonGeeks d)] ,[label "Male", widget (getdMale d)] ,[label "Female", widget (getdFemale d)] ,[label "Nauseators", widget (getdNauseators d)] ,[label "Non Nauseators", widget (getdNonNauseators d)] ,[label "SSRIs", widget (getdSsri d)] ,[label "Benzodiazepines", widget (getdBenzo d)] ,[label "Ritalin", widget (getdRitalin d)] ,[label "Alcohol", widget (getdAlcohol d)] ,[label "Tobacco", widget (getdTobacco d)] ,[label "Marijuana", widget (getdMarijuana d)] ,[label "Cocaine", widget (getdCocaine d)] ,[label "MDMA", widget (getdMdma d)] ,[label "Caffeine", widget (getdCaffeine d)]] ,menubar := [file] ,on (menu open) := onOpen statusFrame d v vKnownFrames ,on (menu quit) := onQuit vKnownFrames ,on closing := onClosing statusFrame vKnownFrames ] -- gather all the frames into a list and set the mutable variable, and set a closing event -- handler on all the graph frames (statusFrame's event handler is set above) so we can repaint -- them when the user opens a data file. varSet vKnownFrames [ statusFrame , distribFrame , distribFrameNauseators , distribFrameNonNauseators , distribFrameDrugs , stressFrame , actFrame , ageFrame ] set distribFrame [ on closing := onClosing distribFrame vKnownFrames ] set distribFrameNauseators [ on closing := onClosing distribFrameNauseators vKnownFrames ] set distribFrameNonNauseators [ on closing := onClosing distribFrameNonNauseators vKnownFrames ] set distribFrameDrugs [ on closing := onClosing distribFrameDrugs vKnownFrames ] set stressFrame [ on closing := onClosing stressFrame vKnownFrames ] set actFrame [ on closing := onClosing actFrame vKnownFrames ] set ageFrame [ on closing := onClosing ageFrame vKnownFrames ] where -- onQuit closes all active frames. onQuit vKnownFrames = do knownFrames <- varGet vKnownFrames mapM_ (\f -> do close f) knownFrames -- onClosing removes the frame from the collection of active frames, so we do not attempt to -- repaint frames the user has dismissed (and crash). Then destroy the frame, or we have -- captured the event but not actioned it! onClosing theFrame vKnownFrames = do knownFrames <- varGet vKnownFrames let filtered = filter (\x -> not (x == theFrame)) knownFrames varSet vKnownFrames filtered skipCurrentEvent -- onOpen asks the user for a filename, returning silently if the user cancels, calling -- openResults if the user supplies a filename. onOpen statusFrame d v vKnownFrames = do fname <- fileOpenDialog statusFrame False True "EFT Results File" [("EFT Results File",["*.txt"])] "" "" case fname of Nothing -> return () Just fname -> openResults statusFrame fname d v vKnownFrames -- openResults reads the input file into a String, simulating a single line of dummy headings -- if the file read fails for any reason. This just provides a default "input" so we can always -- do the rest of the processing. My error handling is still weak :-) Then it calls cutUp, and -- maps the rows into readRow. The resulting list of (key, partial Entry) tuples are then -- placed into a Map, using combine to merge Entrys with the same key. Then it converts the Map -- back to a list, unzips the keys from the Entrys and chooses the list of Entrys. Then it uses -- hardenEntry to map the Entrys into HardEntrys so we don't have to mess around with the -- Maybes afterwards. -- -- Then openResults uses filter to produce subsets of Entrys which are of interest. Valid -- Entrys have a plausible hBefore score. Singles don't have an hAfter score while pairs do. -- Geeks, males, nauseators and non-nauseators are all selected from the list of valid Entrys. -- Lists of Entrys reporting use of the different specific drugs are also identified. -- -- Then openResults derives the lists of statistics - histograms, means and standard deviations -- as described above. It sets the mutable variables, and updates the displays of the counts of -- records in each group. openResults statusFrame fname d v vKnownFrames = do contents <- readFile fname `catch` \_ -> return "line\tof\tdummy\theadings" let entries = snd (unzip (M.toList (M.fromListWith combine (map readRow (cutUp contents))))) let hardened = map hardenEntry entries let valids = filter (\e -> checkScores (hBefore e) (hAfter e)) hardened let singles = filter (\e -> (hAfter e) == 0) valids let pairs = filter (\e -> (hAfter e) > 0) valids let geeks = filter (\e -> hIsGeek e) valids let males = filter (\e -> hIsMale e) valids let nauseous = filter (\e -> hIsNauseous e) valids let nonNauseous = filter (\e -> not (hIsNauseous e)) valids let ssri = filter (\e -> S.member DrugSsri (hDrugs e)) valids let benzo = filter (\e -> S.member DrugBenzo (hDrugs e)) valids let ritalin = filter (\e -> S.member DrugRitalin (hDrugs e)) valids let alcohol = filter (\e -> S.member DrugAlcohol (hDrugs e)) valids let tobacco = filter (\e -> S.member DrugTobacco (hDrugs e)) valids let marijuana = filter (\e -> S.member DrugMarijuana (hDrugs e)) valids let cocaine = filter (\e -> S.member DrugCocaine (hDrugs e)) valids let mdma = filter (\e -> S.member DrugMdma (hDrugs e)) valids let caffeine = filter (\e -> S.member DrugCaffeine (hDrugs e)) valids let ageStats = makeAgeStats (makeAgeColumns valids [0..9]) let distribStatsAll = makeDistribStats (makeDistribColumns valids [0..9]) let distribStatsNauseous = makeDistribStats (makeDistribColumns nauseous [0..9]) let distribStatsNonNauseous = makeDistribStats (makeDistribColumns nonNauseous [0..9]) let stressStats = makeStressStats (makeStressColumns valids [-15..15]) let actStats = makeActStats (makeActColumns pairs [0..17]) let distribStatsSsri = makeDistribStats (makeDistribColumns ssri [0..9]) let distribStatsBenzo = makeDistribStats (makeDistribColumns benzo [0..9]) let distribStatsRitalin = makeDistribStats (makeDistribColumns ritalin [0..9]) let distribStatsAlcohol = makeDistribStats (makeDistribColumns alcohol [0..9]) let distribStatsTobacco = makeDistribStats (makeDistribColumns tobacco [0..9]) let distribStatsMarijuana = makeDistribStats (makeDistribColumns marijuana [0..9]) let distribStatsCocaine = makeDistribStats (makeDistribColumns cocaine [0..9]) let distribStatsMdma = makeDistribStats (makeDistribColumns mdma [0..9]) let distribStatsCaffeine = makeDistribStats (makeDistribColumns caffeine [0..9]) varSet (getvAgeStats v) ageStats varSet (getvDistribStatsAll v) distribStatsAll varSet (getvDistribStatsNauseous v) distribStatsNauseous varSet (getvDistribStatsNonNauseous v) distribStatsNonNauseous varSet (getvStressStats v) stressStats varSet (getvActStats v) actStats varSet (getvDistribStatsSsri v) distribStatsSsri varSet (getvDistribStatsBenzo v) distribStatsBenzo varSet (getvDistribStatsRitalin v) distribStatsRitalin varSet (getvDistribStatsAlcohol v) distribStatsAlcohol varSet (getvDistribStatsTobacco v) distribStatsTobacco varSet (getvDistribStatsMarijuana v) distribStatsMarijuana varSet (getvDistribStatsCocaine v) distribStatsCocaine varSet (getvDistribStatsMdma v) distribStatsMdma varSet (getvDistribStatsCaffeine v) distribStatsCaffeine set (getdTotal d) [text := (show (length entries))] set (getdValid d) [text := (show (length valids))] set (getdSingle d) [text := (show (length singles))] set (getdPaired d) [text := (show ((length valids) - (length singles)))] set (getdGeeks d) [text := (show (length geeks))] set (getdNonGeeks d) [text := (show ((length valids) - (length geeks)))] set (getdMale d) [text := (show (length males))] set (getdFemale d) [text := (show ((length valids) - (length males)))] set (getdNauseators d) [text := (show (length nauseous))] set (getdNonNauseators d) [text := (show (length nonNauseous))] set (getdSsri d) [text := (show (length ssri))] set (getdBenzo d) [text := (show (length benzo))] set (getdRitalin d) [text := (show (length ritalin))] set (getdAlcohol d) [text := (show (length alcohol))] set (getdTobacco d) [text := (show (length tobacco))] set (getdMarijuana d) [text := (show (length marijuana))] set (getdCocaine d) [text := (show (length cocaine))] set (getdMdma d) [text := (show (length mdma))] set (getdCaffeine d) [text := (show (length caffeine))] knownFrames <- varGet vKnownFrames mapM_ (\f -> do repaint f) knownFrames -- onDistribPanelPaint is used to draw the 3 frequency distribution graphs - all, nauseators -- and non-nauseators - depending on the mutable list of statistics that it is set with in the -- 3 cases above. The X axis is calibrated into 1s score bands, the Y axis is calibrated by -- determining the maximum number of respondents in any band, and using pickScale to find a -- suitable tuple of maximum value and division. Then the blocks of the histogram are drawn. onDistribPanelPaint vStats dc viewArea = do stats <- varGet vStats if (length stats == 0) then return () else do chooseColoursDrawAxes dc -- draw the X scale and legend mapM_ (\n -> do let s = show n szX <- getTextExtent dc s let offsetX = intDiv (50 - (sizeW szX)) 2 drawText dc s (pt (100 + (n * 50) + offsetX) (500 + 20))[]) (take 10 [0..]) szX <- getTextExtent dc "Before (s)" let offsetX = intDiv (500 - (sizeW szX)) 2 drawText dc "Before (s)" (pt (100 + offsetX) (500 + 40)) [] -- draw the Y scale and legend let scaleTuple = pickScale (maxOfHistogram stats) let maxScale = fst scaleTuple let division = snd scaleTuple let pixelsPerNumber = intDiv 500 maxScale let pixelsPerDivision = pixelsPerNumber * division mapM_ (\n -> do let s = show (n * division) drawText dc s (pt 60 (500 - (n * pixelsPerDivision)))[]) (take (intDiv maxScale division) [0..]) szY <- getTextExtent dc "Respondents" let offsetY = intDiv (500 - (sizeW szY)) 2 rotatedText dc "Respondents" (pt 30 (500 - offsetY)) 90 [] -- draw the blocks mapM_ (\(c, v) -> do drawRect dc (Rect (100 + (c * 50)) (500 - (v * pixelsPerNumber)) 50 (v * pixelsPerNumber)) [ color := black , brushColor := grey , brushKind := BrushSolid]) stats -- onDistribPanelDrugsPaint is used to draw 9 frequency distribution graphs on one panel to -- show the effects of drugs. The X and Y axes are calibrated as above, and the graphs are -- drawn as polylines, since the splines used in the C++ version don't seem to be available in -- wxhaskell. onDistribPanelDrugsPaint v dc viewArea = do statsSsri <- varGet (getvDistribStatsSsri v) statsBenzo <- varGet (getvDistribStatsBenzo v) statsRitalin <- varGet (getvDistribStatsRitalin v) statsAlcohol <- varGet (getvDistribStatsAlcohol v) statsTobacco <- varGet (getvDistribStatsTobacco v) statsMarijuana <- varGet (getvDistribStatsMarijuana v) statsCocaine <- varGet (getvDistribStatsCocaine v) statsMdma <- varGet (getvDistribStatsMdma v) statsCaffeine <- varGet (getvDistribStatsCaffeine v) if ((length statsSsri == 0) && (length statsBenzo == 0) && (length statsRitalin == 0) && (length statsAlcohol == 0) && (length statsTobacco == 0) && (length statsMarijuana == 0) && (length statsCocaine == 0) && (length statsMdma == 0) && (length statsCaffeine == 0)) then return () else do chooseColoursDrawAxes dc -- draw the X scale and legend mapM_ (\n -> do let s = show n szX <- getTextExtent dc s let offsetX = intDiv (50 - (sizeW szX)) 2 drawText dc s (pt (100 + (n * 50) + offsetX) (500 + 20))[]) (take 10 [0..]) szX <- getTextExtent dc "Before (s)" let offsetX = intDiv (500 - (sizeW szX)) 2 drawText dc "Before (s)" (pt (100 + offsetX) (500 + 40)) [] -- draw the Y scale and legend let maxVal = foldl (\vA vB -> if (vA > vB) then vA else vB) 0 [ (maxOfHistogram statsSsri) , (maxOfHistogram statsBenzo) , (maxOfHistogram statsRitalin) , (maxOfHistogram statsAlcohol) , (maxOfHistogram statsTobacco) , (maxOfHistogram statsMarijuana) , (maxOfHistogram statsCocaine) , (maxOfHistogram statsMdma) , (maxOfHistogram statsCaffeine) ] let scaleTuple = pickScale maxVal let maxScale = fst scaleTuple let division = snd scaleTuple let pixelsPerNumber = intDiv 500 maxScale let pixelsPerDivision = pixelsPerNumber * division mapM_ (\n -> do let s = show (n * division) drawText dc s (pt 60 (500 - (n * pixelsPerDivision)))[]) (take (intDiv maxScale division) [0..]) szY <- getTextExtent dc "Respondents" let offsetY = intDiv (500 - (sizeW szY)) 2 rotatedText dc "Respondents" (pt 30 (500 - offsetY)) 90 [] -- map the lists of stats to points and plot them as polylines polyline dc (mapPoints pixelsPerNumber statsSsri) [color := colourSsri] polyline dc (mapPoints pixelsPerNumber statsBenzo) [color := colourBenzo] polyline dc (mapPoints pixelsPerNumber statsRitalin) [color := colourRitalin] polyline dc (mapPoints pixelsPerNumber statsAlcohol) [color := colourAlcohol] polyline dc (mapPoints pixelsPerNumber statsTobacco) [color := colourTobacco] polyline dc (mapPoints pixelsPerNumber statsMarijuana) [color := colourMarijuana] polyline dc (mapPoints pixelsPerNumber statsCocaine) [color := colourCocaine] polyline dc (mapPoints pixelsPerNumber statsMdma) [color := colourMdma] polyline dc (mapPoints pixelsPerNumber statsCaffeine) [color := colourCaffeine] -- Appropriately coloured keys drawText dc "SSRIs" (pt 400 (100 + (0 * 30))) [color := colourSsri] drawText dc "Benzodiazepines" (pt 400 (100 + (1 * 30))) [color := colourBenzo] drawText dc "Ritalin" (pt 400 (100 + (2 * 30))) [color := colourRitalin] drawText dc "Alcohol" (pt 400 (100 + (3 * 30))) [color := colourAlcohol] drawText dc "Tobacco" (pt 400 (100 + (4 * 30))) [color := colourTobacco] drawText dc "Marijuana" (pt 400 (100 + (5 * 30))) [color := colourMarijuana] drawText dc "Cocaine" (pt 400 (100 + (6 * 30))) [color := colourCocaine] drawText dc "MDMA" (pt 400 (100 + (7 * 30))) [color := colourMdma] drawText dc "Caffeine" (pt 400 (100 + (8 * 30))) [color := colourCaffeine] where mapPoints pixels stats = map (\(c, v) -> pt (100 + (c * 50) + 25) (500 - (v * pixels))) stats -- onStressPanelPaint is used to draw graph of mean (and standard deviation) of scores in each -- "chill point" band. Chill points are taken from the 7 questions concerning workplace -- stressors. Responses to each question can range from very stressed (-2) to unstressed (2). -- Therefore an individuals score can range from -14 to 14, although the X axis is calibrated -- -15 to 15 to allow marks every 5 points. The Y axis is calibrated into 10 1s marks. Means -- are plotted as circles, with the standard deviation as lines passing through the circles. onStressPanelPaint vStats dc viewArea = do stats <- varGet vStats if (length stats == 0) then return () else do chooseColoursDrawAxes dc -- draw the X scale and legend mapM_ (\n -> do let division = intDiv 500 30 let s = show ((n - 3) * 5) szX <- getTextExtent dc s let offsetX = intDiv (sizeW szX) 2 drawText dc s (pt (100 + (n * division * 5) - offsetX) (500 + 20))[]) (take 7 [0..]) szX <- getTextExtent dc "Chill Points" let offsetX = intDiv (500 - (sizeW szX)) 2 drawText dc "Chill Points" (pt (100 + offsetX) (500 + 40)) [] -- draw the Y scale and legend drawScoreScaleY dc False -- draw the means and standard deviations - ms / 20 gives 50 pixels per second mapM_ (\(c, m, sd) -> do if (m > 0) then do let division = intDiv 500 30 let y = intDiv m 20 let d = intDiv sd 20 circle dc (pt (100 + 250 + (c * division)) (500 - y)) 5 [ brushColor := grey , brushKind := BrushSolid] set dc [ penColor := black ] dcDrawLine dc (pt (100 + 250 + (c * division)) (500 - (y + d))) (pt (100 + 250 + (c * division)) (500 - (y - d))) else do return ()) stats -- onActPanelPaint is used to draw graph of mean (and standard deviation) of Before and After -- scores in each band of number of stress reducing exercises performed, from 0 up to the -- maximum of 16. (The scale is calibrated in 18 steps to make pixel rounding nicer.) The Y -- axis is calibrated into 10 1s marks. Means are plotted as circles, with the standard -- deviation as lines passing through the circles. Before scores are plotted in red, After -- scores in green. onActPanelPaint vStats dc viewArea = do stats <- varGet vStats if (length stats == 0) then return () else do chooseColoursDrawAxes dc -- draw the X scale and legend mapM_ (\n -> do let division = intDiv 500 18 let divOver2 = intDiv division 2 let s = show n szX <- getTextExtent dc s let offsetX = intDiv (sizeW szX) 2 drawText dc s (pt (100 + (n * division) + divOver2 - offsetX) (500 + 20))[]) (take 18 [0..]) szX <- getTextExtent dc "Number of Exercises" let offsetX = intDiv (500 - (sizeW szX)) 2 drawText dc "Number of Exercises" (pt (100 + offsetX) (500 + 40)) [] -- draw the Y scale and legend drawScoreScaleY dc True -- draw the Before means and standard deviations in red - ms / 20 gives 50 pixels per -- second mapM_ (\(c, bM, bSD, _, _) -> do if (bM > 0) then do let division = intDiv 500 18 let divOver2 = intDiv division 2 let y = intDiv bM 20 let d = intDiv bSD 20 circle dc (pt (100 + (c * division) + divOver2 - 3) (500 - y)) 3 [ brushColor := red , brushKind := BrushSolid] set dc [ penColor := red ] dcDrawLine dc (pt (100 + (c * division) + divOver2 - 3) (500 - (y + d))) (pt (100 + (c * division) + divOver2 - 3) (500 - (y - d))) else do return ()) stats -- draw the After means and standard deviations in green - ms / 20 gives 50 pixels per -- second mapM_ (\(c, _, _, aM, aSD) -> do if (aM > 0) then do let division = intDiv 500 18 let divOver2 = intDiv division 2 let y = intDiv aM 20 let d = intDiv aSD 20 circle dc (pt (100 + (c * division) + divOver2 + 3) (500 - y)) 3 [ brushColor := green , brushKind := BrushSolid] set dc [ penColor := green ] dcDrawLine dc (pt (100 + (c * division) + divOver2 + 3) (500 - (y + d))) (pt (100 + (c * division) + divOver2 + 3) (500 - (y - d))) else do return ()) stats -- onAgePanelPaint is used to draw graph of mean (and standard deviation) of scores in each -- decade long age band. The X axis is calibrated into 10 age bands, the Y axis is calibrated -- into 10 1s marks. Means are plotted as circles, with the standard deviation as lines passing -- through the circles as with the stressors graph, above. onAgePanelPaint vStats dc viewArea = do stats <- varGet vStats if (length stats == 0) then return () else do chooseColoursDrawAxes dc -- draw the X scale and legend mapM_ (\n -> do let s = show n szX <- getTextExtent dc s let offsetX = intDiv (50 - (sizeW szX)) 2 drawText dc s (pt (100 + (n * 50) + offsetX) (500 + 20))[]) (take 10 [0..]) szX <- getTextExtent dc "Age (Decade)" let offsetX = intDiv (500 - (sizeW szX)) 2 drawText dc "Age (Decade)" (pt (100 + offsetX) (500 + 40)) [] -- draw the Y scale and legend drawScoreScaleY dc False -- draw the means and standard deviations - ms / 20 gives 50 pixels per second mapM_ (\(c, m, sd) -> do if (m > 0) then do let y = intDiv m 20 let d = intDiv sd 20 circle dc (pt (125 + (c * 50)) (500 - y)) 5 [ brushColor := grey , brushKind := BrushSolid] set dc [ penColor := black ] dcDrawLine dc (pt (125 + (c * 50)) (500 - (y + d))) (pt (125 + (c * 50)) (500 - (y - d))) else do return ()) stats --------------------------------------------------------------------------------------------------- -- -- Start the GUI, specifying the initial setup routine. -- --------------------------------------------------------------------------------------------------- main = start setUp