module Simulation.Aivika.Experiment.HistogramView
(HistogramView(..),
defaultHistogramView) where
import Control.Monad
import Control.Monad.Trans
import qualified Data.Map as M
import Data.IORef
import Data.Maybe
import Data.Either
import Data.Array
import Data.Accessor
import System.IO
import System.FilePath
import Graphics.Rendering.Chart
import Simulation.Aivika.Experiment
import Simulation.Aivika.Experiment.HtmlWriter
import Simulation.Aivika.Experiment.Utils (divideBy, replace)
import Simulation.Aivika.Experiment.Chart (colourisePlotBars)
import Simulation.Aivika.Experiment.Histogram
import Simulation.Aivika.Experiment.ListSource
import Simulation.Aivika.Dynamics
import Simulation.Aivika.Dynamics.Simulation
import Simulation.Aivika.Dynamics.Signal
data HistogramView =
HistogramView { histogramTitle :: String,
histogramDescription :: String,
histogramWidth :: Int,
histogramHeight :: Int,
histogramFileName :: FileName,
histogramPredicate :: Dynamics Bool,
histogramBuild :: [[Double]] -> Histogram,
histogramSeries :: [String],
histogramPlotTitle :: String,
histogramRunPlotTitle :: String,
histogramPlotBars :: PlotBars Double Double ->
PlotBars Double Double,
histogramLayout :: Layout1 Double Double ->
Layout1 Double Double
}
defaultHistogramView :: HistogramView
defaultHistogramView =
HistogramView { histogramTitle = "Histogram",
histogramDescription = "It shows the histogram(s) by data gathered in the integration time points.",
histogramWidth = 640,
histogramHeight = 480,
histogramFileName = UniqueFileName "$TITLE - $RUN_INDEX" ".png",
histogramPredicate = return True,
histogramBuild = histogram binSturges,
histogramSeries = [],
histogramPlotTitle = "$TITLE",
histogramRunPlotTitle = "$PLOT_TITLE / Run $RUN_INDEX of $RUN_COUNT",
histogramPlotBars = colourisePlotBars,
histogramLayout = id }
instance View HistogramView where
outputView v =
let reporter exp dir =
do st <- newHistogram v exp dir
return Reporter { reporterInitialise = return (),
reporterFinalise = return (),
reporterSimulate = simulateHistogram st,
reporterTOCHtml = histogramTOCHtml st,
reporterHtml = histogramHtml st }
in Generator { generateReporter = reporter }
data HistogramViewState =
HistogramViewState { histogramView :: HistogramView,
histogramExperiment :: Experiment,
histogramDir :: FilePath,
histogramMap :: M.Map Int FilePath }
newHistogram :: HistogramView -> Experiment -> FilePath -> IO HistogramViewState
newHistogram view exp dir =
do let n = experimentRunCount exp
fs <- forM [0..(n 1)] $ \i ->
resolveFileName (Just dir) (histogramFileName view) $
M.fromList [("$TITLE", histogramTitle view),
("$RUN_INDEX", show $ i + 1),
("$RUN_COUNT", show n)]
forM_ fs $ flip writeFile []
let m = M.fromList $ zip [0..(n 1)] fs
return HistogramViewState { histogramView = view,
histogramExperiment = exp,
histogramDir = dir,
histogramMap = m }
simulateHistogram :: HistogramViewState -> ExperimentData -> Dynamics (Dynamics ())
simulateHistogram st expdata =
do let labels = histogramSeries $ histogramView st
providers = experimentSeriesProviders expdata labels
names = map providerName providers
input =
flip map providers $ \provider ->
case providerToDoubleListSource provider of
Nothing -> error $
"Cannot represent series " ++
providerName provider ++
" as a source of double values: simulateHistogram"
Just input -> fmap listDataList $ listSourceData input
n = experimentRunCount $ histogramExperiment st
width = histogramWidth $ histogramView st
height = histogramHeight $ histogramView st
predicate = histogramPredicate $ histogramView st
bars = histogramPlotBars $ histogramView st
layout = histogramLayout $ histogramView st
build = histogramBuild $ histogramView st
i <- liftSimulation simulationIndex
let file = fromJust $ M.lookup (i 1) (histogramMap st)
title = histogramTitle $ histogramView st
plotTitle =
replace "$TITLE" title
(histogramPlotTitle $ histogramView st)
runPlotTitle =
if n == 1
then plotTitle
else replace "$RUN_INDEX" (show i) $
replace "$RUN_COUNT" (show n) $
replace "$PLOT_TITLE" plotTitle
(histogramRunPlotTitle $ histogramView st)
hs <- forM (zip providers input) $ \(provider, input) ->
newSignalHistory $
mapSignalM (const input) $
filterSignalM (const predicate) $
experimentSignalInIntegTimes expdata
return $
do xs <- forM hs readSignalHistory
let zs = histogramToBars . filterHistogram . build $
map (filterData . concat . elems . snd) xs
p = plotBars $
bars $
plot_bars_values ^= zs $
plot_bars_titles ^= names $
defaultPlotBars
chart = layout $
layout1_title ^= runPlotTitle $
layout1_plots ^= [Left p] $
defaultLayout1
liftIO $
do renderableToPNGFile (toRenderable chart) width height file
when (experimentVerbose $ histogramExperiment st) $
putStr "Generated file " >> putStrLn file
filterData :: [Double] -> [Double]
filterData = filter (\x -> not $ isNaN x || isInfinite x)
filterHistogram :: [(Double, a)] -> [(Double, a)]
filterHistogram = filter (\(x, _) -> not $ isNaN x || isInfinite x)
histogramToBars :: [(Double, [Int])] -> [(Double, [Double])]
histogramToBars = map $ \(x, ns) -> (x, map fromIntegral ns)
histogramHtml :: HistogramViewState -> Int -> HtmlWriter ()
histogramHtml st index =
let n = experimentRunCount $ histogramExperiment st
in if n == 1
then histogramHtmlSingle st index
else histogramHtmlMultiple st index
histogramHtmlSingle :: HistogramViewState -> Int -> HtmlWriter ()
histogramHtmlSingle st index =
do header st index
let f = fromJust $ M.lookup 0 (histogramMap st)
writeHtmlParagraph $
writeHtmlImage (makeRelative (histogramDir st) f)
histogramHtmlMultiple :: HistogramViewState -> Int -> HtmlWriter ()
histogramHtmlMultiple st index =
do header st index
let n = experimentRunCount $ histogramExperiment st
forM_ [0..(n 1)] $ \i ->
let f = fromJust $ M.lookup i (histogramMap st)
in writeHtmlParagraph $
writeHtmlImage (makeRelative (histogramDir st) f)
header :: HistogramViewState -> Int -> HtmlWriter ()
header st index =
do writeHtmlHeader3WithId ("id" ++ show index) $
writeHtmlText (histogramTitle $ histogramView st)
let description = histogramDescription $ histogramView st
unless (null description) $
writeHtmlParagraph $
writeHtmlText description
histogramTOCHtml :: HistogramViewState -> Int -> HtmlWriter ()
histogramTOCHtml st index =
writeHtmlListItem $
writeHtmlLink ("#id" ++ show index) $
writeHtmlText (histogramTitle $ histogramView st)