WPFVisifire.Charts.dll @@ -15,7 +15,8 @@ and NodeDetails<'a> = { Left: BiculsterNode<'a>; Right: BiculsterNode<'a>; Distance: float; } - +// TODO the NameValueParis field seems a bit wrong we only really need a vector here +// (but we rely on having the name went outputing the results) and BiculsterNode<'a> = { NameValueParis: Map<string,float>; NodeDetails: BiculsterNodeDetails<'a>; } clustering/hierclustering.fs @@ -28,6 +28,7 @@ open System.Windows open System.Windows.Data open System.Windows.Controls +open Strangelights.DataTools.Extensions open Strangelights.DataTools.DataAccess open Strangelights.DataTools.DataAccess open Strangelights.DataTools.Clustering @@ -112,11 +113,15 @@ let djia = "Walmart", "WMT", "Broadline retailers" "Walt Disney", "DIS", "Broadcasting & entertainment" ] +type StockValueHistory = + { StockName: String; + DateValues: seq<DateTime * float> } let getStocks desc = let getNamedStockInfo name ticker = async { let! res = YahooFinance.getStockInfo progress ticker DateTime.Now (DateTime.Now.AddMonths(-3)) return name, res } + let workflows = desc |> Seq.map (fun (name, ticker, _) -> getNamedStockInfo name ticker) @@ -130,74 +135,98 @@ let getStocks desc = let datePriceMap prices = Seq.map (fun (d, p, _, _, _, _, _) -> (any_to_string d), p) prices |> Map.of_seq res |> Seq.map (fun (name, prices) -> name, Seq.filter (fun (d, _, _, _, _, _, _) -> Seq.exists (fun d' -> d' = d) dates) prices) - |> Seq.map (fun (name, prices) -> { DataName = name; Vector = Seq.map (fun (_, p, _, _, _, _, _) -> p) prices |> Seq.cache }) - |> Seq.cache, - res - |> Seq.map (fun (name, prices) -> name, Seq.filter (fun (d, _, _, _, _, _, _) -> Seq.exists (fun d' -> d' = d) dates) prices) - |> Seq.map (fun (name, prices) -> { NodeDetails = Leaf name; NameValueParis = datePriceMap prices }) + |> Seq.map (fun (name, prices) -> { StockName = name; DateValues = Seq.map (fun (d, p, _, _, _, _, _) -> d, p) prices |> Seq.cache }) |> Seq.cache -let stocks, stocks' = getStocks djia - -//let scaleDownRes fofMatrix = -// MultiD.scaleDown progress 2 fofMatrix 0.001 +let stocks = getStocks djia -//let res = scaleDownRes stocks - -let res' = Clustering.buildClusterTree progress stocks' +let initClusterNodes stocks = + let datePriceMap prices = + Seq.map (fun (d, p) -> string d, p) prices + |> Map.of_seq + let convertStockHist { StockName = name; DateValues = prices } = + { NodeDetails = Leaf name; NameValueParis = datePriceMap prices } + Seq.cmap convertStockHist stocks :> seq<_> + +let clusterTree = Clustering.buildClusterTree progress (initClusterNodes stocks) -//let viewer = new MutliDScaling2DViewer(res) -let viewer' = new Dendrogram(res'.NodeDetails) -//let tab1 = new TabItem(Content = viewer, Header = "Mutli-diminsional scaling") +let viewer' = new Dendrogram(clusterTree.NodeDetails) let nbl<'a when 'a:(new:unit->'a) and 'a: struct and 'a :> ValueType> x = new Nullable<'a>(x) -let dataSeries = +let calcPerformance stocks = + let perf points = + let _, first = Seq.hd points + Seq.map (fun (x, y) -> x, (y / first - 1.) * 100.) points + Seq.map (fun ({ DateValues = points } as stock) -> { stock with DateValues = perf points }) stocks + +let dataSeries stocks = let series name points = let dataSeries = new DataSeries(RenderAs = RenderAs.Line, LegendText = name, LineThickness = nbl 0.5) - let first = Seq.hd points - Seq.map (fun x -> (x / first - 1.) * 100.) points - |> Seq.iter (fun x -> dataSeries.DataPoints.Add(new DataPoint(YValue = x))) + points |> + Seq.iter (fun (_, y) -> dataSeries.DataPoints.Add(new DataPoint(YValue = y))) dataSeries - Seq.map (fun { DataName = name; Vector = points } -> series name points) stocks + Seq.map (fun { StockName = name; DateValues = points } -> series name points) stocks |> Seq.cache -type ChartCheckbox(title) = +type ChartCheckbox(title, dataSeries: seq<DataSeries>) = inherit DockPanel() + let dataSeries = List.of_seq dataSeries + //do printfn "Seq.length dataSeries: %i" (Seq.length dataSeries) + let chart = let chart = new Chart() chart.Height <- 500. chart.Titles.Add(new Title(Text = title)) chart - let listBox = - let listBox = new ListBox() - stocks |> Seq.iter (fun { DataName = name } -> - let chkbx = new CheckBox(Content = name) + let chkBoxes = + dataSeries |> List.map (fun serie -> + let chkbx = new CheckBox(Content = serie.LegendText) chkbx.Checked.Add(fun _ -> - let series = dataSeries |> Seq.find (fun x -> x.LegendText = name) + let series = dataSeries |> Seq.find (fun x -> x.LegendText = serie.LegendText) chart.Series.Add(series) chart.InvalidateVisual()) chkbx.Unchecked.Add(fun _ -> - let series = dataSeries |> Seq.find (fun x -> x.LegendText = name) + let series = dataSeries |> Seq.find (fun x -> x.LegendText = serie.LegendText) chart.Series.Remove(series) |> ignore chart.InvalidateVisual()) - listBox.Items.Add(chkbx) |> ignore) - new ScrollViewer(Content = listBox) - + chkbx) + let listBox = + let listBox = new ListBox() + chkBoxes |> Seq.iter (fun chkbx -> listBox.Items.Add(chkbx) |> ignore) + listBox + let selectButton text select = + let button = new Button(Content = text) + button.Click.Add(fun _ -> + chkBoxes |> Seq.iter (fun chkbx -> + chkbx.IsChecked <- nbl select)) + button + let stackPanel = + let buttonsPanel = new StackPanel(Orientation = Orientation.Horizontal) + buttonsPanel.Children.Add(selectButton "Select All" true) |> ignore + buttonsPanel.Children.Add(selectButton "Unselect All" false) |> ignore + let stackPanel = new StackPanel() + stackPanel.Children.Add(buttonsPanel) |> ignore + stackPanel.Children.Add(listBox) |> ignore + new ScrollViewer(Content = stackPanel) do DockPanel.SetDock(chart, Dock.Top) do base.Children.Add(chart) |> ignore - do DockPanel.SetDock(listBox, Dock.Bottom) - do base.Children.Add(listBox) |> ignore + do DockPanel.SetDock(stackPanel, Dock.Bottom) + do base.Children.Add(stackPanel) |> ignore -let tab2 = new TabItem(Content = ChartCheckbox("My chart"), Header = "Charts") +let valuesTab = new TabItem(Content = ChartCheckbox("Raw Values", dataSeries stocks), + Header = "Raw Values Chart") +let perfTab = new TabItem(Content = ChartCheckbox("Performance", dataSeries (calcPerformance stocks)), + Header = "Performance Chart") let tab3 = new TabItem(Content = viewer', Header = "Dendogram") let tabs = let tabs = new TabControl() tabs.Items.Add(tab3) |> ignore - tabs.Items.Add(tab2) |> ignore + tabs.Items.Add(valuesTab) |> ignore + tabs.Items.Add(perfTab) |> ignore tabs let window = new Window(Content = tabs) examples/stocks.fs @@ -66,4 +66,11 @@ <Target Name="AfterBuild"> </Target> --> + <PropertyGroup> + <PreBuildEvent> + </PreBuildEvent> + </PropertyGroup> + <PropertyGroup> + <PostBuildEvent>copy "$(ProjectDir)twits.jpg" "$(TargetDir)"</PostBuildEvent> + </PropertyGroup> </Project> \ No newline at end of file examples/twitter.fsproj @@ -21,19 +21,148 @@ #endif open System +open System.Collections +open System.IO +open System.ComponentModel open System.Windows +open System.Windows.Threading +open System.Windows.Controls +open System.Windows.Media.Imaging open Strangelights.DataTools +open Strangelights.DataTools.DataAccess open Strangelights.DataTools.UI open Strangelights.DataTools.Extensions open Strangelights.DataTools.Clustering open Strangelights.DataTools.Treatment -let fofMatrix = Twitter.getFof "robertpi" +//let fofMatrix = Twitter.getFof "robertpi" -let viewer = new MutliDScaling2DViewer(Twitter.scaleDownRes fofMatrix) -let window = new Window(Content = viewer) +//let defaultImage = +// let decoder = BitmapDecoder.Create(new Uri(@"file:///C:\code\fscollintelli\examples\twits.jpg"), BitmapCreateOptions.None, BitmapCacheOption.Default) +// decoder.Frames.[0] + +type InvokeThing = delegate of unit -> unit + +let addChildren (panel: Panel) children = + Seq.iter (fun x -> panel.Children.Add(x) |> ignore) children +let dc x = x :> FrameworkElement + + +let statusBar = new TextBox(Text = "Status: doing nothing", IsReadOnly = true, Width = Double.NaN) +let updateStatus text = + let update = + new InvokeThing(fun _ -> statusBar.Text <- text) + statusBar.Dispatcher.Invoke(DispatcherPriority.Normal, update) |> ignore + +type FriendViewer(twit: Tweeter) as x = + inherit StackPanel() + do updateStatus (sprintf "Creating friend: %s" twit.ScreenName) + let image = new Image(Width = 100., Height = 100.) + let finishedTrigger, finished = Event.create() + let finishImage progress (stream: Stream) = + let updateDelegate = + new InvokeThing(fun _ -> + let decoder = BitmapDecoder.Create(stream, BitmapCreateOptions.None, BitmapCacheOption.Default) + image.Source <- decoder.Frames.[0] + progress (sprintf "Finshed: %s" twit.ScreenName) + finishedTrigger decoder.Frames.[0]) + image.Dispatcher.Invoke(DispatcherPriority.Normal, updateDelegate) |> ignore + let imageWF = HttpXml.getContents updateStatus twit.PictureUrl finishImage () + let checkBox = new CheckBox(Content = twit.ScreenName) + do addChildren x [ dc checkBox; dc image; ] + do Async.Spawn(imageWF) + member x.FinishedImage = finished + member x.IsSelected + with get() = if not checkBox.IsChecked.HasValue then false else checkBox.IsChecked.Value + and set x = checkBox.IsChecked <- Nullable x + member x.Tweeter = twit + + + + +let listView = new ListView(Width = 200.) +let iterAllItems func = + for item in (listView.Items :> IEnumerable) do + match item with + | :? FriendViewer as fv -> func fv + | _ -> () + +let getAllItems () = + seq { for item in (listView.Items :> IEnumerable) do + match item with + | :? FriendViewer as fv -> yield fv + | _ -> () } + + +let listPanel = + let buttonPanel = new StackPanel(Orientation = Orientation.Horizontal) + let selectAll = new Button(Content = "Select All", Width = 100.) + selectAll.Click.Add(fun _ -> iterAllItems (fun fv -> fv.IsSelected <- true)) + let deselectAll = new Button(Content = "Deselect All", Width = 100.) + deselectAll.Click.Add(fun _ -> iterAllItems (fun fv -> fv.IsSelected <- false)) + addChildren buttonPanel [ dc selectAll; dc deselectAll ] + + let topPanel = new DockPanel() + DockPanel.SetDock(buttonPanel, Dock.Top) + addChildren topPanel [ dc buttonPanel; dc listView ] + topPanel + +let mainPanel = new Border() + +let topControls = + let screenName = new TextBox(Text = "robertpi", Width = 400.) + let getFriends = new Button(Content = "Get Friends", Width = 100.) + let draw = new Button(Content = "Draw Friends Map", Width = 100.) + getFriends.Click.Add(fun _ -> + let bckWrk = new BackgroundWorker() + let username = screenName.Text + updateStatus (sprintf "Getting things for: %s" username) + bckWrk.DoWork.Add(fun ea -> + let friends = Twitter.getAllFriends updateStatus username + ea.Result <- friends) + bckWrk.RunWorkerCompleted.Add(fun ea -> + updateStatus (sprintf "Finished getting things for: %s" username) + let friends = ea.Result :?> list<Tweeter> + let fvs = List.map (fun x -> new FriendViewer(x)) friends + Seq.iter (fun x -> listView.Items.Add(x) |> ignore) fvs + fvs |> Seq.iter (fun x -> x.FinishedImage.Add(fun _ -> listView.InvalidateVisual()))) + bckWrk.RunWorkerAsync()) + draw.Click.Add(fun _ -> + let bckWrk = new BackgroundWorker() + let friends = + getAllItems () + |> Seq.filter (fun twit -> twit.IsSelected) + |> Seq.map (fun twit -> twit.Tweeter.ScreenName) + |> Seq.to_list +// TODO fix this bit need to know how one should render results of thingy +// bckWrk.DoWork.Add(fun ea -> +// updateStatus (sprintf "Get matrix for: %A" friends) +// let fofMatrix = Twitter.getFofMatrixFromList friends +// ea.Result <- MultiD.scaleDown updateStatus 2 fofMatrix 0.01) +// bckWrk.RunWorkerCompleted.Add(fun ea -> +// updateStatus "Finished grouping friends" +// let res = ea.Result :?> list<MultiDResult> +// let mdres = new MutliDScaling2DViewer(res) +// printfn "%A" mdres +// mainPanel.Child <- mdres) + bckWrk.RunWorkerAsync()) + let sp = new StackPanel(Orientation = Orientation.Horizontal) + addChildren sp [ dc screenName; dc getFriends; dc draw ] + sp + +let mainDock = + DockPanel.SetDock(statusBar, Dock.Bottom) + DockPanel.SetDock(topControls, Dock.Top) + DockPanel.SetDock(listPanel, Dock.Left) + let dp = new DockPanel() + addChildren dp [ dc statusBar; dc topControls; + dc listPanel; dc mainPanel ] + dp + +let window = new Window(Title = "Robert Pickering's \"the twits\"", + Content = mainDock) let app = new Application() examples/twitterFrontEnd.fs @@ -11,7 +11,7 @@ open System.Windows open System.Windows.Media open Strangelights.DataTools.Clustering -type Dendrogram(t) = +type Dendrogram(t) as x = inherit FrameworkElement() let rec getHeight t = match t with @@ -29,15 +29,13 @@ type Dendrogram(t) = getDepthInner t 0.0 let pen = new Pen(Brushes.Black, 1.0) let height = getHeight t * 20. - let width = 600. let depth = getDepth t - let scaling = width - 150. / depth - do base.Height <- height //do base.Width <- width override x.OnRender(dc: DrawingContext) = + let scaling = x.ActualWidth / depth let rec drawNode t x y = match t with @@ -51,6 +49,11 @@ type Dendrogram(t) = dc.DrawLine(pen, new Point(x, top + h1 / 2.), new Point(x, bottom - h2 / 2.)) // horizontal line +// let text = new FormattedText(string t.Distance, CultureInfo.GetCultureInfo("en-us"), +// FlowDirection.LeftToRight, +// new Typeface("Verdana"), +// 10., Brushes.Black) +// dc.DrawText(text, new Point(x + 5., y - 7.)) dc.DrawLine(pen, new Point(x, top + h1 / 2.), new Point(x + ll, top + h1 / 2.)) dc.DrawLine(pen, new Point(x, bottom - h2 / 2.), new Point(x + ll, bottom - h2 / 2.)) presentation/dendrogram.fs @@ -85,6 +85,7 @@ module BlogTreatment = "&lt;", ""; "&gt;", ""; "&pound;", "£" ] + // TODO where should this go? is there a better choice of words let ignoreList = [ "nbsp" "the" "to" @@ -236,7 +237,7 @@ module BlogTreatment = receiver.Fetch() - + // TODO using the ignoreList seems to give better results than upperBound so maybe it should be removed? /// turn word count list into a hierarical cluster let clusterWordCounts progress lowerBound upperBound masterList blogs = // remove words that are uncommon or too common @@ -245,7 +246,7 @@ module BlogTreatment = wordCount |> Map.filter (fun word wc -> let frac = wc / count //printfn "%s: %i / %i = %f" word wc count frac - lowerBound < frac && not (List.mem word ignoreList)) + lowerBound < frac && not (List.mem word ignoreList)) // && frac < upperBound) // build a master word list containing all the words we interested in let masterWordList = treatment/blogs.fs @@ -4,7 +4,7 @@ // This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. // Contact Robert Pickering via: http://strangelights.com/ -module Strangelights.DataTools.Treatment.Twitter +namespace Strangelights.DataTools.Treatment #if INTERACTIVE #I @"C:\Program Files\Reference Assemblies\Microsoft\Framework\v3.5" #r "System.Threading" @@ -26,8 +26,7 @@ open System.Xml.XPath open System.Globalization open Strangelights.DataTools.DataAccess open Strangelights.DataTools.Clustering - -let progress = printfn "%s" +open Strangelights.DataTools.Optimization type Tweeter = { Id: int; @@ -35,13 +34,14 @@ type Tweeter = ScreenName: string; PictureUrl: string; } -let treatTweeter name progress (stream: Stream) = - progress (Printf.sprintf "Getting: %s" name) - let xdoc = new XPathDocument(stream) - let nav = xdoc.CreateNavigator() - let xpath = nav.Compile("users/user") - let iter = nav.Select(xpath) - let items = +module Twitter = + let progress = printfn "%s" + + let treatTweeter progress (stream: Stream) = + let xdoc = new XPathDocument(stream) + let nav = xdoc.CreateNavigator() + let xpath = nav.Compile("users/user") + let iter = nav.Select(xpath) [ for x in iter -> let x = x :?> XPathNavigator let getValue (nodename: string) = @@ -51,27 +51,50 @@ let treatTweeter name progress (stream: Stream) = Name = getValue "name"; ScreenName = getValue "screen_name"; PictureUrl = getValue "profile_image_url"; } ] - name, items -// ((items -// |> Seq.take (min (List.length items) 20) -// |> Seq.cache) :> seq<_>) -let friendsUrl = Printf.sprintf "http://twitter.com/statuses/friends/%s.xml" + let getFriendsCount progress (stream: Stream) = + let xdoc = new XPathDocument(stream) + let nav = xdoc.CreateNavigator() + let iter = nav.Select("user/friends_count") + let items = + [ for x in iter do + yield x.ToString() ] + match items with + | [ followers ] -> Int32.Parse followers + | _ -> failwith "assert false" -let getAllFriendsOfFriends name = - let url = friendsUrl name - let name, friends = Async.Run (HttpXml.getContents progress url (treatTweeter name) ("", [])) - let friendsScreenName = Seq.map (fun { ScreenName = sn } -> sn) friends - let friendsOfFriendsWorkflows = Seq.map (fun sn -> HttpXml.getContents progress (friendsUrl sn) (treatTweeter sn) ("", [])) friendsScreenName - friendsScreenName, Async.Run (Async.Parallel friendsOfFriendsWorkflows) - + let treatIds id progress (stream: Stream) = + let xdoc = new XPathDocument(stream) + let nav = xdoc.CreateNavigator() + let xpath = nav.Compile("ids/id") + let iter = nav.Select(xpath) + let items = + [ for x in iter do + yield Int32.Parse(x.ToString()) ] + id, items -let getFof firstScreenName = - let friendsScreenName, fof = getAllFriendsOfFriends firstScreenName - Seq.map (fun (name, friends) -> name, Seq.map (fun fsn -> if Seq.exists (fun { ScreenName = sn }-> fsn = sn) friends then 2. else 1.) friendsScreenName) fof - |> Seq.map (fun (name, fvect) -> { DataName = name; Vector = fvect }) - -//Seq.length fofMatrix + let friendsUrl = sprintf "http://twitter.com/statuses/friends/%s.xml?page=%i" + let showUserUrl = sprintf "http://twitter.com/users/show/%s.xml" + let friendsIdUrl = sprintf "http://twitter.com/friends/ids.xml?user_id=%i" + + let getAllFriends progress name = + let count = Async.Run (HttpXml.getContents progress (showUserUrl name) getFriendsCount 0) + printfn "count: %i" count + let urls = List.map (friendsUrl name) [ 0 .. (count / 100) + 1 ] + Async.Run (Async.Parallel (List.map (fun url -> HttpXml.getContents progress url treatTweeter []) urls)) + |> Seq.to_list |> List.concat -let scaleDownRes fofMatrix = - MultiD.scaleDown progress 2 fofMatrix 0.01 + let getAllFof id (ids: list<int>) = + let friendsOfFriendsWorkflows = Seq.map (fun sn -> HttpXml.getContents progress (friendsIdUrl sn) (treatIds sn) (0, [])) ids + let res = Async.Run (Async.Parallel friendsOfFriendsWorkflows) + let allIds = (id, ids) :: List.of_array res + let rec pairsOfFloats list = + match list with + | x :: y :: list -> (x,y) :: pairsOfFloats list + | [] -> [] + | _ -> failwith "uneven list" + let costFun points = + 0. + let res = annealing [ for _ in 1 .. (Seq.length allIds) do yield 400., 400. ] costFun + pairsOfFloats (List.of_seq res) + \ No newline at end of file treatment/twitter.fs 79b6bafc0fe6ae579e435d425e03c1b3b9405832 unknown robert@.(none) http://github.com/robertpi/fscollintelli/commit/4c3177dc8a1ca61deaa52d874641b12fc2666bfe 4c3177dc8a1ca61deaa52d874641b12fc2666bfe 2009-05-10T00:25:59-07:00 2009-05-10T00:25:59-07:00 More general improvements 85a9bd92b74a37f0f0f53d47611da2c3e648328b unknown robert@.(none)