@@ -31,14 +31,19 @@ <WarningLevel>3</WarningLevel> </PropertyGroup> <ItemGroup> - <Compile Include="misc/extensions.fs" /> - <Compile Include="dataaccess/httpxml.fs" /> - <Compile Include="dataaccess/gutenberg.fs" /> - <Compile Include="clustering/hierclustering.fs" /> - <Compile Include="clustering/multidscaling.fs" /> - <Compile Include="treatment/blogs.fs" /> - <Compile Include="treatment/gdata.fs" /> - <Compile Include="presentation/tagcloud.fs" /> + <Compile Include="misc\extensions.fs" /> + <Compile Include="dataaccess\csvreader.fs" /> + <Compile Include="dataaccess\httpxml.fs" /> + <Compile Include="dataaccess\yfinance.fs" /> + <Compile Include="dataaccess\gutenberg.fs" /> + <Compile Include="optimization\optimizer.fs" /> + <Compile Include="geneticalgos\geneticequ.fs" /> + <Compile Include="clustering\hierclustering.fs" /> + <Compile Include="clustering\multidscaling.fs" /> + <Compile Include="treatment\blogs.fs" /> + <Compile Include="treatment\gdata.fs" /> + <Compile Include="presentation\dendrogram.fs" /> + <Compile Include="presentation\tagcloud.fs" /> </ItemGroup> <ItemGroup> <Reference Include="FSharp.PowerPack, Version=1.9.6.2, Culture=neutral, PublicKeyToken=a19089b1c74d0809"> Strangelights.DataTools.fsproj @@ -1,6 +1,11 @@ #light -namespace Strangelights.HierarchicalClustering -open Strangelights.Extensions +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ + +namespace Strangelights.DataTools.Clustering +open Strangelights.DataTools.Extensions type BiculsterNodeDetails<'a> = | Node of NodeDetails<'a> @@ -18,17 +23,17 @@ and BiculsterNode<'a> = module Clustering = /// turns a list of cluster nodes into a hierarchal cluster tree let buildClusterTree progress clusters = - let keys m = Map.to_seq m |> PSeq.map snd + let keys m = Map.to_seq m |> Seq.cmap snd let compareNodes { NameValueParis = c1 } { NameValueParis = c2 } = let wc1, wc2 = keys c1, keys c2 - 1. - abs (Correlations.pearson wc1 wc2) + 1. - abs (Measures.pearson wc1 wc2) let initComparisons = progress (Printf.sprintf "Building initial comparison set ...") let clusters = Set.to_seq (Set.of_seq clusters) - let clusterParis = SeqenceOps.combinations2 clusters + let clusterParis = Seq.combinations2 clusters //Seq.iter (fun (x,y) -> if x = y then System.Windows.MessageBox.Show ("found pair " + (any_to_string x) + (any_to_string y)) |> ignore) toto clusterParis - |> PSeq.map (fun (c1, c2) -> compareNodes c1 c2, (c1, c2)) + |> Seq.cmap (fun (c1, c2) -> compareNodes c1 c2, (c1, c2)) |> Map.of_seq let averageWordMap wc1 wc2 = Seq.map2 (fun (word, v1) (_, v2) -> word, (v1 + v2) / 2.) (Map.to_list wc2) (Map.to_list wc1) @@ -44,8 +49,8 @@ module Clustering = Right = c2; Distance = dist; } } let restClusters = Seq.filter (fun x -> not (x = c1 || x = c2)) clusters - let newComps = PSeq.map (fun c -> compareNodes node c, (node, c)) restClusters - let comparisons = PSeq.fold (fun acc (dist, comps) -> Map.add dist comps acc) restComps newComps + let newComps = Seq.cmap (fun c -> compareNodes node c, (node, c)) restClusters + let comparisons = Seq.fold (fun acc (dist, comps) -> Map.add dist comps acc) restComps newComps if Seq.length restClusters = 0 then node else clustering/hierclustering.fs @@ -1,148 +1,152 @@ #light -namespace Strangelights.DataTools.Sources -#time -#r "Ionic.Utils.Zip.dll";; -#r "ICSharpCode.SharpZipLib.dll";; -module Gutenberg = - open System - open System.IO - open System.IO.Compression - open ICSharpCode.SharpZipLib.Zip - open System.Net - open System.Xml - open System.Xml.XPath +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// 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.Gutenberg +open System +open System.IO +open System.IO.Compression +open System.Net +open System.Xml +open System.Xml.XPath +open ICSharpCode.SharpZipLib.Zip + +let DefaultIndexUrl = "http://www.gutenberg.org/feeds/catalog.rdf.zip" + +type Book = + { Id: string; + Title: string; + Author: string } + +type GutenbergIndexFile(url) = + let uri = new Uri(url) + let stream = + let ext = Path.GetExtension(uri.LocalPath) + let filePath = + if uri.IsFile then + uri.LocalPath + else + let wc = new WebClient() + let temp = Path.GetTempFileName() + let tempExt = Path.ChangeExtension(temp, ext) + File.Move(temp, tempExt) + wc.DownloadFile(uri, tempExt) + tempExt + if ext = ".zip" then + let zip = new ZipFile(filePath) + zip.GetInputStream(0L) + else + File.OpenRead(filePath) :> Stream + let xdoc = XPathDocument(stream) + let nav = xdoc.CreateNavigator() + let mngr = new XmlNamespaceManager(new NameTable()) + let namespaces = + [ "rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#"; + "rdfs", "http://www.w3.org/2000/01/rdf-schema#"; + "xsi", "http://www.w3.org/2001/XMLSchema-instance"; + "dc", "http://purl.org/dc/elements/1.1/"; + "dcterms", "http://purl.org/dc/terms/"; + "dcmitype", "http://purl.org/dc/dcmitype/"; + "cc", "http://web.resource.org/cc/"; + "pgterms", "http://www.gutenberg.org/rdfterms/" ] + do List.iter (fun (prefix,url) -> mngr.AddNamespace(prefix,url)) namespaces - let DefaultIndexUrl = "http://www.gutenberg.org/feeds/catalog.rdf.zip" + let search query = + let xpath = nav.Compile(query) + do xpath.SetContext(mngr) + let iter = nav.Select(xpath) + seq { for x in iter -> x.ToString() } - type Book = - { Id: string; - Title: string; - Author: string } + member x.FindIdByTitleExcat title = + let query = Printf.sprintf "rdf:RDF/pgterms:etext[dc:title = '%s']/@rdf:ID" title + search query + member x.FindIdByTitle title = + let query = Printf.sprintf "rdf:RDF/pgterms:etext[contains(dc:title,'%s')]/@rdf:ID" title + search query - type GutenbergIndexFile(url) = - let uri = new Uri(url) - let stream = - let ext = Path.GetExtension(uri.LocalPath) - let filePath = - if uri.IsFile then - uri.LocalPath - else - let wc = new WebClient() - let temp = Path.GetTempFileName() - let tempExt = Path.ChangeExtension(temp, ext) - File.Move(temp, tempExt) - wc.DownloadFile(uri, tempExt) - tempExt - if ext = ".zip" then - let zip = new ZipFile(filePath) - zip.GetInputStream(0L) - else - File.OpenRead(filePath) :> Stream - let xdoc = XPathDocument(stream) - let nav = xdoc.CreateNavigator() - let mngr = new XmlNamespaceManager(new NameTable()) - let namespaces = - [ "rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#"; - "rdfs", "http://www.w3.org/2000/01/rdf-schema#"; - "xsi", "http://www.w3.org/2001/XMLSchema-instance"; - "dc", "http://purl.org/dc/elements/1.1/"; - "dcterms", "http://purl.org/dc/terms/"; - "dcmitype", "http://purl.org/dc/dcmitype/"; - "cc", "http://web.resource.org/cc/"; - "pgterms", "http://www.gutenberg.org/rdfterms/" ] - do List.iter (fun (prefix,url) -> mngr.AddNamespace(prefix,url)) namespaces - - let search query = - let xpath = nav.Compile(query) - do xpath.SetContext(mngr) - let iter = nav.Select(xpath) - seq { for x in iter -> x.ToString() } - - member x.FindIdByTitleExcat title = - let query = Printf.sprintf "rdf:RDF/pgterms:etext[dc:title = '%s']/@rdf:ID" title - search query - member x.FindIdByTitle title = - let query = Printf.sprintf "rdf:RDF/pgterms:etext[contains(dc:title,'%s')]/@rdf:ID" title - search query + member x.FindIdByAuthorExact title = + let query = Printf.sprintf "rdf:RDF/pgterms:etext[dc:creator = '%s']/@rdf:ID" title + search query + member x.FindIdByAuthor title = + let query = Printf.sprintf "rdf:RDF/pgterms:etext[contains(dc:creator,'%s')]/@rdf:ID" title + search query + + member x.FindBookById id = + let query = Printf.sprintf "rdf:RDF/pgterms:etext[@rdf:ID = '%s']" id + let xpath = nav.Compile(query) + do xpath.SetContext(mngr) + let node = nav.SelectSingleNode(xpath) + let res = node.MoveToFirstChild() + let author = ref "" + let title = ref "" + while node.MoveToNext() do + match node.Name with + | "dc:title" -> title := node.Value + | "dc:creator" -> author := node.Value + | _ -> () + { Id = id; + Title = !title; + Author = !author; } + + member x.FindBookByTitleExcat title = + let ids = x.FindIdByTitleExcat title + Seq.map x.FindBookById ids + member x.FindBookByTitle title = + let ids = x.FindIdByTitle title + Seq.map x.FindBookById ids - member x.FindIdByAuthorExact title = - let query = Printf.sprintf "rdf:RDF/pgterms:etext[dc:creator = '%s']/@rdf:ID" title - search query - member x.FindIdByAuthor title = - let query = Printf.sprintf "rdf:RDF/pgterms:etext[contains(dc:creator,'%s')]/@rdf:ID" title - search query + member x.FindBookByAuthorExact title = + let ids = x.FindIdByAuthorExact title + Seq.map x.FindBookById ids + member x.FindBookByAuthor title = + let ids = x.FindIdByAuthor title + Seq.map x.FindBookById ids - member x.FindBookById id = - let query = Printf.sprintf "rdf:RDF/pgterms:etext[@rdf:ID = '%s']" id - let xpath = nav.Compile(query) - do xpath.SetContext(mngr) - let node = nav.SelectSingleNode(xpath) - let res = node.MoveToFirstChild() - let author = ref "" - let title = ref "" - while node.MoveToNext() do - match node.Name with - | "dc:title" -> title := node.Value - | "dc:creator" -> author := node.Value - | _ -> () - { Id = id; - Title = !title; - Author = !author; } - - member x.FindBookByTitleExcat title = - let ids = x.FindIdByTitleExcat title - Seq.map x.FindBookById ids - member x.FindBookByTitle title = - let ids = x.FindIdByTitle title - Seq.map x.FindBookById ids + member x.DowloadBookById id directory = + let query = Printf.sprintf "rdf:RDF/pgterms:file[contains(dc:format/dcterms:IMT/rdf:value, 'text/plain;') and dcterms:isFormatOf/@rdf:resource = '#%s']/@rdf:about" id + let xpath = nav.Compile(query) + do xpath.SetContext(mngr) + let urls = nav.Select(xpath) + for url in urls do + let url = url.ToString() + //Printf.printfn "Downloading: %s" url + let wc = new WebClient() + let uri = new Uri(url.ToString().Replace("&", "http://www.gutenberg.org/dirs/")) + let filename = Path.GetFileName(uri.LocalPath) + wc.DownloadFile(uri, Path.Combine(directory, filename)) + + member x.DownloadBookByTitleExcat title dir = + let ids = x.FindIdByTitleExcat title + ids |> Seq.iter (fun id -> x.DowloadBookById id dir) + member x.DownloadBookByTitle title dir = + let ids = x.FindIdByTitle title + ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - member x.FindBookByAuthorExact title = - let ids = x.FindIdByAuthorExact title - Seq.map x.FindBookById ids - member x.FindBookByAuthor title = - let ids = x.FindIdByAuthor title - Seq.map x.FindBookById ids - - member x.DowloadBookById id directory = - let query = Printf.sprintf "rdf:RDF/pgterms:file[contains(dc:format/dcterms:IMT/rdf:value, 'text/plain;') and dcterms:isFormatOf/@rdf:resource = '#%s']/@rdf:about" id - let xpath = nav.Compile(query) - do xpath.SetContext(mngr) - let urls = nav.Select(xpath) - for url in urls do - let url = url.ToString() - //Printf.printfn "Downloading: %s" url - let wc = new WebClient() - let uri = new Uri(url.ToString().Replace("&", "http://www.gutenberg.org/dirs/")) - let filename = Path.GetFileName(uri.LocalPath) - wc.DownloadFile(uri, Path.Combine(directory, filename)) + member x.DownloadBookByAuthorExact title dir = + let ids = x.FindIdByAuthorExact title + ids |> Seq.iter (fun id -> x.DowloadBookById id dir) + member x.DownloadBookByAuthor title dir = + let ids = x.FindIdByAuthor title + ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - member x.DownloadBookByTitleExcat title dir = - let ids = x.FindIdByTitleExcat title - ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - member x.DownloadBookByTitle title dir = - let ids = x.FindIdByTitle title - ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - member x.DownloadBookByAuthorExact title dir = - let ids = x.FindIdByAuthorExact title - ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - member x.DownloadBookByAuthor title dir = - let ids = x.FindIdByAuthor title - ids |> Seq.iter (fun id -> x.DowloadBookById id dir) - +#if INTERACTIVE (* <pgterms:file rdf:about="&f;2/6/1/4/26143/26143-8.txt"> - <dc:format><dcterms:IMT><rdf:value>text/plain; charset="iso-8859-1"</rdf:value></dcterms:IMT></dc:format> - <dcterms:extent>381655</dcterms:extent> - <dcterms:modified><dcterms:W3CDTF><rdf:value>2008-07-28</rdf:value></dcterms:W3CDTF></dcterms:modified> - <dcterms:isFormatOf rdf:resource="#etext26143" /> +<dc:format><dcterms:IMT><rdf:value>text/plain; charset="iso-8859-1"</rdf:value></dcterms:IMT></dc:format> +<dcterms:extent>381655</dcterms:extent> +<dcterms:modified><dcterms:W3CDTF><rdf:value>2008-07-28</rdf:value></dcterms:W3CDTF></dcterms:modified> +<dcterms:isFormatOf rdf:resource="#etext26143" /> </pgterms:file> - + *) - + // tests - let test = DefaultIndexUrl //@"D:\gutenberg\catalog.rdf.zip" - let index = new GutenbergIndexFile("D:\gutenberg\catalog.rdf.zip") - index.DownloadBookByAuthor "Dickens" "D:\gutenberg\dickens" - index.DowloadBookById "etext6096" "D:\gutenberg" +let test = DefaultIndexUrl //@"D:\gutenberg\catalog.rdf.zip" +let index = new GutenbergIndexFile("D:\gutenberg\catalog.rdf.zip") +index.DownloadBookByAuthor "Dickens" "D:\gutenberg\dickens" +index.DowloadBookById "etext6096" "D:\gutenberg" //printfn "hello" +#endif \ No newline at end of file dataaccess/gutenberg.fs @@ -3,7 +3,7 @@ Title="Blog Hierarical Clustering" Height="600" Width="800"> <Grid> <Button Height="23" HorizontalAlignment="Right" Name="startButton" VerticalAlignment="Top" Width="75">Start</Button> - <TextBox Height="23" Margin="0,1.861,77.77,0" Name="opmlUrl" VerticalAlignment="Top">http://www.currybet.net/download/opml/top100ukblogs.xml</TextBox> + <TextBox Height="23" Margin="0,1.861,77.77,0" Name="opmlUrl" VerticalAlignment="Top">D:\code\github\HierarchicalClustering\data\blogs</TextBox> <TextBox Height="23" Name="statusBar" VerticalAlignment="Bottom" IsReadOnly="True" /> <TabControl Margin="0,62.216,0,28.58"> <TabItem Header="Tree"> @@ -14,6 +14,9 @@ <TextBox Name="outputDetail" Height="93.324" HorizontalAlignment="Right" VerticalAlignment="Top" Width="275.528" HorizontalScrollBarVisibility="Auto" VerticalScrollBarVisibility="Auto" /> </Grid> </TabItem> + <TabItem Header="Dendrogram" Name="dendrogram"> + + </TabItem> <TabItem Header="Master Word List"> <Grid> <TextBox Name="choosenWords" IsReadOnly="True" VerticalScrollBarVisibility="Auto" HorizontalAlignment="Left" Width="241.501" HorizontalScrollBarVisibility="Auto" /> @@ -21,6 +24,12 @@ <TextBox Name="masterWordList" IsReadOnly="True" HorizontalAlignment="Right" VerticalScrollBarVisibility="Auto" Width="241.501" HorizontalScrollBarVisibility="Auto" /> </Grid> </TabItem> + <TabItem Header="Tag Cloud" Name="tagCloud"> + + </TabItem> + <TabItem Header="Multi D Scaling View" Name="multidscale"> + + </TabItem> <TabItem Header="Current Post" Name="currentPost"> <Grid> <WebBrowser Name="postBrowser" Margin="0,37.154,0,0" /> @@ -30,8 +39,8 @@ </TabControl> <TextBox Name="urlLimit" Height="23" HorizontalAlignment="Left" Margin="72.215,32.219,0,0" VerticalAlignment="Top" Width="31.108">12</TextBox> <TextBox Name="timeout" Height="23" HorizontalAlignment="Left" Margin="175.538,32.219,0,0" VerticalAlignment="Top" Width="24">30</TextBox> - <TextBox Name="lowerBounds" Height="23" Margin="264.718,32.219,0,0" VerticalAlignment="Top" HorizontalAlignment="Left" Width="52.217">0.3</TextBox> - <TextBox Name="upperBounds" Height="23" HorizontalAlignment="Left" Margin="325.523,32.219,0,0" VerticalAlignment="Top" Width="52.217">2</TextBox> + <TextBox Name="lowerBounds" Height="23" Margin="264.718,32.219,0,0" VerticalAlignment="Top" HorizontalAlignment="Left" Width="52.217">0.01</TextBox> + <TextBox Name="upperBounds" Height="23" HorizontalAlignment="Left" Margin="325.523,32.219,0,0" VerticalAlignment="Top" Width="52.217">1</TextBox> <Label Height="28" HorizontalAlignment="Left" Margin="5,30.219,0,0" VerticalAlignment="Top" Width="63.327">Url Limit:</Label> <Label Height="28" HorizontalAlignment="Left" Margin="111.1,30.219,0,0" VerticalAlignment="Top" Width="63.327">Timeout:</Label> <Label Height="28" HorizontalAlignment="Left" Margin="209.979,30.219,0,0" VerticalAlignment="Top" Width="63.327">Bounds:</Label> examples/Window1.xaml @@ -1,6 +1,11 @@ #light +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ open System +open System.Globalization open System.Windows open System.Windows.Controls open System.Windows.Markup @@ -11,8 +16,50 @@ open System.Windows.Threading open System.Threading open System.ComponentModel open System.Diagnostics -open Strangelights.Extensions -open Strangelights.HierarchicalClustering +open Strangelights.DataTools.Extensions +open Strangelights.DataTools.Treatment +open Strangelights.DataTools.Clustering + +type MutliDScaling2DViewer(data) as x = + inherit FrameworkElement() + override x.OnRender(dc: DrawingContext) = + let width, height = x.ActualWidth, x.ActualHeight + for { DataName = label; Location = loc } in data do + let x, y, color = + match loc with + | [ x; y ] -> x, y, None + | [ x; y; color ] -> x, y, Some color + | _ -> failwith (Printf.sprintf "unsupported dims: %i" (List.length loc)) + let x, y = x * width, y * height + let brush = + match color with + | None -> Brushes.Black + | Some x -> + let red = byte (x * 255.) + let blue = byte ((1. - x) * 255.) + new SolidColorBrush(Color.FromRgb(red, byte 0, blue)) + let text = new FormattedText(label, CultureInfo.GetCultureInfo("en-us"), + FlowDirection.LeftToRight, + new Typeface("Verdana"), + 10., brush) + dc.DrawText(text, new Point(x + 5., y - 7.)) + +//type MutliDScaling3DViewer(data) as x = +// inherit Viewport3D() +// do for { DataName = label; Location = loc } in data do +// let x, y, z = +// match loc with +// | [ x; y; z ] -> x, y, z +// | _ -> failwith (Printf.sprintf "unsupported dims: %i" (List.length loc)) +// () + //let x, y = x * width, y * height +// let P +// let text = new FormattedText(label, CultureInfo.GetCultureInfo("en-us"), +// FlowDirection.LeftToRight, +// new Typeface("Verdana"), +// 10., Brushes.Black) +// dc.DrawText(text, new Point(x + 5., y - 7.)) + let processWords words = words @@ -49,6 +96,9 @@ let statusBar = window.FindName("statusBar") :?> TextBox let currentPost = window.FindName("currentPost") :?> TabItem let currentUrl = window.FindName("currentUrl") :?> TextBox let postBrowser = window.FindName("postBrowser") :?> WebBrowser +let tagCloudContainer = window.FindName("tagCloud") :?> TabItem +let dendrogramContainer = window.FindName("dendrogram") :?> TabItem +let multidscaleContainer = window.FindName("multidscale") :?> TabItem let progress s = statusBar.Dispatcher.Invoke(DispatcherPriority.Normal, new Invokee(fun _ -> statusBar.Text <- s)) |> ignore @@ -94,6 +144,8 @@ let start() = enable false let bgwkr = new BackgroundWorker() let url, limit = opmlUrl.Text, Int32.Parse(urlLimit.Text) + let uri = new Uri(url) + let local = uri.IsFile let upperBounds = Double.Parse(upperBounds.Text) / 100. let lowerBounds = Double.Parse(lowerBounds.Text) / 100. let timeout = Int32.Parse(timeout.Text) * 1000 @@ -101,19 +153,44 @@ let start() = let stopwatch = new Stopwatch() bgwkr.DoWork.Add(fun ea -> stopwatch.Start() - ea.Result <- BlogTreatment.processOpml progress url lowerBounds upperBounds limit timeout) + ea.Result <- BlogTreatment.processOpmlAll progress local url lowerBounds upperBounds limit timeout) let showResult result = drawTree treeView.Items result.BiculsterTree - let total = float result.MasterWordList.Count + let total = Map.fold_left(fun total _ count -> total + count) 0. result.MasterWordList processWords (Map.to_seq result.MasterWordList) |> Seq.iter (fun (word, count) -> masterWordList.AppendText(Printf.sprintf "%s: %f = %f%%\n" word count ((count / total) * 100.))) - let chosenWords = Seq.map (fun word -> word, result.MasterWordList.[word]) result.ChosenWords + let chosenWords = Seq.cmap (fun word -> word, result.MasterWordList.[word]) result.ChosenWords chosenWords |> Seq.iter (fun (word, count) -> choosenWordsAlph.AppendText(Printf.sprintf "%s: %f = %f%%\n" word count ((count / total) * 100.))) processWords chosenWords |> Seq.iter (fun (word, count) -> choosenWords.AppendText(Printf.sprintf "%s: %f = %f%%\n" word count ((count / total) * 100.))) + + let rec accNodes acc node = + match node.NodeDetails with + | Node { Left = left; Right = right; Distance = dist } -> + let acc = accNodes acc left + accNodes acc right + | Leaf node -> node :: acc + + let tagCloud = new TagCloud(chosenWords, accNodes [] result.BiculsterTree) + tagCloud.BlogClicked.Add(fun { Name = name; Url = url } -> + currentUrl.Text <- url + postBrowser.Navigate(new Uri(url)) + currentPost.IsSelected <- true) + tagCloudContainer.Content <- tagCloud + + let rec mapNodes node = + match node.NodeDetails with + | Leaf { Name = name } -> { NodeDetails = Leaf name; NameValueParis = node.NameValueParis } + | Node { Left = left; Right = right; Distance = dist } -> + { NodeDetails = Node { Distance = dist; Left = mapNodes left; Right = mapNodes right; } + NameValueParis = node.NameValueParis } + let node = mapNodes result.BiculsterTree + dendrogramContainer.Content <- new Dendrogram(node.NodeDetails) + multidscaleContainer.Content <- new MutliDScaling2DViewer(result.MulitDScaling) enable true + progress (Printf.sprintf "Done - Processed: %i in %O" result.ProcessedBlogs stopwatch.Elapsed) bgwkr.RunWorkerCompleted.Add(fun ea -> @@ -132,7 +209,6 @@ let main() = let tvi = ea.NewValue :?> TreeViewItem nodeSelectChanged (tvi.Tag :?> BiculsterNode<BlogLeafDetails>)) startButton.Click.Add(fun _ -> start()) - let app = new Application() in app.Run(window) |> ignore examples/blogsFrontEnd.fs @@ -1,4 +1,8 @@ #light +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ #if INTERACTIVE #r "PresentationCore";; @@ -17,8 +21,9 @@ #endif open System -open Strangelights.Extensions -open Strangelights.HierarchicalClustering +open Strangelights.DataTools +open Strangelights.DataTools.Extensions +open Strangelights.DataTools.Clustering let progress = printfn "%s" examples/gdataFrontEnd.fs @@ -1,5 +1,10 @@ #light +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ +#r "FSharp.PowerPack";; #r "PresentationCore";; #r "PresentationFramework";; #r "System.Core";; @@ -7,15 +12,19 @@ #r "System.Xml";; #r "WindowsBase";; -#load "extensions.fs";; -#load "dataAccess.fs";; -#load "clustering.fs";; -#load "gdata.fs";; -#load "algo.fs";; -#load "dendrogram.fs";; +#load "../misc/extensions.fs";; +#load "../dataaccess/csvreader.fs";; +#load "../dataaccess/httpxml.fs";; +#load "../dataaccess/yfinance.fs";; +#load "../clustering/hierclustering.fs";; +#load "../clustering/multidscaling.fs";; +#load "../treatment/gdata.fs";; +#load "../treatment/blogs.fs";; +#load "../presentation/dendrogram.fs";; +#load "../presentation/tagcloud.fs";; -open Strangelights.Extensions -open Strangelights.HierarchicalClustering +open Strangelights.DataTools.Extensions +open Strangelights.DataTools.Clustering // how to report progress let progress = printfn "%s" @@ -28,7 +37,7 @@ let lowerLimit = 0.003 let upperLimit = 0.2 // get the URLs and titles from the "OPML" file -let urls = Async.Run(DataAccess.getContents progress url BlogTreatment.treatOpml (Seq.of_list [])) +let urls = Async.Run(HttpXml.getContents progress url BlogTreatment.treatOpml (Seq.of_list [])) let urls' = Seq.take limit urls // download the URLs @@ -37,3 +46,26 @@ let masterList, blogs = BlogTreatment.titleUlrsToWordCountMap progress timeout u let clusterTree, chosen = Seq.filter (fun { BlogWordCount = wc } -> not (Map.is_empty wc)) blogs |> BlogTreatment.clusterWordCounts progress lowerLimit upperLimit masterList + +open System.IO + +DataAccess.getContents progress url (fun _ stream -> + let sr = new StreamReader(stream) + File.WriteAllText(@"D:\code\github\HierarchicalClustering\data\blogs\top100ukblogs.opml", sr.ReadToEnd())) + () + +Async.Run it + +let safeName (s: string) = + let chars = Path.GetInvalidFileNameChars() + chars |> + Seq.fold (fun (s: string) c -> + s.Replace(c.ToString(), "")) s + +let getBlog (name, url) = + DataAccess.getContents progress url (fun _ stream -> + let sr = new StreamReader(stream) + File.WriteAllText(Path.Combine(@"D:\code\github\HierarchicalClustering\data\blogs", (safeName name) + ".xml"), sr.ReadToEnd())) + () + +Async.Run(Async.Parallel(Seq.map getBlog urls)) \ No newline at end of file examples/tests.fsx @@ -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/ -namespace Strangelights.GenericAlgorithms +namespace Strangelights.DataTools open System open Microsoft.FSharp.Math @@ -119,8 +119,8 @@ module GenericExpressions = | x -> Nullary(x) type HoleTree = - | LeftHole of (Expression * Expression -> Expression) * HoleTree * Expression - | RightHole of (Expression * Expression -> Expression) * Expression * HoleTree + | LeftHole of (UntypedExpression * UntypedExpression -> UntypedExpression) * HoleTree * UntypedExpression + | RightHole of (UntypedExpression * UntypedExpression -> UntypedExpression) * UntypedExpression * HoleTree | Hole let rec plug = function geneticalgos/geneticequ.fs @@ -1,5 +1,10 @@ #light -namespace Strangelights.Extensions +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ + +namespace Strangelights.DataTools.Extensions open System open System.Linq @@ -7,25 +12,34 @@ module PSeq = // Import some stuff from PLink let asParallel list: IParallelEnumerable<_> = ParallelQuery.AsParallel(list) let map f list = ParallelEnumerable.Select(asParallel list, new Func<_, _>(f)) - let reduce f list = ParallelEnumerable.Aggregate(asParallel list, new Func<_, _, _>(f)); - let fold f acc list = ParallelEnumerable.Aggregate(asParallel list, acc, new Func<_, _, _>(f)); - -module Net = - /// Add the GetResponseAsync to the WebRequest class so it can - /// be used in async workflows. - type System.Net.WebRequest with - member x.GetResponseAsync() = - Async.BuildPrimitive(x.BeginGetResponse, x.EndGetResponse) + let reduce f list = ParallelEnumerable.Aggregate(asParallel list, new Func<_, _, _>(f)) + let fold f acc list = ParallelEnumerable.Aggregate(asParallel list, acc, new Func<_, _, _>(f)) -module SeqenceOps = +module Seq = + let cmap f s = Seq.map f s |> Seq.cache + let rec combinations n items = + let rec comb n curn items combs = + cmap (fun item -> + match curn with + | 1 -> Seq.concat (comb n 2 (Seq.filter (fun x -> x <> item) items) (seq { yield seq { yield item } })) + | _ when n = curn -> + seq { for comb in combs do yield Seq.cons item comb } + | _ -> + Seq.concat (comb n (curn + 1) (Seq.filter (fun x -> x <> item) items) (seq { for comb in combs do yield Seq.cons item comb })) ) + items + Seq.concat (comb n 1 items (Seq.of_list [])) + /// combine every item with every other item let rec combinations2 items = - let head = Seq.hd items - let items' = Seq.skip 1 items - seq { for el in items' do - yield head, el - if Seq.length items' > 1 then - yield! combinations2 items' } + let combs = combinations 2 items + cmap (fun l -> Seq.nth 0 l, Seq.nth 1 l) combs +// let rec combinations2 items = +// let head = Seq.hd items +// let items' = Seq.skip 1 items +// seq { for el in items' do +// yield head, el +// if Seq.length items' > 1 then +// yield! combinations2 items' } module MapOps = // merge two word count lists let mergeFloatMap wc1 wc2 = @@ -35,10 +49,15 @@ module MapOps = | None -> Map.add word count acc Seq.fold merge wc1 (Map.to_seq wc2) -module Correlations = +module Measures = + let euclidean (wc1: seq<float>) (wc2: seq<float>) = + let vectors = Seq.zip wc1 wc2 + let total = vectors |> Seq.fold (fun acc (p, q) -> acc + ((p - q) ** 2.)) 0. + sqrt total + /// pearson conversion - measures the distance between two list of floats let pearson (wc1: seq<float>) (wc2: seq<float>) = - let sum = PSeq.reduce (+) + let sum = Seq.reduce (+) let sum1 = sum wc1 let sum2 = sum wc2 misc/extensions.fs @@ -1,10 +1,15 @@ #light -namespace Strangelights.HierarchicalClustering +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, Please see the Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ + +namespace Strangelights.DataTools.Clustering open System open System.Globalization open System.Windows open System.Windows.Media -open Strangelights.HierarchicalClustering +open Strangelights.DataTools.Clustering type Dendrogram(t) = inherit FrameworkElement() presentation/dendrogram.fs @@ -1,4 +1,8 @@ #light +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, Please see the Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ namespace Strangelights.DataTools.Clustering open System @@ -7,6 +11,7 @@ open System.Windows open System.Windows.Controls open System.Windows.Media open Strangelights.DataTools.Clustering +open Strangelights.DataTools.Treatment type TagCloud(words: seq<string * float>, blogs: seq<BlogLeafDetails>) as x = inherit WrapPanel() presentation/tagcloud.fs @@ -1,13 +1,19 @@ #light -namespace Strangelights.HierarchicalClustering +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ + +namespace Strangelights.DataTools.Treatment open System open System.Net open System.IO open System.Xml.XPath open System.Text.RegularExpressions open System.Xml -open Strangelights.Extensions -open Strangelights.HierarchicalClustering +open Strangelights.DataTools.DataAccess +open Strangelights.DataTools.Extensions +open Strangelights.DataTools.Clustering type Blog = { Title: string; @@ -46,6 +52,7 @@ type BlogLeafDetails = type Result = { BiculsterTree: BiculsterNode<BlogLeafDetails>; + MulitDScaling: seq<MultiDResult>; MasterWordList: Map<string, float>; ChosenWords: seq<string>; ProcessedBlogs: int } @@ -55,8 +62,8 @@ module BlogTreatment = /// pairs of titles and URL let treatOpml progress (stream: Stream) = let xdoc = new XPathDocument(stream) - let titles = DataAccess.queryXdoc xdoc "opml/body/outline/outline/@title" - let urls = DataAccess.queryXdoc xdoc "opml/body/outline/outline/@xmlUrl" + let titles = HttpXml.queryXdoc xdoc "opml/body/outline/outline/@title" + let urls = HttpXml.queryXdoc xdoc "opml/body/outline/outline/@xmlUrl" progress (Printf.sprintf "urls: %i" (Seq.length urls)) progress (Printf.sprintf "titles: %i" (Seq.length titles)) Seq.zip titles urls @@ -92,10 +99,10 @@ module BlogTreatment = else Map.add word 1. acc let treatPostList posts = - let words = Seq.concat (Seq.map (fun post -> treatText post) posts) - PSeq.fold countWords Map.empty words + let words = Seq.concat (Seq.cmap (fun post -> treatText post) posts) + Seq.fold countWords Map.empty words - let posts = DataAccess.queryXdoc xdoc "rss/channel/item/description" + let posts = HttpXml.queryXdoc xdoc "rss/channel/item/description" progress (Printf.sprintf "items: %i" (Seq.length posts)) let wordMap = treatPostList posts let blog = { Title = title; Url = url; BlogWordCount = wordMap } @@ -104,17 +111,20 @@ module BlogTreatment = /// download opml stream then turn into title/url paris let opmlFileToTitleUlrs progress url limit = - let urlsWorkflow = DataAccess.getContents progress url treatOpml (Seq.of_list []) + let urlsWorkflow = HttpXml.getContents progress url treatOpml (Seq.of_list []) let urls = Async.Run urlsWorkflow Seq.take (min limit (Seq.length urls)) urls /// download rss files and turn into word/count maps - let titleUlrsToWordCountMap progress timeout urls = + let titleUlrsToWordCountMap local progress timeout urls = let receiver = new ReceiveBlogAgent() let flows = urls - |> Seq.map (fun (title, url) -> - DataAccess.getContents progress url (treatRss title url receiver) ()) + |> Seq.cmap (fun (title, url) -> + if local then + HttpXml.getContents progress url (treatRss title url receiver) () + else + HttpXml.getContentsLocal progress url (treatRss title url receiver) ()) try Async.Run (Async.Parallel flows, timeout = timeout) |> ignore with :? TimeoutException -> progress "Request timed out" @@ -126,7 +136,7 @@ module BlogTreatment = let clusterWordCounts progress lowerBound upperBound masterList blogs = // remove words that are uncommon or too common let remove (wordCount: Map<_, _>) = - let count = (float wordCount.Count) + let count = Map.fold_left(fun total _ count -> total + count) 0. wordCount wordCount |> Map.filter (fun word wc -> let frac = wc / count //printfn "%s: %i / %i = %f" word wc count frac @@ -137,12 +147,12 @@ module BlogTreatment = masterList |> remove |> Map.to_seq - |> Seq.map fst + |> Seq.cmap fst // ensure wordcount only contains words from master list let addjustToMasterList wordCount = masterWordList - |> Seq.map (fun word -> + |> Seq.cmap (fun word -> match Map.tryfind word wordCount with | Some count -> word, count | None -> word, 0.) @@ -152,22 +162,51 @@ module BlogTreatment = let clustersList = blogs |> Seq.sort_by (fun { Title = title } -> title) - |> PSeq.map (fun { Title = title; Url = url; BlogWordCount = wordmap } -> + |> Seq.cmap (fun { Title = title; Url = url; BlogWordCount = wordmap } -> { NameValueParis = addjustToMasterList wordmap; NodeDetails = Leaf { Name = title; Url = url; OriginalWordCount = wordmap; }; }) + |> Seq.cache - Clustering.buildClusterTree progress clustersList, masterWordList + clustersList, masterWordList - /// process a word count into a hierarical cluster. - let processOpml progress url lowerLimit upperLimit limit timeout = + let processOpmlToInitClusters progress local url lowerLimit upperLimit limit timeout = let masterList, blogs = - opmlFileToTitleUlrs progress url limit - |> titleUlrsToWordCountMap progress timeout - let clusterTree, chosen = + if local then + Directory.GetFiles(url) + |> Seq.cmap (fun path -> Path.GetFileNameWithoutExtension(path), path) + |> Seq.take limit + |> titleUlrsToWordCountMap local progress timeout + else + opmlFileToTitleUlrs progress url limit + |> titleUlrsToWordCountMap local progress timeout + let clustersList, chosen = Seq.filter (fun { BlogWordCount = wc } -> not (Map.is_empty wc)) blogs //|> (fun blogs -> Set.to_seq (Set.of_seq blogs)) |> clusterWordCounts progress lowerLimit upperLimit masterList - { BiculsterTree = clusterTree; MasterWordList = masterList; - ChosenWords = chosen; ProcessedBlogs = Seq.length blogs } \ No newline at end of file + masterList, blogs, clustersList, chosen + + let mdScaling progress clustersList = + let getName node = + match node with + | Leaf { Name = n } -> n + | Node _ -> "" + let namesVectors = + Seq.cmap (fun { NameValueParis = wc; NodeDetails = nd } -> { DataName = getName nd; Vector = List.map snd (Map.to_list wc) }) clustersList + |> Seq.cache + MultiD.scaleDown progress 3 namesVectors 0.01 + + /// process a word count into a hierarical cluster. + let processOpmlAll progress local url lowerLimit upperLimit limit timeout = + let masterList, blogs, clustersList, chosen = + processOpmlToInitClusters progress local url lowerLimit upperLimit limit timeout + { BiculsterTree = Clustering.buildClusterTree progress clustersList; + MulitDScaling = mdScaling progress clustersList; + MasterWordList = masterList; + ChosenWords = chosen; ProcessedBlogs = Seq.length blogs } + + let processOpmlToMdScaling progress local url lowerLimit upperLimit limit timeout = + let masterList, blogs, clustersList, chosen = + processOpmlToInitClusters progress local url lowerLimit upperLimit limit timeout + mdScaling progress clustersList \ No newline at end of file treatment/blogs.fs @@ -1,7 +1,13 @@ #light +// Copyright (c) 2009 All Right Reserved, Robert Pickering +// +// This source is subject to the GLPv2, please see Strangelights.DataTools.gpl-2.0.txt. +// Contact Robert Pickering via: http://strangelights.com/ + open System -open Strangelights.Extensions -open Strangelights.HierarchicalClustering +open Strangelights.DataTools.DataAccess +open Strangelights.DataTools.Extensions +open Strangelights.DataTools.Clustering type Location = { Country: string; @@ -22,7 +28,7 @@ let getData progress makeUrl urls = async { let url = makeUrl key let cols = Seq.map fst colNames let names = Seq.skip 1 (Seq.map snd colNames) - let! data = DataAccess.getGoogleSpreadSheet progress url cols + let! data = HttpXml.getGoogleSpreadSheet progress url cols return Seq.map (createLocation names) data } Async.Run (Async.Parallel (List.map getData urls)) treatment/gdata.fs 973be01679d75ba6b06b5f2ccf02bb2b88f5a5d0 Robert Pickering robert@strangelights.com http://github.com/robertpi/fscollintelli/commit/a28431f1e0207482250f2e604d0f21aa9d3a697f a28431f1e0207482250f2e604d0f21aa9d3a697f 2009-04-11T00:49:31-07:00 2009-04-11T00:49:31-07:00 Commit stuff that was missing because I don't know how to use GIT yet 7458abc1490e6ef0691941951b4183b4db9465c2 Robert Pickering robert@strangelights.com