module Simulation.Aivika.Experiment.Chart.FinalHistogramView
(FinalHistogramView(..),
defaultFinalHistogramView) where
import Control.Monad
import Control.Monad.Trans
import Control.Concurrent.MVar
import Control.Lens
import qualified Data.Map as M
import Data.IORef
import Data.Maybe
import Data.Either
import Data.Array
import Data.Array.IO.Safe
import Data.Default.Class
import System.IO
import System.FilePath
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Backend.Cairo
import Simulation.Aivika.Experiment
import Simulation.Aivika.Experiment.HtmlWriter
import Simulation.Aivika.Experiment.Utils (divideBy, replace)
import Simulation.Aivika.Experiment.Chart.Utils (colourisePlotBars)
import Simulation.Aivika.Experiment.Histogram
import Simulation.Aivika.Experiment.ListSource
import Simulation.Aivika.Specs
import Simulation.Aivika.Parameter
import Simulation.Aivika.Simulation
import Simulation.Aivika.Dynamics
import Simulation.Aivika.Event
import Simulation.Aivika.Signal
data FinalHistogramView =
FinalHistogramView { finalHistogramTitle :: String,
finalHistogramDescription :: String,
finalHistogramWidth :: Int,
finalHistogramHeight :: Int,
finalHistogramFileName :: FileName,
finalHistogramPredicate :: Event Bool,
finalHistogramBuild :: [[Double]] -> Histogram,
finalHistogramSeries :: [String],
finalHistogramPlotTitle :: String,
finalHistogramPlotBars :: PlotBars Double Double ->
PlotBars Double Double,
finalHistogramLayout :: Layout Double Double ->
Layout Double Double
}
defaultFinalHistogramView :: FinalHistogramView
defaultFinalHistogramView =
FinalHistogramView { finalHistogramTitle = "Final Histogram",
finalHistogramDescription = "It shows a histogram by data gathered in the final time points.",
finalHistogramWidth = 640,
finalHistogramHeight = 480,
finalHistogramFileName = UniqueFileName "$TITLE" ".png",
finalHistogramPredicate = return True,
finalHistogramBuild = histogram binSturges,
finalHistogramSeries = [],
finalHistogramPlotTitle = "$TITLE",
finalHistogramPlotBars = colourisePlotBars,
finalHistogramLayout = id }
instance ExperimentView FinalHistogramView where
outputView v =
let reporter exp dir =
do st <- newFinalHistogram v exp dir
return ExperimentReporter { reporterInitialise = return (),
reporterFinalise = finaliseFinalHistogram st,
reporterSimulate = simulateFinalHistogram st,
reporterTOCHtml = finalHistogramTOCHtml st,
reporterHtml = finalHistogramHtml st }
in ExperimentGenerator { generateReporter = reporter }
data FinalHistogramViewState =
FinalHistogramViewState { finalHistogramView :: FinalHistogramView,
finalHistogramExperiment :: Experiment,
finalHistogramDir :: FilePath,
finalHistogramFile :: IORef (Maybe FilePath),
finalHistogramLock :: MVar (),
finalHistogramResults :: IORef (Maybe FinalHistogramResults) }
data FinalHistogramResults =
FinalHistogramResults { finalHistogramNames :: [String],
finalHistogramValues :: [ListRef Double] }
newFinalHistogram :: FinalHistogramView -> Experiment -> FilePath -> IO FinalHistogramViewState
newFinalHistogram view exp dir =
do f <- newIORef Nothing
l <- newMVar ()
r <- newIORef Nothing
return FinalHistogramViewState { finalHistogramView = view,
finalHistogramExperiment = exp,
finalHistogramDir = dir,
finalHistogramFile = f,
finalHistogramLock = l,
finalHistogramResults = r }
newFinalHistogramResults :: [String] -> Experiment -> IO FinalHistogramResults
newFinalHistogramResults names exp =
do values <- forM names $ \_ -> liftIO newListRef
return FinalHistogramResults { finalHistogramNames = names,
finalHistogramValues = values }
simulateFinalHistogram :: FinalHistogramViewState -> ExperimentData -> Event (Event ())
simulateFinalHistogram st expdata =
do let labels = finalHistogramSeries $ finalHistogramView st
providers = experimentSeriesProviders expdata labels
input =
flip map providers $ \provider ->
case providerToDoubleListSource provider of
Nothing -> error $
"Cannot represent series " ++
providerName provider ++
" as a source of double values: simulateFinalHistogram"
Just input -> listSourceData input
names = map providerName providers
predicate = finalHistogramPredicate $ finalHistogramView st
exp = finalHistogramExperiment st
lock = finalHistogramLock st
results <- liftIO $ readIORef (finalHistogramResults st)
case results of
Nothing ->
liftIO $
do results <- newFinalHistogramResults names exp
writeIORef (finalHistogramResults st) $ Just results
Just results ->
when (names /= finalHistogramNames results) $
error "Series with different names are returned for different runs: simulateFinalHistogram"
results <- liftIO $ fmap fromJust $ readIORef (finalHistogramResults st)
let values = finalHistogramValues results
h = filterSignalM (const predicate) $
experimentSignalInStopTime expdata
handleSignal_ h $ \_ ->
do xs <- sequence input
liftIO $ withMVar lock $ \() ->
forM_ (zip xs values) $ \(x, values) ->
addDataToListRef values x
return $ return ()
finaliseFinalHistogram :: FinalHistogramViewState -> IO ()
finaliseFinalHistogram st =
do let title = finalHistogramTitle $ finalHistogramView st
plotTitle =
replace "$TITLE" title
(finalHistogramPlotTitle $ finalHistogramView st)
width = finalHistogramWidth $ finalHistogramView st
height = finalHistogramHeight $ finalHistogramView st
histogram = finalHistogramBuild $ finalHistogramView st
bars = finalHistogramPlotBars $ finalHistogramView st
layout = finalHistogramLayout $ finalHistogramView st
results <- readIORef $ finalHistogramResults st
case results of
Nothing -> return ()
Just results ->
do let names = finalHistogramNames results
values = finalHistogramValues results
xs <- forM values readListRef
let zs = histogramToBars . filterHistogram . histogram $
map filterData xs
p = plotBars $
bars $
plot_bars_values .~ zs $
plot_bars_titles .~ names $
def
updateAxes =
if null zs
then let v = AxisVisibility True False False
in \l -> layout_top_axis_visibility .~ v $
layout_bottom_axis_visibility .~ v $
layout_left_axis_visibility .~ v $
layout_right_axis_visibility .~ v $
l
else id
chart = layout . updateAxes $
layout_title .~ plotTitle $
layout_plots .~ [p] $
def
file <- resolveFileName
(Just $ finalHistogramDir st)
(finalHistogramFileName $ finalHistogramView st) $
M.fromList [("$TITLE", title)]
let opts = FileOptions (width, height) PNG
renderableToFile opts (toRenderable chart) file
when (experimentVerbose $ finalHistogramExperiment st) $
putStr "Generated file " >> putStrLn file
writeIORef (finalHistogramFile st) $ Just 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)
finalHistogramHtml :: FinalHistogramViewState -> Int -> HtmlWriter ()
finalHistogramHtml st index =
do header st index
file <- liftIO $ readIORef (finalHistogramFile st)
case file of
Nothing -> return ()
Just f ->
writeHtmlParagraph $
writeHtmlImage (makeRelative (finalHistogramDir st) f)
header :: FinalHistogramViewState -> Int -> HtmlWriter ()
header st index =
do writeHtmlHeader3WithId ("id" ++ show index) $
writeHtmlText (finalHistogramTitle $ finalHistogramView st)
let description = finalHistogramDescription $ finalHistogramView st
unless (null description) $
writeHtmlParagraph $
writeHtmlText description
finalHistogramTOCHtml :: FinalHistogramViewState -> Int -> HtmlWriter ()
finalHistogramTOCHtml st index =
writeHtmlListItem $
writeHtmlLink ("#id" ++ show index) $
writeHtmlText (finalHistogramTitle $ finalHistogramView st)